diff options
Diffstat (limited to 'tcl8.6/pkgs/tdbcmysql1.1.0/generic/tdbcmysql.c')
| -rw-r--r-- | tcl8.6/pkgs/tdbcmysql1.1.0/generic/tdbcmysql.c | 3764 |
1 files changed, 0 insertions, 3764 deletions
diff --git a/tcl8.6/pkgs/tdbcmysql1.1.0/generic/tdbcmysql.c b/tcl8.6/pkgs/tdbcmysql1.1.0/generic/tdbcmysql.c deleted file mode 100644 index 5bcebfb..0000000 --- a/tcl8.6/pkgs/tdbcmysql1.1.0/generic/tdbcmysql.c +++ /dev/null @@ -1,3764 +0,0 @@ -/* - * tdbcmysql.c -- - * - * Bridge between TDBC (Tcl DataBase Connectivity) and MYSQL. - * - * Copyright (c) 2008, 2009 by Kevin B. Kenny. - * - * Please refer to the file, 'license.terms' for the conditions on - * redistribution of this file and for a DISCLAIMER OF ALL WARRANTIES. - * - * $Id: $ - * - *----------------------------------------------------------------------------- - */ - -#ifdef _MSC_VER -# define _CRT_SECURE_NO_WARNINGS -#endif - -#include <tcl.h> -#include <tclOO.h> -#include <tdbc.h> - -#include <stdio.h> -#include <string.h> - -#ifdef HAVE_STDINT_H -# include <stdint.h> -#endif - -#include "int2ptr_ptr2int.h" - -#include "fakemysql.h" - -/* Static data contained in this file */ - -TCL_DECLARE_MUTEX(mysqlMutex); /* Mutex protecting the global environment - * and its reference count */ - -static int mysqlRefCount = 0; /* Reference count on the global environment */ -Tcl_LoadHandle mysqlLoadHandle = NULL; - /* Handle to the MySQL library */ -unsigned long mysqlClientVersion; - /* Version number of MySQL */ - -/* - * Objects to create within the literal pool - */ - -const char* LiteralValues[] = { - "", - "0", - "1", - "direction", - "in", - "inout", - "name", - "nullable", - "out", - "precision", - "scale", - "type", - NULL -}; -enum LiteralIndex { - LIT_EMPTY, - LIT_0, - LIT_1, - LIT_DIRECTION, - LIT_IN, - LIT_INOUT, - LIT_NAME, - LIT_NULLABLE, - LIT_OUT, - LIT_PRECISION, - LIT_SCALE, - LIT_TYPE, - LIT__END -}; - -/* - * Structure that holds per-interpreter data for the MYSQL package. - */ - -typedef struct PerInterpData { - int refCount; /* Reference count */ - Tcl_Obj* literals[LIT__END]; - /* Literal pool */ - Tcl_HashTable typeNumHash; /* Lookup table for type numbers */ -} PerInterpData; -#define IncrPerInterpRefCount(x) \ - do { \ - ++((x)->refCount); \ - } while(0) -#define DecrPerInterpRefCount(x) \ - do { \ - PerInterpData* _pidata = x; \ - if ((--(_pidata->refCount)) <= 0) { \ - DeletePerInterpData(_pidata); \ - } \ - } while(0) - -/* - * Structure that carries the data for an MYSQL connection - * - * The ConnectionData structure is refcounted to simplify the - * destruction of statements associated with a connection. - * When a connection is destroyed, the subordinate namespace that - * contains its statements is taken down, destroying them. It's - * not safe to take down the ConnectionData until nothing is - * referring to it, which avoids taking down the hDBC until the - * other objects that refer to it vanish. - */ - -typedef struct ConnectionData { - int refCount; /* Reference count. */ - PerInterpData* pidata; /* Per-interpreter data */ - MYSQL* mysqlPtr; /* MySql connection handle */ - unsigned int nCollations; /* Number of collations defined */ - int* collationSizes; /* Character lengths indexed by collation ID */ - int flags; -} ConnectionData; - -/* - * Flags for the state of an MYSQL connection - */ - -#define CONN_FLAG_AUTOCOMMIT 0x1 /* Autocommit is set */ -#define CONN_FLAG_IN_XCN 0x2 /* Transaction is in progress */ -#define CONN_FLAG_INTERACTIVE 0x4 /* -interactive requested at connect */ - -#define IncrConnectionRefCount(x) \ - do { \ - ++((x)->refCount); \ - } while(0) -#define DecrConnectionRefCount(x) \ - do { \ - ConnectionData* conn = x; \ - if ((--(conn->refCount)) <= 0) { \ - DeleteConnection(conn); \ - } \ - } while(0) - -/* - * Structure that carries the data for a MySQL prepared statement. - * - * Just as with connections, statements need to defer taking down - * their client data until other objects (i.e., result sets) that - * refer to them have had a chance to clean up. Hence, this - * structure is reference counted as well. - */ - -typedef struct StatementData { - int refCount; /* Reference count */ - ConnectionData* cdata; /* Data for the connection to which this - * statement pertains. */ - Tcl_Obj* subVars; /* List of variables to be substituted, in the - * order in which they appear in the - * statement */ - struct ParamData *params; /* Data types and attributes of parameters */ - Tcl_Obj* nativeSql; /* Native SQL statement to pass into - * MySQL */ - MYSQL_STMT* stmtPtr; /* MySQL statement handle */ - MYSQL_RES* metadataPtr; /* MySQL result set metadata */ - Tcl_Obj* columnNames; /* Column names in the result set */ - int flags; -} StatementData; -#define IncrStatementRefCount(x) \ - do { \ - ++((x)->refCount); \ - } while (0) -#define DecrStatementRefCount(x) \ - do { \ - StatementData* stmt = (x); \ - if (--(stmt->refCount) <= 0) { \ - DeleteStatement(stmt); \ - } \ - } while(0) - -/* Flags in the 'StatementData->flags' word */ - -#define STMT_FLAG_BUSY 0x1 /* Statement handle is in use */ - -/* - * Structure describing the data types of substituted parameters in - * a SQL statement. - */ - -typedef struct ParamData { - int flags; /* Flags regarding the parameters - see below */ - int dataType; /* Data type */ - int precision; /* Size of the expected data */ - int scale; /* Digits after decimal point of the - * expected data */ -} ParamData; - -#define PARAM_KNOWN 1<<0 /* Something is known about the parameter */ -#define PARAM_IN 1<<1 /* Parameter is an input parameter */ -#define PARAM_OUT 1<<2 /* Parameter is an output parameter */ - /* (Both bits are set if parameter is - * an INOUT parameter) */ -#define PARAM_BINARY 1<<3 /* Parameter is binary */ - -/* - * Structure describing a MySQL result set. The object that the Tcl - * API terms a "result set" actually has to be represented by a MySQL - * "statement", since a MySQL statement can have only one set of results - * at any given time. - */ - -typedef struct ResultSetData { - int refCount; /* Reference count */ - StatementData* sdata; /* Statement that generated this result set */ - MYSQL_STMT* stmtPtr; /* Handle to the MySQL statement object */ - Tcl_Obj* paramValues; /* List of parameter values */ - MYSQL_BIND* paramBindings; /* Parameter bindings */ - unsigned long* paramLengths;/* Parameter lengths */ - my_ulonglong rowCount; /* Number of affected rows */ - my_bool* resultErrors; /* Failure indicators for retrieving columns */ - my_bool* resultNulls; /* NULL indicators for retrieving columns */ - unsigned long* resultLengths; - /* Byte lengths of retrieved columns */ - MYSQL_BIND* resultBindings; /* Bindings controlling column retrieval */ -} ResultSetData; -#define IncrResultSetRefCount(x) \ - do { \ - ++((x)->refCount); \ - } while (0) -#define DecrResultSetRefCount(x) \ - do { \ - ResultSetData* rs = (x); \ - if (--(rs->refCount) <= 0) { \ - DeleteResultSet(rs); \ - } \ - } while(0) - -/* Table of MySQL type names */ - -#define IS_BINARY (1<<16) /* Flag to OR in if a param is binary */ -typedef struct MysqlDataType { - const char* name; /* Type name */ - int num; /* Type number */ -} MysqlDataType; -static const MysqlDataType dataTypes[] = { - { "tinyint", MYSQL_TYPE_TINY }, - { "smallint", MYSQL_TYPE_SHORT }, - { "integer", MYSQL_TYPE_LONG }, - { "float", MYSQL_TYPE_FLOAT }, - { "real", MYSQL_TYPE_FLOAT }, - { "double", MYSQL_TYPE_DOUBLE }, - { "NULL", MYSQL_TYPE_NULL }, - { "timestamp", MYSQL_TYPE_TIMESTAMP }, - { "bigint", MYSQL_TYPE_LONGLONG }, - { "mediumint", MYSQL_TYPE_INT24 }, - { "date", MYSQL_TYPE_NEWDATE }, - { "date", MYSQL_TYPE_DATE }, - { "time", MYSQL_TYPE_TIME }, - { "datetime", MYSQL_TYPE_DATETIME }, - { "year", MYSQL_TYPE_YEAR }, - { "bit", MYSQL_TYPE_BIT | IS_BINARY }, - { "numeric", MYSQL_TYPE_NEWDECIMAL }, - { "decimal", MYSQL_TYPE_NEWDECIMAL }, - { "numeric", MYSQL_TYPE_DECIMAL }, - { "decimal", MYSQL_TYPE_DECIMAL }, - { "enum", MYSQL_TYPE_ENUM }, - { "set", MYSQL_TYPE_SET }, - { "tinytext", MYSQL_TYPE_TINY_BLOB }, - { "tinyblob", MYSQL_TYPE_TINY_BLOB | IS_BINARY }, - { "mediumtext", MYSQL_TYPE_MEDIUM_BLOB }, - { "mediumblob", MYSQL_TYPE_MEDIUM_BLOB | IS_BINARY }, - { "longtext", MYSQL_TYPE_LONG_BLOB }, - { "longblob", MYSQL_TYPE_LONG_BLOB | IS_BINARY }, - { "text", MYSQL_TYPE_BLOB }, - { "blob", MYSQL_TYPE_BLOB | IS_BINARY }, - { "varbinary", MYSQL_TYPE_VAR_STRING | IS_BINARY }, - { "varchar", MYSQL_TYPE_VAR_STRING }, - { "varbinary", MYSQL_TYPE_VARCHAR | IS_BINARY }, - { "varchar", MYSQL_TYPE_VARCHAR }, - { "binary", MYSQL_TYPE_STRING | IS_BINARY }, - { "char", MYSQL_TYPE_STRING }, - { "geometry", MYSQL_TYPE_GEOMETRY }, - { NULL, 0 } -}; - -/* Configuration options for MySQL connections */ - -/* Data types of configuration options */ - -enum OptType { - TYPE_STRING, /* Arbitrary character string */ - TYPE_FLAG, /* Boolean flag */ - TYPE_ENCODING, /* Encoding name */ - TYPE_ISOLATION, /* Transaction isolation level */ - TYPE_PORT, /* Port number */ - TYPE_READONLY, /* Read-only indicator */ - TYPE_TIMEOUT /* Timeout value */ -}; - -/* Locations of the string options in the string array */ - -enum OptStringIndex { - INDX_DB, INDX_HOST, INDX_PASSWD, INDX_SOCKET, - INDX_SSLCA, INDX_SSLCAPATH, INDX_SSLCERT, INDX_SSLCIPHER, INDX_SSLKEY, - INDX_USER, - INDX_MAX -}; - -/* Flags in the configuration table */ - -#define CONN_OPT_FLAG_MOD 0x1 /* Configuration value changable at runtime */ -#define CONN_OPT_FLAG_SSL 0x2 /* Configuration change requires setting - * SSL options */ -#define CONN_OPT_FLAG_ALIAS 0x4 /* Configuration option is an alias */ - - /* Table of configuration options */ - -static const struct { - const char * name; /* Option name */ - enum OptType type; /* Option data type */ - int info; /* Option index or flag value */ - int flags; /* Flags - modifiable; SSL related; is an alias */ - const char* query; /* How to determine the option value? */ -} ConnOptions [] = { - { "-compress", TYPE_FLAG, CLIENT_COMPRESS, 0, - "SELECT '', @@SLAVE_COMPRESSED_PROTOCOL" }, - { "-database", TYPE_STRING, INDX_DB, CONN_OPT_FLAG_MOD, - "SELECT '', DATABASE();"}, - { "-db", TYPE_STRING, INDX_DB, CONN_OPT_FLAG_MOD - | CONN_OPT_FLAG_ALIAS, - "SELECT '', DATABASE()" }, - { "-encoding", TYPE_ENCODING, 0, 0, - "SELECT '', 'utf-8'" }, - { "-host", TYPE_STRING, INDX_HOST, 0, - "SHOW SESSION VARIABLES WHERE VARIABLE_NAME = 'hostname'" }, - { "-interactive", TYPE_FLAG, CLIENT_INTERACTIVE, 0, - "SELECT '', 0" }, - { "-isolation", TYPE_ISOLATION, 0, CONN_OPT_FLAG_MOD, - "SELECT '', LCASE(REPLACE(@@TX_ISOLATION, '-', ''))" }, - { "-passwd", TYPE_STRING, INDX_PASSWD, CONN_OPT_FLAG_MOD - | CONN_OPT_FLAG_ALIAS, - "SELECT '', ''" }, - { "-password", TYPE_STRING, INDX_PASSWD, CONN_OPT_FLAG_MOD, - "SELECT '', ''" }, - { "-port", TYPE_PORT, 0, 0, - "SHOW SESSION VARIABLES WHERE VARIABLE_NAME = 'port'" }, - { "-readonly", TYPE_READONLY, 0, 0, - "SELECT '', 0" }, - { "-socket", TYPE_STRING, INDX_SOCKET, 0, - "SHOW SESSION VARIABLES WHERE VARIABLE_NAME = 'socket'" }, - { "-ssl_ca", TYPE_STRING, INDX_SSLCA, CONN_OPT_FLAG_SSL, - "SELECT '', @@SSL_CA"}, - { "-ssl_capath", TYPE_STRING, INDX_SSLCAPATH, CONN_OPT_FLAG_SSL, - "SELECT '', @@SSL_CAPATH" }, - { "-ssl_cert", TYPE_STRING, INDX_SSLCERT, CONN_OPT_FLAG_SSL, - "SELECT '', @@SSL_CERT" }, - { "-ssl_cipher", TYPE_STRING, INDX_SSLCIPHER, CONN_OPT_FLAG_SSL, - "SELECT '', @@SSL_CIPHER" }, - { "-ssl_cypher", TYPE_STRING, INDX_SSLCIPHER, CONN_OPT_FLAG_SSL - | CONN_OPT_FLAG_ALIAS, - "SELECT '', @@SSL_CIPHER" }, - { "-ssl_key", TYPE_STRING, INDX_SSLKEY, CONN_OPT_FLAG_SSL, - "SELECT '', @@SSL_KEY" }, - { "-timeout", TYPE_TIMEOUT, 0, CONN_OPT_FLAG_MOD, - "SELECT '', @@WAIT_TIMEOUT" }, - { "-user", TYPE_STRING, INDX_USER, CONN_OPT_FLAG_MOD, - "SELECT '', USER()" }, - { NULL, 0, 0, 0 } -}; - -/* Tables of isolation levels: Tcl, SQL, and MySQL 'tx_isolation' */ - -static const char *const TclIsolationLevels[] = { - "readuncommitted", - "readcommitted", - "repeatableread", - "serializable", - NULL -}; -static const char *const SqlIsolationLevels[] = { - "SET TRANSACTION ISOLATION LEVEL READ UNCOMMITTED", - "SET TRANSACTION ISOLATION LEVEL READ COMMITTED", - "SET TRANSACTION ISOLATION LEVEL REPEATABLE READ", - "SET TRANSACTION ISOLATION LEVEL SERIALIZABLE", - NULL -}; -enum IsolationLevel { - ISOL_READ_UNCOMMITTED, - ISOL_READ_COMMITTED, - ISOL_REPEATABLE_READ, - ISOL_SERIALIZABLE, - ISOL_NONE = -1 -}; - -/* Declarations of static functions appearing in this file */ - -static MYSQL_BIND* MysqlBindAlloc(int nBindings); -static MYSQL_BIND* MysqlBindIndex(MYSQL_BIND* b, int i); -static void* MysqlBindAllocBuffer(MYSQL_BIND* b, int i, unsigned long len); -static void MysqlBindFreeBuffer(MYSQL_BIND* b, int i); -static void MysqlBindSetBufferType(MYSQL_BIND* b, int i, - enum enum_field_types t); -static void* MysqlBindGetBuffer(MYSQL_BIND* b, int i); -static unsigned long MysqlBindGetBufferLength(MYSQL_BIND* b, int i); -static void MysqlBindSetLength(MYSQL_BIND* b, int i, unsigned long* p); -static void MysqlBindSetIsNull(MYSQL_BIND* b, int i, my_bool* p); -static void MysqlBindSetError(MYSQL_BIND* b, int i, my_bool* p); - -static MYSQL_FIELD* MysqlFieldIndex(MYSQL_FIELD* fields, int i); - -static void TransferMysqlError(Tcl_Interp* interp, MYSQL* mysqlPtr); -static void TransferMysqlStmtError(Tcl_Interp* interp, MYSQL_STMT* mysqlPtr); - -static Tcl_Obj* QueryConnectionOption(ConnectionData* cdata, Tcl_Interp* interp, - int optionNum); -static int ConfigureConnection(ConnectionData* cdata, Tcl_Interp* interp, - int objc, Tcl_Obj *const objv[], int skip); -static int ConnectionConstructor(ClientData clientData, Tcl_Interp* interp, - Tcl_ObjectContext context, - int objc, Tcl_Obj *const objv[]); -static int ConnectionBegintransactionMethod(ClientData clientData, - Tcl_Interp* interp, - Tcl_ObjectContext context, - int objc, Tcl_Obj *const objv[]); -static int ConnectionColumnsMethod(ClientData clientData, Tcl_Interp* interp, - Tcl_ObjectContext context, - int objc, Tcl_Obj *const objv[]); -static int ConnectionCommitMethod(ClientData clientData, Tcl_Interp* interp, - Tcl_ObjectContext context, - int objc, Tcl_Obj *const objv[]); -static int ConnectionConfigureMethod(ClientData clientData, Tcl_Interp* interp, - Tcl_ObjectContext context, - int objc, Tcl_Obj *const objv[]); -static int ConnectionEvaldirectMethod(ClientData clientData, Tcl_Interp* interp, - Tcl_ObjectContext context, - int objc, Tcl_Obj *const objv[]); -static int ConnectionNeedCollationInfoMethod(ClientData clientData, - Tcl_Interp* interp, - Tcl_ObjectContext context, - int objc, Tcl_Obj *const objv[]); -static int ConnectionRollbackMethod(ClientData clientData, Tcl_Interp* interp, - Tcl_ObjectContext context, - int objc, Tcl_Obj *const objv[]); -static int ConnectionSetCollationInfoMethod(ClientData clientData, - Tcl_Interp* interp, - Tcl_ObjectContext context, - int objc, Tcl_Obj *const objv[]); -static int ConnectionTablesMethod(ClientData clientData, Tcl_Interp* interp, - Tcl_ObjectContext context, - int objc, Tcl_Obj *const objv[]); - -static void DeleteConnectionMetadata(ClientData clientData); -static void DeleteConnection(ConnectionData* cdata); -static int CloneConnection(Tcl_Interp* interp, ClientData oldClientData, - ClientData* newClientData); - -static StatementData* NewStatement(ConnectionData* cdata); -static MYSQL_STMT* AllocAndPrepareStatement(Tcl_Interp* interp, - StatementData* sdata); -static Tcl_Obj* ResultDescToTcl(MYSQL_RES* resultDesc, int flags); - -static int StatementConstructor(ClientData clientData, Tcl_Interp* interp, - Tcl_ObjectContext context, - int objc, Tcl_Obj *const objv[]); -static int StatementParamtypeMethod(ClientData clientData, Tcl_Interp* interp, - Tcl_ObjectContext context, - int objc, Tcl_Obj *const objv[]); -static int StatementParamsMethod(ClientData clientData, Tcl_Interp* interp, - Tcl_ObjectContext context, - int objc, Tcl_Obj *const objv[]); - -static void DeleteStatementMetadata(ClientData clientData); -static void DeleteStatement(StatementData* sdata); -static int CloneStatement(Tcl_Interp* interp, ClientData oldClientData, - ClientData* newClientData); - -static int ResultSetConstructor(ClientData clientData, Tcl_Interp* interp, - Tcl_ObjectContext context, - int objc, Tcl_Obj *const objv[]); -static int ResultSetColumnsMethod(ClientData clientData, Tcl_Interp* interp, - Tcl_ObjectContext context, - int objc, Tcl_Obj *const objv[]); -static int ResultSetNextrowMethod(ClientData clientData, Tcl_Interp* interp, - Tcl_ObjectContext context, - int objc, Tcl_Obj *const objv[]); -static int ResultSetRowcountMethod(ClientData clientData, Tcl_Interp* interp, - Tcl_ObjectContext context, - int objc, Tcl_Obj *const objv[]); - -static void DeleteResultSetMetadata(ClientData clientData); -static void DeleteResultSet(ResultSetData* rdata); -static int CloneResultSet(Tcl_Interp* interp, ClientData oldClientData, - ClientData* newClientData); - - -static void DeleteCmd(ClientData clientData); -static int CloneCmd(Tcl_Interp* interp, - ClientData oldMetadata, ClientData* newMetadata); - -static void DeletePerInterpData(PerInterpData* pidata); - -/* Metadata type that holds connection data */ - -const static Tcl_ObjectMetadataType connectionDataType = { - TCL_OO_METADATA_VERSION_CURRENT, - /* version */ - "ConnectionData", /* name */ - DeleteConnectionMetadata, /* deleteProc */ - CloneConnection /* cloneProc - should cause an error - * 'cuz connections aren't clonable */ -}; - -/* Metadata type that holds statement data */ - -const static Tcl_ObjectMetadataType statementDataType = { - TCL_OO_METADATA_VERSION_CURRENT, - /* version */ - "StatementData", /* name */ - DeleteStatementMetadata, /* deleteProc */ - CloneStatement /* cloneProc - should cause an error - * 'cuz statements aren't clonable */ -}; - -/* Metadata type for result set data */ - -const static Tcl_ObjectMetadataType resultSetDataType = { - TCL_OO_METADATA_VERSION_CURRENT, - /* version */ - "ResultSetData", /* name */ - DeleteResultSetMetadata, /* deleteProc */ - CloneResultSet /* cloneProc - should cause an error - * 'cuz result sets aren't clonable */ -}; - -/* Method types of the connection methods that are implemented in C */ - -const static Tcl_MethodType ConnectionConstructorType = { - TCL_OO_METHOD_VERSION_CURRENT, - /* version */ - "CONSTRUCTOR", /* name */ - ConnectionConstructor, /* callProc */ - DeleteCmd, /* deleteProc */ - CloneCmd /* cloneProc */ -}; - -const static Tcl_MethodType ConnectionBegintransactionMethodType = { - TCL_OO_METHOD_VERSION_CURRENT, - /* version */ - "begintransaction", /* name */ - ConnectionBegintransactionMethod, /* callProc */ - NULL, /* deleteProc */ - NULL /* cloneProc */ -}; -const static Tcl_MethodType ConnectionColumnsMethodType = { - TCL_OO_METHOD_VERSION_CURRENT, - /* version */ - "Columns", /* name */ - ConnectionColumnsMethod, /* callProc */ - NULL, /* deleteProc */ - NULL /* cloneProc */ -}; -const static Tcl_MethodType ConnectionCommitMethodType = { - TCL_OO_METHOD_VERSION_CURRENT, - /* version */ - "commit", /* name */ - ConnectionCommitMethod, /* callProc */ - NULL, /* deleteProc */ - NULL /* cloneProc */ -}; -const static Tcl_MethodType ConnectionConfigureMethodType = { - TCL_OO_METHOD_VERSION_CURRENT, - /* version */ - "configure", /* name */ - ConnectionConfigureMethod, /* callProc */ - NULL, /* deleteProc */ - NULL /* cloneProc */ -}; -const static Tcl_MethodType ConnectionEvaldirectMethodType = { - TCL_OO_METHOD_VERSION_CURRENT, - /* version */ - "evaldirect", /* name */ - ConnectionEvaldirectMethod, /* callProc */ - NULL, /* deleteProc */ - NULL /* cloneProc */ -}; -const static Tcl_MethodType ConnectionNeedCollationInfoMethodType = { - TCL_OO_METHOD_VERSION_CURRENT, - /* version */ - "NeedCollationInfo", /* name */ - ConnectionNeedCollationInfoMethod, /* callProc */ - NULL, /* deleteProc */ - NULL /* cloneProc */ -}; -const static Tcl_MethodType ConnectionRollbackMethodType = { - TCL_OO_METHOD_VERSION_CURRENT, - /* version */ - "rollback", /* name */ - ConnectionRollbackMethod, /* callProc */ - NULL, /* deleteProc */ - NULL /* cloneProc */ -}; -const static Tcl_MethodType ConnectionSetCollationInfoMethodType = { - TCL_OO_METHOD_VERSION_CURRENT, - /* version */ - "SetCollationInfo", /* name */ - ConnectionSetCollationInfoMethod, /* callProc */ - NULL, /* deleteProc */ - NULL /* cloneProc */ -}; -const static Tcl_MethodType ConnectionTablesMethodType = { - TCL_OO_METHOD_VERSION_CURRENT, - /* version */ - "tables", /* name */ - ConnectionTablesMethod, /* callProc */ - NULL, /* deleteProc */ - NULL /* cloneProc */ -}; - -const static Tcl_MethodType* ConnectionMethods[] = { - &ConnectionBegintransactionMethodType, - &ConnectionColumnsMethodType, - &ConnectionCommitMethodType, - &ConnectionConfigureMethodType, - &ConnectionEvaldirectMethodType, - &ConnectionNeedCollationInfoMethodType, - &ConnectionRollbackMethodType, - &ConnectionSetCollationInfoMethodType, - &ConnectionTablesMethodType, - NULL -}; - -/* Method types of the statement methods that are implemented in C */ - -const static Tcl_MethodType StatementConstructorType = { - TCL_OO_METHOD_VERSION_CURRENT, - /* version */ - "CONSTRUCTOR", /* name */ - StatementConstructor, /* callProc */ - NULL, /* deleteProc */ - NULL /* cloneProc */ -}; -const static Tcl_MethodType StatementParamsMethodType = { - TCL_OO_METHOD_VERSION_CURRENT, - /* version */ - "params", /* name */ - StatementParamsMethod, /* callProc */ - NULL, /* deleteProc */ - NULL /* cloneProc */ -}; -const static Tcl_MethodType StatementParamtypeMethodType = { - TCL_OO_METHOD_VERSION_CURRENT, - /* version */ - "paramtype", /* name */ - StatementParamtypeMethod, /* callProc */ - NULL, /* deleteProc */ - NULL /* cloneProc */ -}; - -/* - * Methods to create on the statement class. - */ - -const static Tcl_MethodType* StatementMethods[] = { - &StatementParamsMethodType, - &StatementParamtypeMethodType, - NULL -}; - -/* Method types of the result set methods that are implemented in C */ - -const static Tcl_MethodType ResultSetConstructorType = { - TCL_OO_METHOD_VERSION_CURRENT, - /* version */ - "CONSTRUCTOR", /* name */ - ResultSetConstructor, /* callProc */ - NULL, /* deleteProc */ - NULL /* cloneProc */ -}; -const static Tcl_MethodType ResultSetColumnsMethodType = { - TCL_OO_METHOD_VERSION_CURRENT, - /* version */ "columns", /* name */ - ResultSetColumnsMethod, /* callProc */ - NULL, /* deleteProc */ - NULL /* cloneProc */ -}; -const static Tcl_MethodType ResultSetNextrowMethodType = { - TCL_OO_METHOD_VERSION_CURRENT, - /* version */ - "nextrow", /* name */ - ResultSetNextrowMethod, /* callProc */ - NULL, /* deleteProc */ - NULL /* cloneProc */ -}; -const static Tcl_MethodType ResultSetRowcountMethodType = { - TCL_OO_METHOD_VERSION_CURRENT, - /* version */ - "rowcount", /* name */ - ResultSetRowcountMethod, /* callProc */ - NULL, /* deleteProc */ - NULL /* cloneProc */ -}; - - -/* Methods to create on the result set class */ - -const static Tcl_MethodType* ResultSetMethods[] = { - &ResultSetColumnsMethodType, - &ResultSetRowcountMethodType, - NULL -}; - -/* - *----------------------------------------------------------------------------- - * - * MysqlBindAlloc -- - * - * Allocate a number of MYSQL_BIND structures. - * - * Results: - * Returns a pointer to the array of structures, which will be zeroed out. - * - *----------------------------------------------------------------------------- - */ - -static MYSQL_BIND* -MysqlBindAlloc(int nBindings) -{ - int size; - void* retval = NULL; - if (mysqlClientVersion >= 50100) { - size = sizeof(struct st_mysql_bind_51); - } else { - size = sizeof(struct st_mysql_bind_50); - } - size *= nBindings; - if (size != 0) { - retval = ckalloc(size); - memset(retval, 0, size); - } - return (MYSQL_BIND*) retval; -} - -/* - *----------------------------------------------------------------------------- - * - * MysqlBindIndex -- - * - * Returns a pointer to one of an array of MYSQL_BIND objects - * - *----------------------------------------------------------------------------- - */ - -static MYSQL_BIND* -MysqlBindIndex( - MYSQL_BIND* b, /* Binding array to alter */ - int i /* Index in the binding array */ -) { - if (mysqlClientVersion >= 50100) { - return (MYSQL_BIND*)(((struct st_mysql_bind_51*) b) + i); - } else { - return (MYSQL_BIND*)(((struct st_mysql_bind_50*) b) + i); - } -} - -/* - *----------------------------------------------------------------------------- - * - * MysqlBindAllocBuffer -- - * - * Allocates the buffer in a MYSQL_BIND object - * - * Results: - * Returns a pointer to the allocated buffer - * - *----------------------------------------------------------------------------- - */ - -static void* -MysqlBindAllocBuffer( - MYSQL_BIND* b, /* Pointer to a binding array */ - int i, /* Index into the array */ - unsigned long len /* Length of the buffer to allocate or 0 */ -) { - void* block = NULL; - if (len != 0) { - block = ckalloc(len); - } - if (mysqlClientVersion >= 50100) { - ((struct st_mysql_bind_51*) b)[i].buffer = block; - ((struct st_mysql_bind_51*) b)[i].buffer_length = len; - } else { - ((struct st_mysql_bind_50*) b)[i].buffer = block; - ((struct st_mysql_bind_50*) b)[i].buffer_length = len; - } - return block; -} - -/* - *----------------------------------------------------------------------------- - * - * MysqlBindFreeBuffer -- - * - * Frees trhe buffer in a MYSQL_BIND object - * - * Results: - * None. - * - * Side effects: - * Buffer is returned to the system. - * - *----------------------------------------------------------------------------- - */ -static void -MysqlBindFreeBuffer( - MYSQL_BIND* b, /* Pointer to a binding array */ - int i /* Index into the array */ -) { - if (mysqlClientVersion >= 50100) { - struct st_mysql_bind_51* bindings = (struct st_mysql_bind_51*) b; - if (bindings[i].buffer) { - ckfree(bindings[i].buffer); - bindings[i].buffer = NULL; - } - bindings[i].buffer_length = 0; - } else { - struct st_mysql_bind_50* bindings = (struct st_mysql_bind_50*) b; - if (bindings[i].buffer) { - ckfree(bindings[i].buffer); - bindings[i].buffer = NULL; - } - bindings[i].buffer_length = 0; - } -} - -/* - *----------------------------------------------------------------------------- - * - * MysqlBindGetBufferLength, MysqlBindSetBufferType, MysqlBindGetBufferType, - * MysqlBindSetLength, MysqlBindSetIsNull, - * MysqlBindSetError -- - * - * Access the fields of a MYSQL_BIND object - * - *----------------------------------------------------------------------------- - */ - -static void* -MysqlBindGetBuffer( - MYSQL_BIND* b, /* Binding array to alter */ - int i /* Index in the binding array */ -) { - if (mysqlClientVersion >= 50100) { - return ((struct st_mysql_bind_51*) b)[i].buffer; - } else { - return ((struct st_mysql_bind_50*) b)[i].buffer; - } -} - -static unsigned long -MysqlBindGetBufferLength( - MYSQL_BIND* b, /* Binding array to alter */ - int i /* Index in the binding array */ -) { - if (mysqlClientVersion >= 50100) { - return ((struct st_mysql_bind_51*) b)[i].buffer_length; - } else { - return ((struct st_mysql_bind_50*) b)[i].buffer_length; - } - -} - -static enum enum_field_types -MysqlBindGetBufferType( - MYSQL_BIND* b, /* Binding array to alter */ - int i /* Index in the binding array */ -) { - if (mysqlClientVersion >= 50100) { - return ((struct st_mysql_bind_51*) b)[i].buffer_type; - } else { - return ((struct st_mysql_bind_50*) b)[i].buffer_type; - } -} - -static void -MysqlBindSetBufferType( - MYSQL_BIND* b, /* Binding array to alter */ - int i, /* Index in the binding array */ - enum enum_field_types t /* Buffer type to assign */ -) { - if (mysqlClientVersion >= 50100) { - ((struct st_mysql_bind_51*) b)[i].buffer_type = t; - } else { - ((struct st_mysql_bind_50*) b)[i].buffer_type = t; - } -} - -static void -MysqlBindSetLength( - MYSQL_BIND* b, /* Binding array to alter */ - int i, /* Index in the binding array */ - unsigned long* p /* Length pointer to assign */ -) { - if (mysqlClientVersion >= 50100) { - ((struct st_mysql_bind_51*) b)[i].length = p; - } else { - ((struct st_mysql_bind_50*) b)[i].length = p; - } -} - -static void -MysqlBindSetIsNull( - MYSQL_BIND* b, /* Binding array to alter */ - int i, /* Index in the binding array */ - my_bool* p /* "Is null" indicator pointer to assign */ -) { - if (mysqlClientVersion >= 50100) { - ((struct st_mysql_bind_51*) b)[i].is_null = p; - } else { - ((struct st_mysql_bind_50*) b)[i].is_null = p; - } -} - -static void -MysqlBindSetError( - MYSQL_BIND* b, /* Binding array to alter */ - int i, /* Index in the binding array */ - my_bool* p /* Error indicator pointer to assign */ -) { - if (mysqlClientVersion >= 50100) { - ((struct st_mysql_bind_51*) b)[i].error = p; - } else { - ((struct st_mysql_bind_50*) b)[i].error = p; - } -} - -/* - *----------------------------------------------------------------------------- - * - * MysqlFieldIndex -- - * - * Return a pointer to a given MYSQL_FIELD structure in an array - * - * The MYSQL_FIELD structure grows by one pointer between 5.0 and 5.1. - * Our code never creates a MYSQL_FIELD, nor does it try to access that - * pointer, so we handle things simply by casting the types. - * - *----------------------------------------------------------------------------- - */ - -static MYSQL_FIELD* -MysqlFieldIndex(MYSQL_FIELD* fields, - /* Pointer to the array*/ - int i) /* Index in the array */ -{ - MYSQL_FIELD* retval; - if (mysqlClientVersion >= 50100) { - retval = (MYSQL_FIELD*)(((struct st_mysql_field_51*) fields)+i); - } else { - retval = (MYSQL_FIELD*)(((struct st_mysql_field_50*) fields)+i); - } - return retval; -} - -/* - *----------------------------------------------------------------------------- - * - * TransferMysqlError -- - * - * Obtains the error message, SQL state, and error number from the - * MySQL client library and transfers them into the Tcl interpreter - * - * Results: - * None. - * - * Side effects: - * Sets the interpreter result and error code to describe the SQL error - * - *----------------------------------------------------------------------------- - */ - -static void -TransferMysqlError( - Tcl_Interp* interp, /* Tcl interpreter */ - MYSQL* mysqlPtr /* MySQL connection handle */ -) { - const char* sqlstate = mysql_sqlstate(mysqlPtr); - Tcl_Obj* errorCode = Tcl_NewObj(); - Tcl_ListObjAppendElement(NULL, errorCode, Tcl_NewStringObj("TDBC", -1)); - Tcl_ListObjAppendElement(NULL, errorCode, - Tcl_NewStringObj(Tdbc_MapSqlState(sqlstate), -1)); - Tcl_ListObjAppendElement(NULL, errorCode, - Tcl_NewStringObj(sqlstate, -1)); - Tcl_ListObjAppendElement(NULL, errorCode, Tcl_NewStringObj("MYSQL", -1)); - Tcl_ListObjAppendElement(NULL, errorCode, - Tcl_NewIntObj(mysql_errno(mysqlPtr))); - Tcl_SetObjErrorCode(interp, errorCode); - Tcl_SetObjResult(interp, Tcl_NewStringObj(mysql_error(mysqlPtr), -1)); -} - -/* - *----------------------------------------------------------------------------- - * - * TransferMysqlStmtError -- - * - * Obtains the error message, SQL state, and error number from the - * MySQL client library and transfers them into the Tcl interpreter - * - * Results: - * None. - * - * Side effects: - * Sets the interpreter result and error code to describe the SQL error - * - *----------------------------------------------------------------------------- - */ - -static void -TransferMysqlStmtError( - Tcl_Interp* interp, /* Tcl interpreter */ - MYSQL_STMT* stmtPtr /* MySQL statment handle */ -) { - const char* sqlstate = mysql_stmt_sqlstate(stmtPtr); - Tcl_Obj* errorCode = Tcl_NewObj(); - Tcl_ListObjAppendElement(NULL, errorCode, Tcl_NewStringObj("TDBC", -1)); - Tcl_ListObjAppendElement(NULL, errorCode, - Tcl_NewStringObj(Tdbc_MapSqlState(sqlstate), -1)); - Tcl_ListObjAppendElement(NULL, errorCode, - Tcl_NewStringObj(sqlstate, -1)); - Tcl_ListObjAppendElement(NULL, errorCode, Tcl_NewStringObj("MYSQL", -1)); - Tcl_ListObjAppendElement(NULL, errorCode, - Tcl_NewIntObj(mysql_stmt_errno(stmtPtr))); - Tcl_SetObjErrorCode(interp, errorCode); - Tcl_SetObjResult(interp, Tcl_NewStringObj(mysql_stmt_error(stmtPtr), -1)); -} - -/* - *----------------------------------------------------------------------------- - * - * QueryConnectionOption -- - * - * Determine the current value of a connection option. - * - * Results: - * Returns a Tcl object containing the value if successful, or NULL - * if unsuccessful. If unsuccessful, stores error information in the - * Tcl interpreter. - * - *----------------------------------------------------------------------------- - */ - -static Tcl_Obj* -QueryConnectionOption ( - ConnectionData* cdata, /* Connection data */ - Tcl_Interp* interp, /* Tcl interpreter */ - int optionNum /* Position of the option in the table */ -) { - MYSQL_RES* result; /* Result of the MySQL query for the option */ - MYSQL_ROW row; /* Row of the result set */ - int fieldCount; /* Number of fields in a row */ - unsigned long* lengths; /* Character lengths of the fields */ - Tcl_Obj* retval; /* Return value */ - - if (mysql_query(cdata->mysqlPtr, ConnOptions[optionNum].query)) { - TransferMysqlError(interp, cdata->mysqlPtr); - return NULL; - } - result = mysql_store_result(cdata->mysqlPtr); - if (result == NULL) { - TransferMysqlError(interp, cdata->mysqlPtr); - return NULL; - } - fieldCount = mysql_num_fields(result); - if (fieldCount < 2) { - retval = cdata->pidata->literals[LIT_EMPTY]; - } else { - if ((row = mysql_fetch_row(result)) == NULL) { - if (mysql_errno(cdata->mysqlPtr)) { - TransferMysqlError(interp, cdata->mysqlPtr); - mysql_free_result(result); - return NULL; - } else { - retval = cdata->pidata->literals[LIT_EMPTY]; - } - } else { - lengths = mysql_fetch_lengths(result); - retval = Tcl_NewStringObj(row[1], lengths[1]); - } - } - mysql_free_result(result); - return retval; -} - -/* - *----------------------------------------------------------------------------- - * - * ConfigureConnection -- - * - * Applies configuration settings to a MySQL connection. - * - * Results: - * Returns a Tcl result. If the result is TCL_ERROR, error information - * is stored in the interpreter. - * - * Side effects: - * Updates configuration in the connection data. Opens a connection - * if none is yet open. - * - *----------------------------------------------------------------------------- - */ - -static int -ConfigureConnection( - ConnectionData* cdata, /* Connection data */ - Tcl_Interp* interp, /* Tcl interpreter */ - int objc, /* Parameter count */ - Tcl_Obj* const objv[], /* Parameter data */ - int skip /* Number of parameters to skip */ -) { - - const char* stringOpts[INDX_MAX]; - /* String-valued options */ - unsigned long mysqlFlags=0; /* Connection flags */ - int sslFlag = 0; /* Flag==1 if SSL configuration is needed */ - int optionIndex; /* Index of the current option in ConnOptions */ - int optionValue; /* Integer value of the current option */ - unsigned short port = 0; /* Server port number */ - int isolation = ISOL_NONE; /* Isolation level */ - int timeout = 0; /* Timeout value */ - int i; - Tcl_Obj* retval; - Tcl_Obj* optval; - - if (cdata->mysqlPtr != NULL) { - - /* Query configuration options on an existing connection */ - - if (objc == skip) { - retval = Tcl_NewObj(); - for (i = 0; ConnOptions[i].name != NULL; ++i) { - if (ConnOptions[i].flags & CONN_OPT_FLAG_ALIAS) continue; - optval = QueryConnectionOption(cdata, interp, i); - if (optval == NULL) { - return TCL_ERROR; - } - Tcl_DictObjPut(NULL, retval, - Tcl_NewStringObj(ConnOptions[i].name, -1), - optval); - } - Tcl_SetObjResult(interp, retval); - return TCL_OK; - } else if (objc == skip+1) { - - if (Tcl_GetIndexFromObjStruct(interp, objv[skip], - (void*) ConnOptions, - sizeof(ConnOptions[0]), "option", - 0, &optionIndex) != TCL_OK) { - return TCL_ERROR; - } - retval = QueryConnectionOption(cdata, interp, optionIndex); - if (retval == NULL) { - return TCL_ERROR; - } else { - Tcl_SetObjResult(interp, retval); - return TCL_OK; - } - } - } - - if ((objc-skip) % 2 != 0) { - Tcl_WrongNumArgs(interp, skip, objv, "?-option value?..."); - return TCL_ERROR; - } - - /* Extract options from the command line */ - - for (i = 0; i < INDX_MAX; ++i) { - stringOpts[i] = NULL; - } - for (i = skip; i < objc; i += 2) { - - /* Unknown option */ - - if (Tcl_GetIndexFromObjStruct(interp, objv[i], (void*) ConnOptions, - sizeof(ConnOptions[0]), "option", - 0, &optionIndex) != TCL_OK) { - return TCL_ERROR; - } - - /* Unmodifiable option */ - - if (cdata->mysqlPtr != NULL && !(ConnOptions[optionIndex].flags - & CONN_OPT_FLAG_MOD)) { - Tcl_Obj* msg = Tcl_NewStringObj("\"", -1); - Tcl_AppendObjToObj(msg, objv[i]); - Tcl_AppendToObj(msg, "\" option cannot be changed dynamically", -1); - Tcl_SetObjResult(interp, msg); - Tcl_SetErrorCode(interp, "TDBC", "GENERAL_ERROR", "HY000", - "MYSQL", "-1", NULL); - return TCL_ERROR; - } - - /* Record option value */ - - switch (ConnOptions[optionIndex].type) { - case TYPE_STRING: - stringOpts[ConnOptions[optionIndex].info] = - Tcl_GetString(objv[i+1]); - break; - case TYPE_FLAG: - if (Tcl_GetBooleanFromObj(interp, objv[i+1], &optionValue) - != TCL_OK) { - return TCL_ERROR; - } - if (optionValue) { - mysqlFlags |= ConnOptions[optionIndex].info; - } - break; - case TYPE_ENCODING: - if (strcmp(Tcl_GetString(objv[i+1]), "utf-8")) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("Only UTF-8 transfer " - "encoding is supported.\n", - -1)); - Tcl_SetErrorCode(interp, "TDBC", "GENERAL_ERROR", "HY000", - "MYSQL", "-1", NULL); - return TCL_ERROR; - } - break; - case TYPE_ISOLATION: - if (Tcl_GetIndexFromObj(interp, objv[i+1], TclIsolationLevels, - "isolation level", TCL_EXACT, &isolation) - != TCL_OK) { - return TCL_ERROR; - } - break; - case TYPE_PORT: - if (Tcl_GetIntFromObj(interp, objv[i+1], &optionValue) != TCL_OK) { - return TCL_ERROR; - } - if (optionValue < 0 || optionValue > 0xffff) { - Tcl_SetObjResult(interp, Tcl_NewStringObj("port number must " - "be in range " - "[0..65535]", -1)); - Tcl_SetErrorCode(interp, "TDBC", "GENERAL_ERROR", "HY000", - "MYSQL", "-1", NULL); - return TCL_ERROR; - } - port = optionValue; - break; - case TYPE_READONLY: - if (Tcl_GetBooleanFromObj(interp, objv[i+1], &optionValue) - != TCL_OK) { - return TCL_ERROR; - } - if (optionValue != 0) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("MySQL does not support " - "readonly connections", -1)); - Tcl_SetErrorCode(interp, "TDBC", "GENERAL_ERROR", "HY000", - "MYSQL", "-1", NULL); - return TCL_ERROR; - } - break; - case TYPE_TIMEOUT: - if (Tcl_GetIntFromObj(interp, objv[i+1], &timeout) != TCL_OK) { - return TCL_ERROR; - } - break; - } - if (ConnOptions[optionIndex].flags & CONN_OPT_FLAG_SSL) { - sslFlag = 1; - } - } - - if (cdata->mysqlPtr == NULL) { - - /* Configuring a new connection. Open the database */ - - cdata->mysqlPtr = mysql_init(NULL); - if (cdata->mysqlPtr == NULL) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("mysql_init() failed.", -1)); - Tcl_SetErrorCode(interp, "TDBC", "GENERAL_ERROR", "HY001", - "MYSQL", "NULL", NULL); - return TCL_ERROR; - } - - /* Set character set for the connection */ - - mysql_options(cdata->mysqlPtr, MYSQL_SET_CHARSET_NAME, "utf8"); - - /* Set SSL options if needed */ - - if (sslFlag) { - mysql_ssl_set(cdata->mysqlPtr, stringOpts[INDX_SSLKEY], - stringOpts[INDX_SSLCERT], stringOpts[INDX_SSLCA], - stringOpts[INDX_SSLCAPATH], - stringOpts[INDX_SSLCIPHER]); - } - - /* Establish the connection */ - - /* - * TODO - mutex around this unless linked to libmysqlclient_r ? - */ - - if (mysql_real_connect(cdata->mysqlPtr, stringOpts[INDX_HOST], - stringOpts[INDX_USER], stringOpts[INDX_PASSWD], - stringOpts[INDX_DB], port, - stringOpts[INDX_SOCKET], mysqlFlags) == NULL) { - TransferMysqlError(interp, cdata->mysqlPtr); - return TCL_ERROR; - } - - cdata->flags |= CONN_FLAG_AUTOCOMMIT; - - } else { - - /* Already open connection */ - - if (stringOpts[INDX_USER] != NULL) { - - /* User name changed - log in again */ - - if (mysql_change_user(cdata->mysqlPtr, - stringOpts[INDX_USER], - stringOpts[INDX_PASSWD], - stringOpts[INDX_DB])) { - TransferMysqlError(interp, cdata->mysqlPtr); - return TCL_ERROR; - } - } else if (stringOpts[INDX_DB] != NULL) { - - /* Database name changed - use the new database */ - - if (mysql_select_db(cdata->mysqlPtr, stringOpts[INDX_DB])) { - TransferMysqlError(interp, cdata->mysqlPtr); - return TCL_ERROR; - } - } - } - - /* Transaction isolation level */ - - if (isolation != ISOL_NONE) { - if (mysql_query(cdata->mysqlPtr, SqlIsolationLevels[isolation])) { - TransferMysqlError(interp, cdata->mysqlPtr); - return TCL_ERROR; - } - } - - /* Timeout */ - - if (timeout != 0) { - int result; - Tcl_Obj* query = Tcl_ObjPrintf("SET SESSION WAIT_TIMEOUT = %d\n", - timeout); - Tcl_IncrRefCount(query); - result = mysql_query(cdata->mysqlPtr, Tcl_GetString(query)); - Tcl_DecrRefCount(query); - if (result) { - TransferMysqlError(interp, cdata->mysqlPtr); - return TCL_ERROR; - } - } - - return TCL_OK; -} - -/* - *----------------------------------------------------------------------------- - * - * ConnectionConstructor -- - * - * Constructor for ::tdbc::mysql::connection, which represents a - * database connection. - * - * Results: - * Returns a standard Tcl result. - * - * The ConnectionInitMethod takes alternating keywords and values giving - * the configuration parameters of the connection, and attempts to connect - * to the database. - * - *----------------------------------------------------------------------------- - */ - -static int -ConnectionConstructor( - ClientData clientData, /* Environment handle */ - Tcl_Interp* interp, /* Tcl interpreter */ - Tcl_ObjectContext context, /* Object context */ - int objc, /* Parameter count */ - Tcl_Obj *const objv[] /* Parameter vector */ -) { - PerInterpData* pidata = (PerInterpData*) clientData; - /* Per-interp data for the MYSQL package */ - Tcl_Object thisObject = Tcl_ObjectContextObject(context); - /* The current object */ - int skip = Tcl_ObjectContextSkippedArgs(context); - /* The number of leading arguments to skip */ - ConnectionData* cdata; /* Per-connection data */ - - /* Hang client data on this connection */ - - cdata = (ConnectionData*) ckalloc(sizeof(ConnectionData)); - cdata->refCount = 1; - cdata->pidata = pidata; - cdata->mysqlPtr = NULL; - cdata->nCollations = 0; - cdata->collationSizes = NULL; - cdata->flags = 0; - IncrPerInterpRefCount(pidata); - Tcl_ObjectSetMetadata(thisObject, &connectionDataType, (ClientData) cdata); - - /* Configure the connection */ - - if (ConfigureConnection(cdata, interp, objc, objv, skip) != TCL_OK) { - return TCL_ERROR; - } - - return TCL_OK; - -} - -/* - *----------------------------------------------------------------------------- - * - * ConnectionBegintransactionMethod -- - * - * Method that requests that following operations on an OBBC connection - * be executed as an atomic transaction. - * - * Usage: - * $connection begintransaction - * - * Parameters: - * None. - * - * Results: - * Returns an empty result if successful, and throws an error otherwise. - * - *----------------------------------------------------------------------------- -*/ - -static int -ConnectionBegintransactionMethod( - ClientData clientData, /* Unused */ - Tcl_Interp* interp, /* Tcl interpreter */ - Tcl_ObjectContext objectContext, /* Object context */ - int objc, /* Parameter count */ - Tcl_Obj *const objv[] /* Parameter vector */ -) { - Tcl_Object thisObject = Tcl_ObjectContextObject(objectContext); - /* The current connection object */ - ConnectionData* cdata = (ConnectionData*) - Tcl_ObjectGetMetadata(thisObject, &connectionDataType); - - /* Check parameters */ - - if (objc != 2) { - Tcl_WrongNumArgs(interp, 2, objv, ""); - return TCL_ERROR; - } - - /* Reject attempts at nested transactions */ - - if (cdata->flags & CONN_FLAG_IN_XCN) { - Tcl_SetObjResult(interp, Tcl_NewStringObj("MySQL does not support " - "nested transactions", -1)); - Tcl_SetErrorCode(interp, "TDBC", "GENERAL_ERROR", "HYC00", - "MYSQL", "-1", NULL); - return TCL_ERROR; - } - cdata->flags |= CONN_FLAG_IN_XCN; - - /* Turn off autocommit for the duration of the transaction */ - - if (cdata->flags & CONN_FLAG_AUTOCOMMIT) { - if (mysql_autocommit(cdata->mysqlPtr, 0)) { - TransferMysqlError(interp, cdata->mysqlPtr); - return TCL_ERROR; - } - cdata->flags &= ~CONN_FLAG_AUTOCOMMIT; - } - - return TCL_OK; -} - -/* - *----------------------------------------------------------------------------- - * - * ConnectionColumnsMethod -- - * - * Method that asks for the names of columns in a table - * in the database (optionally matching a given pattern) - * - * Usage: - * $connection columns table ?pattern? - * - * Parameters: - * None. - * - * Results: - * Returns the list of tables - * - *----------------------------------------------------------------------------- - */ - -static int -ConnectionColumnsMethod( - ClientData clientData, /* Completion type */ - Tcl_Interp* interp, /* Tcl interpreter */ - Tcl_ObjectContext objectContext, /* Object context */ - int objc, /* Parameter count */ - Tcl_Obj *const objv[] /* Parameter vector */ -) { - Tcl_Object thisObject = Tcl_ObjectContextObject(objectContext); - /* The current connection object */ - ConnectionData* cdata = (ConnectionData*) - Tcl_ObjectGetMetadata(thisObject, &connectionDataType); - /* Instance data */ - PerInterpData* pidata = cdata->pidata; - /* Per-interpreter data */ - Tcl_Obj** literals = pidata->literals; - /* Literal pool */ - const char* patternStr; /* Pattern to match table names */ - MYSQL_RES* results; /* Result set */ - Tcl_Obj* retval; /* List of table names */ - Tcl_Obj* name; /* Name of a column */ - Tcl_Obj* attrs; /* Attributes of the column */ - Tcl_HashEntry* entry; /* Hash entry for data type */ - - /* Check parameters */ - - if (objc == 3) { - patternStr = NULL; - } else if (objc == 4) { - patternStr = Tcl_GetString(objv[3]); - } else { - Tcl_WrongNumArgs(interp, 2, objv, "table ?pattern?"); - return TCL_ERROR; - } - - results = mysql_list_fields(cdata->mysqlPtr, Tcl_GetString(objv[2]), - patternStr); - if (results == NULL) { - TransferMysqlError(interp, cdata->mysqlPtr); - return TCL_ERROR; - } else { - unsigned int fieldCount = mysql_num_fields(results); - MYSQL_FIELD* fields = mysql_fetch_fields(results); - unsigned int i; - retval = Tcl_NewObj(); - Tcl_IncrRefCount(retval); - for (i = 0; i < fieldCount; ++i) { - MYSQL_FIELD* field = MysqlFieldIndex(fields, i); - attrs = Tcl_NewObj(); - name = Tcl_NewStringObj(field->name, field->name_length); - - Tcl_DictObjPut(NULL, attrs, literals[LIT_NAME], name); - /* TODO - Distinguish CHAR and BINARY */ - entry = Tcl_FindHashEntry(&(pidata->typeNumHash), - (char*) field->type); - if (entry != NULL) { - Tcl_DictObjPut(NULL, attrs, literals[LIT_TYPE], - (Tcl_Obj*) Tcl_GetHashValue(entry)); - } - if (IS_NUM(field->type)) { - Tcl_DictObjPut(NULL, attrs, literals[LIT_PRECISION], - Tcl_NewIntObj(field->length)); - } else if (field->charsetnr < cdata->nCollations) { - Tcl_DictObjPut(NULL, attrs, literals[LIT_PRECISION], - Tcl_NewIntObj(field->length - / cdata->collationSizes[field->charsetnr])); - } - Tcl_DictObjPut(NULL, attrs, literals[LIT_SCALE], - Tcl_NewIntObj(field->decimals)); - Tcl_DictObjPut(NULL, attrs, literals[LIT_NULLABLE], - Tcl_NewIntObj(!(field->flags - & (NOT_NULL_FLAG)))); - Tcl_DictObjPut(NULL, retval, name, attrs); - } - mysql_free_result(results); - Tcl_SetObjResult(interp, retval); - Tcl_DecrRefCount(retval); - return TCL_OK; - } -} - -/* - *----------------------------------------------------------------------------- - * - * ConnectionCommitMethod -- - * - * Method that requests that a pending transaction against a database - * be committed. - * - * Usage: - * $connection commit - * - * Parameters: - * None. - * - * Results: - * Returns an empty Tcl result if successful, and throws an error - * otherwise. - * - *----------------------------------------------------------------------------- - */ - -static int -ConnectionCommitMethod( - ClientData clientData, /* Completion type */ - Tcl_Interp* interp, /* Tcl interpreter */ - Tcl_ObjectContext objectContext, /* Object context */ - int objc, /* Parameter count */ - Tcl_Obj *const objv[] /* Parameter vector */ -) { - Tcl_Object thisObject = Tcl_ObjectContextObject(objectContext); - /* The current connection object */ - ConnectionData* cdata = (ConnectionData*) - Tcl_ObjectGetMetadata(thisObject, &connectionDataType); - /* Instance data */ - my_bool rc; /* MySQL status return */ - - /* Check parameters */ - - if (objc != 2) { - Tcl_WrongNumArgs(interp, 2, objv, ""); - return TCL_ERROR; - } - - /* Reject the request if no transaction is in progress */ - - if (!(cdata->flags & CONN_FLAG_IN_XCN)) { - Tcl_SetObjResult(interp, Tcl_NewStringObj("no transaction is in " - "progress", -1)); - Tcl_SetErrorCode(interp, "TDBC", "GENERAL_ERROR", "HY010", - "MYSQL", "-1", NULL); - return TCL_ERROR; - } - - /* End transaction, turn off "transaction in progress", and report status */ - - rc = mysql_commit(cdata->mysqlPtr); - cdata->flags &= ~ CONN_FLAG_IN_XCN; - if (rc) { - TransferMysqlError(interp, cdata->mysqlPtr); - return TCL_ERROR; - } - return TCL_OK; -} - -/* - *----------------------------------------------------------------------------- - * - * ConnectionConfigureMethod -- - * - * Change configuration parameters on an open connection. - * - * Usage: - * $connection configure ?-keyword? ?value? ?-keyword value ...? - * - * Parameters: - * Keyword-value pairs (or a single keyword, or an empty set) - * of configuration options. - * - * Options: - * The following options are supported; - * -database - * Name of the database to use by default in queries - * -encoding - * Character encoding to use with the server. (Must be utf-8) - * -isolation - * Transaction isolation level. - * -readonly - * Read-only flag (must be a false Boolean value) - * -timeout - * Timeout value (both wait_timeout and interactive_timeout) - * - * Other options supported by the constructor are here in read-only - * mode; any attempt to change them will result in an error. - * - *----------------------------------------------------------------------------- - */ - -static int ConnectionConfigureMethod( - ClientData clientData, - Tcl_Interp* interp, - Tcl_ObjectContext objectContext, - int objc, - Tcl_Obj *const objv[] -) { - Tcl_Object thisObject = Tcl_ObjectContextObject(objectContext); - /* The current connection object */ - int skip = Tcl_ObjectContextSkippedArgs(objectContext); - /* Number of arguments to skip */ - ConnectionData* cdata = (ConnectionData*) - Tcl_ObjectGetMetadata(thisObject, &connectionDataType); - /* Instance data */ - return ConfigureConnection(cdata, interp, objc, objv, skip); -} - -/* - *----------------------------------------------------------------------------- - * - * ConnectionEvaldirectMethod -- - * - * Evaluates a MySQL statement that is not supported by the prepared - * statement API. - * - * Usage: - * $connection evaldirect sql-statement - * - * Parameters: - * sql-statement - - * SQL statement to evaluate. The statement may not contain - * substitutions. - * - * Results: - * Returns a standard Tcl result. If the operation is successful, - * the result consists of a list of rows (in the same form as - * [$connection allrows -as dicts]). If the operation fails, the - * result is an error message. - * - * Side effects: - * Whatever the SQL statement does. - * - *----------------------------------------------------------------------------- - */ - -static int -ConnectionEvaldirectMethod( - ClientData clientData, /* Unused */ - Tcl_Interp* interp, /* Tcl interpreter */ - Tcl_ObjectContext objectContext, /* Object context */ - int objc, /* Parameter count */ - Tcl_Obj *const objv[]) /* Parameter vector */ -{ - Tcl_Object thisObject = Tcl_ObjectContextObject(objectContext); - /* Current connection object */ - ConnectionData* cdata = (ConnectionData*) - Tcl_ObjectGetMetadata(thisObject, &connectionDataType); - /* Instance data */ - int nColumns; /* Number of columns in the result set */ - MYSQL_RES* resultPtr; /* MySQL result set */ - MYSQL_ROW rowPtr; /* One row of the result set */ - unsigned long* lengths; /* Lengths of the fields in a row */ - Tcl_Obj* retObj; /* Result set as a Tcl list */ - Tcl_Obj* rowObj; /* One row of the result set as a Tcl list */ - Tcl_Obj* fieldObj; /* One field of the row */ - int i; - - /* Check parameters */ - - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, ""); - return TCL_ERROR; - } - - /* Execute the given statement */ - - if (mysql_query(cdata->mysqlPtr, Tcl_GetString(objv[2]))) { - TransferMysqlError(interp, cdata->mysqlPtr); - return TCL_ERROR; - } - - /* Retrieve the result set */ - - resultPtr = mysql_store_result(cdata->mysqlPtr); - nColumns = mysql_field_count(cdata->mysqlPtr); - if (resultPtr == NULL) { - /* - * Can't retrieve result set. Distinguish result-less statements - * from MySQL errors. - */ - if (nColumns == 0) { - Tcl_SetObjResult - (interp, - Tcl_NewWideIntObj(mysql_affected_rows(cdata->mysqlPtr))); - return TCL_OK; - } else { - TransferMysqlError(interp, cdata->mysqlPtr); - return TCL_ERROR; - } - } - - /* Make a list-of-lists of the result */ - - retObj = Tcl_NewObj(); - while ((rowPtr = mysql_fetch_row(resultPtr)) != NULL) { - rowObj = Tcl_NewObj(); - lengths = mysql_fetch_lengths(resultPtr); - for (i = 0; i < nColumns; ++i) { - if (rowPtr[i] != NULL) { - fieldObj = Tcl_NewStringObj(rowPtr[i], lengths[i]); - } else { - fieldObj = cdata->pidata->literals[LIT_EMPTY]; - } - Tcl_ListObjAppendElement(NULL, rowObj, fieldObj); - } - Tcl_ListObjAppendElement(NULL, retObj, rowObj); - } - Tcl_SetObjResult(interp, retObj); - - /* - * Free the result set. - */ - mysql_free_result(resultPtr); - - return TCL_OK; -} - - -/* - *----------------------------------------------------------------------------- - * - * ConnectionNeedCollationInfoMethod -- - * - * Internal method that determines whether the collation lengths - * are known yet. - * - * Usage: - * $connection NeedCollationInfo - * - * Parameters: - * None. - * - * Results: - * Returns a Boolean value. - * - *----------------------------------------------------------------------------- - */ - -static int -ConnectionNeedCollationInfoMethod( - ClientData clientData, /* Completion type */ - Tcl_Interp* interp, /* Tcl interpreter */ - Tcl_ObjectContext objectContext, /* Object context */ - int objc, /* Parameter count */ - Tcl_Obj *const objv[] /* Parameter vector */ -) { - Tcl_Object thisObject = Tcl_ObjectContextObject(objectContext); - /* The current connection object */ - ConnectionData* cdata = (ConnectionData*) - Tcl_ObjectGetMetadata(thisObject, &connectionDataType); - /* Instance data */ - - if (objc != 2) { - Tcl_WrongNumArgs(interp, 2, objv, ""); - return TCL_ERROR; - } - - Tcl_SetObjResult(interp, Tcl_NewIntObj(cdata->collationSizes == NULL)); - return TCL_OK; -} - -/* - *----------------------------------------------------------------------------- - * - * ConnectionRollbackMethod -- - * - * Method that requests that a pending transaction against a database - * be rolled back. - * - * Usage: - * $connection rollback - * - * Parameters: - * None. - * - * Results: - * Returns an empty Tcl result if successful, and throws an error - * otherwise. - * - *----------------------------------------------------------------------------- - */ - -static int -ConnectionRollbackMethod( - ClientData clientData, /* Completion type */ - Tcl_Interp* interp, /* Tcl interpreter */ - Tcl_ObjectContext objectContext, /* Object context */ - int objc, /* Parameter count */ - Tcl_Obj *const objv[] /* Parameter vector */ -) { - Tcl_Object thisObject = Tcl_ObjectContextObject(objectContext); - /* The current connection object */ - ConnectionData* cdata = (ConnectionData*) - Tcl_ObjectGetMetadata(thisObject, &connectionDataType); - /* Instance data */ - my_bool rc; /* Result code from MySQL operations */ - - /* Check parameters */ - - if (objc != 2) { - Tcl_WrongNumArgs(interp, 2, objv, ""); - return TCL_ERROR; - } - - /* Reject the request if no transaction is in progress */ - - if (!(cdata->flags & CONN_FLAG_IN_XCN)) { - Tcl_SetObjResult(interp, Tcl_NewStringObj("no transaction is in " - "progress", -1)); - Tcl_SetErrorCode(interp, "TDBC", "GENERAL_ERROR", "HY010", - "MYSQL", "-1", NULL); - return TCL_ERROR; - } - - /* End transaction, turn off "transaction in progress", and report status */ - - rc = mysql_rollback(cdata->mysqlPtr); - cdata->flags &= ~CONN_FLAG_IN_XCN; - if (rc) { - TransferMysqlError(interp, cdata->mysqlPtr); - return TCL_ERROR; - } - return TCL_OK; -} - -/* - *----------------------------------------------------------------------------- - * - * ConnectionSetCollationInfoMethod -- - * - * Internal method that saves the character lengths of the collations - * - * Usage: - * $connection SetCollationInfo {collationNum size} ... - * - * Parameters: - * One or more pairs of collation number and character length, - * ordered in decreasing sequence by collation number. - * - * Results: - * None. - * - * The [$connection columns $table] method needs to know the sizes - * of characters in a given column's collation and character set. - * This information is available by querying INFORMATION_SCHEMA, which - * is easier to do from Tcl than C. This method passes in the results. - * - *----------------------------------------------------------------------------- - */ - -static int -ConnectionSetCollationInfoMethod( - ClientData clientData, /* Completion type */ - Tcl_Interp* interp, /* Tcl interpreter */ - Tcl_ObjectContext objectContext, /* Object context */ - int objc, /* Parameter count */ - Tcl_Obj *const objv[] /* Parameter vector */ -) { - Tcl_Object thisObject = Tcl_ObjectContextObject(objectContext); - /* The current connection object */ - ConnectionData* cdata = (ConnectionData*) - Tcl_ObjectGetMetadata(thisObject, &connectionDataType); - /* Instance data */ - int listLen; - Tcl_Obj* objPtr; - unsigned int collationNum; - int i; - int t; - - if (objc <= 2) { - Tcl_WrongNumArgs(interp, 2, objv, "{collationNum size}..."); - return TCL_ERROR; - } - if (Tcl_ListObjIndex(interp, objv[2], 0, &objPtr) != TCL_OK) { - return TCL_ERROR; - } - if (Tcl_GetIntFromObj(interp, objPtr, &t) != TCL_OK) { - return TCL_ERROR; - } - cdata->nCollations = (unsigned int)(t+1); - if (cdata->collationSizes) { - ckfree((char*) cdata->collationSizes); - } - cdata->collationSizes = - (int*) ckalloc(cdata->nCollations * sizeof(int)); - memset(cdata->collationSizes, 0, cdata->nCollations * sizeof(int)); - for (i = 2; i < objc; ++i) { - if (Tcl_ListObjLength(interp, objv[i], &listLen) != TCL_OK) { - return TCL_ERROR; - } - if (listLen != 2) { - Tcl_SetObjResult(interp, Tcl_NewStringObj("args must be 2-element " - "lists", -1)); - return TCL_ERROR; - } - if (Tcl_ListObjIndex(interp, objv[i], 0, &objPtr) != TCL_OK - || Tcl_GetIntFromObj(interp, objPtr, &t) != TCL_OK) { - return TCL_ERROR; - } - collationNum = (unsigned int) t; - if (collationNum > cdata->nCollations) { - Tcl_SetObjResult(interp, Tcl_NewStringObj("collations must be " - "in decreasing sequence", - -1)); - return TCL_ERROR; - } - if ((Tcl_ListObjIndex(interp, objv[i], 1, &objPtr) != TCL_OK) - || (Tcl_GetIntFromObj(interp, objPtr, - cdata->collationSizes+collationNum) - != TCL_OK)) { - return TCL_ERROR; - } - } - return TCL_OK; -} - -/* - *----------------------------------------------------------------------------- - * - * ConnectionTablesMethod -- - * - * Method that asks for the names of tables in the database (optionally - * matching a given pattern - * - * Usage: - * $connection tables ?pattern? - * - * Parameters: - * None. - * - * Results: - * Returns the list of tables - * - *----------------------------------------------------------------------------- - */ - -static int -ConnectionTablesMethod( - ClientData clientData, /* Completion type */ - Tcl_Interp* interp, /* Tcl interpreter */ - Tcl_ObjectContext objectContext, /* Object context */ - int objc, /* Parameter count */ - Tcl_Obj *const objv[] /* Parameter vector */ -) { - Tcl_Object thisObject = Tcl_ObjectContextObject(objectContext); - /* The current connection object */ - ConnectionData* cdata = (ConnectionData*) - Tcl_ObjectGetMetadata(thisObject, &connectionDataType); - /* Instance data */ - Tcl_Obj** literals = cdata->pidata->literals; - /* Literal pool */ - const char* patternStr = NULL; - /* Pattern to match table names */ - MYSQL_RES* results = NULL; /* Result set */ - MYSQL_ROW row = NULL; /* Row in the result set */ - int status = TCL_OK; /* Return status */ - Tcl_Obj* retval = NULL; /* List of table names */ - - /* Check parameters */ - - if (objc == 2) { - patternStr = NULL; - } else if (objc == 3) { - patternStr = Tcl_GetString(objv[2]); - } else { - Tcl_WrongNumArgs(interp, 2, objv, ""); - return TCL_ERROR; - } - - results = mysql_list_tables(cdata->mysqlPtr, patternStr); - if (results == NULL) { - TransferMysqlError(interp, cdata->mysqlPtr); - return TCL_ERROR; - } else { - retval = Tcl_NewObj(); - Tcl_IncrRefCount(retval); - while ((row = mysql_fetch_row(results)) != NULL) { - unsigned long * lengths = mysql_fetch_lengths(results); - if (row[0]) { - Tcl_ListObjAppendElement(NULL, retval, - Tcl_NewStringObj(row[0], - (int)lengths[0])); - Tcl_ListObjAppendElement(NULL, retval, literals[LIT_EMPTY]); - } - } - if (mysql_errno(cdata->mysqlPtr)) { - TransferMysqlError(interp, cdata->mysqlPtr); - status = TCL_ERROR; - } - if (status == TCL_OK) { - Tcl_SetObjResult(interp, retval); - } - Tcl_DecrRefCount(retval); - mysql_free_result(results); - return status; - } -} - -/* - *----------------------------------------------------------------------------- - * - * DeleteCmd -- - * - * Callback executed when the initialization method of the connection - * class is deleted. - * - * Side effects: - * Dismisses the environment, which has the effect of shutting - * down MYSQL when it is no longer required. - * - *----------------------------------------------------------------------------- - */ - -static void -DeleteCmd ( - ClientData clientData /* Environment handle */ -) { - PerInterpData* pidata = (PerInterpData*) clientData; - DecrPerInterpRefCount(pidata); -} - -/* - *----------------------------------------------------------------------------- - * - * CloneCmd -- - * - * Callback executed when any of the MYSQL client methods is cloned. - * - * Results: - * Returns TCL_OK to allow the method to be copied. - * - * Side effects: - * Obtains a fresh copy of the environment handle, to keep the - * refcounts accurate - * - *----------------------------------------------------------------------------- - */ - -static int -CloneCmd( - Tcl_Interp* interp, /* Tcl interpreter */ - ClientData oldClientData, /* Environment handle to be discarded */ - ClientData* newClientData /* New environment handle to be used */ -) { - *newClientData = oldClientData; - return TCL_OK; -} - -/* - *----------------------------------------------------------------------------- - * - * DeleteConnectionMetadata, DeleteConnection -- - * - * Cleans up when a database connection is deleted. - * - * Results: - * None. - * - * Side effects: - * Terminates the connection and frees all system resources associated - * with it. - * - *----------------------------------------------------------------------------- - */ - -static void -DeleteConnectionMetadata( - ClientData clientData /* Instance data for the connection */ -) { - DecrConnectionRefCount((ConnectionData*)clientData); -} - -static void -DeleteConnection( - ConnectionData* cdata /* Instance data for the connection */ -) { - if (cdata->collationSizes != NULL) { - ckfree((char*) cdata->collationSizes); - } - if (cdata->mysqlPtr != NULL) { - mysql_close(cdata->mysqlPtr); - } - DecrPerInterpRefCount(cdata->pidata); - ckfree((char*) cdata); -} - -/* - *----------------------------------------------------------------------------- - * - * CloneConnection -- - * - * Attempts to clone an MYSQL connection's metadata. - * - * Results: - * Returns the new metadata - * - * At present, we don't attempt to clone connections - it's not obvious - * that such an action would ever even make sense. Instead, we return NULL - * to indicate that the metadata should not be cloned. (Note that this - * action isn't right, either. What *is* right is to indicate that the object - * is not clonable, but the API gives us no way to do that. - * - *----------------------------------------------------------------------------- - */ - -static int -CloneConnection( - Tcl_Interp* interp, /* Tcl interpreter for error reporting */ - ClientData metadata, /* Metadata to be cloned */ - ClientData* newMetaData /* Where to put the cloned metadata */ -) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("MYSQL connections are not clonable", -1)); - return TCL_ERROR; -} - -/* - *----------------------------------------------------------------------------- - * - * NewStatement -- - * - * Creates an empty object to hold statement data. - * - * Results: - * Returns a pointer to the newly-created object. - * - *----------------------------------------------------------------------------- - */ - -static StatementData* -NewStatement( - ConnectionData* cdata /* Instance data for the connection */ -) { - StatementData* sdata = (StatementData*) ckalloc(sizeof(StatementData)); - sdata->refCount = 1; - sdata->cdata = cdata; - IncrConnectionRefCount(cdata); - sdata->subVars = Tcl_NewObj(); - Tcl_IncrRefCount(sdata->subVars); - sdata->params = NULL; - sdata->nativeSql = NULL; - sdata->stmtPtr = NULL; - sdata->metadataPtr = NULL; - sdata->columnNames = NULL; - sdata->flags = 0; - return sdata; -} - -/* - *----------------------------------------------------------------------------- - * - * AllocAndPrepareStatement -- - * - * Allocate space for a MySQL prepared statement, and prepare the - * statement. - * - * Results: - * Returns the statement handle if successful, and NULL on failure. - * - * Side effects: - * Prepares the statement. - * Stores error message and error code in the interpreter on failure. - * - *----------------------------------------------------------------------------- - */ - -static MYSQL_STMT* -AllocAndPrepareStatement( - Tcl_Interp* interp, /* Tcl interpreter for error reporting */ - StatementData* sdata /* Statement data */ -) { - ConnectionData* cdata = sdata->cdata; - /* Connection data */ - MYSQL_STMT* stmtPtr; /* Statement handle */ - const char* nativeSqlStr; /* Native SQL statement to prepare */ - int nativeSqlLen; /* Length of the statement */ - - /* Allocate space for the prepared statement */ - - stmtPtr = mysql_stmt_init(cdata->mysqlPtr); - /* - * MySQL allows only one writable cursor open at a time, and - * the default cursor type is writable. Make all our cursors - * read-only to avoid 'Commands out of sync' errors. - */ - - if (stmtPtr == NULL) { - TransferMysqlError(interp, cdata->mysqlPtr); - } else { - - /* Prepare the statement */ - - nativeSqlStr = Tcl_GetStringFromObj(sdata->nativeSql, &nativeSqlLen); - if (mysql_stmt_prepare(stmtPtr, nativeSqlStr, nativeSqlLen)) { - TransferMysqlStmtError(interp, stmtPtr); - mysql_stmt_close(stmtPtr); - stmtPtr = NULL; - } - } - return stmtPtr; -} - -/* - *----------------------------------------------------------------------------- - * - * ResultDescToTcl -- - * - * Converts a MySQL result description for return as a Tcl list. - * - * Results: - * Returns a Tcl object holding the result description - * - * If any column names are duplicated, they are disambiguated by - * appending '#n' where n increments once for each occurrence of the - * column name. - * - *----------------------------------------------------------------------------- - */ - -static Tcl_Obj* -ResultDescToTcl( - MYSQL_RES* result, /* Result set description */ - int flags /* Flags governing the conversion */ -) { - Tcl_Obj* retval = Tcl_NewObj(); - Tcl_HashTable names; /* Hash table to resolve name collisions */ - Tcl_Obj* nameObj; /* Name of a result column */ - int new; /* Flag == 1 if a result column is unique */ - Tcl_HashEntry* entry; /* Hash table entry for a column name */ - int count; /* Number used to disambiguate a column name */ - - Tcl_InitHashTable(&names, TCL_STRING_KEYS); - if (result != NULL) { - unsigned int fieldCount = mysql_num_fields(result); - MYSQL_FIELD* fields = mysql_fetch_fields(result); - unsigned int i; - char numbuf[16]; - for (i = 0; i < fieldCount; ++i) { - MYSQL_FIELD* field = MysqlFieldIndex(fields, i); - nameObj = Tcl_NewStringObj(field->name, field->name_length); - Tcl_IncrRefCount(nameObj); - entry = Tcl_CreateHashEntry(&names, field->name, &new); - count = 1; - while (!new) { - count = PTR2INT(Tcl_GetHashValue(entry)); - ++count; - Tcl_SetHashValue(entry, INT2PTR(count)); - sprintf(numbuf, "#%d", count); - Tcl_AppendToObj(nameObj, numbuf, -1); - entry = Tcl_CreateHashEntry(&names, Tcl_GetString(nameObj), - &new); - } - Tcl_SetHashValue(entry, INT2PTR(count)); - Tcl_ListObjAppendElement(NULL, retval, nameObj); - Tcl_DecrRefCount(nameObj); - } - } - Tcl_DeleteHashTable(&names); - return retval; -} - -/* - *----------------------------------------------------------------------------- - * - * StatementConstructor -- - * - * C-level initialization for the object representing an MySQL prepared - * statement. - * - * Usage: - * statement new connection statementText - * statement create name connection statementText - * - * Parameters: - * connection -- the MySQL connection object - * statementText -- text of the statement to prepare. - * - * Results: - * Returns a standard Tcl result - * - * Side effects: - * Prepares the statement, and stores it (plus a reference to the - * connection) in instance metadata. - * - *----------------------------------------------------------------------------- - */ - -static int -StatementConstructor( - ClientData clientData, /* Not used */ - Tcl_Interp* interp, /* Tcl interpreter */ - Tcl_ObjectContext context, /* Object context */ - int objc, /* Parameter count */ - Tcl_Obj *const objv[] /* Parameter vector */ -) { - - Tcl_Object thisObject = Tcl_ObjectContextObject(context); - /* The current statement object */ - int skip = Tcl_ObjectContextSkippedArgs(context); - /* Number of args to skip before the - * payload arguments */ - Tcl_Object connectionObject; - /* The database connection as a Tcl_Object */ - ConnectionData* cdata; /* The connection object's data */ - StatementData* sdata; /* The statement's object data */ - Tcl_Obj* tokens; /* The tokens of the statement to be prepared */ - int tokenc; /* Length of the 'tokens' list */ - Tcl_Obj** tokenv; /* Exploded tokens from the list */ - Tcl_Obj* nativeSql; /* SQL statement mapped to native form */ - char* tokenStr; /* Token string */ - int tokenLen; /* Length of a token */ - int nParams; /* Number of parameters of the statement */ - int i; - - /* Find the connection object, and get its data. */ - - thisObject = Tcl_ObjectContextObject(context); - if (objc != skip+2) { - Tcl_WrongNumArgs(interp, skip, objv, "connection statementText"); - return TCL_ERROR; - } - - connectionObject = Tcl_GetObjectFromObj(interp, objv[skip]); - if (connectionObject == NULL) { - return TCL_ERROR; - } - cdata = (ConnectionData*) Tcl_ObjectGetMetadata(connectionObject, - &connectionDataType); - if (cdata == NULL) { - Tcl_AppendResult(interp, Tcl_GetString(objv[skip]), - " does not refer to a MySQL connection", NULL); - return TCL_ERROR; - } - - /* - * Allocate an object to hold data about this statement - */ - - sdata = NewStatement(cdata); - - /* Tokenize the statement */ - - tokens = Tdbc_TokenizeSql(interp, Tcl_GetString(objv[skip+1])); - if (tokens == NULL) { - goto freeSData; - } - Tcl_IncrRefCount(tokens); - - /* - * Rewrite the tokenized statement to MySQL syntax. Reject the - * statement if it is actually multiple statements. - */ - - if (Tcl_ListObjGetElements(interp, tokens, &tokenc, &tokenv) != TCL_OK) { - goto freeTokens; - } - nativeSql = Tcl_NewObj(); - Tcl_IncrRefCount(nativeSql); - for (i = 0; i < tokenc; ++i) { - tokenStr = Tcl_GetStringFromObj(tokenv[i], &tokenLen); - - switch (tokenStr[0]) { - case '$': - case ':': - case '@': - Tcl_AppendToObj(nativeSql, "?", 1); - Tcl_ListObjAppendElement(NULL, sdata->subVars, - Tcl_NewStringObj(tokenStr+1, tokenLen-1)); - break; - - case ';': - Tcl_SetObjResult(interp, - Tcl_NewStringObj("tdbc::mysql" - " does not support semicolons " - "in statements", -1)); - goto freeNativeSql; - break; - - default: - Tcl_AppendToObj(nativeSql, tokenStr, tokenLen); - break; - - } - } - sdata->nativeSql = nativeSql; - Tcl_DecrRefCount(tokens); - - /* Prepare the statement */ - - sdata->stmtPtr = AllocAndPrepareStatement(interp, sdata); - if (sdata->stmtPtr == NULL) { - goto freeSData; - } - - /* Get result set metadata */ - - sdata->metadataPtr = mysql_stmt_result_metadata(sdata->stmtPtr); - if (mysql_stmt_errno(sdata->stmtPtr)) { - TransferMysqlStmtError(interp, sdata->stmtPtr); - goto freeSData; - } - sdata->columnNames = ResultDescToTcl(sdata->metadataPtr, 0); - Tcl_IncrRefCount(sdata->columnNames); - - Tcl_ListObjLength(NULL, sdata->subVars, &nParams); - sdata->params = (ParamData*) ckalloc(nParams * sizeof(ParamData)); - for (i = 0; i < nParams; ++i) { - sdata->params[i].flags = PARAM_IN; - sdata->params[i].dataType = MYSQL_TYPE_VARCHAR; - sdata->params[i].precision = 0; - sdata->params[i].scale = 0; - } - - /* Attach the current statement data as metadata to the current object */ - - Tcl_ObjectSetMetadata(thisObject, &statementDataType, (ClientData) sdata); - return TCL_OK; - - /* On error, unwind all the resource allocations */ - - freeNativeSql: - Tcl_DecrRefCount(nativeSql); - freeTokens: - Tcl_DecrRefCount(tokens); - freeSData: - DecrStatementRefCount(sdata); - return TCL_ERROR; -} - -/* - *----------------------------------------------------------------------------- - * - * StatementParamsMethod -- - * - * Lists the parameters in a MySQL statement. - * - * Usage: - * $statement params - * - * Results: - * Returns a standard Tcl result containing a dictionary. The keys - * of the dictionary are parameter names, and the values are parameter - * types, themselves expressed as dictionaries containing the keys, - * 'name', 'direction', 'type', 'precision', 'scale' and 'nullable'. - * - * - *----------------------------------------------------------------------------- - */ - -static int -StatementParamsMethod( - ClientData clientData, /* Not used */ - Tcl_Interp* interp, /* Tcl interpreter */ - Tcl_ObjectContext context, /* Object context */ - int objc, /* Parameter count */ - Tcl_Obj *const objv[] /* Parameter vector */ -) { - Tcl_Object thisObject = Tcl_ObjectContextObject(context); - /* The current statement object */ - StatementData* sdata /* The current statement */ - = (StatementData*) Tcl_ObjectGetMetadata(thisObject, - &statementDataType); - ConnectionData* cdata = sdata->cdata; - PerInterpData* pidata = cdata->pidata; /* Per-interp data */ - Tcl_Obj** literals = pidata->literals; /* Literal pool */ - int nParams; /* Number of parameters to the statement */ - Tcl_Obj* paramName; /* Name of a parameter */ - Tcl_Obj* paramDesc; /* Description of one parameter */ - Tcl_Obj* dataTypeName; /* Name of a parameter's data type */ - Tcl_Obj* retVal; /* Return value from this command */ - Tcl_HashEntry* typeHashEntry; - int i; - - if (objc != 2) { - Tcl_WrongNumArgs(interp, 2, objv, ""); - return TCL_ERROR; - } - - retVal = Tcl_NewObj(); - Tcl_ListObjLength(NULL, sdata->subVars, &nParams); - for (i = 0; i < nParams; ++i) { - paramDesc = Tcl_NewObj(); - Tcl_ListObjIndex(NULL, sdata->subVars, i, ¶mName); - Tcl_DictObjPut(NULL, paramDesc, literals[LIT_NAME], paramName); - switch (sdata->params[i].flags & (PARAM_IN | PARAM_OUT)) { - case PARAM_IN: - Tcl_DictObjPut(NULL, paramDesc, literals[LIT_DIRECTION], - literals[LIT_IN]); - break; - case PARAM_OUT: - Tcl_DictObjPut(NULL, paramDesc, literals[LIT_DIRECTION], - literals[LIT_OUT]); - break; - case PARAM_IN | PARAM_OUT: - Tcl_DictObjPut(NULL, paramDesc, literals[LIT_DIRECTION], - literals[LIT_INOUT]); - break; - default: - break; - } - typeHashEntry = - Tcl_FindHashEntry(&(pidata->typeNumHash), - INT2PTR(sdata->params[i].dataType)); - if (typeHashEntry != NULL) { - dataTypeName = (Tcl_Obj*) Tcl_GetHashValue(typeHashEntry); - Tcl_DictObjPut(NULL, paramDesc, literals[LIT_TYPE], dataTypeName); - } - Tcl_DictObjPut(NULL, paramDesc, literals[LIT_PRECISION], - Tcl_NewIntObj(sdata->params[i].precision)); - Tcl_DictObjPut(NULL, paramDesc, literals[LIT_SCALE], - Tcl_NewIntObj(sdata->params[i].scale)); - Tcl_DictObjPut(NULL, retVal, paramName, paramDesc); - } - - Tcl_SetObjResult(interp, retVal); - return TCL_OK; -} - -/* - *----------------------------------------------------------------------------- - * - * StatementParamtypeMethod -- - * - * Defines a parameter type in a MySQL statement. - * - * Usage: - * $statement paramtype paramName ?direction? type ?precision ?scale?? - * - * Results: - * Returns a standard Tcl result. - * - * Side effects: - * Updates the description of the given parameter. - * - *----------------------------------------------------------------------------- - */ - -static int -StatementParamtypeMethod( - ClientData clientData, /* Not used */ - Tcl_Interp* interp, /* Tcl interpreter */ - Tcl_ObjectContext context, /* Object context */ - int objc, /* Parameter count */ - Tcl_Obj *const objv[] /* Parameter vector */ -) { - Tcl_Object thisObject = Tcl_ObjectContextObject(context); - /* The current statement object */ - StatementData* sdata /* The current statement */ - = (StatementData*) Tcl_ObjectGetMetadata(thisObject, - &statementDataType); - static const struct { - const char* name; - int flags; - } directions[] = { - { "in", PARAM_IN }, - { "out", PARAM_OUT }, - { "inout", PARAM_IN | PARAM_OUT }, - { NULL, 0 } - }; - int direction; - int typeNum; /* Data type number of a parameter */ - int precision; /* Data precision */ - int scale; /* Data scale */ - - int nParams; /* Number of parameters to the statement */ - const char* paramName; /* Name of the parameter being set */ - Tcl_Obj* targetNameObj; /* Name of the ith parameter in the statement */ - const char* targetName; /* Name of a candidate parameter in the - * statement */ - int matchCount = 0; /* Number of parameters matching the name */ - Tcl_Obj* errorObj; /* Error message */ - - int i; - - /* Check parameters */ - - if (objc < 4) { - goto wrongNumArgs; - } - - i = 3; - if (Tcl_GetIndexFromObjStruct(interp, objv[i], directions, - sizeof(directions[0]), "direction", - TCL_EXACT, &direction) != TCL_OK) { - direction = PARAM_IN; - Tcl_ResetResult(interp); - } else { - ++i; - } - if (i >= objc) goto wrongNumArgs; - if (Tcl_GetIndexFromObjStruct(interp, objv[i], dataTypes, - sizeof(dataTypes[0]), "SQL data type", - TCL_EXACT, &typeNum) == TCL_OK) { - ++i; - } else { - return TCL_ERROR; - } - if (i < objc) { - if (Tcl_GetIntFromObj(interp, objv[i], &precision) == TCL_OK) { - ++i; - } else { - return TCL_ERROR; - } - } - if (i < objc) { - if (Tcl_GetIntFromObj(interp, objv[i], &scale) == TCL_OK) { - ++i; - } else { - return TCL_ERROR; - } - } - if (i != objc) { - goto wrongNumArgs; - } - - /* Look up parameters by name. */ - - Tcl_ListObjLength(NULL, sdata->subVars, &nParams); - paramName = Tcl_GetString(objv[2]); - for (i = 0; i < nParams; ++i) { - Tcl_ListObjIndex(NULL, sdata->subVars, i, &targetNameObj); - targetName = Tcl_GetString(targetNameObj); - if (!strcmp(paramName, targetName)) { - ++matchCount; - sdata->params[i].flags = direction; - sdata->params[i].dataType = dataTypes[typeNum].num; - sdata->params[i].precision = precision; - sdata->params[i].scale = scale; - } - } - if (matchCount == 0) { - errorObj = Tcl_NewStringObj("unknown parameter \"", -1); - Tcl_AppendToObj(errorObj, paramName, -1); - Tcl_AppendToObj(errorObj, "\": must be ", -1); - for (i = 0; i < nParams; ++i) { - Tcl_ListObjIndex(NULL, sdata->subVars, i, &targetNameObj); - Tcl_AppendObjToObj(errorObj, targetNameObj); - if (i < nParams-2) { - Tcl_AppendToObj(errorObj, ", ", -1); - } else if (i == nParams-2) { - Tcl_AppendToObj(errorObj, " or ", -1); - } - } - Tcl_SetObjResult(interp, errorObj); - return TCL_ERROR; - } - - return TCL_OK; - - wrongNumArgs: - Tcl_WrongNumArgs(interp, 2, objv, - "name ?direction? type ?precision ?scale??"); - return TCL_ERROR; -} - -/* - *----------------------------------------------------------------------------- - * - * DeleteStatementMetadata, DeleteStatement -- - * - * Cleans up when a MySQL statement is no longer required. - * - * Side effects: - * Frees all resources associated with the statement. - * - *----------------------------------------------------------------------------- - */ - -static void -DeleteStatementMetadata( - ClientData clientData /* Instance data for the connection */ -) { - DecrStatementRefCount((StatementData*)clientData); -} -static void -DeleteStatement( - StatementData* sdata /* Metadata for the statement */ -) { - if (sdata->columnNames != NULL) { - Tcl_DecrRefCount(sdata->columnNames); - } - if (sdata->metadataPtr != NULL) { - mysql_free_result(sdata->metadataPtr); - } - if (sdata->stmtPtr != NULL) { - mysql_stmt_close(sdata->stmtPtr); - } - if (sdata->nativeSql != NULL) { - Tcl_DecrRefCount(sdata->nativeSql); - } - if (sdata->params != NULL) { - ckfree((char*)sdata->params); - } - Tcl_DecrRefCount(sdata->subVars); - DecrConnectionRefCount(sdata->cdata); - ckfree((char*)sdata); -} - -/* - *----------------------------------------------------------------------------- - * - * CloneStatement -- - * - * Attempts to clone a MySQL statement's metadata. - * - * Results: - * Returns the new metadata - * - * At present, we don't attempt to clone statements - it's not obvious - * that such an action would ever even make sense. Instead, we return NULL - * to indicate that the metadata should not be cloned. (Note that this - * action isn't right, either. What *is* right is to indicate that the object - * is not clonable, but the API gives us no way to do that. - * - *----------------------------------------------------------------------------- - */ - -static int -CloneStatement( - Tcl_Interp* interp, /* Tcl interpreter for error reporting */ - ClientData metadata, /* Metadata to be cloned */ - ClientData* newMetaData /* Where to put the cloned metadata */ -) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("MySQL statements are not clonable", -1)); - return TCL_ERROR; -} - -/* - *----------------------------------------------------------------------------- - * - * ResultSetConstructor -- - * - * Constructs a new result set. - * - * Usage: - * $resultSet new statement ?dictionary? - * $resultSet create name statement ?dictionary? - * - * Parameters: - * statement -- Statement handle to which this resultset belongs - * dictionary -- Dictionary containing the substitutions for named - * parameters in the given statement. - * - * Results: - * Returns a standard Tcl result. On error, the interpreter result - * contains an appropriate message. - * - *----------------------------------------------------------------------------- - */ - -static int -ResultSetConstructor( - ClientData clientData, /* Not used */ - Tcl_Interp* interp, /* Tcl interpreter */ - Tcl_ObjectContext context, /* Object context */ - int objc, /* Parameter count */ - Tcl_Obj *const objv[] /* Parameter vector */ -) { - - Tcl_Object thisObject = Tcl_ObjectContextObject(context); - /* The current result set object */ - int skip = Tcl_ObjectContextSkippedArgs(context); - /* Number of args to skip */ - Tcl_Object statementObject; /* The current statement object */ - ConnectionData* cdata; /* The MySQL connection object's data */ - StatementData* sdata; /* The statement object's data */ - ResultSetData* rdata; /* THe result set object's data */ - int nParams; /* The parameter count on the statement */ - int nBound; /* Number of parameters bound so far */ - Tcl_Obj* paramNameObj; /* Name of the current parameter */ - const char* paramName; /* Name of the current parameter */ - Tcl_Obj* paramValObj; /* Value of the current parameter */ - const char* paramValStr; /* String value of the current parameter */ - char* bufPtr; /* Pointer to the parameter buffer */ - int len; /* Length of a bound parameter */ - int nColumns; /* Number of columns in the result set */ - MYSQL_FIELD* fields = NULL; /* Description of columns of the result set */ - MYSQL_BIND* resultBindings; /* Bindings of the columns of the result set */ - unsigned long* resultLengths; - /* Lengths of the columns of the result set */ - int i; - - /* Check parameter count */ - - if (objc != skip+1 && objc != skip+2) { - Tcl_WrongNumArgs(interp, skip, objv, "statement ?dictionary?"); - return TCL_ERROR; - } - - /* Initialize the base classes */ - - Tcl_ObjectContextInvokeNext(interp, context, skip, objv, skip); - - /* Find the statement object, and get the statement data */ - - statementObject = Tcl_GetObjectFromObj(interp, objv[skip]); - if (statementObject == NULL) { - return TCL_ERROR; - } - sdata = (StatementData*) Tcl_ObjectGetMetadata(statementObject, - &statementDataType); - if (sdata == NULL) { - Tcl_AppendResult(interp, Tcl_GetString(objv[skip]), - " does not refer to a MySQL statement", NULL); - return TCL_ERROR; - } - Tcl_ListObjLength(NULL, sdata->columnNames, &nColumns); - cdata = sdata->cdata; - - /* - * If there is no transaction in progress, turn on auto-commit so that - * this statement will execute directly. - */ - - if ((cdata->flags & (CONN_FLAG_IN_XCN | CONN_FLAG_AUTOCOMMIT)) == 0) { - if (mysql_autocommit(cdata->mysqlPtr, 1)) { - TransferMysqlError(interp, cdata->mysqlPtr); - return TCL_ERROR; - } - cdata->flags |= CONN_FLAG_AUTOCOMMIT; - } - - /* Allocate an object to hold data about this result set */ - - rdata = (ResultSetData*) ckalloc(sizeof(ResultSetData)); - rdata->refCount = 1; - rdata->sdata = sdata; - rdata->stmtPtr = NULL; - rdata->paramValues = NULL; - rdata->paramBindings = NULL; - rdata->paramLengths = NULL; - rdata->rowCount = 0; - rdata->resultErrors = (my_bool*) ckalloc(nColumns * sizeof(my_bool)); - rdata->resultNulls = (my_bool*) ckalloc(nColumns * sizeof(my_bool)); - resultLengths = rdata->resultLengths = (unsigned long*) - ckalloc(nColumns * sizeof(unsigned long)); - rdata->resultBindings = resultBindings = MysqlBindAlloc(nColumns); - IncrStatementRefCount(sdata); - Tcl_ObjectSetMetadata(thisObject, &resultSetDataType, (ClientData) rdata); - - /* Make bindings for all the result columns. Defer binding variable - * length fields until first execution. */ - - if (nColumns > 0) { - fields = mysql_fetch_fields(sdata->metadataPtr); - } - for (i = 0; i < nColumns; ++i) { - MYSQL_FIELD* field = MysqlFieldIndex(fields, i); - switch (field->type) { - - case MYSQL_TYPE_FLOAT: - case MYSQL_TYPE_DOUBLE: - MysqlBindSetBufferType(resultBindings, i, MYSQL_TYPE_DOUBLE); - MysqlBindAllocBuffer(resultBindings, i, sizeof(double)); - resultLengths[i] = sizeof(double); - break; - - case MYSQL_TYPE_BIT: - MysqlBindSetBufferType(resultBindings, i, MYSQL_TYPE_BIT); - MysqlBindAllocBuffer(resultBindings, i, field->length); - resultLengths[i] = field->length; - break; - - case MYSQL_TYPE_LONGLONG: - MysqlBindSetBufferType(resultBindings, i, MYSQL_TYPE_LONGLONG); - MysqlBindAllocBuffer(resultBindings, i, sizeof(Tcl_WideInt)); - resultLengths[i] = sizeof(Tcl_WideInt); - break; - - case MYSQL_TYPE_TINY: - case MYSQL_TYPE_SHORT: - case MYSQL_TYPE_INT24: - case MYSQL_TYPE_LONG: - MysqlBindSetBufferType(resultBindings, i, MYSQL_TYPE_LONG); - MysqlBindAllocBuffer(resultBindings, i, sizeof(int)); - resultLengths[i] = sizeof(int); - break; - - default: - MysqlBindSetBufferType(resultBindings, i, MYSQL_TYPE_STRING); - MysqlBindAllocBuffer(resultBindings, i, 0); - resultLengths[i] = 0; - break; - } - MysqlBindSetLength(resultBindings, i, rdata->resultLengths + i); - rdata->resultNulls[i] = 0; - MysqlBindSetIsNull(resultBindings, i, rdata->resultNulls + i); - rdata->resultErrors[i] = 0; - MysqlBindSetError(resultBindings, i, rdata->resultErrors + i); - } - - /* - * Find a statement handle that we can use to execute the SQL code. - * If the main statement handle associated with the statement - * is idle, we can use it. Otherwise, we have to allocate and - * prepare a fresh one. - */ - - if (sdata->flags & STMT_FLAG_BUSY) { - rdata->stmtPtr = AllocAndPrepareStatement(interp, sdata); - if (rdata->stmtPtr == NULL) { - return TCL_ERROR; - } - } else { - rdata->stmtPtr = sdata->stmtPtr; - sdata->flags |= STMT_FLAG_BUSY; - } - - /* Allocate the parameter bindings */ - - Tcl_ListObjLength(NULL, sdata->subVars, &nParams); - rdata->paramValues = Tcl_NewObj(); - Tcl_IncrRefCount(rdata->paramValues); - rdata->paramBindings = MysqlBindAlloc(nParams); - rdata->paramLengths = (unsigned long*) ckalloc(nParams - * sizeof(unsigned long)); - for (nBound = 0; nBound < nParams; ++nBound) { - MysqlBindSetBufferType(rdata->paramBindings, nBound, MYSQL_TYPE_NULL); - } - - /* Bind the substituted parameters */ - - for (nBound = 0; nBound < nParams; ++nBound) { - Tcl_ListObjIndex(NULL, sdata->subVars, nBound, ¶mNameObj); - paramName = Tcl_GetString(paramNameObj); - if (objc == skip+2) { - - /* Param from a dictionary */ - - if (Tcl_DictObjGet(interp, objv[skip+1], - paramNameObj, ¶mValObj) != TCL_OK) { - return TCL_ERROR; - } - } else { - - /* Param from a variable */ - - paramValObj = Tcl_GetVar2Ex(interp, paramName, NULL, - TCL_LEAVE_ERR_MSG); - } - - /* - * At this point, paramValObj contains the parameter to bind. - * Convert the parameters to the appropriate data types for - * MySQL's prepared statement interface, and bind them. - */ - - if (paramValObj != NULL) { - switch (sdata->params[nBound].dataType & 0xffff) { - - case MYSQL_TYPE_NEWDECIMAL: - case MYSQL_TYPE_DECIMAL: - if (sdata->params[nBound].scale == 0) { - if (sdata->params[nBound].precision < 10) { - goto smallinteger; - } else if (sdata->params[nBound].precision < 19) { - goto biginteger; - } else { - goto charstring; - } - } else if (sdata->params[nBound].precision < 17) { - goto real; - } else { - goto charstring; - } - - case MYSQL_TYPE_FLOAT: - case MYSQL_TYPE_DOUBLE: - real: - MysqlBindSetBufferType(rdata->paramBindings, nBound, - MYSQL_TYPE_DOUBLE); - bufPtr = MysqlBindAllocBuffer(rdata->paramBindings, - nBound, sizeof(double)); - rdata->paramLengths[nBound] = sizeof(double); - MysqlBindSetLength(rdata->paramBindings, nBound, - &(rdata->paramLengths[nBound])); - if (Tcl_GetDoubleFromObj(interp, paramValObj, - (double*) bufPtr) != TCL_OK) { - return TCL_ERROR; - } - break; - - case MYSQL_TYPE_BIT: - case MYSQL_TYPE_LONGLONG: - biginteger: - MysqlBindSetBufferType(rdata->paramBindings, nBound, - MYSQL_TYPE_LONGLONG); - bufPtr = MysqlBindAllocBuffer(rdata->paramBindings, nBound, - sizeof(Tcl_WideInt)); - rdata->paramLengths[nBound] = sizeof(Tcl_WideInt); - MysqlBindSetLength(rdata->paramBindings, nBound, - &(rdata->paramLengths[nBound])); - if (Tcl_GetWideIntFromObj(interp, paramValObj, - (Tcl_WideInt*) bufPtr) != TCL_OK) { - return TCL_ERROR; - } - break; - - case MYSQL_TYPE_TINY: - case MYSQL_TYPE_SHORT: - case MYSQL_TYPE_INT24: - case MYSQL_TYPE_LONG: - smallinteger: - MysqlBindSetBufferType(rdata->paramBindings, nBound, - MYSQL_TYPE_LONG); - bufPtr = MysqlBindAllocBuffer(rdata->paramBindings, nBound, - sizeof(int)); - rdata->paramLengths[nBound] = sizeof(int); - MysqlBindSetLength(rdata->paramBindings, nBound, - &(rdata->paramLengths[nBound])); - if (Tcl_GetIntFromObj(interp, paramValObj, - (int*) bufPtr) != TCL_OK) { - return TCL_ERROR; - } - break; - - default: - charstring: - Tcl_ListObjAppendElement(NULL, rdata->paramValues, paramValObj); - if (sdata->params[nBound].dataType & IS_BINARY) { - MysqlBindSetBufferType(rdata->paramBindings, nBound, - MYSQL_TYPE_BLOB); - paramValStr = (char*) - Tcl_GetByteArrayFromObj(paramValObj, &len); - } else { - MysqlBindSetBufferType(rdata->paramBindings, nBound, - MYSQL_TYPE_STRING); - paramValStr = Tcl_GetStringFromObj(paramValObj, &len); - } - bufPtr = MysqlBindAllocBuffer(rdata->paramBindings, nBound, - len+1); - memcpy(bufPtr, paramValStr, len); - rdata->paramLengths[nBound] = len; - MysqlBindSetLength(rdata->paramBindings, nBound, - &(rdata->paramLengths[nBound])); - break; - - } - } else { - MysqlBindSetBufferType(rdata->paramBindings, nBound, - MYSQL_TYPE_NULL); - } - } - - /* Execute the statement */ - - /* - * It is tempting to conserve client memory here by omitting - * the call to 'mysql_stmt_store_result', but doing so causes - * 'calls out of sync' errors when attempting to prepare a - * statement while a result set is open. Certain of these errors - * can, in turn, be avoided by using mysql_stmt_set_attr - * and turning on "CURSOR_MODE_READONLY", but that, in turn - * causes the server summarily to disconnect the client in - * some tests. - */ - - if (mysql_stmt_bind_param(rdata->stmtPtr, rdata->paramBindings) - || ((nColumns > 0) && mysql_stmt_bind_result(rdata->stmtPtr, - resultBindings)) - || mysql_stmt_execute(rdata->stmtPtr) - || mysql_stmt_store_result(rdata->stmtPtr) ) { - TransferMysqlStmtError(interp, sdata->stmtPtr); - return TCL_ERROR; - } - - /* Determine and store the row count */ - - rdata->rowCount = mysql_stmt_affected_rows(sdata->stmtPtr); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * ResultSetColumnsMethod -- - * - * Retrieves the list of columns from a result set. - * - * Usage: - * $resultSet columns - * - * Results: - * Returns the count of columns - * - *----------------------------------------------------------------------------- - */ - -static int -ResultSetColumnsMethod( - ClientData clientData, /* Not used */ - Tcl_Interp* interp, /* Tcl interpreter */ - Tcl_ObjectContext context, /* Object context */ - int objc, /* Parameter count */ - Tcl_Obj *const objv[] /* Parameter vector */ -) { - - Tcl_Object thisObject = Tcl_ObjectContextObject(context); - /* The current result set object */ - ResultSetData* rdata = (ResultSetData*) - Tcl_ObjectGetMetadata(thisObject, &resultSetDataType); - StatementData* sdata = (StatementData*) rdata->sdata; - - if (objc != 2) { - Tcl_WrongNumArgs(interp, 2, objv, "?pattern?"); - return TCL_ERROR; - } - - Tcl_SetObjResult(interp, sdata->columnNames); - - return TCL_OK; - -} - -/* - *----------------------------------------------------------------------------- - * - * ResultSetNextrowMethod -- - * - * Retrieves the next row from a result set. - * - * Usage: - * $resultSet nextrow ?-as lists|dicts? ?--? variableName - * - * Options: - * -as Selects the desired form for returning the results. - * - * Parameters: - * variableName -- Variable in which the results are to be returned - * - * Results: - * Returns a standard Tcl result. The interpreter result is 1 if there - * are more rows remaining, and 0 if no more rows remain. - * - * Side effects: - * Stores in the given variable either a list or a dictionary - * containing one row of the result set. - * - *----------------------------------------------------------------------------- - */ - -static int -ResultSetNextrowMethod( - ClientData clientData, /* Not used */ - Tcl_Interp* interp, /* Tcl interpreter */ - Tcl_ObjectContext context, /* Object context */ - int objc, /* Parameter count */ - Tcl_Obj *const objv[] /* Parameter vector */ -) { - - int lists = PTR2INT(clientData); - /* Flag == 1 if lists are to be returned, - * 0 if dicts are to be returned */ - - Tcl_Object thisObject = Tcl_ObjectContextObject(context); - /* The current result set object */ - ResultSetData* rdata = (ResultSetData*) - Tcl_ObjectGetMetadata(thisObject, &resultSetDataType); - /* Data pertaining to the current result set */ - StatementData* sdata = (StatementData*) rdata->sdata; - /* Statement that yielded the result set */ - ConnectionData* cdata = (ConnectionData*) sdata->cdata; - /* Connection that opened the statement */ - PerInterpData* pidata = (PerInterpData*) cdata->pidata; - /* Per interpreter data */ - Tcl_Obj** literals = pidata->literals; - /* Literal pool */ - - int nColumns = 0; /* Number of columns in the result set */ - Tcl_Obj* colName; /* Name of the current column */ - Tcl_Obj* resultRow; /* Row of the result set under construction */ - - Tcl_Obj* colObj; /* Column obtained from the row */ - int status = TCL_ERROR; /* Status return from this command */ - MYSQL_FIELD* fields; /* Fields of the result set */ - MYSQL_BIND* resultBindings = rdata->resultBindings; - /* Descriptions of the results */ - unsigned long* resultLengths = rdata->resultLengths; - /* String lengths of the results */ - my_bool* resultNulls = rdata->resultNulls; - /* Indicators that the results are null */ - void* bufPtr; /* Pointer to a result's buffer */ - unsigned char byte; /* One byte extracted from a bit field */ - Tcl_WideInt bitVal; /* Value of a bit field */ - int mysqlStatus; /* Status return from MySQL */ - int i; - unsigned int j; - - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "varName"); - return TCL_ERROR; - } - - - /* Get the column names in the result set. */ - - Tcl_ListObjLength(NULL, sdata->columnNames, &nColumns); - if (nColumns == 0) { - Tcl_SetObjResult(interp, literals[LIT_0]); - return TCL_OK; - } - - resultRow = Tcl_NewObj(); - Tcl_IncrRefCount(resultRow); - - /* - * Try to rebind the result set before doing the next fetch - */ - - fields = mysql_fetch_fields(sdata->metadataPtr); - if (mysql_stmt_bind_result(rdata->stmtPtr, resultBindings)) { - goto cleanup; - } - - /* Fetch the row to determine sizes. */ - - mysqlStatus = mysql_stmt_fetch(rdata->stmtPtr); - if (mysqlStatus != 0 && mysqlStatus != MYSQL_DATA_TRUNCATED) { - if (mysqlStatus == MYSQL_NO_DATA) { - Tcl_SetObjResult(interp, literals[LIT_0]); - status = TCL_OK; - } - goto cleanup; - } - - /* Retrieve one column at a time. */ - - for (i = 0; i < nColumns; ++i) { - MYSQL_FIELD* field = MysqlFieldIndex(fields, i); - colObj = NULL; - if (!resultNulls[i]) { - if (resultLengths[i] - > MysqlBindGetBufferLength(resultBindings, i)) { - MysqlBindFreeBuffer(resultBindings, i); - MysqlBindAllocBuffer(resultBindings, i, resultLengths[i] + 1); - if (mysql_stmt_fetch_column(rdata->stmtPtr, - MysqlBindIndex(resultBindings, i), - i, 0)) { - goto cleanup; - } - } - bufPtr = MysqlBindGetBuffer(resultBindings, i); - switch (MysqlBindGetBufferType(resultBindings, i)) { - - case MYSQL_TYPE_BIT: - bitVal = 0; - for (j = 0; j < resultLengths[i]; ++j) { - byte = ((unsigned char*) bufPtr)[resultLengths[i]-1-j]; - bitVal |= (byte << (8*j)); - } - colObj = Tcl_NewWideIntObj(bitVal); - break; - - case MYSQL_TYPE_DOUBLE: - colObj = Tcl_NewDoubleObj(*(double*) bufPtr); - break; - - case MYSQL_TYPE_LONG: - colObj = Tcl_NewIntObj(*(int*) bufPtr); - break; - - case MYSQL_TYPE_LONGLONG: - colObj = Tcl_NewWideIntObj(*(Tcl_WideInt*) bufPtr); - break; - - default: - if (field->charsetnr == 63) { - colObj = Tcl_NewByteArrayObj((unsigned char*) bufPtr, - resultLengths[i]); - } else { - colObj = Tcl_NewStringObj((char*) bufPtr, - resultLengths[i]); - } - break; - } - } - - if (lists) { - if (colObj == NULL) { - colObj = literals[LIT_EMPTY]; - } - Tcl_ListObjAppendElement(NULL, resultRow, colObj); - } else { - if (colObj != NULL) { - Tcl_ListObjIndex(NULL, sdata->columnNames, i, &colName); - Tcl_DictObjPut(NULL, resultRow, colName, colObj); - } - } - } - - /* Save the row in the given variable */ - - if (Tcl_SetVar2Ex(interp, Tcl_GetString(objv[2]), NULL, - resultRow, TCL_LEAVE_ERR_MSG) == NULL) { - goto cleanup; - } - - Tcl_SetObjResult(interp, literals[LIT_1]); - status = TCL_OK; - - cleanup: - if (status != TCL_OK) { - TransferMysqlStmtError(interp, rdata->stmtPtr); - } - Tcl_DecrRefCount(resultRow); - return status; - -} - -/* - *----------------------------------------------------------------------------- - * - * ResultSetRowcountMethod -- - * - * Returns (if known) the number of rows affected by a MySQL statement. - * - * Usage: - * $resultSet rowcount - * - * Results: - * Returns a standard Tcl result giving the number of affected rows. - * - *----------------------------------------------------------------------------- - */ - -static int -ResultSetRowcountMethod( - ClientData clientData, /* Not used */ - Tcl_Interp* interp, /* Tcl interpreter */ - Tcl_ObjectContext context, /* Object context */ - int objc, /* Parameter count */ - Tcl_Obj *const objv[] /* Parameter vector */ -) { - - Tcl_Object thisObject = Tcl_ObjectContextObject(context); - /* The current result set object */ - ResultSetData* rdata = (ResultSetData*) - Tcl_ObjectGetMetadata(thisObject, &resultSetDataType); - /* Data pertaining to the current result set */ - - if (objc != 2) { - Tcl_WrongNumArgs(interp, 2, objv, ""); - return TCL_ERROR; - } - Tcl_SetObjResult(interp, - Tcl_NewWideIntObj((Tcl_WideInt)(rdata->rowCount))); - return TCL_OK; -} - -/* - *----------------------------------------------------------------------------- - * - * DeleteResultSetMetadata, DeleteResultSet -- - * - * Cleans up when a MySQL result set is no longer required. - * - * Side effects: - * Frees all resources associated with the result set. - * - *----------------------------------------------------------------------------- - */ - -static void -DeleteResultSetMetadata( - ClientData clientData /* Instance data for the connection */ -) { - DecrResultSetRefCount((ResultSetData*)clientData); -} -static void -DeleteResultSet( - ResultSetData* rdata /* Metadata for the result set */ -) { - StatementData* sdata = rdata->sdata; - int i; - int nParams; - int nColumns; - Tcl_ListObjLength(NULL, sdata->subVars, &nParams); - Tcl_ListObjLength(NULL, sdata->columnNames, &nColumns); - for (i = 0; i < nColumns; ++i) { - MysqlBindFreeBuffer(rdata->resultBindings, i); - } - ckfree((char*)(rdata->resultBindings)); - ckfree((char*)(rdata->resultLengths)); - ckfree((char*)(rdata->resultNulls)); - ckfree((char*)(rdata->resultErrors)); - ckfree((char*)(rdata->paramLengths)); - if (rdata->paramBindings != NULL) { - for (i = 0; i < nParams; ++i) { - if (MysqlBindGetBufferType(rdata->paramBindings, i) - != MYSQL_TYPE_NULL) { - MysqlBindFreeBuffer(rdata->paramBindings, i); - } - } - ckfree((char*)(rdata->paramBindings)); - } - if (rdata->paramValues != NULL) { - Tcl_DecrRefCount(rdata->paramValues); - } - if (rdata->stmtPtr != NULL) { - if (rdata->stmtPtr != sdata->stmtPtr) { - mysql_stmt_close(rdata->stmtPtr); - } else { - sdata->flags &= ~ STMT_FLAG_BUSY; - } - } - DecrStatementRefCount(rdata->sdata); - ckfree((char*)rdata); -} - -/* - *----------------------------------------------------------------------------- - * - * CloneResultSet -- - * - * Attempts to clone a MySQL result set's metadata. - * - * Results: - * Returns the new metadata - * - * At present, we don't attempt to clone result sets - it's not obvious - * that such an action would ever even make sense. Instead, we throw an - * error. - * - *----------------------------------------------------------------------------- - */ - -static int -CloneResultSet( - Tcl_Interp* interp, /* Tcl interpreter for error reporting */ - ClientData metadata, /* Metadata to be cloned */ - ClientData* newMetaData /* Where to put the cloned metadata */ -) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("MySQL result sets are not clonable", - -1)); - return TCL_ERROR; -} - -/* - *----------------------------------------------------------------------------- - * - * Tdbcmysql_Init -- - * - * Initializes the TDBC-MYSQL bridge when this library is loaded. - * - * Side effects: - * Creates the ::tdbc::mysql namespace and the commands that reside in it. - * Initializes the MYSQL environment. - * - *----------------------------------------------------------------------------- - */ - -extern DLLEXPORT int -Tdbcmysql_Init( - Tcl_Interp* interp /* Tcl interpreter */ -) { - PerInterpData* pidata; /* Per-interpreter data for this package */ - Tcl_Obj* nameObj; /* Name of a class or method being looked up */ - Tcl_Object curClassObject; /* Tcl_Object representing the current class */ - Tcl_Class curClass; /* Tcl_Class representing the current class */ - int i; - - /* Require all package dependencies */ - - if (Tcl_InitStubs(interp, TCL_VERSION, 0) == NULL) { - return TCL_ERROR; - } - if (TclOOInitializeStubs(interp, "1.0") == NULL) { - return TCL_ERROR; - } - if (Tdbc_InitStubs(interp) == NULL) { - return TCL_ERROR; - } - - /* Provide the current package */ - - if (Tcl_PkgProvide(interp, "tdbc::mysql", PACKAGE_VERSION) == TCL_ERROR) { - return TCL_ERROR; - } - - /* - * Create per-interpreter data for the package - */ - - pidata = (PerInterpData*) ckalloc(sizeof(PerInterpData)); - pidata->refCount = 1; - for (i = 0; i < LIT__END; ++i) { - pidata->literals[i] = Tcl_NewStringObj(LiteralValues[i], -1); - Tcl_IncrRefCount(pidata->literals[i]); - } - Tcl_InitHashTable(&(pidata->typeNumHash), TCL_ONE_WORD_KEYS); - for (i = 0; dataTypes[i].name != NULL; ++i) { - int new; - Tcl_HashEntry* entry = - Tcl_CreateHashEntry(&(pidata->typeNumHash), - INT2PTR(dataTypes[i].num), - &new); - Tcl_Obj* nameObj = Tcl_NewStringObj(dataTypes[i].name, -1); - Tcl_IncrRefCount(nameObj); - Tcl_SetHashValue(entry, (ClientData) nameObj); - } - - /* - * Find the connection class, and attach an 'init' method to it. - */ - - nameObj = Tcl_NewStringObj("::tdbc::mysql::connection", -1); - Tcl_IncrRefCount(nameObj); - if ((curClassObject = Tcl_GetObjectFromObj(interp, nameObj)) == NULL) { - Tcl_DecrRefCount(nameObj); - return TCL_ERROR; - } - Tcl_DecrRefCount(nameObj); - curClass = Tcl_GetObjectAsClass(curClassObject); - - /* Attach the constructor to the 'connection' class */ - - Tcl_ClassSetConstructor(interp, curClass, - Tcl_NewMethod(interp, curClass, NULL, 1, - &ConnectionConstructorType, - (ClientData) pidata)); - - /* Attach the methods to the 'connection' class */ - - for (i = 0; ConnectionMethods[i] != NULL; ++i) { - nameObj = Tcl_NewStringObj(ConnectionMethods[i]->name, -1); - Tcl_IncrRefCount(nameObj); - Tcl_NewMethod(interp, curClass, nameObj, 1, ConnectionMethods[i], - (ClientData) NULL); - Tcl_DecrRefCount(nameObj); - } - - /* Look up the 'statement' class */ - - nameObj = Tcl_NewStringObj("::tdbc::mysql::statement", -1); - Tcl_IncrRefCount(nameObj); - if ((curClassObject = Tcl_GetObjectFromObj(interp, nameObj)) == NULL) { - Tcl_DecrRefCount(nameObj); - return TCL_ERROR; - } - Tcl_DecrRefCount(nameObj); - curClass = Tcl_GetObjectAsClass(curClassObject); - - /* Attach the constructor to the 'statement' class */ - - Tcl_ClassSetConstructor(interp, curClass, - Tcl_NewMethod(interp, curClass, NULL, 1, - &StatementConstructorType, - (ClientData) NULL)); - - /* Attach the methods to the 'statement' class */ - - for (i = 0; StatementMethods[i] != NULL; ++i) { - nameObj = Tcl_NewStringObj(StatementMethods[i]->name, -1); - Tcl_IncrRefCount(nameObj); - Tcl_NewMethod(interp, curClass, nameObj, 1, StatementMethods[i], - (ClientData) NULL); - Tcl_DecrRefCount(nameObj); - } - - /* Look up the 'resultSet' class */ - - nameObj = Tcl_NewStringObj("::tdbc::mysql::resultset", -1); - Tcl_IncrRefCount(nameObj); - if ((curClassObject = Tcl_GetObjectFromObj(interp, nameObj)) == NULL) { - Tcl_DecrRefCount(nameObj); - return TCL_ERROR; - } - Tcl_DecrRefCount(nameObj); - curClass = Tcl_GetObjectAsClass(curClassObject); - - /* Attach the constructor to the 'resultSet' class */ - - Tcl_ClassSetConstructor(interp, curClass, - Tcl_NewMethod(interp, curClass, NULL, 1, - &ResultSetConstructorType, - (ClientData) NULL)); - - /* Attach the methods to the 'resultSet' class */ - - for (i = 0; ResultSetMethods[i] != NULL; ++i) { - nameObj = Tcl_NewStringObj(ResultSetMethods[i]->name, -1); - Tcl_IncrRefCount(nameObj); - Tcl_NewMethod(interp, curClass, nameObj, 1, ResultSetMethods[i], - (ClientData) NULL); - Tcl_DecrRefCount(nameObj); - } - nameObj = Tcl_NewStringObj("nextlist", -1); - Tcl_IncrRefCount(nameObj); - Tcl_NewMethod(interp, curClass, nameObj, 1, &ResultSetNextrowMethodType, - (ClientData) 1); - Tcl_DecrRefCount(nameObj); - nameObj = Tcl_NewStringObj("nextdict", -1); - Tcl_IncrRefCount(nameObj); - Tcl_NewMethod(interp, curClass, nameObj, 1, &ResultSetNextrowMethodType, - (ClientData) 0); - Tcl_DecrRefCount(nameObj); - - /* - * Initialize the MySQL library if this is the first interp using it - */ - - Tcl_MutexLock(&mysqlMutex); - if (mysqlRefCount == 0) { - if ((mysqlLoadHandle = MysqlInitStubs(interp)) == NULL) { - Tcl_MutexUnlock(&mysqlMutex); - return TCL_ERROR; - } - mysql_library_init(0, NULL, NULL); - mysqlClientVersion = mysql_get_client_version(); - } - ++mysqlRefCount; - Tcl_MutexUnlock(&mysqlMutex); - - /* - * TODO: mysql_thread_init, and keep a TSD reference count of users. - */ - - return TCL_OK; -} - -/* - *----------------------------------------------------------------------------- - * - * DeletePerInterpData -- - * - * Delete per-interpreter data when the MYSQL package is finalized - * - * Side effects: - * Releases the (presumably last) reference on the environment handle, - * cleans up the literal pool, and deletes the per-interp data structure. - * - *----------------------------------------------------------------------------- - */ - -static void -DeletePerInterpData( - PerInterpData* pidata /* Data structure to clean up */ -) { - int i; - - Tcl_HashSearch search; - Tcl_HashEntry *entry; - for (entry = Tcl_FirstHashEntry(&(pidata->typeNumHash), &search); - entry != NULL; - entry = Tcl_NextHashEntry(&search)) { - Tcl_Obj* nameObj = (Tcl_Obj*) Tcl_GetHashValue(entry); - Tcl_DecrRefCount(nameObj); - } - Tcl_DeleteHashTable(&(pidata->typeNumHash)); - - for (i = 0; i < LIT__END; ++i) { - Tcl_DecrRefCount(pidata->literals[i]); - } - ckfree((char *) pidata); - - /* - * TODO: decrease thread refcount and mysql_thread_end if need be - */ - - Tcl_MutexLock(&mysqlMutex); - if (--mysqlRefCount == 0) { - mysql_library_end(); - Tcl_FSUnloadFile(NULL, mysqlLoadHandle); - } - Tcl_MutexUnlock(&mysqlMutex); -} |