greg/dbsql
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity
dbsql/test/scr050/tcl_dbsql.c

1203 lines
32 KiB
C
Raw Normal View History

Initial import.
2007-03-10 19:04:07 +00:00
/*
* A TCL harness for executing the Sqlite test suite.
*/
#include "dbsql_config.h"
#ifndef NO_SYSTEM_INCLUDES
#include <stdlib.h>
#include <string.h>
#endif
#include "dbsql_int.h"
#include "tcl.h"
/*
* 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 {
Tcl_Interp *interp; /* The TCL interpret to execute the function */
char *script; /* The script to be run */
sql_func_t *next; /* Next function on the list of them all */
};
/*
* 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 */
};
#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(_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;
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(_data, ncol, col, col_names)
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(_dbctx)
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(cd)
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(_dbctx)
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",
0
};
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;
dbsql_set_authorizer(dbctx->dbp,
__tcl_auth_callback,
dbctx);
} else {
dbsql_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 = dbsql_last_inserted_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 = dbsql_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_strerr(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;
dbsql_set_busy_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;
dbsql_trace(dbctx->dbp,
__tcl_trace_handler, dbctx);
} else {
dbsql_trace(dbctx->dbp, 0, 0);
}
}
break;
}
return rc;
}
/*
* __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(_dbctx, interp, objc, objv)
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, dbsql_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);
if ((rc = dbctx->dbenv->set_cachesize(dbctx->dbenv, 0, 64 * 1024,
0)) != 0) {
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;
}
/*
* Provide a dummy Tcl_InitStubs if we are using this as a static
* library.
*/
#ifndef USE_TCL_STUBS
#undef Tcl_InitStubs
#define Tcl_InitStubs(a,b,c)
#endif
/*
* 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(interp)
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;
}
Reference in a new issue Copy permalink