dbsql/test/scr050/dbsql_tclsh.c

/*-
 * DBSQL - A SQL database engine.
 *
 * Copyright (C) 2007-2008  The DBSQL Group, Inc. - All rights reserved.
 *
 * This library is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * There are special exceptions to the terms and conditions of the GPL as it
 * is applied to this software. View the full text of the exception in file
 * LICENSE_EXCEPTIONS in the directory of this software distribution.
 *
 * This library is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 * General Public License for more details.
 */

/*
 * A TCL Shell, dbsql_tclsh, for testing DBSQL.
 */

#include <dbsql.h>
#include <dbsql_config.h>
#include <dbsql_int.h>
#include "inc/os_ext.h"

#include <tcl.h>

#include <stdlib.h>
#include <string.h>

extern void __tcl_sql_func_md5step(dbsql_func_t *, int, const char **);
extern void __tcl_sql_func_md5finalize(dbsql_func_t *);


/*
 * If TCL uses UTF-8 and DBSQL 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(DBSQL_UTF8_ENCODING)
#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 sql_func sql_func_t;
struct sql_func {
	sql_func_t *next;   /* Next function on the list of them all */
	Tcl_Interp *interp; /* The TCL interpret to execute the function */
	char *script;       /* The script to be run */
};

/*
 * There is one instance of this structure for each database
 * that has been opened by this inteface.
 */
typedef struct dbsql_ctx dbsql_ctx_t;
struct dbsql_ctx {
	DB_ENV *dbenv;        /* The Berkeley DB Environment */
	DBSQL *dbp;           /* The SQL datbase within the dbenv */
	Tcl_Interp *interp;   /* The interpreter used for this database */
	char *busy;           /* The busy callback routine */
	char *commit;         /* The commit hook callback routine */
	char *trace;          /* The trace callback routine */
	char *progress;       /* The progress callback routine */
	char *auth;           /* The authorization callback routine */
	int crypt;            /* Non-zero if environment is encrypted */
	sql_func_t *func;     /* List of SQL functions */
	int rc;               /* Return code of most recent dbsql_exec() */
};

/*
 * An instance of this structure passes information thru the internal
 * logic from the original TCL command into the callback routine.
*/
typedef struct callback_data callback_data_t;
struct callback_data {
	Tcl_Interp *interp;    /* The TCL interpreter */
	char *array;           /* The array into which data is written */
	Tcl_Obj *code;         /* The code to execute for each row */
	int once;              /* Set for first callback only */
	int tcl_rc;            /* Return code from TCL script */
	int ncols;             /* Number of entries in the col_names[] array */
	char **col_names;      /* Column names translated to UTF-8 */
};

/* __testset_1 --------------------------------------------------------------*/
#ifdef DB_WIN32
#define PTR_FMT "%x"
#else
#define PTR_FMT "%p"
#endif

/*
 * get_dbsql_from_ptr --
 *	Decode a pointer encoded in a string to an pointer to a structure.
 */
static int
get_dbsql_from_ptr(Tcl_Interp *interp, const char *args, DBSQL **dbsqlp)
{
	if (sscanf(args, PTR_FMT, (void**)dbsqlp) != 1 &&
	    (args[0] != '0' || args[1] != 'x' ||
	     sscanf(&args[2], PTR_FMT, (void**)dbsqlp) != 1)) {
		Tcl_AppendResult(interp,
			 "\"", args, "\" is not a valid pointer value", 0);
		return TCL_ERROR;
	}
	return TCL_OK;
}

/*
 * get_sqlvm_from_ptr --
 *	Decode a pointer to an sqlvm_t object.
 */
static int
get_sqlvm_from_ptr(Tcl_Interp *interp, const char *args, dbsql_stmt_t **sqlvmp)
{
	if (sscanf(args, PTR_FMT, (void**)sqlvmp) != 1) {
		Tcl_AppendResult(interp,
			    "\"", args, "\" is not a valid pointer value", 0);
		return TCL_ERROR;
	}
	return TCL_OK;
}

/*
 * __encode_as_ptr --
 *	Generate a text representation of a pointer that can be understood
 *	by the get_dbsql_from_ptr and get_sqlvm_from_ptr routines above.
 *
 *	The problem is, on some machines (Solaris) if you do a printf with
 *	"%p" you cannot turn around and do a scanf with the same "%p" and
 *	get your pointer back.  You have to prepend a "0x" before it will
 *	work.  But this behavior varies from machine to machine.  This
 *	work around tests the string after it is generated to see if it can be
 *	understood by scanf, and if not, try prepending an "0x" to see if
 *	that helps.  If nothing works, a fatal error is generated.
 */
static int
__encode_as_ptr(Tcl_Interp* interp, char* ptr, void* p)
{
	void *p2;

	sprintf(ptr, PTR_FMT, p);
	if( sscanf(ptr, PTR_FMT, &p2) != 1 || p2 != p) {
		sprintf(ptr, "0x" PTR_FMT, p);
		if (sscanf(ptr, PTR_FMT, &p2) != 1 || p2 != p) {
			Tcl_AppendResult(interp,
	    "unable to convert a pointer to a string "
	    "in the file " __FILE__ " in function __encode_as_ptr().  Please "
            "report this problem to support@dbsql.org as a new "
            "report.  Please provide detailed information about how "
	    "you compiled DBSQL (include your config.log file) and what "
            "hardware and operating system you are using.", 0);
			return TCL_ERROR;
		}
	}
	return TCL_OK;
}

/*
 * t__dbsql_env_create --
 *	TCL usage:    dbsql_create name
 *	Returns:  The name of an open database.
 */
static int
t__dbsql_env_create(void* _dbctx, Tcl_Interp* interp, int argc, char* *argv)
{
	DBSQL *dbp;
	char *err_msgs;
	char ptr[100];
	int rc;

	COMPQUIET(_dbctx, NULL);

	if (argc != 2) {
		Tcl_AppendResult(interp, "wrong # args: should be \"",
				 argv[0], " FILENAME\"", 0);
		return TCL_ERROR;
	}

	rc = dbsql_create_env(&dbp, argv[1], NULL, 0, DBSQL_THREAD);
	if (rc != DBSQL_SUCCESS) {
		Tcl_AppendResult(interp, dbsql_strerror(rc), 0);
		return TCL_ERROR;
	}
	if (__encode_as_ptr(interp, ptr, dbp))
		return TCL_ERROR;
	Tcl_AppendResult(interp, ptr, 0);
	return TCL_OK;
}

/*
 * exec_printf_cb --
 *	The callback routine for DBSQL->exec_printf().
 */
static int
exec_printf_cb(void* arg, int argc, char* *argv, char* *name)
{
	Tcl_DString *str;
	int i;

	str = (Tcl_DString*)arg;
	if (Tcl_DStringLength(str) == 0) {
		for(i = 0; i < argc; i++) {
			Tcl_DStringAppendElement(str, name[i] ?
						 name[i] : "NULL");
		}
	}
	for(i = 0; i < argc; i++) {
		Tcl_DStringAppendElement(str, argv[i] ? argv[i] : "NULL");
	}
	return 0;
}

/*
 * t__exec_printf --
 *	TCL usage:  exec_printf  DBSQL  FORMAT  STRING
 *
 *	Invoke the dbsql_exec_printf() interface using the open database
 *	DB.  The SQL is the string FORMAT.  The format string should contain
 *	one %s or %q.  STRING is the value inserted into %s or %q.
 */
static int
t__exec_printf(void* _dbctx, Tcl_Interp* interp, int argc, char* *argv)
{
	DBSQL *dbp;
	Tcl_DString str;
	char *err = 0;
	char buf[30];
	int rc;

	COMPQUIET(_dbctx, NULL);

	if (argc != 4) {
		Tcl_AppendResult(interp, "wrong # args: should be \"",
				 argv[0], " DB FORMAT STRING", 0);
		return TCL_ERROR;
	}
	if (get_dbsql_from_ptr(interp, argv[1], &dbp))
		return TCL_ERROR;
	Tcl_DStringInit(&str);
	rc = dbp->exec_printf(dbp, argv[2], exec_printf_cb,
			      &str, &err, argv[3]);
	sprintf(buf, "%d", rc);
	Tcl_AppendElement(interp, buf);
	Tcl_AppendElement(interp, rc == DBSQL_SUCCESS ?
			  Tcl_DStringValue(&str) : err);
	Tcl_DStringFree(&str);
	if (err)
		free(err);
	return TCL_OK;
}

#if 0
FIXME
/*
 * test_xprintf --
 *	Usage:  xprintf  SEPARATOR  ARG0  ARG1 ...
 *
 *	Test the %z format of xprintf().  Use multiple xprintf() calls to
 *	concatenate arg0 through argn using separator as the separator.
 *	Return the result.
 */
static int
test_xprintf(void* _dbctx, Tcl_Interp* interp, int argc, char* *argv)
{
	int i;
	char *result = 0;

	COMPQUIET(_dbctx, NULL);

	if (get_dbsql_from_ptr(interp, argv[1], &db))
		return TCL_ERROR;

	for(i = 2; i < argc; i++) {
		result = exec_xprintf(dbctx->dbp, "%z%s%s",
				      result, argv[1], argv[i]);
	}
	Tcl_AppendResult(interp, result, 0);
	__dbsql_free(dbctx->dbp, result);
	return TCL_OK;
}
#endif

/*
 * t__get_table_printf --
 *	TCL usage:  dbsql_get_table_printf  DB  FORMAT  STRING
 *
 *	Invoke the dbsql_get_table_printf() interface using the open database
 *	DB.  The SQL is the string FORMAT.  The format string should contain
 *	one %s or %q.  STRING is the value inserted into %s or %q.
 */
static int
t__get_table_printf(void* _dbctx, Tcl_Interp* interp, int argc, char* *argv)
{
	DBSQL *dbp;
	Tcl_DString str;
	int rc;
	char *err = 0;
	int nrow, ncol;
	char **result;
	int i;
	char buf[30];

	COMPQUIET(_dbctx, NULL);

	if (argc != 4) {
		Tcl_AppendResult(interp, "wrong # args: should be \"",
				 argv[0], " DB FORMAT STRING", 0);
		return TCL_ERROR;
	}
	if (get_dbsql_from_ptr(interp, argv[1], &dbp))
		return TCL_ERROR;
	Tcl_DStringInit(&str);
	rc = dbp->exec_table_printf(dbp, argv[2], &result, &nrow, &ncol,
				    &err, argv[3]);
	sprintf(buf, "%d", rc);
	Tcl_AppendElement(interp, buf);
	if (rc == DBSQL_SUCCESS) {
		sprintf(buf, "%d", nrow);
		Tcl_AppendElement(interp, buf);
		sprintf(buf, "%d", ncol);
		Tcl_AppendElement(interp, buf);
		for (i = 0; i < (nrow + 1) * ncol; i++) {
			Tcl_AppendElement(interp, result[i] ?
					  result[i] : "NULL");
		}
	} else {
		Tcl_AppendElement(interp, err);
	}
	dbp->free_table(result);
	if (err)
		free(err);
	return TCL_OK;
}


/*
 * t__last_rowid --
 *	TCL usage:  t__last_inserted_rowid DB
 *
 *	Returns the integer ROWID of the most recent insert.
 */
static int
t__last_rowid(void* _dbctx, Tcl_Interp* interp, int argc, char* *argv)
{
	DBSQL *dbp;
	dbsql_ctx_t *dbctx = (dbsql_ctx_t *)_dbctx;
	char buf[30];

	COMPQUIET(_dbctx, NULL);

	if (argc != 2) {
		Tcl_AppendResult(interp, "wrong # args: should be \"",
				 argv[0], " DB\"", 0);
		return TCL_ERROR;
	}
	if (get_dbsql_from_ptr(interp, argv[1], &dbp))
		return TCL_ERROR;
	sprintf(buf, "%d", dbp->rowid(dbp));
	Tcl_AppendResult(interp, buf, 0);
	return DBSQL_SUCCESS;
}

/*
 * t__test_close --
 *	TCL usage:  dbsql_close DB
 *
 *	Closes the database.
 */
static int
t__test_close(void* _dbctx, Tcl_Interp* interp, int argc, char* *argv)
{
	DBSQL *dbp;

	COMPQUIET(_dbctx, NULL);

	if (argc != 2) {
		Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
				 " FILENAME\"", 0);
		return TCL_ERROR;
	}
	if (get_dbsql_from_ptr(interp, argv[1], &dbp))
		return TCL_ERROR;
	dbp->close(dbp);
	return TCL_OK;
}

/*
 * ifnull_func --
 *	Implementation of the x_coalesce() function.
 *	Return the first argument non-NULL argument.
 */
static void
ifnull_func(context, argc, argv)
	dbsql_func_t *context;
	int argc;
	const char **argv;
{
	int i;

	for(i = 0; i < argc; i++) {
		if (argv[i]) {
			dbsql_set_result_string(context, argv[i], -1);
			break;
		}
	}
}

/*
 * A structure into which to accumulate text.
 */
struct dstr {
	int size;	/* Space allocated */
	int len;	/* Space used */
	char *str;	/* The string */
};

/*
 * dstr_append --
 *	Append text to a dstr.
 */
static void
dstr_append(p, z, divider)
	struct dstr *p;
	const char *z;
	int divider;
{
	int n = strlen(z);
	if (p->len + n + 2 > p->size) {
		char *zNew;
		p->size = p->size * 2 + n + 200;
		if (__dbsql_realloc(NULL, p->size, &p->str) == ENOMEM)
			return;
	}
	if (divider && p->len > 0) {
		p->str[p->len++] = divider;
	}
	memcpy(&p->str[p->len], z, n + 1);
	p->len += n;
}

/*
 * exec_func_callback --
 *	Invoked for each callback from dbsql_exec
 */
static int
exec_func_callback(void* data, int argc, char* *argv, char* *notused)
{
	struct dstr *p;
	int i;

	COMPQUIET(notused, NULL);
	p = (struct dstr*)data;

	for(i = 0; i < argc; i++) {
		if (argv[i] == 0) {
			dstr_append(p, "NULL", ' ');
		} else {
			dstr_append(p, argv[i], ' ');
		}
	}
	return 0;
}

/*
 * exec_func --
 *	Implementation of the x_dbsql_exec() function.  This function takes
 *	a single argument and attempts to execute that argument as SQL code.
 *	This is illegal and should set the DBSQL_MISUSE flag on the database.
 *	This routine simulates the effect of having two threads attempt to
 *	use the same database at the same time.
 */
static void
exec_func(context, argc, argv)
	dbsql_func_t *context;
	int argc;
	const char **argv;
{
	DBSQL *dbp = (DBSQL*)dbsql_user_data(context);
	struct dstr x;
	memset(&x, 0, sizeof(x));
	dbp->exec(dbp, argv[0], exec_func_callback, &x, 0);
	dbsql_set_result_string(context, x.str, x.len);
	__dbsql_free(NULL, x.str);
}

/*
 * t__create_function --
 *	TCL usage:  dbsql_test_create_function DB
 *
 *	Call the dbsql_create_function API on the given database in order
 *	to create a function named "x_coalesce".  This function does the same
 *	thing as the "coalesce" function.  This function also registers an
 *	SQL function named "x_dbsql_exec" that invokes dbsql_exec().
 *	Invoking dbsql_exec() in this way is illegal recursion and should
 *	raise an DBSQL_MISUSE error.  The effect is similar to trying to use
 *	the same database connection from
 *	two threads at the same time.
 *
 *	The original motivation for this routine was to be able to call the
 *	dbsql_create_function function while a query is in progress in order
 *	to test the DBSQL_MISUSE detection logic.
 */
static int
t__create_function(void* _dbctx, Tcl_Interp* interp, int argc, char* *argv)
{
	DBSQL *dbp;
	extern void Md5_Register(DBSQL*);

	if (argc != 2) {
		Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
				 " FILENAME\"", 0);
		return TCL_ERROR;
	}
	if (get_dbsql_from_ptr(interp, argv[1], &dbp))
		return TCL_ERROR;

	dbp->create_function(dbp, "x_coalesce", -1, DBSQL_UTF8_ENCODED,
			     NULL, ifnull_func, NULL, NULL);
	dbp->create_function(dbp, "x_dbsql_exec", -1, DBSQL_UTF8_ENCODED,
			     NULL, exec_func, NULL, NULL);

	return TCL_OK;
}

/*
 * Routines to implement the x_count() aggregate function.
 */
typedef struct cnt {
	int n;
} cnt_t;

/*
 * count_step --
 *
 */
static void
count_step(context, argc, argv)
	dbsql_func_t *context;
	int argc;
	const char **argv;
{
	cnt_t *p;
	p = dbsql_aggregate_context(context, sizeof(*p));
	if ((argc == 0 || argv[0]) && p) {
		p->n++;
	}
}

/*
 * count_finalize --
 *
 */
static void
count_finalize(dbsql_func_t* context)
{
	cnt_t *p;
	p = dbsql_aggregate_context(context, sizeof(*p));
	dbsql_set_result_int(context, p ? p->n : 0);
}

/*
 * t__create_aggregate --
 *	TCL usage:  dbsql_test_create_aggregate DB
 *
 *	Call the dbsql_create_function API on the given database in order
 *	to create a function named "x_count".  This function does the same
 *	thing as the "md5sum" function.
 *
 *	The original motivation for this routine was to be able to call the
 *	dbsql_create_aggregate function while a query is in progress in order
 *	to test the DBSQL_MISUSE detection logic.
 */
static int
t__create_aggregate(void* _dbctx, Tcl_Interp* interp, int argc, char* *argv)
{
	DBSQL *dbp;

	COMPQUIET(_dbctx, NULL);

	if (argc != 2) {
		Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
				 " FILENAME\"", 0);
		return TCL_ERROR;
	}
	if (get_dbsql_from_ptr(interp, argv[1], &dbp))
		return TCL_ERROR;
	dbp->create_function(dbp, "x_count", 0, DBSQL_UTF8_ENCODED,
			     NULL, NULL, count_step, count_finalize);

	return TCL_OK;
}

#if 0
TODO
/*
 * dbsql_mprintf_int --
 *	Usage:  dbsql_mprintf_int FORMAT INTEGER INTEGER INTEGER
 *
 *	Call mprintf with three integer arguments.
 */
static int
dbsql_mprintf_int(void* _dbctx, Tcl_Interp* interp, int argc, char* *argv)
{
	int a[3], i;
	char *buf;

	COMPQUIET(_dbctx, NULL);

	if (argc != 5) {
		Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
				 " FORMAT INT INT INT\"", 0);
		return TCL_ERROR;
	}
	for(i = 2; i < 5; i++) {
		if (Tcl_GetInt(interp, argv[i], &a[i-2]))
			return TCL_ERROR;
	}
	buf = __mprintf(argv[1], a[0], a[1], a[2]);
	Tcl_AppendResult(interp, buf, 0);
	__dbsql_free(NULL, buf);
	return TCL_OK;
}

/*
 * dbsql_mprintf_str --
 *	Usage:  dbsql_mprintf_str FORMAT INTEGER INTEGER STRING
 *
 *	Call mprintf with two integer arguments and one string argument.
 */
static int
dbsql_mprintf_str(void* _dbctx, Tcl_Interp* interp, int argc, char* *argv)
{
	int a[3], i;
	char *buf;

	COMPQUIET(_dbctx, NULL);

	if (argc < 4 || argc > 5) {
		Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
				 " FORMAT INT INT ?STRING?\"", 0);
		return TCL_ERROR;
	}
	for (i = 2; i < 4; i++) {
		if (Tcl_GetInt(interp, argv[i], &a[i-2]))
			return TCL_ERROR;
	}
	buf = __mprintf(argv[1], a[0], a[1], argc > 4 ? argv[4] : NULL);
	Tcl_AppendResult(interp, buf, 0);
	dbsql_free(buf);
	return TCL_OK;
}

/*
 * dbsql_mprintf_double --
 * Usage:  dbsql_mprintf_str FORMAT INTEGER INTEGER DOUBLE
 *
 *	Call mprintf with two integer arguments and one double argument
 */
static int
dbsql_mprintf_double(void* _dbctx, Tcl_Interp* interp, int argc, char* *argv)
{
	int a[3], i;
	double r;
	char *buf;

	COMPQUIET(_dbctx, NULL);

	if (argc != 5) {
		Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
				 " FORMAT INT INT STRING\"", 0);
		return TCL_ERROR;
	}
	for (i = 2; i < 4; i++) {
		if (Tcl_GetInt(interp, argv[i], &a[i-2]))
			return TCL_ERROR;
	}
	if (Tcl_GetDouble(interp, argv[4], &r))
		return TCL_ERROR;
	buf = __mprintf(argv[1], a[0], a[1], r);
	Tcl_AppendResult(interp, buf, 0);
	dbsql_free(buf);
	return TCL_OK;
}
#endif

/*
 * dbsql_malloc_fail --
 *	Usage: dbsql_malloc_fail N
 *
 *	Rig __dbsql_calloc() to fail on the N-th call.  Turn off this mechanism
 *	and reset the dbsql_malloc_failed variable is N==0.
 */
#ifdef MEMORY_DEBUG
static int
dbsql_malloc_fail(void* _dbctx, Tcl_Interp* interp, int argc, char* *argv)
{
	int n;

	COMPQUIET(_dbctx, NULL);

	if (argc != 2) {
		Tcl_AppendResult(interp, "wrong # args: should be \"",
				 argv[0], " N\"", 0);
		return TCL_ERROR;
	}
	if (Tcl_GetInt(interp, argv[1], &n))
		return TCL_ERROR;
	sqlite_iMallocFail = n;
	sqlite_malloc_failed = 0;
	return TCL_OK;
}
#endif

/*
 * dbsql_malloc_stat --
 *	Usage: dbsql_malloc_stat
 *
 *	Return the number of prior calls to __dbsql_calloc()
 *	and __dbsql_free().
 */
#ifdef MEMORY_DEBUG
static int
dbsql_malloc_stat(void* _dbctx, Tcl_Interp* interp, int argc, char* *argv)
{
	char buf[200];

	COMPQUIET(_dbctx, NULL);

	sprintf(buf, "%d %d %d", sqlite_nMalloc, sqlite_nFree,
		sqlite_iMallocFail);
	Tcl_AppendResult(interp, buf, 0);
	return TCL_OK;
}
#endif

/*
 * t__dbsql_abort --
 *	TCL usage:  dbsql_abort
 *
 *	Shutdown the process immediately.  This is not a clean shutdown.
 *	This command is used to test the recoverability of a database in
 *	the event of a program crash.
 */
static int
t__dbsql_abort(void* _dbctx, Tcl_Interp* interp, int argc, char* *argv)
{
	COMPQUIET(_dbctx, NULL);

	DBSQL_ASSERT(interp == 0);   /* This will always fail. */
	return TCL_OK;
}

/*
 * test_func --
 *	The following routine is a user-defined SQL function whose purpose
 *	is to test the dbsql_set_result_string() API.
 */
static void
test_func(context, argc, argv)
	dbsql_func_t *context;
	int argc;
	const char **argv;
{
	while(argc >= 2) {
		if (argv[0] == 0) {
			dbsql_set_result_error(context,
			  "first argument to test function may "
                          "not be NULL", -1);
		} else if (strcasecmp(argv[0], "string") == 0) {
			dbsql_set_result_string(context, argv[1], -1);
		} else if (argv[1] == 0) {
			dbsql_set_result_error(context,
                          "2nd argument may not be NULL if the "
                          "first argument is not \"string\"", -1);
		} else if (strcasecmp(argv[0], "int") == 0) {
			dbsql_set_result_int(context, atoi(argv[1]));
		} else if (strcasecmp(argv[0], "double") == 0) {
			dbsql_set_result_double(context,
						__dbsql_atof(argv[1]));
		} else {
			dbsql_set_result_error(context,
			  "first argument should be one of: "
                          "string int double", -1);
		}
		argc -= 2;
		argv += 2;
	}
}

/*
 * t__register_func --
 *	TCL usage:   dbsql_register_test_function  DB  NAME
 *
 *	Register the test SQL function on the database DB under the name NAME.
 */
static int
t__register_func(void* _dbctx, Tcl_Interp* interp, int argc, char* *argv)
{
	DBSQL *dbp;
	int rc;

	COMPQUIET(_dbctx, NULL);

	if (argc != 3) {
		Tcl_AppendResult(interp, "wrong # args: should be \"",
				 argv[0], " DB FUNCTION-NAME", 0);
		return TCL_ERROR;
	}
	if (get_dbsql_from_ptr(interp, argv[1], &dbp))
		return TCL_ERROR;
	rc = dbp->create_function(dbp, argv[2], -1, DBSQL_UTF8_ENCODED,
				  NULL, test_func, NULL, NULL);
	if (rc != 0) {
		Tcl_AppendResult(interp, dbsql_strerror(rc), 0);
		return TCL_ERROR;
	}
	return TCL_OK;
}

/*
 * __remember_data_types --
 *	Usage:   This callback records the datatype of all columns.
 *
 *	Column names are inserted as the result of this interpreter.
 *	Return non-zero should cause the query to abort.
 */
static int
__remember_data_types(Tcl_Interp* interp, int cols, char* *argv, char* *colv)
{
	int i;
	Tcl_Obj *list, *elem;

	if (colv[cols + 1] == 0)
		return 1;
	list = Tcl_NewObj();
	for (i = 0; i < cols; i++) {
		elem = Tcl_NewStringObj(colv[i + cols] ? colv[i + cols] :
					"NULL", -1);
		Tcl_ListObjAppendElement(interp, list, elem);
	}
	Tcl_SetObjResult(interp, list);
	return 1;
}

/*
 * t__dbsql_datatypes --
 *	TCL usage:   This callback records the datatype of all columns.
 *
 *	Invoke an SQL statement but ignore all the data in the result.
 *	Instead, return a list that consists of the datatypes of the
 *	various columns.
 *
 *	This only works if "PRAGMA show_datatypes=on" has been executed
 *	against the database connection.
 */
static int
t__dbsql_datatypes(void* _dbctx, Tcl_Interp* interp, int argc, char* *argv)
{
	DBSQL *dbp;
	int rc;

	COMPQUIET(_dbctx, NULL);

	if (argc != 3) {
		Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
				 " DB SQL", 0);
		return TCL_ERROR;
	}
	if (get_dbsql_from_ptr(interp, argv[1], &dbp))
		return TCL_ERROR;
	rc = dbp->exec(dbp, argv[2], __remember_data_types, interp, 0);
	if (rc != 0 && rc != DBSQL_ABORT) {
		Tcl_AppendResult(interp, dbsql_strerror(rc), 0);
		return TCL_ERROR;
	}
	return TCL_OK;
}

/*
 * t__dbsql_compile --
 *	TCL usage:  dbsql_compile  DB  SQL  ?TAILVAR?
 *
 *	Attempt to compile an SQL statement.  Return a pointer to the virtual
 *	machine used to execute that statement.  Unprocessed SQL is written
 *	into TAILVAR.
 */
static int
t__dbsql_compile(void* _dbctx, Tcl_Interp* interp, int argc, char* *argv)
{
	DBSQL *dbp;
	dbsql_stmt_t *vm;
	int rc;
	char *err = 0;
	const char *tail;
	char buf[50];

	COMPQUIET(_dbctx, NULL);

	if (argc != 3 && argc !=4) {
		Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
				 " DB SQL TAILVAR", 0);
		return TCL_ERROR;
	}
	if (get_dbsql_from_ptr(interp, argv[1], &dbp))
		return TCL_ERROR;
	rc = dbp->prepare(dbp, argv[2], argc==4 ? &tail : 0, &vm, &err);
	if (argc == 4)
		Tcl_SetVar(interp, argv[3], tail, 0);
	if (rc) {
		DBSQL_ASSERT(vm == 0);
		sprintf(buf, "(%d) ", rc);
		Tcl_AppendResult(interp, buf, err, 0);
		free(err); /* TODO this was a dbsql_freemem call... */
		return TCL_ERROR;
	}
	if (vm) {
		if (__encode_as_ptr(interp, buf, vm))
			return TCL_ERROR;
		Tcl_AppendResult(interp, buf, 0);
	}
	return TCL_OK;
}

/*
 * t__dbsql_step --
 *	TCL usage:  dbsql_step  VM  ?NVAR?  ?VALUEVAR?  ?COLNAMEVAR?
 *
 *	Step a virtual machine.  Return a the result code as a string.
 *	Column results are written into three variables.
 */
static int
t__dbsql_step(void* _dbctx, Tcl_Interp* interp, int argc, char* *argv)
{
	DBSQL *dbp;
	dbsql_stmt_t *vm;
	int rc, i;
	const char **values = 0;
	const char **names = 0;
	int n = 0;
	char *result;
	char buf[50];

	COMPQUIET(_dbctx, NULL);

	if (argc < 2 || argc > 5) {
		Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
				 " VM NVAR VALUEVAR COLNAMEVAR", 0);
		return TCL_ERROR;
	}
	if (get_dbsql_from_ptr(interp, argv[1], &dbp))
		return TCL_ERROR;
	if (get_sqlvm_from_ptr(interp, argv[1], &vm))
		return TCL_ERROR;
	rc = dbp->step(vm,
		       argc >= 3 ? &n : 0,
		       argc >= 4 ? &values : 0,
		       argc == 5 ? &names : 0);
	if (argc >= 3) {
		sprintf(buf, "%d", n);
		Tcl_SetVar(interp, argv[2], buf, 0);
	}
	if (argc >= 4) {
		Tcl_SetVar(interp, argv[3], "", 0);
		if (values) {
			for(i = 0; i < n; i++) {
				Tcl_SetVar(interp, argv[3],
					  values[i] ? values[i] : "",
					  TCL_APPEND_VALUE | TCL_LIST_ELEMENT);
			}
		}
	}
	if (argc == 5) {
		Tcl_SetVar(interp, argv[4], "", 0);
		if (names) {
			for(i = 0; i < n * 2; i++) {
				Tcl_SetVar(interp, argv[4],
					  names[i] ? names[i] : "",
					  TCL_APPEND_VALUE | TCL_LIST_ELEMENT);
			}
		}
	}
	switch(rc) {
	case DBSQL_DONE:   result = "DBSQL_DONE";    break;
	case DBSQL_BUSY:   result = "DBSQL_BUSY";    break;
	case DBSQL_ROW:    result = "DBSQL_ROW";     break;
	case DBSQL_ERROR:  result = "DBSQL_ERROR";   break;
	case DBSQL_MISUSE: result = "DBSQL_MISUSE";  break;
	default:           result = "unknown";       break;
	}
	Tcl_AppendResult(interp, result, 0);
	return TCL_OK;
}

/*
 * t__dbsql_finalize
 *	TCL usage:  dbsql_close_sqlvm  VM
 *
 *	Shutdown a virtual machine.
 */
static int
t__dbsql_finalize(void* _dbctx, Tcl_Interp* interp, int argc, char* *argv)
{
	DBSQL *dbp;
	dbsql_stmt_t *vm;
	int rc;
	char *err_msg = 0;
	char buf[50];

	COMPQUIET(_dbctx, NULL);

	if (argc != 2) {
		Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
				 " VM\"", 0);
		return TCL_ERROR;
	}
	if (get_dbsql_from_ptr(interp, argv[1], &dbp))
		return TCL_ERROR;
	if (get_sqlvm_from_ptr(interp, argv[1], &vm))
		return TCL_ERROR;
	rc = dbp->finalize(vm, &err_msg);
	if (rc) {
		sprintf(buf, "(%d) ", rc);
		Tcl_AppendResult(interp, buf, err_msg, 0);
		free(err_msg); /* TODO, who allocated this memory? */
		return TCL_ERROR;
	}
	return TCL_OK;
}

/*
 * t__dbsql_test --
 *	TCL usage:  dbsql_reset_sqlvm   VM
 *
 *	Reset a virtual machine and prepare it to be run again.
 */
static int
t__dbsql_reset(void* _dbctx, Tcl_Interp* interp, int argc, char* *argv)
{
	DBSQL *dbp;
	dbsql_stmt_t *vm;
	int rc;
	char *err_msg = 0;
	char buf[50];

	COMPQUIET(_dbctx, NULL);

	if (argc != 2) {
		Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
				 " VM\"", 0);
		return TCL_ERROR;
	}
	if (get_dbsql_from_ptr(interp, argv[1], &dbp))
		return TCL_ERROR;
	if (get_sqlvm_from_ptr(interp, argv[1], &vm))
		return TCL_ERROR;
	rc = dbp->reset(vm, &err_msg);
	if (rc) {
		sprintf(buf, "(%d) ", rc);
		Tcl_AppendResult(interp, buf, err_msg, 0);
		free(err_msg); /* TODO who allocated this memory? */
		return TCL_ERROR;
	}
	return TCL_OK;
}

/*
 * This is the "static_bind_value" that variables are bound to when
 * the FLAG option of dbsql_bind is "static"
 */
static char *dbsql_static_bind_value = 0;

/*
 * t__dbsql_bind --
 *	TCL usage:  dbsql_bind  VM  IDX  VALUE  FLAGS
 *
 *	Sets the value of the IDX-th occurance of "?" in the original SQL
 *	string.  VALUE is the new value.  If FLAGS=="null" then VALUE is
 *	ignored and the value is set to NULL.  If FLAGS=="static" then
 *	the value is set to the value of a static variable named
 *	"dbsql_static_bind_value".  If FLAGS=="normal" then a copy
 *	of the VALUE is made.
 */
static int
t__dbsql_bind(void* _dbctx, Tcl_Interp* interp, int argc, char* *argv)
{
	DBSQL *dbp;
	dbsql_stmt_t *vm;
	int rc;
	int idx;
	char buf[50];

	COMPQUIET(_dbctx, NULL);

	if (argc != 5) {
		Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
				 " VM IDX VALUE (null|static|normal)\"", 0);
		return TCL_ERROR;
	}
	if (get_dbsql_from_ptr(interp, argv[1], &dbp))
		return TCL_ERROR;
	if (get_sqlvm_from_ptr(interp, argv[1], &vm))
		return TCL_ERROR;
	if (Tcl_GetInt(interp, argv[2], &idx))
		return TCL_ERROR;
	if (strcmp(argv[4],"null") == 0) {
		rc = dbp->bind(vm, idx, 0, 0, 0);
	} else if (strcmp(argv[4], "static") == 0) {
		rc = dbp->bind(vm, idx, dbsql_static_bind_value, -1, 0);
	} else if (strcmp(argv[4], "normal") == 0) {
		rc = dbp->bind(vm, idx, argv[3], -1, 1);
	} else {
		Tcl_AppendResult(interp, "4th argument should be "
				 "\"null\" or \"static\" or \"normal\"", 0);
		return TCL_ERROR;
	}
	if (rc) {
		sprintf(buf, "(%d) ", rc);
		Tcl_AppendResult(interp, buf, dbsql_strerror(rc), 0);
		return TCL_ERROR;
	}
	return TCL_OK;
}

/*
 * t__dbsql_breakpoint --
 *	TCL usage:    breakpoint
 *
 *	This routine exists for one purpose - to provide a place to put a
 *	breakpoint with GDB that can be triggered using TCL code.  The use
 *	for this is when a particular test fails on (say) the 1485th iteration.
 *	In the TCL test script, we can add code like this:
 *
 *	if {$i==1485} breakpoint
 *
 *	Then run testfixture in the debugger and wait for the breakpoint to
 *	fire.  Then additional breakpoints can be set to trace down the bug.
 */
static int
t__dbsql_breakpoint(void* _dbctx, Tcl_Interp* interp, int argc, char* *argv)
{
	COMPQUIET(_dbctx, NULL);

	return TCL_OK; /* Do nothing */
}

/*
 *	Register commands with the TCL interpreter.
 */
int
__testset_1_init(Tcl_Interp* interp)
{
	extern int dbsql_search_count;
	extern int dbsql_interrupt_count;
	extern int dbsql_open_file_count;
	extern int _fake_current_time;
	int i;
	static struct {
		char *name;
		Tcl_CmdProc *proc;
	} cmds[] = {
#if 0
TODO
     { "dbsql_mprintf_int",             (Tcl_CmdProc*)dbsql_mprintf_int    },
     { "dbsql_mprintf_str",             (Tcl_CmdProc*)dbsql_mprintf_str    },
     { "dbsql_mprintf_double",          (Tcl_CmdProc*)dbsql_mprintf_double },
     { "__mprintf_z_test",              (Tcl_CmdProc*)test_mprintf_z       },
#endif
     { "dbsql_env_create",              (Tcl_CmdProc*)t__dbsql_env_create  },
     { "dbsql_last_inserted_rowid",     (Tcl_CmdProc*)t__last_rowid        },
     { "dbsql_exec_printf",             (Tcl_CmdProc*)t__exec_printf       },
     { "dbsql_get_table_printf",        (Tcl_CmdProc*)t__get_table_printf  },
     { "dbsql_close",                   (Tcl_CmdProc*)t__test_close        },
     { "dbsql_create_function",         (Tcl_CmdProc*)t__create_function   },
     { "dbsql_create_aggregate",        (Tcl_CmdProc*)t__create_aggregate  },
     { "dbsql_register_test_function",  (Tcl_CmdProc*)t__register_func     },
     { "dbsql_abort",                   (Tcl_CmdProc*)t__dbsql_abort       },
     { "dbsql_datatypes",               (Tcl_CmdProc*)t__dbsql_datatypes   },
#ifdef MEMORY_DEBUG
     { "dbsql_malloc_fail",             (Tcl_CmdProc*)dbsql_malloc_fail    },
     { "dbsql_malloc_stat",             (Tcl_CmdProc*)dbsql_malloc_stat    },
#endif
     { "dbsql_compile",                 (Tcl_CmdProc*)t__dbsql_compile     },
     { "dbsql_step",                    (Tcl_CmdProc*)t__dbsql_step        },
     { "dbsql_close_sqlvm",             (Tcl_CmdProc*)t__dbsql_finalize    },
     { "dbsql_bind",                    (Tcl_CmdProc*)t__dbsql_bind        },
     { "dbsql_reset_sqlvm",             (Tcl_CmdProc*)t__dbsql_reset       },
     { "breakpoint",                    (Tcl_CmdProc*)t__dbsql_breakpoint  },
  };

	for(i = 0; i < sizeof(cmds) / sizeof(cmds[0]); i++) {
		Tcl_CreateCommand(interp, cmds[i].name,
				  cmds[i].proc, 0, 0);
	}
	Tcl_LinkVar(interp, "dbsql_search_count",
		    (char*)&dbsql_search_count, TCL_LINK_INT);
	Tcl_LinkVar(interp, "dbsql_interrupt_count",
		    (char*)&dbsql_interrupt_count, TCL_LINK_INT);
#if 0
FIXME
	Tcl_LinkVar(interp, "dbsql_open_file_count",
		    (char*)&dbsql_open_file_count, TCL_LINK_INT);
#endif
	Tcl_LinkVar(interp, "dbsql_current_time",
		    (char*)&_fake_current_time, TCL_LINK_INT);
	Tcl_LinkVar(interp, "dbsql_static_bind_value",
		    (char*)&dbsql_static_bind_value, TCL_LINK_STRING);
	return TCL_OK;
}
/* end of __testset_1 -------------------------------------------------------*/

#ifdef UTF_TRANSLATION_NEEDED
/*
 * __tcl_process_row --
 *	Called for each row of the result.
 *	This version is used when TCL expects UTF-8 data but the database
 *	uses the ISO-8859 format.  A translation must occur from ISO-8859 into
 *	UTF-8.
 *
 * _data			An instance of callback_data_t
 * ncol				Number of columns in the result
 * col				Data for each column
 * col_names			Name for each column
 */
static int
__tcl_process_row(void* _data, int ncol, char* *col, char* *col_names)
{
	callback_data_t *data = (callback_data_t*)_data;
	int i, rc;
	Tcl_DString tcol;
	Tcl_DStringInit(&tcol);
	if (data->col_names == 0) {
		DBSQL_ASSERT(data->once);
		data->once = 0;
		if (data->array[0]) {
			Tcl_SetVar2(data->interp, data->array, "*", "", 0);
		}
		data->col_names = malloc(ncol * sizeof(char*));
		if (data->col_names == 0) {
			return 1;
		}
		data->ncols = ncol;
		for (i = 0; i < ncol; i++) {
			Tcl_ExternalToUtfDString(NULL, col_names[i],
						 -1, &tcol);
			data->col_names[i] =malloc(Tcl_DStringLength(&tcol)+1);
			if (data->col_names[i]) {
				strcpy(data->col_names[i],
				       Tcl_DStringValue(&tcol));
			} else {
				return 1;
			}
			if (data->array[0]) {
				Tcl_SetVar2(data->interp, data->array, "*",
					    Tcl_DStringValue(&tcol),
					    TCL_LIST_ELEMENT |
					    TCL_APPEND_VALUE);
				if (col_names[ncol] != 0) {
					Tcl_DString type;
					Tcl_DStringInit(&type);
					Tcl_DStringAppend(&type,"typeof:", -1);
					Tcl_DStringAppend(&type,
						 Tcl_DStringValue(&tcol), -1);
					Tcl_DStringFree(&tcol);
					Tcl_ExternalToUtfDString(NULL,
						 col_names[i+ncol], -1, &tcol);
					Tcl_SetVar2(data->interp, data->array,
						    Tcl_DStringValue(&type),
						    Tcl_DStringValue(&tcol),
						    TCL_LIST_ELEMENT |
						    TCL_APPEND_VALUE);
					Tcl_DStringFree(&type);
				}
			}
			Tcl_DStringFree(&tcol);
		}
	}
	if (col != 0) {
		if (data->array[0]) {
			for (i = 0; i < ncol; i++) {
				char *z = col[i];
				if (z == 0)
					z = "";
				Tcl_DStringInit(&tcol);
				Tcl_ExternalToUtfDString(NULL, z, -1, &tcol);
				Tcl_SetVar2(data->interp, data->array,
					    data->col_names[i],
					    Tcl_DStringValue(&tcol), 0);
				Tcl_DStringFree(&tcol);
			}
		} else {
			for (i = 0; i < ncol; i++) {
				char *z = col[i];
				if (z == 0)
					z = "";
				Tcl_DStringInit(&tcol);
				Tcl_ExternalToUtfDString(NULL, z, -1, &tcol);
				Tcl_SetVar(data->interp, data->col_names[i],
					   Tcl_DStringValue(&tcol), 0);
				Tcl_DStringFree(&tcol);
			}
		}
	}
	rc = Tcl_EvalObj(data->interp, data->code);
	if (rc == TCL_CONTINUE)
		rc = TCL_OK;
	data->tcl_rc = rc;
	return (rc != TCL_OK);
}
#endif /* UTF_TRANSLATION_NEEDED */

#ifndef UTF_TRANSLATION_NEEDED
/*
 * __tcl_process_row --
 *	Called for each row of the result.
 *	This version is used when either of the following is true:
 *	(1) This version of TCL uses UTF-8 and the data in the
 *	    database is already in the UTF-8 format.
 *	(2) This version of TCL uses ISO-8859 and the data in the
 *	    database is already in the ISO-8859 format.
 *
 * _data			An instance of callback_data_t
 * ncol				Number of columns in the result
 * col				Data for each column
 * col_names			Name for each column
 */
static int
__tcl_process_row(_data, ncol, col, col_names)
	void *_data;
	int ncol;
	char** col;
	char **col_names;
{
	callback_data_t *data = (callback_data_t*)_data;
	int i, rc;
	if (col == 0 || (data->once && data->array[0])) {
		Tcl_SetVar2(data->interp, data->array, "*", "", 0);
		for (i = 0; i < ncol; i++) {
			Tcl_SetVar2(data->interp, data->array, "*",
				    col_names[i],
				    TCL_LIST_ELEMENT | TCL_APPEND_VALUE);
			if (col_names[ncol]) {
				char *z;
				__dbsql_calloc(NULL, 7 + strlen(col_names[i]),
					    sizeof(char), &z);
				sprintf(z, "typeof:%s", col_names[i]);
				Tcl_SetVar2(data->interp, data->array, z,
					    col_names[i + ncol],
					    TCL_LIST_ELEMENT |
					    TCL_APPEND_VALUE);
				__dbsql_free(NULL, z);
			}
		}
		data->once = 0;
	}
	if (col != 0) {
		if (data->array[0]) {
			for (i = 0; i < ncol; i++) {
				char *z = col[i];
				if (z == 0)
					z = "";
				Tcl_SetVar2(data->interp, data->array,
					    col_names[i], z, 0);
			}
		} else {
			for (i = 0; i < ncol; i++) {
				char *z = col[i];
				if (z == 0)
					z = "";
				Tcl_SetVar(data->interp, col_names[i], z, 0);
			}
		}
	}
	rc = Tcl_EvalObj(data->interp, data->code);
	if (rc == TCL_CONTINUE)
		rc = TCL_OK;
	data->tcl_rc = rc;
	return rc!=TCL_OK;
}
#endif

/*
 * __tcl_process_row2 --
 *	This is an alternative callback for database queries.  Instead
 *	of invoking a TCL script to handle the result, this callback just
 *	appends each column of the result to a list.  After the query
 *	is complete, the list is returned.
 *
 * _data			An instance of callback_data_t
 * ncol				Number of columns in the result
 * col				Data for each column
 * col_names			Name for each column
 */
static int
__tcl_process_row2(_data, ncol, col, col_names)
	void *_data;
	int ncol;
	char ** col;
	char ** col_names;
{
	int i;
	Tcl_Obj *elem;
	Tcl_Obj *list = (Tcl_Obj*)_data;
	if (col == 0)
		return 0;
	for (i = 0; i < ncol; i++) {
		if (col[i] && *col[i]) {
#ifdef UTF_TRANSLATION_NEEDED
			Tcl_DString tcol;
			Tcl_DStringInit(&tcol);
			Tcl_ExternalToUtfDString(NULL, col[i], -1, &tcol);
			elem = Tcl_NewStringObj(Tcl_DStringValue(&tcol), -1);
			Tcl_DStringFree(&tcol);
#else
			elem = Tcl_NewStringObj(col[i], -1);
#endif
		} else {
			elem = Tcl_NewObj();
		}
		Tcl_ListObjAppendElement(0, list, elem);
	}
	return 0;
}

/*
 * __tcl_process_row3 --
 *	This is a second alternative callback for database queries.  A the
 *	first column of the first row of the result is made the TCL result.
 *
 * _data			An instance of callback_data_t
 * ncol				Number of columns in the result
 * col				Data for each column
 * col_names			Name for each column
 */
static int
__tcl_process_row3(void* _data, int ncol, char* *col, char* *col_names)
{
	Tcl_Interp *interp = (Tcl_Interp*)_data;
	Tcl_Obj *elem;
	if (col == 0)
		return 1;
	if (ncol == 0)
		return 1;
#ifdef UTF_TRANSLATION_NEEDED
	{
	Tcl_DString tcol;
	Tcl_DStringInit(&tcol);
	Tcl_ExternalToUtfDString(NULL, col[0], -1, &tcol);
	elem = Tcl_NewStringObj(Tcl_DStringValue(&tcol), -1);
	Tcl_DStringFree(&tcol);
	}
#else
	elem = Tcl_NewStringObj(col[0], -1);
#endif
	Tcl_SetObjResult(interp, elem);
	return 1;
}

/*
 * __tcl_delete_cmd
 *	Called when the command is deleted.
 */
static void
__tcl_delete_cmd(void* _dbctx)
{
	dbsql_ctx_t *dbctx = (dbsql_ctx_t*)_dbctx;
	dbctx->dbp->close(dbctx->dbp);
	while (dbctx->func) {
		sql_func_t *func = dbctx->func;
		dbctx->func = func->next;
		Tcl_Free((char*)func);
	}
	if (dbctx->busy) {
		Tcl_Free(dbctx->busy);
	}
	if (dbctx->trace) {
		Tcl_Free(dbctx->trace);
	}
	if (dbctx->auth) {
		Tcl_Free(dbctx->auth);
	}
	Tcl_Free((char*)dbctx);
}

/*
 * __tcl_busy_handler
 *	This routine is called when a database file is locked while trying
 *	to execute SQL.
 */
static int
__tcl_busy_handler(cd, table, tries)
	void *cd;
	const char *table;
	int tries;
{
	dbsql_ctx_t *dbctx = (dbsql_ctx_t*)cd;
	int rc;
	char val[30];
	char *command;
	Tcl_DString cmd;

	Tcl_DStringInit(&cmd);
	Tcl_DStringAppend(&cmd, dbctx->busy, -1);
	Tcl_DStringAppendElement(&cmd, table);
	sprintf(val, " %d", tries);
	Tcl_DStringAppend(&cmd, val, -1);
	command = Tcl_DStringValue(&cmd);
	rc = Tcl_Eval(dbctx->interp, command);
	Tcl_DStringFree(&cmd);
	if (rc != TCL_OK || atoi(Tcl_GetStringResult(dbctx->interp))) {
		return 0;
	}
	return 1;
}

/*
 * __tcl_progress_handler --
 *	This routine is invoked as the 'progress callback' for the database.
 */
static int
__tcl_progress_handler(void* cd)
{
	int rc;
	dbsql_ctx_t *dbctx = (dbsql_ctx_t*)cd;

	DBSQL_ASSERT(dbctx->progress);
	rc = Tcl_Eval(dbctx->interp, dbctx->progress);
	if (rc != TCL_OK || atoi(Tcl_GetStringResult(dbctx->interp))) {
		return 1;
	}
	return 0;
}

/*
 * __tcl_trace_handler --
 *	This routine is called by the DBSQL trace handler whenever a new
 *	block of SQL is executed.  The TCL script in dbctx->trace is executed.
 */
static void
__tcl_trace_handler(_dbctx, sql)
	void *_dbctx;
	const char *sql;
{
	dbsql_ctx_t *dbctx = (dbsql_ctx_t*)_dbctx;
	Tcl_DString str;

	Tcl_DStringInit(&str);
	Tcl_DStringAppend(&str, dbctx->trace, -1);
	Tcl_DStringAppendElement(&str, sql);
	Tcl_Eval(dbctx->interp, Tcl_DStringValue(&str));
	Tcl_DStringFree(&str);
	Tcl_ResetResult(dbctx->interp);
}

/*
 * __tcl_commit_handler --
 *	This routine is called when a transaction is committed.  The
 *	TCL script in dbctx->commit is executed.  If it returns non-zero or
 *	if it throws an exception, the transaction is rolled back instead
 *	of being committed.
 */
static int
__tcl_commit_handler(void* _dbctx)
{
	int rc;
	dbsql_ctx_t *dbctx = (dbsql_ctx_t*)_dbctx;

	rc = Tcl_Eval(dbctx->interp, dbctx->commit);
	if (rc != TCL_OK || atoi(Tcl_GetStringResult(dbctx->interp))) {
		return 1;
	}
	return 0;
}

/*
 * __tcl_eval_sql_fn
 *	This routine is called to evaluate a SQL function implemented
 *	using TCL script.
 */
static void
__tcl_eval_sql_fn(context, argc, argv)
	dbsql_func_t *context;
	int argc;
	const char **argv;
{
	int i;
	int rc;
	sql_func_t *p = dbsql_user_data(context);
	Tcl_DString cmd;

	Tcl_DStringInit(&cmd);
	Tcl_DStringAppend(&cmd, p->script, -1);
	for (i = 0; i < argc; i++) {
		Tcl_DStringAppendElement(&cmd, argv[i] ? argv[i] : "");
	}
	rc = Tcl_Eval(p->interp, Tcl_DStringValue(&cmd));
	if (rc) {
		dbsql_set_result_error(context,
					Tcl_GetStringResult(p->interp), -1);
	} else {
		dbsql_set_result_string(context,
					 Tcl_GetStringResult(p->interp), -1);
	}
}

#ifndef DBSQL_NO_AUTH
/*
** This is the authentication function.  It appends the authentication
** type code and the two arguments to cmd[] then invokes the result
** on the interpreter.  The reply is examined to determine if the
** authentication fails or succeeds.
*/
static int
__tcl_auth_callback(_dbctx, c, arg1, arg2, arg3, arg4)
	void *_dbctx;
	int c;
	const char *arg1;
	const char *arg2;
	const char *arg3;
	const char *arg4;
{
	int rc;
	char *code;
	Tcl_DString str;
	const char *reply;
	dbsql_ctx_t *dbctx = (dbsql_ctx_t*)_dbctx;

	switch(c) {
	case DBSQL_COPY              : code="DBSQL_COPY"; break;
	case DBSQL_CREATE_INDEX      : code="DBSQL_CREATE_INDEX"; break;
	case DBSQL_CREATE_TABLE      : code="DBSQL_CREATE_TABLE"; break;
	case DBSQL_CREATE_TEMP_INDEX : code="DBSQL_CREATE_TEMP_INDEX"; break;
	case DBSQL_CREATE_TEMP_TABLE : code="DBSQL_CREATE_TEMP_TABLE"; break;
	case DBSQL_CREATE_TEMP_TRIGGER:code="DBSQL_CREATE_TEMP_TRIGGER"; break;
	case DBSQL_CREATE_TEMP_VIEW  : code="DBSQL_CREATE_TEMP_VIEW"; break;
	case DBSQL_CREATE_TRIGGER    : code="DBSQL_CREATE_TRIGGER"; break;
	case DBSQL_CREATE_VIEW       : code="DBSQL_CREATE_VIEW"; break;
	case DBSQL_DELETE            : code="DBSQL_DELETE"; break;
	case DBSQL_DROP_INDEX        : code="DBSQL_DROP_INDEX"; break;
	case DBSQL_DROP_TABLE        : code="DBSQL_DROP_TABLE"; break;
	case DBSQL_DROP_TEMP_INDEX   : code="DBSQL_DROP_TEMP_INDEX"; break;
	case DBSQL_DROP_TEMP_TABLE   : code="DBSQL_DROP_TEMP_TABLE"; break;
	case DBSQL_DROP_TEMP_TRIGGER : code="DBSQL_DROP_TEMP_TRIGGER"; break;
	case DBSQL_DROP_TEMP_VIEW    : code="DBSQL_DROP_TEMP_VIEW"; break;
	case DBSQL_DROP_TRIGGER      : code="DBSQL_DROP_TRIGGER"; break;
	case DBSQL_DROP_VIEW         : code="DBSQL_DROP_VIEW"; break;
	case DBSQL_INSERT            : code="DBSQL_INSERT"; break;
	case DBSQL_PRAGMA            : code="DBSQL_PRAGMA"; break;
	case DBSQL_READ              : code="DBSQL_READ"; break;
	case DBSQL_SELECT            : code="DBSQL_SELECT"; break;
	case DBSQL_TRANSACTION       : code="DBSQL_TRANSACTION"; break;
	case DBSQL_UPDATE            : code="DBSQL_UPDATE"; break;
	case DBSQL_ATTACH            : code="DBSQL_ATTACH"; break;
	case DBSQL_DETACH            : code="DBSQL_DETACH"; break;
	default                      : code="????"; break;
	}
	Tcl_DStringInit(&str);
	Tcl_DStringAppend(&str, dbctx->auth, -1);
	Tcl_DStringAppendElement(&str, code);
	Tcl_DStringAppendElement(&str, arg1 ? arg1 : "");
	Tcl_DStringAppendElement(&str, arg2 ? arg2 : "");
	Tcl_DStringAppendElement(&str, arg3 ? arg3 : "");
	Tcl_DStringAppendElement(&str, arg4 ? arg4 : "");
	rc = Tcl_GlobalEval(dbctx->interp, Tcl_DStringValue(&str));
	Tcl_DStringFree(&str);
	reply = Tcl_GetStringResult(dbctx->interp);
	if (strcmp(reply,"DBSQL_SUCCESS") == 0) {
		rc = DBSQL_SUCCESS;
	} else if (strcmp(reply,"DBSQL_DENY") == 0) {
		rc = DBSQL_DENY;
	} else if (strcmp(reply,"DBSQL_IGNORE") == 0) {
		rc = DBSQL_IGNORE;
	} else {
		rc = 999;
	}
	return rc;
}
#endif /* DBSQL_NO_AUTH */

/*
 * __tcl_dbsql_cmd_impl --
 *	The "dbsql" command below creates a new Tcl command for each
 *	connection it opens to a DBSQL database.  This routine is invoked
 *	whenever one of those connection-specific commands is executed
 *	in Tcl.  For example, if you run Tcl code like this:
 *
 *	dbsql db1  "my_database"
 *	db1 close
 *
 *	The first command opens a connection to the "my_database" database
 *	and calls that connection "db1".  The second command causes this
 *	subroutine to be invoked.
 */
static int
__tcl_dbsql_cmd_impl(_dbctx, interp, objc, objv)
	void *_dbctx;
	Tcl_Interp *interp;
	int objc;
	Tcl_Obj * const *objv;
{
	int n, complete, nscript, rowid, nchanges, choice, len, rc = TCL_OK;
	int nkey, ms;
	char *script, *name, *auth, *busy, *progress, *commit, *err_msgs, *sql;
	char *trace;
	dbsql_ctx_t *dbctx = (dbsql_ctx_t*)_dbctx;
	Tcl_Obj *result;
	callback_data_t data;
	sql_func_t *func;
	void *key;
#ifdef UTF_TRANSLATION_NEEDED
	Tcl_DString dsql;
	int i;
#endif
	static const char *DBSQL_strs[] = {
		"authorizer",           "busy",              "changes",
		"close",                "commit_hook",       "complete",
		"errorcode",            "eval",              "function",
		"last_inserted_rowid",  "onecolumn",         "progress",
		"timeout",              "trace",             NULL };
	enum DBSQL_enum {
	DBSQL__AUTHORIZER,        DBSQL__BUSY,             DBSQL__CHANGES,
	DBSQL__CLOSE,             DBSQL__COMMIT_HOOK,      DBSQL__COMPLETE,
	DBSQL__ERRORCODE,         DBSQL__EVAL,             DBSQL__FUNCTION,
	DBSQL__LAST_INSERT_ROWID, DBSQL__ONECOLUMN,        DBSQL__PROGRESS,
	DBSQL__TIMEOUT,           DBSQL__TRACE
	};

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

	switch ((enum DBSQL_enum)choice) {

	case DBSQL__AUTHORIZER:
		/*
		 *    $db authorizer ?CALLBACK?
		 *
		 * Invoke the given callback to authorize each SQL operation
		 * as it is compiled.  5 arguments are appended to the
		 * callback before it is invoked:
		 *
		 *   (1) The authorization type (ex: DBSQL_CREATE_TABLE,
		 *       DBSQL_INSERT, ...)
		 *   (2) First descriptive name (depends on authorization type)
		 *   (3) Second descriptive name
		 *   (4) Name of the database (ex: "main", "temp")
		 *   (5) Name of trigger that is doing the access
		 *
		 * The callback should return on of the following
		 * strings: DBSQL_SUCCESS, DBSQL_IGNORE, or DBSQL_DENY.  Any
		 * other return value is an error.
		 *
		 * If this method is invoked with no arguments, the current
		 * authorization* callback string is returned.
		 */
		if (objc > 3) {
			Tcl_WrongNumArgs(interp, 2, objv, "?CALLBACK?");
		} else if (objc == 2) {
			if (dbctx->auth) {
				Tcl_AppendResult(interp, dbctx->auth, 0);
			}
		} else {
			if (dbctx->auth) {
				Tcl_Free(dbctx->auth);
			}
			auth = Tcl_GetStringFromObj(objv[2], &len);
			if (auth && len > 0) {
				dbctx->auth = Tcl_Alloc(len + 1);
				strcpy(dbctx->auth, auth);
			} else {
				dbctx->auth = 0;
			}
#ifndef DBSQL_NO_AUTH
			if (dbctx->auth) {
				dbctx->interp = interp;
				dbctx->dbp->set_authorizer(dbctx->dbp,
							   __tcl_auth_callback,
							   dbctx);
			} else {
				dbctx->dbp->set_authorizer(dbctx->dbp, 0, 0);
			}
#endif
		}
		break;

	case DBSQL__BUSY:
		/*
		 * $db busy ?CALLBACK?
		 *
		 * Invoke the given callback if an SQL statement attempts
		 * to open a locked database file.
		 */
		if (objc > 3) {
			Tcl_WrongNumArgs(interp, 2, objv, "CALLBACK");
			return TCL_ERROR;
		} else if (objc == 2) {
			if (dbctx->busy) {
				Tcl_AppendResult(interp, dbctx->busy, 0);
			}
		} else {
			if (dbctx->busy) {
				Tcl_Free(dbctx->busy);
			}
			busy = Tcl_GetStringFromObj(objv[2], &len);
			if (busy && len > 0) {
				dbctx->busy = Tcl_Alloc(len + 1);
				strcpy(dbctx->busy, busy);
			} else {
				dbctx->busy = 0;
			}
			if (dbctx->busy) {
				dbctx->interp = interp;
				dbctx->dbp->set_busycall(dbctx->dbp,
							 __tcl_busy_handler,
							 dbctx);
			} else {
				dbctx->dbp->set_busycall(dbctx->dbp, 0, 0);
			}
		}
		break;
	case DBSQL__PROGRESS:
		/*
		 *    $db progress ?N CALLBACK?
		 *
		 * Invoke the given callback every N virtual machine
		 * opcodes while executing queries.
		 */
		if (objc == 2) {
			if (dbctx->progress) {
				Tcl_AppendResult(interp, dbctx->progress, 0);
			}
		} else if (objc == 4) {
			if (TCL_OK!=Tcl_GetIntFromObj(interp, objv[2], &n)) {
				return TCL_ERROR;
			}
			if (dbctx->progress) {
				Tcl_Free(dbctx->progress);
			}
			progress = Tcl_GetStringFromObj(objv[3], &len);
			if (progress && len > 0) {
				dbctx->progress = Tcl_Alloc(len + 1);
				strcpy(dbctx->progress, progress);
			} else {
				dbctx->progress = 0;
			}
#ifndef DBSQL_NO_PROGRESS
			if (dbctx->progress) {
				dbctx->interp = interp;
				dbctx->dbp->set_progresscall(dbctx->dbp, n,
							__tcl_progress_handler,
							dbctx);
			} else {
				dbctx->dbp->set_progresscall(dbctx->dbp,0,0,0);
			}
#endif
		} else {
			Tcl_WrongNumArgs(interp, 2, objv, "N CALLBACK");
			return TCL_ERROR;
		}
		break;
	case DBSQL__CHANGES:
		/*
		*     $db changes
		*
		* Return the number of rows that were modified, inserted,
		* or deleted by the most recent "eval".
		*/
		if (objc != 2) {
			Tcl_WrongNumArgs(interp, 2, objv, "");
			return TCL_ERROR;
		}
		nchanges = dbctx->dbp->last_change_count(dbctx->dbp);
		result = Tcl_GetObjResult(interp);
		Tcl_SetIntObj(result, nchanges);
		break;
	case DBSQL__CLOSE:
		/*
		 *    $db close
		 *
		 * Shutdown the database.
		 */
		dbctx->dbp->close(dbctx->dbp);
		dbctx->dbenv->close(dbctx->dbenv, 0);
		Tcl_DeleteCommand(interp, Tcl_GetStringFromObj(objv[0], 0));
		break;
	case DBSQL__COMMIT_HOOK:
		/*
		 *    $db commit_hook ?CALLBACK?
		 *
		 * Invoke the given callback just before committing every
		 * SQL transaction.  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.
		 */
		if (objc > 3) {
			Tcl_WrongNumArgs(interp, 2, objv, "?CALLBACK?");
		} else if (objc == 2) {
			if (dbctx->commit) {
				Tcl_AppendResult(interp, dbctx->commit, 0);
			}
		} else {
			if (dbctx->commit) {
				Tcl_Free(dbctx->commit);
			}
			commit = Tcl_GetStringFromObj(objv[2], &len);
			if (commit && len > 0) {
				dbctx->commit = Tcl_Alloc(len + 1);
				strcpy(dbctx->commit, commit);
			} else {
				dbctx->commit = 0;
			}
			if (dbctx->commit) {
				dbctx->interp = interp;
				dbctx->dbp->set_commitcall(dbctx->dbp,
							 __tcl_commit_handler,
							 dbctx);
			} else {
				dbctx->dbp->set_commitcall(dbctx->dbp, 0, 0);
			}
		}
		break;
	case DBSQL__COMPLETE:
		/*
		 *    $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.
		 */
		if (objc != 3) {
			Tcl_WrongNumArgs(interp, 2, objv, "SQL");
			return TCL_ERROR;
		}
		complete = dbsql_complete_stmt(Tcl_GetStringFromObj(objv[2],
								    0));
		result = Tcl_GetObjResult(interp);
		Tcl_SetBooleanObj(result, complete);
		break;
	case DBSQL__ERRORCODE:
		/*
		 *    $db errorcode
		 *
		 * Return the numeric error code that was returned by the
		 * most recent call to dbsql_exec().
		 */
		Tcl_SetObjResult(interp, Tcl_NewIntObj(dbctx->rc));
		break;
	case DBSQL__EVAL:
		/*
		*    $db eval $sql ?array {  ...code... }?
		*
		* The SQL statement in $sql is evaluated.  For each row, the
		* values are placed in elements of the array named "array"
		* and ...code... is executed.  If "array" and "code" are
		* omitted, then no callback is every invoked.  If "array" is
		* an empty string, then the values are placed in variables
		* that have the same name as the fields extracted by the query.
		*/
		if (objc != 5 && objc != 3) {
			Tcl_WrongNumArgs(interp, 2, objv,
					 "SQL ?ARRAY-NAME CODE?");
			return TCL_ERROR;
		}
		dbctx->interp = interp;
		sql = Tcl_GetStringFromObj(objv[2], 0);
#ifdef UTF_TRANSLATION_NEEDED
		Tcl_DStringInit(&dsql);
		Tcl_UtfToExternalDString(NULL, sql, -1, &dsql);
		sql = Tcl_DStringValue(&dsql);
#endif
		Tcl_IncrRefCount(objv[2]);
		if (objc == 5) {
			data.interp = interp;
			data.once = 1;
			data.array = Tcl_GetStringFromObj(objv[3], 0);
			data.code = objv[4];
			data.tcl_rc = TCL_OK;
			data.ncols = 0;
			data.col_names = 0;
			err_msgs = 0;
			Tcl_IncrRefCount(objv[3]);
			Tcl_IncrRefCount(objv[4]);
			rc = dbctx->dbp->exec(dbctx->dbp, sql,
					__tcl_process_row, &data, &err_msgs);
			Tcl_DecrRefCount(objv[4]);
			Tcl_DecrRefCount(objv[3]);
			if (data.tcl_rc == TCL_BREAK) {
				data.tcl_rc = TCL_OK;
			}
		} else {
			Tcl_Obj *list = Tcl_NewObj();
			data.tcl_rc = TCL_OK;
			rc = dbctx->dbp->exec(dbctx->dbp, sql,
					__tcl_process_row2, list, &err_msgs);
			Tcl_SetObjResult(interp, list);
		}
		dbctx->rc = rc;
		if (rc == DBSQL_ABORT) {
			if (err_msgs)
				free(err_msgs);
			rc = data.tcl_rc;
		} else if (err_msgs) {
			Tcl_SetResult(interp, err_msgs, TCL_VOLATILE);
			free(err_msgs);
			rc = TCL_ERROR;
		} else if (rc != DBSQL_SUCCESS) {
			Tcl_AppendResult(interp, dbsql_strerror(rc), 0);
			rc = TCL_ERROR;
		} else {
		}
		Tcl_DecrRefCount(objv[2]);
#ifdef UTF_TRANSLATION_NEEDED
		Tcl_DStringFree(&dsql);
		if (objc == 5 && data.col_names) {
			for (i = 0; i < data.ncols; i++) {
				if (data.col_names[i])
					free(data.col_names[i]);
			}
			free(data.col_names);
			data.col_names = 0;
		}
#endif
		break;
	case DBSQL__FUNCTION:
		/*
		 *     $db function NAME SCRIPT
		 *
		 * Create a new SQL function called NAME.  Whenever that
		 * function is called, invoke SCRIPT to evaluate the function.
		 */
		if (objc != 4) {
		  Tcl_WrongNumArgs(interp, 2, objv, "NAME SCRIPT");
		  return TCL_ERROR;
		}
		name = Tcl_GetStringFromObj(objv[2], 0);
		script = Tcl_GetStringFromObj(objv[3], &nscript);
		func = (sql_func_t*)Tcl_Alloc(sizeof(*func) + nscript + 1);
		if (func == 0)
			return TCL_ERROR;
		func->interp = interp;
		func->next = dbctx->func;
		func->script = (char*)&func[1];
		strcpy(func->script, script);
		dbctx->dbp->create_function(dbctx->dbp, name, -1,
					    DBSQL_UTF8_ENCODED, func,
					    __tcl_eval_sql_fn,
					    NULL, NULL);
		dbctx->dbp->func_return_type(dbctx->dbp, name, DBSQL_NUMERIC);
		break;
	case DBSQL__LAST_INSERT_ROWID:
		/*
		*     $db last_inserted_rowid
		*
		* Return an integer which is the ROWID for the most
		* recent insert.
		*/
		if (objc != 2) {
			Tcl_WrongNumArgs(interp, 2, objv, "");
			return TCL_ERROR;
		}
		rowid = dbctx->dbp->rowid(dbctx->dbp);
		result = Tcl_GetObjResult(interp);
		Tcl_SetIntObj(result, rowid);
		break;
	case DBSQL__ONECOLUMN:
		/*
		 *     $db onecolumn SQL
		 *
		 * Return a single column from a single row of the given
		 * SQL query.
		 */
		if (objc != 3) {
			Tcl_WrongNumArgs(interp, 2, objv, "SQL");
			return TCL_ERROR;
		}
		sql = Tcl_GetStringFromObj(objv[2], 0);
		rc = dbctx->dbp->exec(dbctx->dbp, sql, __tcl_process_row3,
				      interp, &err_msgs);
		if (rc == DBSQL_ABORT) {
			rc = DBSQL_SUCCESS;
		} else if (err_msgs) {
			Tcl_SetResult(interp, err_msgs, TCL_VOLATILE);
			free(err_msgs);
			rc = TCL_ERROR;
		} else if (rc != DBSQL_SUCCESS) {
			Tcl_AppendResult(interp, dbsql_strerror(rc), 0);
			rc = TCL_ERROR;
		}
		break;
	case DBSQL__TIMEOUT:
		/*
		 *     $db timeout MILLESECONDS
		 *
		 * Delay for the number of milliseconds specified when a
		 * file is locked.
		 */
		if (objc != 3) {
			Tcl_WrongNumArgs(interp, 2, objv, "MILLISECONDS");
			return TCL_ERROR;
		}
		if (Tcl_GetIntFromObj(interp, objv[2], &ms))
			return TCL_ERROR;
		dbctx->dbp->set_timeout(dbctx->dbp, ms);
		break;
	case DBSQL__TRACE:
		/*
		 *    $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.
		 */
		if (objc > 3) {
			Tcl_WrongNumArgs(interp, 2, objv, "?CALLBACK?");
		} else if (objc == 2) {
			if (dbctx->trace) {
				Tcl_AppendResult(interp, dbctx->trace, 0);
			}
		} else {
			if(dbctx->trace) {
				Tcl_Free(dbctx->trace);
			}
			trace = Tcl_GetStringFromObj(objv[2], &len);
			if (trace && len > 0) {
				dbctx->trace = Tcl_Alloc(len + 1);
				strcpy(dbctx->trace, trace);
			} else {
				dbctx->trace = 0;
			}
			if (dbctx->trace) {
				dbctx->interp = interp;
				dbctx->dbp->set_tracecall(dbctx->dbp,
							  __tcl_trace_handler,
							  dbctx);
			} else {
				dbctx->dbp->set_tracecall(dbctx->dbp, 0, 0);
			}
		}
		break;
	}
	return rc;
}

/*
 * This function generates a string of random characters.  Used for
 * generating test data.
 */
void
__tcl_sql_func_randstr(context, argc, argv)
	dbsql_func_t *context;
	int argc;
	const char **argv;
{
	static const char src[] =
		"abcdefghijklmnopqrstuvwxyz"
		"ABCDEFGHIJKLMNOPQRSTUVWXYZ"
		"0123456789"
		".-!,:*^+=_|?/<> ";
	int min, max, n, r, i;
	char buf[1000];

	if (argc >= 1) {
		min = atoi(argv[0]);
		if (min <0)
			min = 0;
		if (min >= sizeof(buf))
			min = sizeof(buf) - 1;
	} else {
		min = 1;
	}
	if (argc >= 2) {
		max = atoi(argv[1]);
		if (max < min)
			max = min;
		if (max >= sizeof(buf))
			max = sizeof(buf) - 1;
	} else {
		max = 50;
	}
	n = min;
	if (max > min) {
		r = rand() & 0x7fffffff;
		n += r % (max + 1 - min);
	}
	DBSQL_ASSERT(n < sizeof(buf));
	r = 0;
	for (i = 0; i < n; i++) {
		uint8_t rb = (uint8_t) (rand() % 256);
		r = (r + rb) % (sizeof(src) - 1);
		buf[i] = src[r];
	}
	buf[n] = 0;
	dbsql_set_result_string(context, buf, n);
}

/*
 * __register_tcl_sql_funcs --
 *	This function registered all of the above C functions as SQL
 *	functions.  This should be the only routine in this file with
 *	external linkage.
 */
void
__register_tcl_sql_funcs(DBSQL* dbp)
{
	static struct {
		char *name;
		int args;
		int type;
		void (*fn)(dbsql_func_t *, int, const char**);
	} funcs[] = {
#ifdef CONFIG_TEST
		{ "randstr", 2, DBSQL_TEXT, __tcl_sql_func_randstr },
#endif
	};
	static struct {
		char *name;
		int args;
		int type;
		void (*step)(dbsql_func_t *, int, const char**);
		void (*finalize)(dbsql_func_t *);
	} aggfns[] = {
#ifdef CONFIG_TEST
		{ "md5sum", -1, DBSQL_TEXT,
		  __tcl_sql_func_md5step, __tcl_sql_func_md5finalize },
#endif
	};
	int i;

	for (i = 0; i < (sizeof(funcs) / sizeof(funcs[0])); i++) {
		dbp->create_function(dbp, funcs[i].name,
				     funcs[i].args,
				     DBSQL_ASCII_ENCODED,/* FIXME: not used */
				     NULL,
				     funcs[i].fn,
				     NULL,
				     NULL);
		if (funcs[i].fn) {
			dbp->func_return_type(dbp, funcs[i].name,
					      funcs[i].type);
		}
	}

	for (i = 0; i < (sizeof(aggfns) / sizeof(aggfns[0])); i++) {
		dbp->create_function(dbp, aggfns[i].name,
				     aggfns[i].args,
				     DBSQL_ASCII_ENCODED,/* FIXME: not used */
				     NULL,
				     NULL,
				     aggfns[i].step,
				     aggfns[i].finalize);
		dbp->func_return_type(dbp, aggfns[i].name, aggfns[i].type);
	}
}

/*
 * __tcl_dbsql_impl --
 *	dbsql DBNAME FILENAME ?MODE? ?-key KEY?
 *
 *	This is the main Tcl command.  When the "dbsql" Tcl command is
 *	invoked, this routine runs to process that command.
 *
 * DBNAME
 *          An arbitrary name for a new database connection.  This
 *          command creates a new command named DBNAME that is used
 *          to control that connection.  The database connection is
 *          deleted when the DBNAME command is deleted.
 *
 * FILENAME
 *          The name of the directory that contains the database that
 *          is to be accessed.
 *
 * ?MODE?
 *          The mode of the database to be created.
 *
 * ?-key KEY?
 *
 *
 * -encoding
 *          Return the encoding used by LIKE and GLOB operators.  Choices
 *          are UTF-8 and iso8859.
 *
 * -version
 *          Return the version number of the library.
 *
 * -tcl-uses-utf
 *          Return "1" if compiled with a Tcl uses UTF-8.  Return "0" if
 *          not.  Used by tests to make sure the library was compiled
 *          correctly.
 */
static int
__tcl_dbsql_impl(void* _dbctx, Tcl_Interp* interp, int objc, Tcl_Obj* const*objv)
{
	int rc;
	int mode;
	dbsql_ctx_t *dbctx;
	void *key = 0;
	int nkey = 0;
	const char *args;
	char *err_msgs;
	const char *filename;
	char buf[80];
	const char *ver;

	if (objc == 2) {
		args = Tcl_GetStringFromObj(objv[1], 0);
		if (strcmp(args, "-encoding") == 0) {
			Tcl_AppendResult(interp, dbctx->dbp->encoding(), 0);
			return TCL_OK;
		}
		if (strcmp(args, "-version") == 0) {
			int major, minor, patch;
			ver = dbsql_version(&major, &minor, &patch);
			Tcl_AppendResult(interp, ver, 0);
			return TCL_OK;
		}
		if (strcmp(args, "-has-crypto") == 0) {
			Tcl_AppendResult(interp,"1",0);
			return TCL_OK;
		}
		if (strcmp(args,"-tcl-uses-utf") == 0) {
#ifdef TCL_UTF_MAX
			Tcl_AppendResult(interp,"1",0);
#else
			Tcl_AppendResult(interp,"0",0);
#endif
			return TCL_OK;
		}
	}
	if (objc == 5 || objc == 6) {
		args = Tcl_GetStringFromObj(objv[objc-2], 0);
		if (strcmp(args, "-key") == 0){
			key = Tcl_GetByteArrayFromObj(objv[objc-1], &nkey);
			objc -= 2;
		}
	}
	if (objc != 3 && objc != 4) {
		Tcl_WrongNumArgs(interp, 1, objv,
				 "HANDLE FILENAME ?MODE? ?-key CRYPTOKEY?");
		return TCL_ERROR;
	}
	if (objc == 3) {
		mode = 0666;
	} else if (Tcl_GetIntFromObj(interp, objv[3], &mode) != TCL_OK) {
		return TCL_ERROR;
	}
	err_msgs = 0;
	dbctx = (dbsql_ctx_t*)Tcl_Alloc(sizeof(*dbctx));
	if (dbctx == 0) {
		Tcl_SetResult(interp, "malloc failed", TCL_STATIC);
		return TCL_ERROR;
	}
	memset(dbctx, 0, sizeof(*dbctx));
	filename = Tcl_GetStringFromObj(objv[2], 0);

	/* First setup the DB_ENV */
	if ((rc = db_env_create(&dbctx->dbenv, 0)) != 0) {
		Tcl_SetResult(interp, db_strerror(rc), TCL_STATIC);
		return TCL_ERROR;
	}
	dbctx->dbenv->set_errfile(dbctx->dbenv, stderr);
	dbctx->dbenv->set_lk_detect(dbctx->dbenv, DB_LOCK_DEFAULT);
	rc = dbctx->dbenv->set_cachesize(dbctx->dbenv, 0, 64 * 1024 * 1024, 0);
	if (rc) {
		Tcl_SetResult(interp, db_strerror(rc), TCL_STATIC);
		dbctx->dbenv->close(dbctx->dbenv, 0);
		return TCL_ERROR;
	}
	if (nkey > 0) {
		dbctx->crypt = (nkey ? 1 : 0);
		if ((rc = dbctx->dbenv->set_encrypt(dbctx->dbenv, key,
					      DB_ENCRYPT_AES)) != 0) {
			Tcl_SetResult(interp, db_strerror(rc), TCL_STATIC);
			dbctx->dbenv->close(dbctx->dbenv, 0);
			return TCL_ERROR;
		}
	}
	if ((rc = dbctx->dbenv->open(dbctx->dbenv, filename,
				     DB_CREATE | DB_INIT_LOCK | DB_INIT_LOG |
				     DB_INIT_MPOOL | DB_INIT_TXN, 0)) != 0) {
		Tcl_SetResult(interp, db_strerror(rc), TCL_STATIC);
		dbctx->dbenv->close(dbctx->dbenv, 0);
	}
	if (dbsql_create(&dbctx->dbp, dbctx->dbenv, mode) != 0) {
		Tcl_SetResult(interp, err_msgs, TCL_VOLATILE);
		Tcl_Free((char*)dbctx);
		free(err_msgs);
		return TCL_ERROR;
	}
	args = Tcl_GetStringFromObj(objv[1], 0);
	Tcl_CreateObjCommand(interp, args, __tcl_dbsql_cmd_impl,
			     (char*)dbctx, __tcl_delete_cmd);

	/*
	 * The return value is the value of the DBSQL* pointer.
	 */
	sprintf(buf, "%p", dbctx->dbp);
	if (strncmp(buf,"0x",2)) {
		sprintf(buf, "0x%p", dbctx->dbp);
	}
	Tcl_AppendResult(interp, buf, 0);

	/*
	 * If compiled with CONFIG_TEST turned on, then register the "md5sum"
	 * SQL function.
	 */
	__register_tcl_sql_funcs(dbctx->dbp);
	return TCL_OK;
}

/*
 * dbsql_init_tcl_interface --
 *	Initialize this module.
 *	This Tcl module contains only a single new Tcl command named "dbsql".
 *	By using this single name, there are no Tcl namespace issues.
 */
int
dbsql_init_tcl_interface(Tcl_Interp* interp)
{
	const char *cmd = "dbsql";

	Tcl_InitStubs(interp, "8.0", 0);
	Tcl_CreateObjCommand(interp, cmd, (Tcl_ObjCmdProc*)__tcl_dbsql_impl,
			     0, 0);
	Tcl_PkgProvide(interp, cmd, "2.0");
	return TCL_OK;
}

static char main_loop[] =
  "set line {}\n"
  "while {![eof stdin]} {\n"
    "if {$line!=\"\"} {\n"
      "puts -nonewline \"> \"\n"
    "} else {\n"
      "puts -nonewline \"% \"\n"
    "}\n"
    "flush stdout\n"
    "append line [gets stdin]\n"
    "if {[info complete $line]} {\n"
      "if {[catch {uplevel #0 $line} result]} {\n"
	"puts stderr \"Error: $result\"\n"
      "} elseif {$result!=\"\"} {\n"
	"puts $result\n"
      "}\n"
      "set line {}\n"
    "} else {\n"
      "append line \\n\n"
    "}\n"
  "}\n"
;

/*
 * main --
 */
int
main(int argc, char* *argv)
{
	int i;
	const char *info;
	Tcl_Interp *interp;
	Tcl_FindExecutable(argv[0]);
	interp = Tcl_CreateInterp();
	dbsql_init_tcl_interface(interp);
#ifdef CONFIG_TEST
	__testset_1_init(interp);
/* FIXME	extern int __testset_4_init(Tcl_Interp*);
        __testset_4_init(interp); */
	extern int __testset_MD5_init(Tcl_Interp*);
	__testset_MD5_init(interp);
#endif
	if (argc >= 2) {
		Tcl_SetVar(interp, "argv0", argv[1], TCL_GLOBAL_ONLY);
		Tcl_SetVar(interp, "argv", "", TCL_GLOBAL_ONLY);
		for (i = 2; i < argc; i++) {
			Tcl_SetVar(interp, "argv", argv[i],
				   TCL_GLOBAL_ONLY | TCL_LIST_ELEMENT |
				   TCL_APPEND_VALUE);
		}
		if (Tcl_EvalFile(interp, argv[1]) != TCL_OK) {
			info = Tcl_GetVar(interp, "errorInfo",
					  TCL_GLOBAL_ONLY);
			if (info == 0)
				info = interp->result;
			fprintf(stderr, "%s: %s\n", *argv, info);
			return 1;
		}
	} else {
		Tcl_GlobalEval(interp, main_loop);
	}
	return 0;
}