5671 lines
164 KiB
C
5671 lines
164 KiB
C
/*
|
||
* tdbcodbc.c --
|
||
*
|
||
* Bridge between TDBC (Tcl DataBase Connectivity) and ODBC.
|
||
*
|
||
* Copyright (c) 2008, 2009, 2011 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_DEPRECATE
|
||
#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"
|
||
|
||
#ifdef _WIN32
|
||
# define WIN32_LEAN_AND_MEAN
|
||
# include <windows.h>
|
||
#endif
|
||
|
||
#include "fakesql.h"
|
||
|
||
/* Static data contained in this file */
|
||
|
||
TCL_DECLARE_MUTEX(hEnvMutex); /* Mutex protecting the environment handle
|
||
* and its reference count */
|
||
|
||
static Tcl_LoadHandle odbcLoadHandle = NULL;
|
||
/* Handle to the ODBC client library */
|
||
static Tcl_LoadHandle odbcInstLoadHandle = NULL;
|
||
/* Handle to the ODBC installer library */
|
||
static SQLHENV hEnv = SQL_NULL_HENV;
|
||
/* Handle to the global ODBC environment */
|
||
static size_t hEnvRefCount = 0; /* Reference count on the global environment */
|
||
static size_t sizeofSQLWCHAR = sizeof(SQLWCHAR);
|
||
/* Preset, will be autodetected later */
|
||
|
||
/*
|
||
* Objects to create within the literal pool
|
||
*/
|
||
|
||
const char* const LiteralValues[] = {
|
||
"0",
|
||
"1",
|
||
"-encoding",
|
||
"-isolation",
|
||
"-readonly",
|
||
"-timeout",
|
||
"id",
|
||
"readuncommitted",
|
||
"readcommitted",
|
||
"repeatableread",
|
||
"serializable",
|
||
"::winfo",
|
||
NULL
|
||
};
|
||
enum LiteralIndex {
|
||
LIT_0,
|
||
LIT_1,
|
||
LIT_ENCODING,
|
||
LIT_ISOLATION,
|
||
LIT_READONLY,
|
||
LIT_TIMEOUT,
|
||
LIT_ID,
|
||
LIT_READUNCOMMITTED,
|
||
LIT_READCOMMITTED,
|
||
LIT_REPEATABLEREAD,
|
||
LIT_SERIALIZABLE,
|
||
LIT_WINFO,
|
||
LIT__END
|
||
};
|
||
|
||
/*
|
||
* Structure that holds per-interpreter data for the ODBC package.
|
||
*/
|
||
|
||
typedef struct PerInterpData {
|
||
size_t refCount; /* Reference count */
|
||
SQLHENV hEnv; /* ODBC environment handle */
|
||
Tcl_Obj* literals[LIT__END];
|
||
/* Literal pool */
|
||
} PerInterpData;
|
||
#define IncrPerInterpRefCount(x) \
|
||
do { \
|
||
++((x)->refCount); \
|
||
} while(0)
|
||
#define DecrPerInterpRefCount(x) \
|
||
do { \
|
||
PerInterpData* _pidata = x; \
|
||
if (_pidata->refCount-- <= 1) { \
|
||
DeletePerInterpData(_pidata); \
|
||
} \
|
||
} while(0)
|
||
|
||
/*
|
||
* Structure that carries the data for an ODBC 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 {
|
||
size_t refCount; /* Reference count. */
|
||
PerInterpData* pidata; /* Per-interpreter data */
|
||
Tcl_Obj* connectionString; /* Connection string actually used to
|
||
* connect to the database */
|
||
SQLHDBC hDBC; /* Connection handle */
|
||
int flags; /* Flags describing the state of the
|
||
* connection */
|
||
} ConnectionData;
|
||
|
||
/*
|
||
* Flags for the state of an ODBC connection
|
||
*/
|
||
|
||
#define CONNECTION_FLAG_AUTOCOMMIT (1<<0)
|
||
/* Connection is in auto-commit mode */
|
||
#define CONNECTION_FLAG_XCN_ACTIVE (1<<1)
|
||
/* Connection has a transaction in progress.
|
||
* (Note that ODBC does not support nesting
|
||
* of transactions.) */
|
||
#define CONNECTION_FLAG_HAS_WVARCHAR (1<<2)
|
||
/* Connection supports WVARCHAR */
|
||
#define CONNECTION_FLAG_HAS_BIGINT (1<<3)
|
||
/* Connection supports WVARCHAR */
|
||
|
||
#define IncrConnectionRefCount(x) \
|
||
do { \
|
||
++((x)->refCount); \
|
||
} while(0)
|
||
#define DecrConnectionRefCount(x) \
|
||
do { \
|
||
ConnectionData* conn = x; \
|
||
if (conn->refCount-- <= 1) { \
|
||
DeleteConnection(conn); \
|
||
} \
|
||
} while(0)
|
||
|
||
/*
|
||
* Structure that carries the data for an ODBC 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 {
|
||
size_t refCount; /* Reference count */
|
||
Tcl_Object connectionObject;
|
||
/* The connection object */
|
||
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 */
|
||
SQLHSTMT hStmt; /* Handle to the ODBC statement */
|
||
SQLWCHAR* nativeSqlW; /* SQL statement as wide chars */
|
||
size_t nativeSqlLen; /* Length of the statement */
|
||
SQLWCHAR* nativeMatchPatternW;
|
||
/* Match pattern for metadata queries */
|
||
size_t nativeMatchPatLen; /* Length of the match pattern */
|
||
struct ParamData* params; /* Pointer to an array of ParamData
|
||
* structures that describe the data types
|
||
* of substituted parameters. */
|
||
int typeNum; /* Type number for a query of data types */
|
||
int flags; /* Flags tracking the state of the
|
||
* StatementData */
|
||
} StatementData;
|
||
#define IncrStatementRefCount(x) \
|
||
do { \
|
||
++((x)->refCount); \
|
||
} while (0)
|
||
#define DecrStatementRefCount(x) \
|
||
do { \
|
||
StatementData* stmt = (x); \
|
||
if (stmt->refCount-- <= 1) { \
|
||
DeleteStatement(stmt); \
|
||
} \
|
||
} while(0)
|
||
|
||
/* Flags in StatementData */
|
||
|
||
#define STATEMENT_FLAG_HSTMT_BUSY 0x1
|
||
/* This flag is set if hStmt is in use, in
|
||
* which case the progam must clone it if
|
||
* another result set is needed */
|
||
/*
|
||
* Stored procedure calls and statements that return multiple
|
||
* results defeat the attempt to cache result set metadata, so
|
||
* the following flag is now obsolete.
|
||
*/
|
||
#if 0
|
||
#define STATEMENT_FLAG_RESULTS_KNOWN 0x2
|
||
/* This flag is set if the result set
|
||
* has already been described. The result
|
||
* set metadata for a given statement is
|
||
* queried only once, and retained for
|
||
* use in future invocations. */
|
||
#endif
|
||
#define STATEMENT_FLAG_TABLES 0x4
|
||
/* This flag is set if the statement is
|
||
* asking for table metadata */
|
||
#define STATEMENT_FLAG_COLUMNS 0x8
|
||
/* This flag is set if the statement is
|
||
* asking for column metadata */
|
||
#define STATEMENT_FLAG_TYPES 0x10
|
||
/* This flag is set if the statement is
|
||
* asking for data type metadata */
|
||
#define STATEMENT_FLAG_PRIMARYKEYS 0x20
|
||
/* This flag is set if the statement is
|
||
* asking for primary key metadata */
|
||
#define STATEMENT_FLAG_FOREIGNKEYS 0x40
|
||
/* This flag is set if the statement is
|
||
* asking for primary key metadata */
|
||
|
||
/*
|
||
* Structure describing the data types of substituted parameters in
|
||
* a SQL statement.
|
||
*/
|
||
|
||
typedef struct ParamData {
|
||
int flags; /* Flags regarding the parameters - see below */
|
||
SQLSMALLINT dataType; /* Data type */
|
||
SQLULEN precision; /* Size of the expected data */
|
||
SQLSMALLINT scale; /* Digits after decimal point of the
|
||
* expected data */
|
||
SQLSMALLINT nullable; /* Flag == 1 if the parameter is nullable */
|
||
} 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) */
|
||
|
||
/*
|
||
* Structure describing an ODBC result set. The object that the Tcl
|
||
* API terms a "result set" actually has to be represented by an ODBC
|
||
* "statement", since an ODBC statement can have only one set of results
|
||
* at any given time.
|
||
*/
|
||
|
||
typedef struct ResultSetData {
|
||
size_t refCount; /* Reference count */
|
||
StatementData* sdata; /* Statement that generated this result set */
|
||
SQLHSTMT hStmt; /* Handle to the ODBC statement object */
|
||
SQLCHAR** bindStrings; /* Buffers for binding string parameters */
|
||
SQLLEN* bindStringLengths; /* Lengths of the buffers */
|
||
SQLLEN rowCount; /* Number of rows affected by the statement */
|
||
Tcl_Obj* resultColNames; /* Names of the columns in the result set */
|
||
struct ParamData* results; /* Pointer to the description of the
|
||
* result set columns */
|
||
} ResultSetData;
|
||
|
||
#define IncrResultSetRefCount(x) \
|
||
do { \
|
||
++((x)->refCount); \
|
||
} while (0)
|
||
#define DecrResultSetRefCount(x) \
|
||
do { \
|
||
ResultSetData* rs = (x); \
|
||
if (rs->refCount-- <= 1) { \
|
||
DeleteResultSet(rs); \
|
||
} \
|
||
} while(0)
|
||
|
||
/*
|
||
* Structure for looking up a string that maps to an ODBC constant
|
||
*/
|
||
|
||
typedef struct OdbcConstant {
|
||
const char* name; /* Constant name */
|
||
int value; /* Constant value */
|
||
} OdbcConstant;
|
||
|
||
/*
|
||
* Constants for the directions of parameter transmission
|
||
*/
|
||
|
||
static const OdbcConstant OdbcParamDirections[] = {
|
||
{ "in", PARAM_KNOWN | PARAM_IN, },
|
||
{ "out", PARAM_KNOWN | PARAM_OUT },
|
||
{ "inout", PARAM_KNOWN | PARAM_IN | PARAM_OUT },
|
||
{ NULL, 0 }
|
||
};
|
||
|
||
/*
|
||
* ODBC constants for the names of data types
|
||
*/
|
||
|
||
static const OdbcConstant OdbcTypeNames[] = {
|
||
{ "bigint", SQL_BIGINT },
|
||
{ "binary", SQL_BINARY },
|
||
{ "bit", SQL_BIT } ,
|
||
{ "char", SQL_CHAR } ,
|
||
{ "date", SQL_DATE } ,
|
||
{ "decimal", SQL_DECIMAL } ,
|
||
{ "double", SQL_DOUBLE } ,
|
||
{ "float", SQL_FLOAT } ,
|
||
{ "integer", SQL_INTEGER } ,
|
||
{ "longvarbinary", SQL_LONGVARBINARY } ,
|
||
{ "longvarchar", SQL_LONGVARCHAR } ,
|
||
{ "numeric", SQL_NUMERIC } ,
|
||
{ "real", SQL_REAL } ,
|
||
{ "smallint", SQL_SMALLINT } ,
|
||
{ "time", SQL_TIME } ,
|
||
{ "timestamp", SQL_TIMESTAMP } ,
|
||
{ "tinyint", SQL_TINYINT } ,
|
||
{ "varbinary", SQL_VARBINARY } ,
|
||
{ "varchar", SQL_VARCHAR } ,
|
||
{ NULL, -1 }
|
||
};
|
||
|
||
static const OdbcConstant OdbcIsolationLevels[] = {
|
||
{ "readuncommitted", SQL_TXN_READ_UNCOMMITTED },
|
||
{ "readcommitted", SQL_TXN_READ_COMMITTED },
|
||
{ "repeatableread", SQL_TXN_REPEATABLE_READ },
|
||
{ "serializable", SQL_TXN_SERIALIZABLE },
|
||
{ NULL, 0 }
|
||
};
|
||
|
||
static const OdbcConstant OdbcErrorCodeNames[] = {
|
||
{ "GENERAL_ERR", ODBC_ERROR_GENERAL_ERR },
|
||
{ "INVALID_BUFF_LEN", ODBC_ERROR_INVALID_BUFF_LEN },
|
||
{ "INVALID_HWND", ODBC_ERROR_INVALID_HWND },
|
||
{ "INVALID_STR", ODBC_ERROR_INVALID_STR },
|
||
{ "INVALID_REQUEST_TYPE", ODBC_ERROR_INVALID_REQUEST_TYPE },
|
||
{ "COMPONENT_NOT_FOUND", ODBC_ERROR_COMPONENT_NOT_FOUND },
|
||
{ "INVALID_NAME", ODBC_ERROR_INVALID_NAME },
|
||
{ "INVALID_KEYWORD_VALUE", ODBC_ERROR_INVALID_KEYWORD_VALUE },
|
||
{ "INVALID_DSN", ODBC_ERROR_INVALID_DSN },
|
||
{ "INVALID_INF", ODBC_ERROR_INVALID_INF },
|
||
{ "REQUEST_FAILED", ODBC_ERROR_REQUEST_FAILED },
|
||
{ "LOAD_LIB_FAILED", ODBC_ERROR_LOAD_LIB_FAILED },
|
||
{ "INVALID_PARAM_SEQUENCE", ODBC_ERROR_INVALID_PARAM_SEQUENCE },
|
||
{ "INVALID_LOG_FILE", ODBC_ERROR_INVALID_LOG_FILE },
|
||
{ "USER_CANCELED", ODBC_ERROR_USER_CANCELED },
|
||
{ "USAGE_UPDATE_FAILED", ODBC_ERROR_USAGE_UPDATE_FAILED },
|
||
{ "CREATE_DSN_FAILED", ODBC_ERROR_CREATE_DSN_FAILED },
|
||
{ "WRITING_SYSINFO_FAILED", ODBC_ERROR_WRITING_SYSINFO_FAILED },
|
||
{ "REMOVE_DSN_FAILED", ODBC_ERROR_REMOVE_DSN_FAILED },
|
||
{ "OUT_OF_MEM", ODBC_ERROR_OUT_OF_MEM },
|
||
{ "OUTPUT_STRING_TRUNCATED", ODBC_ERROR_OUTPUT_STRING_TRUNCATED },
|
||
{ NULL, 0 }
|
||
};
|
||
|
||
/* Prototypes for static functions appearing in this file */
|
||
|
||
static void DStringAppendWChars(Tcl_DString* ds, SQLWCHAR* ws, size_t len);
|
||
static SQLWCHAR* GetWCharStringFromObj(Tcl_Obj* obj, size_t* lengthPtr);
|
||
|
||
static void TransferSQLError(Tcl_Interp* interp, SQLSMALLINT handleType,
|
||
SQLHANDLE handle, const char* info);
|
||
static int SQLStateIs(SQLSMALLINT handleType, SQLHANDLE handle,
|
||
const char* sqlstate);
|
||
static int LookupOdbcConstant(Tcl_Interp* interp, const OdbcConstant* table,
|
||
const char* kind, Tcl_Obj* name,
|
||
SQLSMALLINT* valuePtr);
|
||
static int LookupOdbcType(Tcl_Interp* interp, Tcl_Obj* name,
|
||
SQLSMALLINT* valuePtr);
|
||
static Tcl_Obj* TranslateOdbcIsolationLevel(SQLINTEGER level,
|
||
Tcl_Obj* literals[]);
|
||
static SQLHENV GetHEnv(Tcl_Interp* interp);
|
||
static void DismissHEnv(void);
|
||
static SQLHSTMT AllocAndPrepareStatement(Tcl_Interp* interp,
|
||
StatementData* sdata);
|
||
static int GetResultSetDescription(Tcl_Interp* interp, ResultSetData* rdata);
|
||
static int ConfigureConnection(Tcl_Interp* interp,
|
||
SQLHDBC hDBC,
|
||
PerInterpData* pidata,
|
||
int objc, Tcl_Obj *const objv[],
|
||
SQLUSMALLINT* connectFlagsPtr,
|
||
HWND* hParentWindowPtr);
|
||
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 ConnectionConfigureMethod(ClientData clientData,
|
||
Tcl_Interp* interp,
|
||
Tcl_ObjectContext context,
|
||
int objc, Tcl_Obj *const objv[]);
|
||
static int ConnectionEndXcnMethod(ClientData clientData,
|
||
Tcl_Interp* interp,
|
||
Tcl_ObjectContext context,
|
||
int objc, Tcl_Obj *const objv[]);
|
||
static int ConnectionHasBigintMethod(ClientData clientData,
|
||
Tcl_Interp* interp,
|
||
Tcl_ObjectContext context,
|
||
int objc, Tcl_Obj *const objv[]);
|
||
static int ConnectionHasWvarcharMethod(ClientData clientData,
|
||
Tcl_Interp* interp,
|
||
Tcl_ObjectContext context,
|
||
int objc, Tcl_Obj *const objv[]);
|
||
static int SetAutocommitFlag(Tcl_Interp* interp, ConnectionData* cdata,
|
||
SQLINTEGER flag);
|
||
static void DeleteCmd(ClientData clientData);
|
||
static int CloneCmd(Tcl_Interp* interp,
|
||
ClientData oldMetadata, ClientData* newMetadata);
|
||
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,
|
||
Tcl_Object connectionObject);
|
||
static int StatementConstructor(ClientData clientData, Tcl_Interp* interp,
|
||
Tcl_ObjectContext context,
|
||
int objc, Tcl_Obj *const objv[]);
|
||
static int StatementConnectionMethod(ClientData clientData, Tcl_Interp* interp,
|
||
Tcl_ObjectContext context,
|
||
int objc, Tcl_Obj *const objv[]);
|
||
static int StatementParamListMethod(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 TablesStatementConstructor(ClientData clientData, Tcl_Interp* interp,
|
||
Tcl_ObjectContext context,
|
||
int objc, Tcl_Obj *const objv[]);
|
||
static int ColumnsStatementConstructor(ClientData clientData,
|
||
Tcl_Interp* interp,
|
||
Tcl_ObjectContext context,
|
||
int objc, Tcl_Obj *const objv[]);
|
||
static int PrimarykeysStatementConstructor(ClientData clientData,
|
||
Tcl_Interp* interp,
|
||
Tcl_ObjectContext context,
|
||
int objc, Tcl_Obj *const objv[]);
|
||
static int ForeignkeysStatementConstructor(ClientData clientData,
|
||
Tcl_Interp* interp,
|
||
Tcl_ObjectContext context,
|
||
int objc, Tcl_Obj *const objv[]);
|
||
static int TypesStatementConstructor(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 ResultSetNextresultsMethod(ClientData clientData, Tcl_Interp* interp,
|
||
Tcl_ObjectContext context,
|
||
int objc, Tcl_Obj *const objv[]);
|
||
static int GetCell(ResultSetData* rdata, Tcl_Interp* interp,
|
||
int columnIndex, Tcl_Obj** retval);
|
||
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 void DeleteResultSetDescription(ResultSetData* rdata);
|
||
static int CloneResultSet(Tcl_Interp* interp, ClientData oldClientData,
|
||
ClientData* newClientData);
|
||
static void FreeBoundParameters(ResultSetData* rdata);
|
||
static void DeletePerInterpData(PerInterpData* pidata);
|
||
static int DatasourcesObjCmd(ClientData clientData, Tcl_Interp* interp,
|
||
int objc, Tcl_Obj *const objv[]);
|
||
static int DriversObjCmd(ClientData clientData, Tcl_Interp* interp,
|
||
int objc, Tcl_Obj *const objv[]);
|
||
|
||
/* Metadata type that holds connection data */
|
||
|
||
static const 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 */
|
||
|
||
static const 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 */
|
||
|
||
static const 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 */
|
||
|
||
static const Tcl_MethodType ConnectionConstructorType = {
|
||
TCL_OO_METHOD_VERSION_CURRENT,
|
||
/* version */
|
||
"CONSTRUCTOR", /* name */
|
||
ConnectionConstructor, /* callProc */
|
||
DeleteCmd, /* deleteProc */
|
||
CloneCmd /* cloneProc */
|
||
};
|
||
static const Tcl_MethodType ConnectionBeginTransactionMethodType = {
|
||
TCL_OO_METHOD_VERSION_CURRENT,
|
||
/* version */
|
||
"begintransaction", /* name */
|
||
ConnectionBeginTransactionMethod,
|
||
/* callProc */
|
||
NULL, /* deleteProc */
|
||
CloneCmd /* cloneProc */
|
||
};
|
||
static const Tcl_MethodType ConnectionConfigureMethodType = {
|
||
TCL_OO_METHOD_VERSION_CURRENT,
|
||
/* version */
|
||
"configure", /* name */
|
||
ConnectionConfigureMethod, /* callProc */
|
||
NULL, /* deleteProc */
|
||
CloneCmd /* cloneProc */
|
||
};
|
||
static const Tcl_MethodType ConnectionEndXcnMethodType = {
|
||
TCL_OO_METHOD_VERSION_CURRENT,
|
||
/* version */
|
||
"endtransaction", /* name */
|
||
ConnectionEndXcnMethod, /* callProc */
|
||
NULL, /* deleteProc */
|
||
CloneCmd /* cloneProc */
|
||
};
|
||
static const Tcl_MethodType ConnectionHasBigintMethodType = {
|
||
TCL_OO_METHOD_VERSION_CURRENT,
|
||
/* version */
|
||
"HasBigint", /* name */
|
||
ConnectionHasBigintMethod,
|
||
/* callProc */
|
||
NULL, /* deleteProc */
|
||
CloneCmd /* cloneProc */
|
||
};
|
||
static const Tcl_MethodType ConnectionHasWvarcharMethodType = {
|
||
TCL_OO_METHOD_VERSION_CURRENT,
|
||
/* version */
|
||
"HasWvarchar", /* name */
|
||
ConnectionHasWvarcharMethod,
|
||
/* callProc */
|
||
NULL, /* deleteProc */
|
||
CloneCmd /* cloneProc */
|
||
};
|
||
|
||
/*
|
||
* Methods to create on the connection class. Note that 'init', 'commit' and
|
||
* 'rollback' are all special because they have non-NULL clientData.
|
||
*/
|
||
|
||
static const Tcl_MethodType* ConnectionMethods[] = {
|
||
&ConnectionBeginTransactionMethodType,
|
||
&ConnectionConfigureMethodType,
|
||
&ConnectionHasBigintMethodType,
|
||
&ConnectionHasWvarcharMethodType,
|
||
NULL
|
||
};
|
||
|
||
/* Method types of the statement methods that are implemented in C */
|
||
|
||
static const Tcl_MethodType StatementConstructorType = {
|
||
TCL_OO_METHOD_VERSION_CURRENT,
|
||
/* version */
|
||
"CONSTRUCTOR", /* name */
|
||
StatementConstructor, /* callProc */
|
||
NULL, /* deleteProc */
|
||
NULL /* cloneProc */
|
||
};
|
||
static const Tcl_MethodType StatementConnectionMethodType = {
|
||
TCL_OO_METHOD_VERSION_CURRENT,
|
||
/* version */
|
||
"connection", /* name */
|
||
StatementConnectionMethod, /* callProc */
|
||
NULL, /* deleteProc */
|
||
NULL /* cloneProc */
|
||
};
|
||
static const Tcl_MethodType StatementParamListMethodType = {
|
||
TCL_OO_METHOD_VERSION_CURRENT,
|
||
/* version */
|
||
"ParamList", /* name */
|
||
StatementParamListMethod, /* callProc */
|
||
NULL, /* deleteProc */
|
||
NULL /* cloneProc */
|
||
};
|
||
static const Tcl_MethodType StatementParamtypeMethodType = {
|
||
TCL_OO_METHOD_VERSION_CURRENT,
|
||
/* version */
|
||
"paramtype", /* name */
|
||
StatementParamtypeMethod, /* callProc */
|
||
NULL, /* deleteProc */
|
||
NULL /* cloneProc */
|
||
};
|
||
|
||
/*
|
||
* Methods to create on the statement class.
|
||
*/
|
||
|
||
static const Tcl_MethodType* StatementMethods[] = {
|
||
&StatementConnectionMethodType,
|
||
&StatementParamListMethodType,
|
||
&StatementParamtypeMethodType,
|
||
NULL
|
||
};
|
||
|
||
/*
|
||
* Constructor type for the class that implements the fake 'statement'
|
||
* used to query the names and attributes of database tables.
|
||
*/
|
||
|
||
static const Tcl_MethodType TablesStatementConstructorType = {
|
||
TCL_OO_METHOD_VERSION_CURRENT,
|
||
/* version */
|
||
"CONSTRUCTOR", /* name */
|
||
TablesStatementConstructor, /* callProc */
|
||
NULL, /* deleteProc */
|
||
NULL /* cloneProc */
|
||
};
|
||
|
||
/*
|
||
* Method types for the class that implements the fake 'statement'
|
||
* used to query the names and attributes of database columns.
|
||
*/
|
||
|
||
static const Tcl_MethodType ColumnsStatementConstructorType = {
|
||
TCL_OO_METHOD_VERSION_CURRENT,
|
||
/* version */
|
||
"CONSTRUCTOR", /* name */
|
||
ColumnsStatementConstructor,
|
||
/* callProc */
|
||
NULL, /* deleteProc */
|
||
NULL /* cloneProc */
|
||
};
|
||
|
||
/*
|
||
* Method types for the class that implements the fake 'statement'
|
||
* used to query the names and attributes of primary keys.
|
||
*/
|
||
|
||
static const Tcl_MethodType PrimarykeysStatementConstructorType = {
|
||
TCL_OO_METHOD_VERSION_CURRENT,
|
||
/* version */
|
||
"CONSTRUCTOR", /* name */
|
||
PrimarykeysStatementConstructor,
|
||
/* callProc */
|
||
NULL, /* deleteProc */
|
||
NULL /* cloneProc */
|
||
};
|
||
|
||
/*
|
||
* Method types for the class that implements the fake 'statement'
|
||
* used to query the names and attributes of foreign keys.
|
||
*/
|
||
|
||
static const Tcl_MethodType ForeignkeysStatementConstructorType = {
|
||
TCL_OO_METHOD_VERSION_CURRENT,
|
||
/* version */
|
||
"CONSTRUCTOR", /* name */
|
||
ForeignkeysStatementConstructor,
|
||
/* callProc */
|
||
NULL, /* deleteProc */
|
||
NULL /* cloneProc */
|
||
};
|
||
|
||
/*
|
||
* Constructor type for the class that implements the fake 'statement'
|
||
* used to query the names and attributes of database types.
|
||
*/
|
||
|
||
static const Tcl_MethodType TypesStatementConstructorType = {
|
||
TCL_OO_METHOD_VERSION_CURRENT,
|
||
/* version */
|
||
"CONSTRUCTOR", /* name */
|
||
&TypesStatementConstructor, /* callProc */
|
||
NULL, /* deleteProc */
|
||
NULL /* cloneProc */
|
||
};
|
||
|
||
/* Method types of the result set methods that are implemented in C */
|
||
|
||
static const Tcl_MethodType ResultSetConstructorType = {
|
||
TCL_OO_METHOD_VERSION_CURRENT,
|
||
/* version */
|
||
"CONSTRUCTOR", /* name */
|
||
ResultSetConstructor, /* callProc */
|
||
NULL, /* deleteProc */
|
||
NULL /* cloneProc */
|
||
};
|
||
static const Tcl_MethodType ResultSetColumnsMethodType = {
|
||
TCL_OO_METHOD_VERSION_CURRENT,
|
||
/* version */ "columns", /* name */
|
||
ResultSetColumnsMethod, /* callProc */
|
||
NULL, /* deleteProc */
|
||
NULL /* cloneProc */
|
||
};
|
||
static const Tcl_MethodType ResultSetNextresultsMethodType = {
|
||
TCL_OO_METHOD_VERSION_CURRENT,
|
||
/* version */
|
||
"nextresults", /* name */
|
||
ResultSetNextresultsMethod, /* callProc */
|
||
NULL, /* deleteProc */
|
||
NULL /* cloneProc */
|
||
};
|
||
static const Tcl_MethodType ResultSetNextrowMethodType = {
|
||
TCL_OO_METHOD_VERSION_CURRENT,
|
||
/* version */
|
||
"nextrow", /* name */
|
||
ResultSetNextrowMethod, /* callProc */
|
||
NULL, /* deleteProc */
|
||
NULL /* cloneProc */
|
||
};
|
||
static const Tcl_MethodType ResultSetRowcountMethodType = {
|
||
TCL_OO_METHOD_VERSION_CURRENT,
|
||
/* version */
|
||
"rowcount", /* name */
|
||
ResultSetRowcountMethod, /* callProc */
|
||
NULL, /* deleteProc */
|
||
NULL /* cloneProc */
|
||
};
|
||
|
||
|
||
static const Tcl_MethodType* ResultSetMethods[] = {
|
||
&ResultSetColumnsMethodType,
|
||
&ResultSetNextresultsMethodType,
|
||
&ResultSetRowcountMethodType,
|
||
NULL
|
||
};
|
||
|
||
/*
|
||
*-----------------------------------------------------------------------------
|
||
*
|
||
* DStringAppendWChars --
|
||
*
|
||
* Converts a wide-character string returned from ODBC into UTF-8
|
||
* and appends the result to a Tcl_DString.
|
||
*
|
||
* Results:
|
||
* None.
|
||
*
|
||
* Side effects:
|
||
* Appends the given SQLWCHAR string to the given Tcl_DString, which
|
||
* must have been previously initialized.
|
||
*
|
||
*-----------------------------------------------------------------------------
|
||
*/
|
||
|
||
static void
|
||
DStringAppendWChars(
|
||
Tcl_DString* ds, /* Output string */
|
||
SQLWCHAR* ws, /* Input string */
|
||
size_t len /* Length of the input string in characters */
|
||
) {
|
||
size_t i;
|
||
char buf[4] = "";
|
||
|
||
if (sizeofSQLWCHAR == sizeof(unsigned short)) {
|
||
unsigned short* ptr16 = (unsigned short*) ws;
|
||
|
||
for (i = 0; i < len; ++i) {
|
||
unsigned int ch;
|
||
size_t bytes;
|
||
|
||
ch = ptr16[i];
|
||
bytes = Tcl_UniCharToUtf(ch, buf);
|
||
Tcl_DStringAppend(ds, buf, bytes);
|
||
}
|
||
} else {
|
||
unsigned int* ptr32 = (unsigned int*) ws;
|
||
|
||
for (i = 0; i < len; ++i) {
|
||
unsigned int ch;
|
||
size_t bytes;
|
||
|
||
ch = ptr32[i];
|
||
if (ch > 0x10ffff) {
|
||
ch = 0xfffd;
|
||
}
|
||
bytes = Tcl_UniCharToUtf(ch, buf);
|
||
Tcl_DStringAppend(ds, buf, bytes);
|
||
}
|
||
}
|
||
}
|
||
|
||
/*
|
||
*-----------------------------------------------------------------------------
|
||
*
|
||
* GetWCharStringFromObj --
|
||
*
|
||
* Get a string of SQLWCHAR from the string value of a Tcl object.
|
||
*
|
||
* Results:
|
||
* Returns a pointer to the string, which the caller is responsible
|
||
* for freeing.
|
||
*
|
||
* Side effects:
|
||
* Stores the length of the string in '*lengthPtr' if 'lengthPtr'
|
||
* is not NULL
|
||
*
|
||
*-----------------------------------------------------------------------------
|
||
*/
|
||
|
||
static SQLWCHAR*
|
||
GetWCharStringFromObj(
|
||
Tcl_Obj* obj, /* Tcl object whose string rep is desired */
|
||
size_t* lengthPtr /* Length of the string */
|
||
) {
|
||
char* bytes = Tcl_GetString(obj);
|
||
/* UTF-8 representation of the input string */
|
||
size_t len = obj->length; /* Length of the input string in bytes */
|
||
char* end = bytes + len; /* End of UTF-8 representation */
|
||
SQLWCHAR* retval; /* Buffer to hold the converted string */
|
||
SQLWCHAR* wcPtr;
|
||
int shrink = 0;
|
||
Tcl_UniChar ch = 0;
|
||
|
||
len = (len + 1) * sizeofSQLWCHAR;
|
||
if (sizeofSQLWCHAR < sizeof(Tcl_UniChar)) {
|
||
len *= 2; /* doubled space for surrogates */
|
||
shrink = 1;
|
||
}
|
||
retval = wcPtr = (SQLWCHAR*) ckalloc(len);
|
||
|
||
if (sizeofSQLWCHAR == sizeof(unsigned short)) {
|
||
unsigned short *ptr16 = (unsigned short*) wcPtr;
|
||
|
||
while (bytes < end) {
|
||
unsigned int uch;
|
||
|
||
if (Tcl_UtfCharComplete(bytes, end - bytes)) {
|
||
bytes += Tcl_UtfToUniChar(bytes, &ch);
|
||
} else {
|
||
ch = *bytes++ & 0x00ff;
|
||
}
|
||
uch = ch;
|
||
if ((sizeof(Tcl_UniChar) > 2) && (uch > 0xffff)) {
|
||
*ptr16++ = (((uch - 0x10000) >> 10) & 0x3ff) | 0xd800;
|
||
uch = ((uch - 0x10000) & 0x3ff) | 0xdc00;
|
||
}
|
||
if (uch > 0x7f) {
|
||
shrink = 1;
|
||
}
|
||
*ptr16++ = uch;
|
||
}
|
||
*ptr16 = 0;
|
||
len = ptr16 - (unsigned short*) retval;
|
||
wcPtr = (SQLWCHAR*) ptr16;
|
||
} else {
|
||
unsigned int *ptr32 = (unsigned int*) wcPtr;
|
||
|
||
while (bytes < end) {
|
||
unsigned int uch;
|
||
|
||
if (Tcl_UtfCharComplete(bytes, end - bytes)) {
|
||
bytes += Tcl_UtfToUniChar(bytes, &ch);
|
||
} else {
|
||
ch = *bytes++ & 0x00ff;
|
||
}
|
||
uch = ch;
|
||
if ((sizeof(Tcl_UniChar) == 2) && ((uch & 0xfc00) == 0xd800)) {
|
||
if (Tcl_UtfCharComplete(bytes, end - bytes)) {
|
||
len = Tcl_UtfToUniChar(bytes, &ch);
|
||
if ((ch & 0xfc00) == 0xdc00) {
|
||
bytes += len;
|
||
uch = (((uch & 0x3ff) << 10) | (ch & 0x3ff)) + 0x10000;
|
||
}
|
||
}
|
||
}
|
||
if (uch > 0x7f) {
|
||
shrink = 1;
|
||
}
|
||
*ptr32++ = uch;
|
||
}
|
||
*ptr32 = 0;
|
||
len = ptr32 - (unsigned int*) retval;
|
||
wcPtr = (SQLWCHAR*) ptr32;
|
||
}
|
||
|
||
if (shrink) {
|
||
/* Shrink buffer to fit result */
|
||
wcPtr = (SQLWCHAR*) ckrealloc(retval, (len + 1) * sizeofSQLWCHAR);
|
||
if (wcPtr != NULL) {
|
||
retval = wcPtr;
|
||
}
|
||
}
|
||
if (lengthPtr != NULL) {
|
||
*lengthPtr = len;
|
||
}
|
||
return retval;
|
||
}
|
||
|
||
/*
|
||
*-----------------------------------------------------------------------------
|
||
*
|
||
* TransferSQLError --
|
||
*
|
||
* Transfers an error message and associated error code from ODBC
|
||
* to Tcl.
|
||
*
|
||
* Results:
|
||
* None.
|
||
*
|
||
* Side effects:
|
||
* The interpreter's result is set to a formatted error message, and
|
||
* the error code is set to a three-element list: TDBC ODBC xxxxx,
|
||
* where xxxxx is the SQL state code.
|
||
*
|
||
*-----------------------------------------------------------------------------
|
||
*/
|
||
|
||
static void
|
||
TransferSQLError(
|
||
Tcl_Interp* interp, /* Tcl interpreter */
|
||
SQLSMALLINT handleType, /* Type of the handle for which the error
|
||
* has been reported. */
|
||
SQLHANDLE handle, /* Handle that reported the error */
|
||
const char* info /* Additional information to report */
|
||
) {
|
||
SQLWCHAR state[6*2]; /* SQL state code */
|
||
SQLINTEGER nativeError; /* Native error code */
|
||
SQLSMALLINT msgLen; /* Length of the error message */
|
||
SQLWCHAR msg[(SQL_MAX_MESSAGE_LENGTH+1)*2];
|
||
/* Buffer to hold the error message */
|
||
SQLSMALLINT i; /* Loop index for going through diagnostics */
|
||
const char* sep = ""; /* Separator string for messages */
|
||
const char* sqlstate; /* SQL state */
|
||
Tcl_Obj* resultObj; /* Result string containing error message */
|
||
Tcl_Obj* codeObj; /* Error code object */
|
||
Tcl_Obj* lineObj; /* Object holding one diagnostic */
|
||
Tcl_DString bufferDS; /* Buffer for transferring messages */
|
||
SQLRETURN rc; /* SQL result */
|
||
|
||
resultObj = Tcl_NewObj();
|
||
codeObj = Tcl_NewStringObj("TDBC", -1);
|
||
|
||
/* Loop through the diagnostics */
|
||
|
||
i = 1;
|
||
while (1) {
|
||
msg[0] = msg[1] = 0;
|
||
msgLen = 0;
|
||
state[0] = state[1] = 0;
|
||
rc = SQLGetDiagRecW(handleType, handle, i, state, &nativeError,
|
||
msg, SQL_MAX_MESSAGE_LENGTH, &msgLen);
|
||
if (!SQL_SUCCEEDED(rc) || rc == SQL_NO_DATA) {
|
||
break;
|
||
}
|
||
|
||
/* Add the diagnostic to ::errorCode */
|
||
|
||
Tcl_DStringInit(&bufferDS);
|
||
DStringAppendWChars(&bufferDS, state, 5);
|
||
sqlstate = Tcl_DStringValue(&bufferDS);
|
||
lineObj = Tcl_NewStringObj(sqlstate, Tcl_DStringLength(&bufferDS));
|
||
if (i == 1) {
|
||
Tcl_Obj* stateObj = Tcl_NewStringObj(Tdbc_MapSqlState(sqlstate),
|
||
-1);
|
||
Tcl_ListObjAppendElement(NULL, codeObj, stateObj);
|
||
}
|
||
Tcl_DStringFree(&bufferDS);
|
||
Tcl_ListObjAppendElement(NULL, codeObj, lineObj);
|
||
if (i == 1) {
|
||
Tcl_ListObjAppendElement(NULL, codeObj,
|
||
Tcl_NewStringObj("ODBC", -1));
|
||
}
|
||
Tcl_ListObjAppendElement(NULL, codeObj, Tcl_NewWideIntObj(nativeError));
|
||
|
||
/* Add the error message to the return value */
|
||
|
||
Tcl_DStringInit(&bufferDS);
|
||
DStringAppendWChars(&bufferDS, msg, msgLen);
|
||
Tcl_AppendToObj(resultObj, sep, -1);
|
||
Tcl_AppendToObj(resultObj, Tcl_DStringValue(&bufferDS),
|
||
Tcl_DStringLength(&bufferDS));
|
||
Tcl_DStringFree(&bufferDS);
|
||
sep = "\n";
|
||
++i;
|
||
}
|
||
if (info != NULL) {
|
||
Tcl_AppendToObj(resultObj, "\n", -1);
|
||
Tcl_AppendToObj(resultObj, info, -1);
|
||
}
|
||
|
||
/* Stash the information into the interpreter */
|
||
|
||
Tcl_SetObjResult(interp, resultObj);
|
||
Tcl_SetObjErrorCode(interp, codeObj);
|
||
}
|
||
|
||
/*
|
||
*-----------------------------------------------------------------------------
|
||
*
|
||
* SQLStateIs --
|
||
*
|
||
* Determines whther SQLSTATE in the set of diagnostic records
|
||
* contains a particular state.
|
||
*
|
||
* Results:
|
||
* Returns 1 if the state matches, and 0 otherwise.
|
||
*
|
||
* This function is used primarily to look for the state "HYC00"
|
||
* (Optional Function Not Implemented), but may also be used for
|
||
* other states such as "HYT00" (Timeout Expired), "HY008"
|
||
* (Operation Cancelled), "01004" (Data Truncated) and "01S02"
|
||
* (Option Value Changed).
|
||
*
|
||
*-----------------------------------------------------------------------------
|
||
*/
|
||
|
||
static int
|
||
SQLStateIs(
|
||
SQLSMALLINT handleType, /* Type of handle reporting the state */
|
||
SQLHANDLE handle, /* Handle that reported the state */
|
||
const char* sqlstate /* State to look for */
|
||
) {
|
||
SQLCHAR state[6]; /* SQL state code from the diagnostic record */
|
||
SQLSMALLINT stateLen; /* String length of the state code */
|
||
SQLSMALLINT i; /* Loop index */
|
||
SQLRETURN rc; /* SQL result */
|
||
|
||
i = 1;
|
||
while (1) {
|
||
state[0] = 0;
|
||
stateLen = 0,
|
||
rc = SQLGetDiagFieldA(handleType, handle, i, SQL_DIAG_SQLSTATE,
|
||
(SQLPOINTER) state, sizeof(state), &stateLen);
|
||
if (!SQL_SUCCEEDED(rc) || rc == SQL_NO_DATA) {
|
||
break;
|
||
}
|
||
if (stateLen >= 0 && !strcmp(sqlstate, (const char*) state)) {
|
||
return 1;
|
||
}
|
||
}
|
||
return 0;
|
||
}
|
||
|
||
/*
|
||
*-----------------------------------------------------------------------------
|
||
*
|
||
* LookupOdbcConstant --
|
||
*
|
||
* Looks up an ODBC enumerated constant in a table.
|
||
*
|
||
* Results:
|
||
* Returns a standard Tcl result, with an error message stored in
|
||
* the result of the provided Tcl_Interp if it is not NULL.
|
||
*
|
||
* Side effects:
|
||
* If successful, stores the enumerated value in '*valuePtr'
|
||
*
|
||
* Notes:
|
||
* The 'table' argument must be constant and statically allocated.
|
||
*
|
||
*-----------------------------------------------------------------------------
|
||
*/
|
||
|
||
static int
|
||
LookupOdbcConstant(
|
||
Tcl_Interp* interp, /* Tcl interpreter */
|
||
const OdbcConstant* table, /* Table giving the enumerations */
|
||
const char* kind, /* String descibing the kind of enumerated
|
||
* object being looked up */
|
||
Tcl_Obj* name, /* Name being looked up */
|
||
SQLSMALLINT* valuePtr /* Pointer to the returned value */
|
||
) {
|
||
int index;
|
||
if (Tcl_GetIndexFromObjStruct(interp, name, (void*)table,
|
||
sizeof(OdbcConstant), kind, TCL_EXACT,
|
||
&index) != TCL_OK) {
|
||
return TCL_ERROR;
|
||
}
|
||
*valuePtr = (SQLSMALLINT) table[index].value;
|
||
return TCL_OK;
|
||
}
|
||
|
||
static inline int LookupOdbcType(
|
||
Tcl_Interp* interp,
|
||
Tcl_Obj* name,
|
||
SQLSMALLINT* valuePtr
|
||
) {
|
||
return LookupOdbcConstant(interp, OdbcTypeNames, "SQL data type",
|
||
name, valuePtr);
|
||
}
|
||
|
||
/*
|
||
*-----------------------------------------------------------------------------
|
||
*
|
||
* TranslateOdbcIsolationLevel --
|
||
*
|
||
* Translates an ODBC isolation level into human-readable form.
|
||
*
|
||
* Results:
|
||
* Returns a Tcl_Obj with the human-readable level.
|
||
*
|
||
*-----------------------------------------------------------------------------
|
||
*/
|
||
|
||
static Tcl_Obj*
|
||
TranslateOdbcIsolationLevel(
|
||
SQLINTEGER level, /* Isolation level */
|
||
Tcl_Obj* literals[] /* Pointer to the literal pool */
|
||
) {
|
||
if (level & SQL_TXN_SERIALIZABLE) {
|
||
return literals[LIT_SERIALIZABLE];
|
||
}
|
||
if (level & SQL_TXN_REPEATABLE_READ) {
|
||
return literals[LIT_REPEATABLEREAD];
|
||
}
|
||
if (level & SQL_TXN_READ_COMMITTED) {
|
||
return literals[LIT_READCOMMITTED];
|
||
}
|
||
return literals[LIT_READUNCOMMITTED];
|
||
}
|
||
|
||
/*
|
||
*-----------------------------------------------------------------------------
|
||
*
|
||
* GetHEnv --
|
||
*
|
||
* Retrieves the global environment handle for ODBC.
|
||
*
|
||
* Results:
|
||
* Returns the global environment handle. If the allocation of the
|
||
* global enviroment fails, returns SQL_NULL_ENV. If 'interp' is
|
||
* not NULL, stores an error message in the interpreter.
|
||
*
|
||
* Maintains a reference count so that the handle is closed when the
|
||
* last use of ODBC in the process goes away.
|
||
*
|
||
*-----------------------------------------------------------------------------
|
||
*/
|
||
|
||
static SQLHENV
|
||
GetHEnv(
|
||
Tcl_Interp* interp /* Interpreter for error reporting, or NULL */
|
||
) {
|
||
RETCODE rc; /* Return from ODBC calls */
|
||
Tcl_MutexLock(&hEnvMutex);
|
||
if (hEnvRefCount == 0) {
|
||
/*
|
||
* This is the first reference to ODBC in this process.
|
||
* Load the ODBC client library.
|
||
*/
|
||
if ((odbcLoadHandle = OdbcInitStubs(interp, &odbcInstLoadHandle))
|
||
== NULL) {
|
||
Tcl_MutexUnlock(&hEnvMutex);
|
||
return SQL_NULL_HENV;
|
||
}
|
||
/*
|
||
* Allocate the ODBC environment
|
||
*/
|
||
rc = SQLAllocHandle(SQL_HANDLE_ENV, SQL_NULL_HANDLE, &hEnv);
|
||
if (SQL_SUCCEEDED(rc)) {
|
||
rc = SQLSetEnvAttr(hEnv, SQL_ATTR_ODBC_VERSION,
|
||
(SQLPOINTER) SQL_OV_ODBC3, 0);
|
||
}
|
||
if (!SQL_SUCCEEDED(rc)) {
|
||
/*
|
||
* The call failed. Report the error.
|
||
*/
|
||
if (hEnv != SQL_NULL_HENV) {
|
||
if (interp != NULL) {
|
||
TransferSQLError(interp, SQL_HANDLE_ENV, hEnv,
|
||
"(allocating environment handle)");
|
||
}
|
||
SQLFreeHandle(SQL_HANDLE_ENV, hEnv);
|
||
hEnv = SQL_NULL_HENV;
|
||
} else {
|
||
Tcl_SetObjResult(interp,
|
||
Tcl_NewStringObj("Could not allocate the "
|
||
"ODBC SQL environment.", -1));
|
||
Tcl_SetErrorCode(interp, "TDBC", "GENERAL_ERROR",
|
||
"HY001", "ODBC", "-1", NULL);
|
||
}
|
||
} else {
|
||
/*
|
||
* Detect real size of SQLWCHAR used by the driver manager.
|
||
*/
|
||
SQLHDBC hDBC = SQL_NULL_HDBC;
|
||
|
||
sizeofSQLWCHAR = sizeof(SQLWCHAR); /* fallback */
|
||
rc = SQLAllocHandle(SQL_HANDLE_DBC, hEnv, &hDBC);
|
||
if (SQL_SUCCEEDED(rc)) {
|
||
SQLSMALLINT infoLen;
|
||
int i;
|
||
char info[64];
|
||
|
||
rc = SQLGetInfoW(hDBC, SQL_ODBC_VER, (SQLPOINTER) info,
|
||
sizeof(info), &infoLen);
|
||
if (SQL_SUCCEEDED(rc) && infoLen >= 8) {
|
||
static const char BE32sig[] = {
|
||
'\0', '\0', '\0', '#', '\0', '\0', '\0', '#'
|
||
};
|
||
static const char LE32sig[] = {
|
||
'#', '\0', '\0', '\0', '#', '\0', '\0', '\0'
|
||
};
|
||
static const char BE16sig[] = {
|
||
'\0', '#', '\0', '#'
|
||
};
|
||
static const char LE16sig[] = {
|
||
'#', '\0', '#', '\0'
|
||
};
|
||
|
||
if ((size_t)infoLen > sizeof(info)) {
|
||
infoLen = sizeof(info);
|
||
}
|
||
for (i = 0; i < infoLen; i++) {
|
||
if (info[i] >= '0' && info[i] <= '9') {
|
||
info[i] = '#';
|
||
}
|
||
}
|
||
if (memcmp(info, BE32sig, sizeof(BE32sig)) == 0 ||
|
||
memcmp(info, LE32sig, sizeof(LE32sig)) == 0) {
|
||
sizeofSQLWCHAR = 4;
|
||
} else if (memcmp(info, BE16sig, sizeof(BE16sig)) == 0 ||
|
||
memcmp(info, LE16sig, sizeof(LE16sig)) == 0) {
|
||
sizeofSQLWCHAR = 2;
|
||
}
|
||
}
|
||
SQLFreeHandle(SQL_HANDLE_DBC, hDBC);
|
||
}
|
||
}
|
||
}
|
||
/*
|
||
* On subsequent calls, simply adjust the refcount
|
||
*/
|
||
if (hEnv != SQL_NULL_HENV) {
|
||
++hEnvRefCount;
|
||
}
|
||
Tcl_MutexUnlock(&hEnvMutex);
|
||
return hEnv;
|
||
}
|
||
|
||
/*
|
||
*-----------------------------------------------------------------------------
|
||
*
|
||
* DismissHEnv --
|
||
*
|
||
* Notifies that the SQLHENV returned from GetHEnv is no longer
|
||
* in use.
|
||
*
|
||
* Side effects:
|
||
* Decreases the refcount of the handle, and returns it if all
|
||
* extant refs have gone away.
|
||
*
|
||
*-----------------------------------------------------------------------------
|
||
*/
|
||
|
||
static void
|
||
DismissHEnv(void)
|
||
{
|
||
Tcl_MutexLock(&hEnvMutex);
|
||
if (hEnvRefCount-- <= 1) {
|
||
SQLFreeHandle(SQL_HANDLE_ENV, hEnv);
|
||
hEnv = SQL_NULL_HANDLE;
|
||
if (odbcInstLoadHandle != NULL) {
|
||
Tcl_FSUnloadFile(NULL, odbcInstLoadHandle);
|
||
odbcInstLoadHandle = NULL;
|
||
}
|
||
Tcl_FSUnloadFile(NULL, odbcLoadHandle);
|
||
odbcLoadHandle = NULL;
|
||
}
|
||
Tcl_MutexUnlock(&hEnvMutex);
|
||
}
|
||
|
||
/*
|
||
*-----------------------------------------------------------------------------
|
||
*
|
||
* AllocAndPrepareStatement --
|
||
*
|
||
* Allocates an ODBC statement handle, and prepares SQL code in it.
|
||
*
|
||
* Results:
|
||
* Returns the handle, or SQL_NULL_HSTMT if an error occurs.
|
||
*
|
||
*-----------------------------------------------------------------------------
|
||
*/
|
||
|
||
static SQLHSTMT
|
||
AllocAndPrepareStatement(
|
||
Tcl_Interp* interp, /* Tcl interpreter for error reporting */
|
||
StatementData* sdata /* Data describing the statement */
|
||
) {
|
||
SQLRETURN rc;
|
||
SQLHSTMT hStmt;
|
||
ConnectionData* cdata = sdata->cdata;
|
||
if (sdata->flags & (STATEMENT_FLAG_TABLES
|
||
| STATEMENT_FLAG_COLUMNS
|
||
| STATEMENT_FLAG_PRIMARYKEYS
|
||
| STATEMENT_FLAG_FOREIGNKEYS
|
||
| STATEMENT_FLAG_TYPES)) {
|
||
Tcl_SetObjResult(interp, Tcl_NewStringObj("cannot have multiple result "
|
||
"sets in this context", -1));
|
||
return SQL_NULL_HSTMT;
|
||
}
|
||
rc = SQLAllocHandle(SQL_HANDLE_STMT, cdata->hDBC, &hStmt);
|
||
if (!SQL_SUCCEEDED(rc)) {
|
||
TransferSQLError(interp, SQL_HANDLE_DBC, cdata->hDBC,
|
||
"(allocating statement handle)");
|
||
return SQL_NULL_HSTMT;
|
||
}
|
||
rc = SQLPrepareW(hStmt, sdata->nativeSqlW, sdata->nativeSqlLen);
|
||
if (!SQL_SUCCEEDED(rc)) {
|
||
TransferSQLError(interp, SQL_HANDLE_STMT, hStmt,
|
||
"(preparing statement)");
|
||
SQLFreeHandle(SQL_HANDLE_STMT, hStmt);
|
||
return SQL_NULL_HSTMT;
|
||
}
|
||
return hStmt;
|
||
}
|
||
|
||
/*
|
||
*-----------------------------------------------------------------------------
|
||
*
|
||
* GetResultSetDescription --
|
||
*
|
||
* Describes the result set of an ODBC statement
|
||
*
|
||
* Results:
|
||
* Returns a standard Tcl result and stores an error message in the
|
||
* interpreter result if a failure occurs.
|
||
*
|
||
* Side effects:
|
||
* Stores column names and type information in 'sdata' and
|
||
* updates the flags to indicate that the data are present.
|
||
*
|
||
*-----------------------------------------------------------------------------
|
||
*/
|
||
|
||
static int
|
||
GetResultSetDescription(
|
||
Tcl_Interp* interp, /* Tcl interpreter */
|
||
ResultSetData* rdata /* Result set data object */
|
||
) {
|
||
SQLHSTMT hStmt = rdata->hStmt;
|
||
/* Statement handle */
|
||
SQLRETURN rc; /* Return code from ODBC operations */
|
||
Tcl_Obj* colNames; /* List of the column names */
|
||
SQLSMALLINT nColumns; /* Number of result set columns */
|
||
SQLWCHAR colNameBuf[41*2]; /* Buffer to hold the column name */
|
||
SQLSMALLINT colNameLen = 40;
|
||
/* Length of the column name */
|
||
SQLSMALLINT colNameAllocLen = 40;
|
||
/* Allocated length of the column name */
|
||
SQLWCHAR* colNameW = colNameBuf;
|
||
/* Name of the current column */
|
||
Tcl_DString colNameDS; /* Name of the current column, translated */
|
||
Tcl_Obj* colNameObj; /* Name of the current column, packaged in
|
||
* a Tcl_Obj */
|
||
Tcl_HashTable nameHash; /* Hash table to manage column name
|
||
* uniqueness. */
|
||
Tcl_HashEntry* nameEntry; /* Hash table entry for the current name */
|
||
int isNew; /* Flag that column name is unique */
|
||
int count; /* Count to append to the name */
|
||
char numbuf[16]; /* Buffer to hold the appended count */
|
||
SQLSMALLINT i;
|
||
int retry;
|
||
int status = TCL_ERROR;
|
||
|
||
/* Create a hash table to manage column name uniqueness */
|
||
|
||
Tcl_InitHashTable(&nameHash, TCL_STRING_KEYS);
|
||
nameEntry = Tcl_CreateHashEntry(&nameHash, "", &isNew);
|
||
Tcl_SetHashValue(nameEntry, (ClientData) 0);
|
||
|
||
/* Count the columns of the result set */
|
||
|
||
rc = SQLNumResultCols(hStmt, &nColumns);
|
||
if (!SQL_SUCCEEDED(rc)) {
|
||
TransferSQLError(interp, SQL_HANDLE_STMT, hStmt,
|
||
"(getting number of result columns)");
|
||
return TCL_ERROR;
|
||
}
|
||
colNames = Tcl_NewObj();
|
||
Tcl_IncrRefCount(colNames);
|
||
if (nColumns != 0) {
|
||
|
||
/*
|
||
* If there are columns in the result set, find their names and
|
||
* data types.
|
||
*/
|
||
|
||
rdata->results = (ParamData*) ckalloc(nColumns * sizeof(ParamData));
|
||
for (i = 0; i < nColumns; ++i) {
|
||
retry = 0;
|
||
do {
|
||
|
||
/* Describe one column of the result set */
|
||
|
||
rc = SQLDescribeColW(hStmt, i + 1, colNameW,
|
||
colNameAllocLen, &colNameLen,
|
||
&(rdata->results[i].dataType),
|
||
&(rdata->results[i].precision),
|
||
&(rdata->results[i].scale),
|
||
&(rdata->results[i].nullable));
|
||
|
||
/*
|
||
* Reallocate the name buffer and retry if the buffer was
|
||
* too small.
|
||
*/
|
||
|
||
if (colNameLen < colNameAllocLen) {
|
||
retry = 0;
|
||
} else {
|
||
colNameAllocLen = 2 * colNameLen + 1;
|
||
if (colNameW != colNameBuf) {
|
||
ckfree((char*) colNameW);
|
||
}
|
||
colNameW = (SQLWCHAR*)
|
||
ckalloc(colNameAllocLen * sizeofSQLWCHAR);
|
||
retry = 1;
|
||
}
|
||
} while (retry);
|
||
|
||
/* Bail out on an ODBC error */
|
||
|
||
if (!SQL_SUCCEEDED(rc)) {
|
||
char info[80];
|
||
sprintf(info, "(describing result column #%d)", i+1);
|
||
TransferSQLError(interp, SQL_HANDLE_STMT, hStmt, info);
|
||
Tcl_DecrRefCount(colNames);
|
||
ckfree((char*)rdata->results);
|
||
goto cleanup;
|
||
}
|
||
|
||
/* Make a Tcl_Obj for the column name */
|
||
|
||
Tcl_DStringInit(&colNameDS);
|
||
DStringAppendWChars(&colNameDS, colNameW, colNameLen);
|
||
colNameObj = Tcl_NewStringObj(Tcl_DStringValue(&colNameDS),
|
||
Tcl_DStringLength(&colNameDS));
|
||
|
||
/* Test if column name is unique */
|
||
|
||
for (;;) {
|
||
nameEntry = Tcl_CreateHashEntry(&nameHash,
|
||
Tcl_GetString(colNameObj),
|
||
&isNew);
|
||
if (isNew) {
|
||
Tcl_SetHashValue(nameEntry, (ClientData) 1);
|
||
break;
|
||
}
|
||
|
||
/*
|
||
* Non-unique name - append a # and the number of times
|
||
* we've seen it before.
|
||
*/
|
||
|
||
count = PTR2INT(Tcl_GetHashValue(nameEntry));
|
||
++count;
|
||
Tcl_SetHashValue(nameEntry, INT2PTR(count));
|
||
sprintf(numbuf, "#%d", count);
|
||
Tcl_AppendToObj(colNameObj, numbuf, -1);
|
||
}
|
||
|
||
/* Add column name to the list of column names */
|
||
|
||
Tcl_ListObjAppendElement(NULL, colNames, colNameObj);
|
||
Tcl_DStringFree(&colNameDS);
|
||
}
|
||
}
|
||
|
||
/* Success: store the list of column names */
|
||
|
||
if (rdata->resultColNames != NULL) {
|
||
Tcl_DecrRefCount(rdata->resultColNames);
|
||
}
|
||
rdata->resultColNames = colNames;
|
||
status = TCL_OK;
|
||
|
||
/* Clean up the column name buffer if we reallocated it. */
|
||
|
||
cleanup:
|
||
Tcl_DeleteHashTable(&nameHash);
|
||
if (colNameW != colNameBuf) {
|
||
ckfree((char*) colNameW);
|
||
}
|
||
return status;
|
||
|
||
}
|
||
|
||
/*
|
||
*-----------------------------------------------------------------------------
|
||
*
|
||
* ConfigureConnection --
|
||
*
|
||
* Processes configuration options for an ODBC connection.
|
||
*
|
||
* Results:
|
||
* Returns a standard Tcl result; if TCL_ERROR is returned, the
|
||
* interpreter result is set to an error message.
|
||
*
|
||
* Side effects:
|
||
* Makes appropriate SQLSetConnectAttr calls to set the connection
|
||
* attributes. If connectFlagsPtr or hMainWindowPtr are not NULL,
|
||
* also accepts a '-parent' option, sets *connectFlagsPtr to
|
||
* SQL_DRIVER_COMPLETE_REQUIED or SQL_DRIVER_NOPROMPT according
|
||
* to whether '-parent' is supplied, and *hParentWindowPtr to the
|
||
* HWND corresponding to the parent window.
|
||
*
|
||
* objc,objv are presumed to frame just the options, with positional
|
||
* parameters already stripped. The following options are accepted:
|
||
*
|
||
* -parent PATH
|
||
* Specifies the path name of a parent window to use in a connection
|
||
* dialog.
|
||
*
|
||
*-----------------------------------------------------------------------------
|
||
*/
|
||
|
||
static int
|
||
ConfigureConnection(
|
||
Tcl_Interp* interp, /* Tcl interpreter */
|
||
SQLHDBC hDBC, /* Handle to the connection */
|
||
PerInterpData* pidata, /* Package-global data */
|
||
int objc, /* Option count */
|
||
Tcl_Obj *const objv[], /* Option vector */
|
||
SQLUSMALLINT* connectFlagsPtr,
|
||
/* Pointer to the driver connection options */
|
||
HWND* hParentWindowPtr /* Handle to the parent window for a
|
||
* connection dialog */
|
||
) {
|
||
|
||
/* Configuration options */
|
||
|
||
static const char* options[] = {
|
||
"-encoding",
|
||
"-isolation",
|
||
"-parent",
|
||
"-readonly",
|
||
"-timeout",
|
||
NULL
|
||
};
|
||
enum optionType {
|
||
COPTION_ENCODING,
|
||
COPTION_ISOLATION,
|
||
COPTION_PARENT,
|
||
COPTION_READONLY,
|
||
COPTION_TIMEOUT
|
||
};
|
||
|
||
int indx; /* Index of the current option */
|
||
Tcl_Obj** literals = pidata->literals;
|
||
/* Literal pool */
|
||
Tcl_Obj* retval; /* Return value from this command */
|
||
Tcl_Obj* command; /* Tcl command executed to find parent win */
|
||
Tcl_Encoding sysEncoding; /* The system encoding */
|
||
Tcl_Encoding newEncoding; /* The requested encoding */
|
||
const char* encName; /* The name of the system encoding */
|
||
int i;
|
||
int j;
|
||
SQLINTEGER mode; /* Access mode of the database */
|
||
SQLSMALLINT isol; /* Isolation level */
|
||
SQLINTEGER seconds; /* Timeout value in seconds */
|
||
SQLRETURN rc; /* Return code from SQL operations */
|
||
int w; /* Window ID of the parent window */
|
||
int status; /* Return call from Tcl */
|
||
|
||
if (connectFlagsPtr) {
|
||
*connectFlagsPtr = SQL_DRIVER_NOPROMPT;
|
||
}
|
||
if (hParentWindowPtr) {
|
||
*hParentWindowPtr = NULL;
|
||
}
|
||
|
||
if (objc == 0) {
|
||
|
||
/* return configuration options */
|
||
|
||
retval = Tcl_NewObj();
|
||
|
||
/* -encoding -- The ODBC encoding should be the system encoding */
|
||
|
||
sysEncoding = Tcl_GetEncoding(interp, NULL);
|
||
if (sysEncoding == NULL) {
|
||
encName = "iso8859-1";
|
||
} else {
|
||
encName = Tcl_GetEncodingName(sysEncoding);
|
||
}
|
||
Tcl_ListObjAppendElement(NULL, retval, literals[LIT_ENCODING]);
|
||
Tcl_ListObjAppendElement(NULL, retval, Tcl_NewStringObj(encName, -1));
|
||
if (sysEncoding != NULL) {
|
||
Tcl_FreeEncoding(sysEncoding);
|
||
}
|
||
|
||
/* -isolation */
|
||
|
||
rc = SQLGetConnectAttr(hDBC, SQL_ATTR_TXN_ISOLATION,
|
||
(SQLPOINTER) &mode, 0, NULL);
|
||
if (!SQL_SUCCEEDED(rc)) {
|
||
TransferSQLError(interp, SQL_HANDLE_DBC, hDBC,
|
||
"(getting isolation level of connection)");
|
||
return TCL_ERROR;
|
||
}
|
||
Tcl_ListObjAppendElement(NULL, retval, literals[LIT_ISOLATION]);
|
||
Tcl_ListObjAppendElement(NULL, retval,
|
||
TranslateOdbcIsolationLevel(mode, literals));
|
||
|
||
/* -readonly */
|
||
|
||
rc = SQLGetConnectAttr(hDBC, SQL_ATTR_ACCESS_MODE,
|
||
(SQLPOINTER) &mode, 0, NULL);
|
||
if (!SQL_SUCCEEDED(rc)) {
|
||
TransferSQLError(interp, SQL_HANDLE_DBC, hDBC,
|
||
"(getting access mode of connection)");
|
||
return TCL_ERROR;
|
||
}
|
||
Tcl_ListObjAppendElement(NULL, retval, literals[LIT_READONLY]);
|
||
Tcl_ListObjAppendElement(NULL, retval,
|
||
Tcl_NewWideIntObj(mode == SQL_MODE_READ_ONLY));
|
||
|
||
/* -timeout */
|
||
|
||
rc = SQLGetConnectAttr(hDBC, SQL_ATTR_CONNECTION_TIMEOUT,
|
||
(SQLPOINTER)&seconds, 0, NULL);
|
||
if (!SQL_SUCCEEDED(rc)) {
|
||
if (SQLStateIs(SQL_HANDLE_DBC, hDBC, "HYC00")) {
|
||
seconds = 0;
|
||
} else {
|
||
TransferSQLError(interp, SQL_HANDLE_DBC, hDBC,
|
||
"(getting connection timeout value)");
|
||
return TCL_ERROR;
|
||
}
|
||
}
|
||
Tcl_ListObjAppendElement(NULL, retval, literals[LIT_TIMEOUT]);
|
||
Tcl_ListObjAppendElement(NULL, retval,
|
||
Tcl_NewWideIntObj(1000 * (Tcl_WideInt)seconds));
|
||
|
||
/* end of options */
|
||
|
||
Tcl_SetObjResult(interp, retval);
|
||
return TCL_OK;
|
||
|
||
} else if (objc == 1) {
|
||
|
||
/* look up a single configuration option */
|
||
|
||
if (Tcl_GetIndexFromObjStruct(interp, objv[0], options, sizeof(char *),
|
||
"option", 0, &indx) != TCL_OK) {
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
switch (indx) {
|
||
|
||
case COPTION_ENCODING:
|
||
sysEncoding = Tcl_GetEncoding(interp, NULL);
|
||
if (sysEncoding == NULL) {
|
||
encName = "iso8859-1";
|
||
} else {
|
||
encName = Tcl_GetEncodingName(sysEncoding);
|
||
}
|
||
Tcl_SetObjResult(interp, Tcl_NewStringObj(encName, -1));
|
||
if (sysEncoding != NULL) {
|
||
Tcl_FreeEncoding(sysEncoding);
|
||
}
|
||
break;
|
||
|
||
case COPTION_ISOLATION:
|
||
rc = SQLGetConnectAttr(hDBC, SQL_ATTR_TXN_ISOLATION,
|
||
(SQLPOINTER) &mode, 0, NULL);
|
||
if (!SQL_SUCCEEDED(rc)) {
|
||
TransferSQLError(interp, SQL_HANDLE_DBC, hDBC,
|
||
"(getting isolation level of connection)");
|
||
return TCL_ERROR;
|
||
}
|
||
Tcl_SetObjResult(interp,
|
||
TranslateOdbcIsolationLevel(mode, literals));
|
||
break;
|
||
|
||
case COPTION_PARENT:
|
||
Tcl_SetObjResult(interp,
|
||
Tcl_NewStringObj("-parent option cannot "
|
||
"be used after connection "
|
||
"is established", -1));
|
||
Tcl_SetErrorCode(interp, "TDBC", "GENERAL_ERROR", "HY010",
|
||
"ODBC", "-1", NULL);
|
||
return TCL_ERROR;
|
||
|
||
case COPTION_READONLY:
|
||
rc = SQLGetConnectAttr(hDBC, SQL_ATTR_ACCESS_MODE,
|
||
(SQLPOINTER) &mode, 0, NULL);
|
||
if (!SQL_SUCCEEDED(rc)) {
|
||
TransferSQLError(interp, SQL_HANDLE_DBC, hDBC,
|
||
"(getting access mode of connection)");
|
||
return TCL_ERROR;
|
||
}
|
||
Tcl_SetObjResult(interp,
|
||
Tcl_NewWideIntObj(mode == SQL_MODE_READ_ONLY));
|
||
break;
|
||
|
||
case COPTION_TIMEOUT:
|
||
rc = SQLGetConnectAttr(hDBC, SQL_ATTR_CONNECTION_TIMEOUT,
|
||
(SQLPOINTER)&seconds, 0, NULL);
|
||
if (SQLStateIs(SQL_HANDLE_DBC, hDBC, "HYC00")) {
|
||
seconds = 0;
|
||
} else {
|
||
if (!SQL_SUCCEEDED(rc)) {
|
||
TransferSQLError(interp, SQL_HANDLE_DBC, hDBC,
|
||
"(getting connection timeout value)");
|
||
return TCL_ERROR;
|
||
}
|
||
}
|
||
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(1000 * (Tcl_WideInt) seconds));
|
||
break;
|
||
|
||
}
|
||
|
||
return TCL_OK;
|
||
|
||
}
|
||
|
||
/* set configuration options */
|
||
|
||
for (i = 0; i < objc; i+=2) {
|
||
|
||
if (Tcl_GetIndexFromObjStruct(interp, objv[i], options, sizeof(char *),
|
||
"option", 0, &indx) != TCL_OK) {
|
||
return TCL_ERROR;
|
||
}
|
||
switch (indx) {
|
||
|
||
case COPTION_ENCODING:
|
||
/*
|
||
* Encoding - report "not implemented" unless the encoding
|
||
* would not be changed.
|
||
*/
|
||
|
||
newEncoding = Tcl_GetEncoding(interp, Tcl_GetString(objv[i+1]));
|
||
if (newEncoding == NULL) {
|
||
return TCL_ERROR;
|
||
}
|
||
sysEncoding = Tcl_GetEncoding(interp, NULL);
|
||
Tcl_FreeEncoding(newEncoding);
|
||
if (sysEncoding != NULL) {
|
||
Tcl_FreeEncoding(sysEncoding);
|
||
}
|
||
if (newEncoding != sysEncoding) {
|
||
Tcl_SetObjResult(interp,
|
||
Tcl_NewStringObj("optional function "
|
||
"not implemented", -1));
|
||
Tcl_SetErrorCode(interp, "TDBC", "GENERAL_ERROR", "HYC00",
|
||
"ODBC", "-1", NULL);
|
||
return TCL_ERROR;
|
||
}
|
||
break;
|
||
|
||
case COPTION_ISOLATION:
|
||
/* Transaction isolation level */
|
||
|
||
if (LookupOdbcConstant(interp, OdbcIsolationLevels,
|
||
"isolation level", objv[i+1],
|
||
&isol) != TCL_OK) {
|
||
return TCL_ERROR;
|
||
}
|
||
mode = isol;
|
||
rc = SQLSetConnectAttr(hDBC, SQL_ATTR_TXN_ISOLATION,
|
||
(SQLPOINTER)(INT2PTR(mode)), 0);
|
||
if (!SQL_SUCCEEDED(rc)) {
|
||
TransferSQLError(interp, SQL_HANDLE_DBC, hDBC,
|
||
"(setting isolation level of connection)");
|
||
return TCL_ERROR;
|
||
}
|
||
break;
|
||
|
||
case COPTION_PARENT:
|
||
/* Parent window for connection dialog */
|
||
|
||
/* Make sure we haven't connected already */
|
||
|
||
if (connectFlagsPtr == NULL || hParentWindowPtr == NULL) {
|
||
Tcl_SetObjResult(interp,
|
||
Tcl_NewStringObj("-parent option cannot "
|
||
"be used after connection "
|
||
"is established", -1));
|
||
Tcl_SetErrorCode(interp, "TDBC", "GENERAL_ERROR", "HY010",
|
||
"ODBC", "-1", NULL);
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/* Make sure that Tk is present. */
|
||
|
||
if (Tcl_PkgPresentEx(interp, "Tk", "8.4", 0, NULL) == NULL) {
|
||
Tcl_ResetResult(interp);
|
||
Tcl_SetObjResult(interp,
|
||
Tcl_NewStringObj("cannot use -parent "
|
||
"option because Tk is not "
|
||
"loaded", -1));
|
||
Tcl_SetErrorCode(interp, "TDBC", "GENERAL_ERROR", "HY000",
|
||
"ODBC", "-1", NULL);
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/* Try to obtain the HWND of the parent window. */
|
||
|
||
command = Tcl_NewObj();
|
||
Tcl_ListObjAppendElement(NULL, command, literals[LIT_WINFO]);
|
||
Tcl_ListObjAppendElement(NULL, command, literals[LIT_ID]);
|
||
Tcl_ListObjAppendElement(NULL, command, objv[i+1]);
|
||
Tcl_IncrRefCount(command);
|
||
status = Tcl_EvalObjEx(interp, command, 0);
|
||
if (status == TCL_OK) {
|
||
status = Tcl_GetIntFromObj(interp, Tcl_GetObjResult(interp),
|
||
&w);
|
||
}
|
||
Tcl_DecrRefCount(command);
|
||
if (status != TCL_OK) {
|
||
Tcl_AppendObjToErrorInfo(interp, Tcl_NewStringObj(
|
||
"\n (retrieving ID of parent window)", -1));
|
||
return status;
|
||
}
|
||
Tcl_ResetResult(interp);
|
||
*hParentWindowPtr = INT2PTR(w);
|
||
*connectFlagsPtr = SQL_DRIVER_COMPLETE_REQUIRED;
|
||
break;
|
||
|
||
case COPTION_READONLY:
|
||
/* read-only indicator */
|
||
|
||
if (Tcl_GetBooleanFromObj(interp, objv[i+1], &j) != TCL_OK) {
|
||
return TCL_ERROR;
|
||
}
|
||
if (j) {
|
||
mode = SQL_MODE_READ_ONLY;
|
||
} else {
|
||
mode = SQL_MODE_READ_WRITE;
|
||
}
|
||
rc = SQLSetConnectAttr(hDBC, SQL_ATTR_ACCESS_MODE,
|
||
(SQLPOINTER)(INT2PTR(mode)), 0);
|
||
if (!SQL_SUCCEEDED(rc)) {
|
||
TransferSQLError(interp, SQL_HANDLE_DBC, hDBC,
|
||
"(setting access mode of connection)");
|
||
return TCL_ERROR;
|
||
}
|
||
break;
|
||
|
||
case COPTION_TIMEOUT:
|
||
/* timeout value */
|
||
|
||
if (Tcl_GetIntFromObj(interp, objv[i+1], &j) != TCL_OK) {
|
||
return TCL_ERROR;
|
||
}
|
||
seconds = (SQLINTEGER)((j + 999) / 1000);
|
||
rc = SQLSetConnectAttr(hDBC, SQL_ATTR_CONNECTION_TIMEOUT,
|
||
(SQLPOINTER)(INT2PTR(seconds)), 0);
|
||
if (!SQL_SUCCEEDED(rc)) {
|
||
/*
|
||
* A failure is OK if the SQL state is "Optional
|
||
* Function Not Implemented" and we were trying to set
|
||
* a zero timeout.
|
||
*/
|
||
if (!SQLStateIs(SQL_HANDLE_DBC, hDBC, "HYC00")
|
||
|| seconds != 0) {
|
||
TransferSQLError(interp, SQL_HANDLE_DBC, hDBC,
|
||
"(setting access mode of connection)");
|
||
return TCL_ERROR;
|
||
}
|
||
}
|
||
break;
|
||
}
|
||
}
|
||
return TCL_OK;
|
||
}
|
||
|
||
/*
|
||
*-----------------------------------------------------------------------------
|
||
*
|
||
* ConnectionConstructor --
|
||
*
|
||
* Initializer for ::tdbc::odbc::connection, which represents a
|
||
* database connection.
|
||
*
|
||
* Parameters:
|
||
* Accepts a connection string followed by alternating keywords
|
||
* and values. Refer to the manual page for the acceptable options.
|
||
*
|
||
* Results:
|
||
* Returns a standard Tcl result.
|
||
*
|
||
*-----------------------------------------------------------------------------
|
||
*/
|
||
|
||
static int
|
||
ConnectionConstructor(
|
||
ClientData clientData, /* Environment handle */
|
||
Tcl_Interp* interp, /* Tcl interpreter */
|
||
Tcl_ObjectContext objectContext, /* Object context */
|
||
int objc, /* Parameter count */
|
||
Tcl_Obj *const objv[] /* Parameter vector */
|
||
) {
|
||
PerInterpData* pidata = (PerInterpData*) clientData;
|
||
/* Per-interp data for the ODBC package */
|
||
Tcl_Object thisObject = Tcl_ObjectContextObject(objectContext);
|
||
/* The current connection object */
|
||
int skip = Tcl_ObjectContextSkippedArgs(objectContext);
|
||
/* Number of leading args to skip */
|
||
SQLHDBC hDBC = SQL_NULL_HDBC;
|
||
/* Handle to the database connection */
|
||
SQLRETURN rc; /* Return code from ODBC calls */
|
||
HWND hParentWindow = NULL; /* Windows handle of the main window */
|
||
SQLWCHAR* connectionStringReq;
|
||
/* Connection string requested by the caller */
|
||
size_t connectionStringReqLen;
|
||
/* Length of the requested connection string */
|
||
SQLWCHAR connectionString[1025*2];
|
||
/* Connection string actually used */
|
||
SQLSMALLINT connectionStringLen;
|
||
/* Length of the actual connection string */
|
||
Tcl_DString connectionStringDS;
|
||
/* Connection string converted to UTF-8 */
|
||
SQLUSMALLINT connectFlags = SQL_DRIVER_NOPROMPT;
|
||
/* Driver options */
|
||
ConnectionData *cdata; /* Client data for the connection object */
|
||
|
||
|
||
/*
|
||
* Check param count
|
||
*/
|
||
|
||
if (objc < skip+1 || ((objc-skip) % 2) != 1) {
|
||
Tcl_WrongNumArgs(interp, skip, objv,
|
||
"connection-string ?-option value?...");
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/*
|
||
* Allocate a connection handle
|
||
*/
|
||
|
||
rc = SQLAllocHandle(SQL_HANDLE_DBC, pidata->hEnv, (SQLHANDLE*) &hDBC);
|
||
if (!SQL_SUCCEEDED(rc)) {
|
||
TransferSQLError(interp, SQL_HANDLE_ENV, pidata->hEnv,
|
||
"(allocating connection handle)");
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/*
|
||
* Grab configuration options.
|
||
*/
|
||
|
||
if (objc > skip+1
|
||
&& ConfigureConnection(interp, hDBC, pidata, objc-skip-1, objv+skip+1,
|
||
&connectFlags, &hParentWindow) != TCL_OK) {
|
||
SQLFreeHandle(SQL_HANDLE_DBC, hDBC);
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/*
|
||
* Connect to the database (SQLConnect, SQLDriverConnect, SQLBrowseConnect)
|
||
*/
|
||
|
||
connectionStringReq = GetWCharStringFromObj(objv[skip],
|
||
&connectionStringReqLen);
|
||
rc = SQLDriverConnectW(hDBC, hParentWindow, connectionStringReq,
|
||
(SQLSMALLINT) connectionStringReqLen,
|
||
connectionString, 1024, &connectionStringLen,
|
||
connectFlags);
|
||
ckfree((char*) connectionStringReq);
|
||
if (rc == SQL_NO_DATA) {
|
||
Tcl_SetObjResult(interp, Tcl_NewStringObj("operation cancelled", -1));
|
||
SQLFreeHandle(SQL_HANDLE_DBC, hDBC);
|
||
return TCL_ERROR;
|
||
} else if (!SQL_SUCCEEDED(rc)) {
|
||
TransferSQLError(interp, SQL_HANDLE_DBC, hDBC,
|
||
"(connecting to database)");
|
||
SQLFreeHandle(SQL_HANDLE_DBC, hDBC);
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/* Attach data about the connection to the object metadata */
|
||
|
||
cdata = (ConnectionData*) ckalloc(sizeof(ConnectionData));
|
||
cdata->refCount = 1;
|
||
cdata->pidata = pidata;
|
||
IncrPerInterpRefCount(pidata);
|
||
cdata->hDBC = hDBC;
|
||
Tcl_DStringInit(&connectionStringDS);
|
||
DStringAppendWChars(&connectionStringDS,
|
||
connectionString, connectionStringLen);
|
||
cdata->connectionString =
|
||
Tcl_NewStringObj(Tcl_DStringValue(&connectionStringDS),
|
||
Tcl_DStringLength(&connectionStringDS));
|
||
Tcl_IncrRefCount(cdata->connectionString);
|
||
Tcl_DStringFree(&connectionStringDS);
|
||
cdata->flags = CONNECTION_FLAG_AUTOCOMMIT;
|
||
Tcl_ObjectSetMetadata(thisObject, &connectionDataType, (ClientData) cdata);
|
||
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 dummy, /* 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);
|
||
(void)dummy;
|
||
|
||
/* Check parameters */
|
||
|
||
if (objc != 2) {
|
||
Tcl_WrongNumArgs(interp, 2, objv, "");
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/* Reject attempts at nested transactions */
|
||
|
||
if (cdata->flags & CONNECTION_FLAG_XCN_ACTIVE) {
|
||
Tcl_SetObjResult(interp, Tcl_NewStringObj("ODBC does not support "
|
||
"nested transactions", -1));
|
||
Tcl_SetErrorCode(interp, "TDBC", "GENERAL_ERROR", "HYC00",
|
||
"ODBC", "-1", NULL);
|
||
return TCL_ERROR;
|
||
}
|
||
cdata->flags |= CONNECTION_FLAG_XCN_ACTIVE;
|
||
|
||
/* Turn off autocommit for the duration of the transaction */
|
||
|
||
if (cdata->flags & CONNECTION_FLAG_AUTOCOMMIT) {
|
||
if (SetAutocommitFlag(interp, cdata, 0) != TCL_OK) {
|
||
return TCL_ERROR;
|
||
}
|
||
cdata->flags &= ~CONNECTION_FLAG_AUTOCOMMIT;
|
||
}
|
||
|
||
return TCL_OK;
|
||
}
|
||
|
||
/*
|
||
*-----------------------------------------------------------------------------
|
||
*
|
||
* ConnectionConfigureMethod --
|
||
*
|
||
* Method that changes the configuration of an ODBC connection
|
||
*
|
||
* Usage:
|
||
* $connection configure
|
||
* -or- $connection configure -option
|
||
* -or- $connection configure ?-option value?...
|
||
*
|
||
* Parameters:
|
||
* Alternating options and values
|
||
*
|
||
* Results:
|
||
* With no arguments, returns a complete list of configuration options.
|
||
* With a single argument, returns the value of the given configuration
|
||
* option. With two or more arguments, sets the given configuration
|
||
* options to the given values.
|
||
*
|
||
*-----------------------------------------------------------------------------
|
||
*/
|
||
|
||
static int
|
||
ConnectionConfigureMethod(
|
||
ClientData dummy, /* Not used */
|
||
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 */
|
||
(void)dummy;
|
||
|
||
/* Check parameters */
|
||
|
||
if (objc != 2 && objc != 3 && (objc%2) != 0) {
|
||
Tcl_WrongNumArgs(interp, 2, objv,
|
||
"?" "?-option? value? ?-option value?...");
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
return ConfigureConnection(interp, cdata->hDBC, cdata->pidata,
|
||
objc-2, objv+2, NULL, NULL);
|
||
}
|
||
|
||
/*
|
||
*-----------------------------------------------------------------------------
|
||
*
|
||
* ConnectionEndXcnMethod --
|
||
*
|
||
* Method that requests that a pending transaction against a database
|
||
* be committed or rolled back.
|
||
*
|
||
* Usage:
|
||
* $connection commit
|
||
* -or- $connection rollback
|
||
*
|
||
* Parameters:
|
||
* None.
|
||
*
|
||
* Results:
|
||
* Returns an empty Tcl result if successful, and throws an error
|
||
* otherwise.
|
||
*
|
||
*-----------------------------------------------------------------------------
|
||
*/
|
||
|
||
static int
|
||
ConnectionEndXcnMethod(
|
||
ClientData clientData, /* Completion type */
|
||
Tcl_Interp* interp, /* Tcl interpreter */
|
||
Tcl_ObjectContext objectContext, /* Object context */
|
||
int objc, /* Parameter count */
|
||
Tcl_Obj *const objv[] /* Parameter vector */
|
||
) {
|
||
SQLSMALLINT completionType = (SQLSMALLINT) PTR2INT(clientData);
|
||
Tcl_Object thisObject = Tcl_ObjectContextObject(objectContext);
|
||
/* The current connection object */
|
||
ConnectionData* cdata = (ConnectionData*)
|
||
Tcl_ObjectGetMetadata(thisObject, &connectionDataType);
|
||
/* Instance data */
|
||
SQLRETURN rc; /* Result code from ODBC 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 & CONNECTION_FLAG_XCN_ACTIVE)) {
|
||
Tcl_SetObjResult(interp, Tcl_NewStringObj("no transaction is in "
|
||
"progress", -1));
|
||
Tcl_SetErrorCode(interp, "TDBC", "GENERAL_ERROR", "HY010",
|
||
"ODBC", "-1", NULL);
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/* End transaction, turn off "transaction in progress", and report status */
|
||
|
||
rc = SQLEndTran(SQL_HANDLE_DBC, cdata->hDBC, completionType);
|
||
cdata->flags &= ~ CONNECTION_FLAG_XCN_ACTIVE;
|
||
if (!SQL_SUCCEEDED(rc)) {
|
||
TransferSQLError(interp, SQL_HANDLE_DBC, cdata->hDBC,
|
||
"(ending the transaction)");
|
||
return TCL_ERROR;
|
||
}
|
||
return TCL_OK;
|
||
}
|
||
|
||
/*
|
||
*-----------------------------------------------------------------------------
|
||
*
|
||
* ConnectionHasBigintMethod --
|
||
*
|
||
* Private method that informs the code whether the connection supports
|
||
* 64-bit ints.
|
||
*
|
||
* Usage:
|
||
* $connection HasBigint boolean
|
||
*
|
||
* Parameters:
|
||
* boolean - 1 if the connection supports BIGINT, 0 otherwise
|
||
*
|
||
* Results:
|
||
* Returns an empty Tcl result.
|
||
*
|
||
*-----------------------------------------------------------------------------
|
||
*/
|
||
|
||
static int
|
||
ConnectionHasBigintMethod(
|
||
ClientData dummy, /* Not used */
|
||
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 flag;
|
||
(void)dummy;
|
||
|
||
/* Check parameters */
|
||
|
||
if (objc != 3) {
|
||
Tcl_WrongNumArgs(interp, 2, objv, "flag");
|
||
return TCL_ERROR;
|
||
}
|
||
if (Tcl_GetBooleanFromObj(interp, objv[2], &flag) != TCL_OK) {
|
||
return TCL_ERROR;
|
||
}
|
||
if (flag) {
|
||
cdata->flags |= CONNECTION_FLAG_HAS_BIGINT;
|
||
} else {
|
||
cdata->flags &= ~CONNECTION_FLAG_HAS_BIGINT;
|
||
}
|
||
return TCL_OK;
|
||
}
|
||
|
||
/*
|
||
*-----------------------------------------------------------------------------
|
||
*
|
||
* ConnectionHasWvarcharMethod --
|
||
*
|
||
* Private method that informs the code whether the connection supports
|
||
* WVARCHAR strings.
|
||
*
|
||
* Usage:
|
||
* $connection HasWvarchar boolean
|
||
*
|
||
* Parameters:
|
||
* boolean - 1 if the connection supports WVARCHAR, 0 otherwise
|
||
*
|
||
* Results:
|
||
* Returns an empty Tcl result.
|
||
*
|
||
*-----------------------------------------------------------------------------
|
||
*/
|
||
|
||
static int
|
||
ConnectionHasWvarcharMethod(
|
||
ClientData dummy, /* Not used */
|
||
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 flag;
|
||
(void)dummy;
|
||
|
||
/* Check parameters */
|
||
|
||
if (objc != 3) {
|
||
Tcl_WrongNumArgs(interp, 2, objv, "flag");
|
||
return TCL_ERROR;
|
||
}
|
||
if (Tcl_GetBooleanFromObj(interp, objv[2], &flag) != TCL_OK) {
|
||
return TCL_ERROR;
|
||
}
|
||
if (flag) {
|
||
cdata->flags |= CONNECTION_FLAG_HAS_WVARCHAR;
|
||
} else {
|
||
cdata->flags &= ~CONNECTION_FLAG_HAS_WVARCHAR;
|
||
}
|
||
return TCL_OK;
|
||
}
|
||
|
||
/*
|
||
*-----------------------------------------------------------------------------
|
||
*
|
||
* SetAutocommitFlag --
|
||
*
|
||
* Turns autocommit on or off at the ODBC level.
|
||
*
|
||
* Results:
|
||
* Returns TCL_OK if successful, TCL_ERROR otherwise. Stores error message
|
||
* in the interpreter.
|
||
*
|
||
*-----------------------------------------------------------------------------
|
||
*/
|
||
|
||
static int
|
||
SetAutocommitFlag(
|
||
Tcl_Interp* interp, /* Tcl interpreter */
|
||
ConnectionData* cdata, /* Instance data for the connection */
|
||
SQLINTEGER flag /* Auto-commit indicator */
|
||
) {
|
||
SQLRETURN rc;
|
||
rc = SQLSetConnectAttr(cdata->hDBC, SQL_ATTR_AUTOCOMMIT,
|
||
(SQLPOINTER)(INT2PTR(flag)), 0);
|
||
if (!SQL_SUCCEEDED(rc)) {
|
||
TransferSQLError(interp, SQL_HANDLE_DBC, cdata->hDBC,
|
||
"(changing the 'autocommit' attribute)");
|
||
return TCL_ERROR;
|
||
}
|
||
return TCL_OK;
|
||
}
|
||
|
||
/*
|
||
*-----------------------------------------------------------------------------
|
||
*
|
||
* 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 ODBC 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 ODBC 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* dummy, /* Tcl interpreter */
|
||
ClientData oldClientData, /* Environment handle to be discarded */
|
||
ClientData* newClientData /* New environment handle to be used */
|
||
) {
|
||
(void)dummy;
|
||
(void)oldClientData;
|
||
|
||
*newClientData = GetHEnv(NULL);
|
||
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 */
|
||
) {
|
||
/*
|
||
* All SQL errors are ignored here because we can't do anything
|
||
* about them, anyway.
|
||
*/
|
||
|
||
if (cdata->flags & CONNECTION_FLAG_XCN_ACTIVE) {
|
||
SQLEndTran(SQL_HANDLE_DBC, cdata->hDBC, SQL_ROLLBACK);
|
||
}
|
||
SQLDisconnect(cdata->hDBC);
|
||
SQLFreeHandle(SQL_HANDLE_DBC, cdata->hDBC);
|
||
Tcl_DecrRefCount(cdata->connectionString);
|
||
DecrPerInterpRefCount(cdata->pidata);
|
||
ckfree((char*) cdata);
|
||
}
|
||
|
||
/*
|
||
*-----------------------------------------------------------------------------
|
||
*
|
||
* CloneConnection --
|
||
*
|
||
* Attempts to clone an ODBC 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 */
|
||
) {
|
||
(void)metadata;
|
||
(void)newMetaData;
|
||
|
||
Tcl_SetObjResult(interp,
|
||
Tcl_NewStringObj("ODBC 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 */
|
||
Tcl_Object connectionObject /* Object handle wrapping the instance */
|
||
) {
|
||
StatementData* sdata = (StatementData*) ckalloc(sizeof(StatementData));
|
||
sdata->refCount = 1;
|
||
sdata->cdata = cdata;
|
||
sdata->connectionObject = connectionObject;
|
||
IncrConnectionRefCount(cdata);
|
||
sdata->subVars = Tcl_NewObj();
|
||
Tcl_IncrRefCount(sdata->subVars);
|
||
sdata->hStmt = SQL_NULL_HANDLE;
|
||
sdata->nativeSqlW = NULL;
|
||
sdata->nativeSqlLen = 0;
|
||
sdata->nativeMatchPatternW = NULL;
|
||
sdata->nativeMatchPatLen = 0;
|
||
sdata->params = NULL;
|
||
sdata->flags = 0;
|
||
sdata->typeNum = SQL_ALL_TYPES;
|
||
return sdata;
|
||
}
|
||
|
||
/*
|
||
*-----------------------------------------------------------------------------
|
||
*
|
||
* StatementConstructor --
|
||
*
|
||
* C-level initialization for the object representing an ODBC prepared
|
||
* statement.
|
||
*
|
||
* Parameters:
|
||
* Accepts a 4-element 'objv': statement new $connection $statementText,
|
||
* where $connection is the ODBC connection object, and $statementText
|
||
* is the 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 dummy, /* 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);
|
||
/* The number of args to skip */
|
||
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 = NULL; /* 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 ODBC form */
|
||
char* tokenStr; /* Token string */
|
||
size_t tokenLen; /* Length of a token */
|
||
RETCODE rc; /* Return code from ODBC */
|
||
SQLSMALLINT nParams; /* Number of parameters in the ODBC statement */
|
||
int i, j;
|
||
(void)dummy;
|
||
|
||
/* Find the connection object, and get its data. */
|
||
|
||
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 an ODBC connection", NULL);
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/*
|
||
* Allocate an object to hold data about this statement
|
||
*/
|
||
|
||
sdata = NewStatement(cdata, connectionObject);
|
||
|
||
/* 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 ODBC syntax. Reject the
|
||
* statement if it is actually multiple statements.
|
||
*/
|
||
|
||
if (Tcl_ListObjGetElements(interp, tokens, &tokenc, &tokenv) != TCL_OK) {
|
||
Tcl_DecrRefCount(tokens);
|
||
goto freeSData;
|
||
}
|
||
nativeSql = Tcl_NewObj();
|
||
Tcl_IncrRefCount(nativeSql);
|
||
for (i = 0; i < tokenc; ++i) {
|
||
tokenStr = Tcl_GetString(tokenv[i]);
|
||
tokenLen = tokenv[i]->length;
|
||
|
||
switch (tokenStr[0]) {
|
||
case '$':
|
||
case ':':
|
||
Tcl_AppendToObj(nativeSql, "?", 1);
|
||
Tcl_ListObjAppendElement(NULL, sdata->subVars,
|
||
Tcl_NewStringObj(tokenStr+1, tokenLen-1));
|
||
break;
|
||
|
||
default:
|
||
Tcl_AppendToObj(nativeSql, tokenStr, tokenLen);
|
||
break;
|
||
|
||
}
|
||
}
|
||
Tcl_DecrRefCount(tokens);
|
||
|
||
/* Allocate an ODBC statement handle, and prepare the statement */
|
||
|
||
sdata->nativeSqlW = GetWCharStringFromObj(nativeSql, &sdata->nativeSqlLen);
|
||
Tcl_DecrRefCount(nativeSql);
|
||
sdata->hStmt = AllocAndPrepareStatement(interp, sdata);
|
||
if (sdata->hStmt == SQL_NULL_HANDLE) {
|
||
goto freeSData;
|
||
}
|
||
|
||
/* Determine the number of parameters that ODBC thinks are in the
|
||
* statement. */
|
||
|
||
Tcl_ListObjLength(NULL, sdata->subVars, &i);
|
||
sdata->params = (ParamData*) ckalloc(i * sizeof(ParamData));
|
||
for (j = 0; j < i; ++j) {
|
||
/*
|
||
* Supply defaults in case the driver doesn't support introspection
|
||
* of parameters. Since not all drivers do WVARCHAR, VARCHAR
|
||
* appears to be the only workable option.
|
||
*/
|
||
if (cdata->flags & CONNECTION_FLAG_HAS_WVARCHAR) {
|
||
sdata->params[j].dataType = SQL_WVARCHAR;
|
||
} else {
|
||
sdata->params[j].dataType = SQL_VARCHAR;
|
||
}
|
||
sdata->params[j].precision = 255;
|
||
sdata->params[j].scale = 0;
|
||
sdata->params[j].nullable = SQL_NULLABLE_UNKNOWN;
|
||
sdata->params[j].flags = PARAM_IN;
|
||
}
|
||
rc = SQLNumParams(sdata->hStmt, &nParams);
|
||
if (SQL_SUCCEEDED(rc)) {
|
||
if (nParams != i) {
|
||
Tcl_SetObjResult(interp,
|
||
Tcl_NewStringObj("The SQL statement appears "
|
||
"to contain parameters in "
|
||
"native SQL syntax. You need "
|
||
"to replace them with ones "
|
||
"in ':variableName' form.", -1));
|
||
Tcl_SetErrorCode(interp, "TDBC", "DYNAMIC_SQL_ERROR", "07002",
|
||
"ODBC", "-1", NULL);
|
||
goto freeSData;
|
||
}
|
||
|
||
/*
|
||
* Try to describe the parameters for the sake of consistency
|
||
* in conversion and efficiency in execution.
|
||
*/
|
||
|
||
for (i = 0; i < nParams; ++i) {
|
||
rc = SQLDescribeParam(sdata->hStmt, i+1,
|
||
&(sdata->params[i].dataType),
|
||
&(sdata->params[i].precision),
|
||
&(sdata->params[i].scale),
|
||
&(sdata->params[i].nullable));
|
||
if (SQL_SUCCEEDED(rc)) {
|
||
/*
|
||
* FIXME: SQLDescribeParam doesn't actually describe
|
||
* the direction of parameter transmission for
|
||
* stored procedure calls. It appears simply
|
||
* to be the caller's responsibility to know
|
||
* these things. If anyone has an idea how to
|
||
* determine this, please send a patch! (Remember
|
||
* that the patch has to work with DB2 and
|
||
* unixodbc as well as Microsoft.)
|
||
*/
|
||
sdata->params[i].flags = PARAM_IN | PARAM_KNOWN;
|
||
} else {
|
||
/*
|
||
* Supply defaults in case the driver doesn't support
|
||
* introspection of parameters. Again, not all drivers can
|
||
* handle WVARCHAR, so VARCHAR seems to be the only
|
||
* workable option.
|
||
*/
|
||
if (cdata->flags & CONNECTION_FLAG_HAS_WVARCHAR) {
|
||
sdata->params[i].dataType = SQL_WVARCHAR;
|
||
} else {
|
||
sdata->params[i].dataType = SQL_VARCHAR;
|
||
}
|
||
sdata->params[i].precision = 255;
|
||
sdata->params[i].scale = 0;
|
||
sdata->params[i].nullable = SQL_NULLABLE_UNKNOWN;
|
||
sdata->params[i].flags = PARAM_IN;
|
||
}
|
||
}
|
||
}
|
||
|
||
/* 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 */
|
||
|
||
freeSData:
|
||
DecrStatementRefCount(sdata);
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/*
|
||
*-----------------------------------------------------------------------------
|
||
*
|
||
* StatementConnectionMethod --
|
||
*
|
||
* Retrieves the handle of the connection to which a statement belongs
|
||
*
|
||
* Parameters:
|
||
* None.
|
||
*
|
||
* Results:
|
||
* Returns the connection handle
|
||
*
|
||
*-----------------------------------------------------------------------------
|
||
*/
|
||
|
||
static int
|
||
StatementConnectionMethod(
|
||
ClientData dummy, /* 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 */
|
||
Tcl_Object connectionObject;
|
||
/* The object representing the connection */
|
||
Tcl_Command connectionCommand;
|
||
/* The command representing the object */
|
||
Tcl_Obj* retval = Tcl_NewObj();
|
||
/* The command name */
|
||
(void)dummy;
|
||
(void)objc;
|
||
(void)objv;
|
||
|
||
sdata = (StatementData*) Tcl_ObjectGetMetadata(thisObject,
|
||
&statementDataType);
|
||
connectionObject = sdata->connectionObject;
|
||
connectionCommand = Tcl_GetObjectCommand(connectionObject);
|
||
Tcl_GetCommandFullName(interp, connectionCommand, retval);
|
||
Tcl_SetObjResult(interp, retval);
|
||
return TCL_OK;
|
||
}
|
||
|
||
/*
|
||
*-----------------------------------------------------------------------------
|
||
*
|
||
* StatementParamListMethod --
|
||
*
|
||
* Lists the parameters to an ODBC statement
|
||
*
|
||
* Usage:
|
||
* $statement ParamList
|
||
*
|
||
* Results:
|
||
* Returns a standard Tcl result that is a list of alternating
|
||
* elements: paramName flags typeNumber precision scale nullable
|
||
*
|
||
*-----------------------------------------------------------------------------
|
||
*/
|
||
|
||
static int
|
||
StatementParamListMethod(
|
||
ClientData dummy, /* 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 */
|
||
Tcl_Obj **paramNames; /* Parameter list to the current statement */
|
||
int nParams; /* Parameter count for the current statement */
|
||
int i; /* Current parameter index */
|
||
Tcl_Obj* retval; /* Return value from this command */
|
||
(void)dummy;
|
||
(void)objc;
|
||
(void)objv;
|
||
|
||
sdata = (StatementData*) Tcl_ObjectGetMetadata(thisObject,
|
||
&statementDataType);
|
||
|
||
retval = Tcl_NewObj();
|
||
if (sdata->subVars != NULL) {
|
||
Tcl_ListObjGetElements(NULL, sdata->subVars, &nParams, ¶mNames);
|
||
for (i = 0; i < nParams; ++i) {
|
||
ParamData* pd = sdata->params + i;
|
||
Tcl_ListObjAppendElement(NULL, retval, paramNames[i]);
|
||
Tcl_ListObjAppendElement(NULL, retval, Tcl_NewWideIntObj(pd->flags));
|
||
Tcl_ListObjAppendElement(NULL, retval, Tcl_NewWideIntObj(pd->dataType));
|
||
Tcl_ListObjAppendElement(NULL, retval,
|
||
Tcl_NewWideIntObj(pd->precision));
|
||
Tcl_ListObjAppendElement(NULL, retval, Tcl_NewWideIntObj(pd->scale));
|
||
Tcl_ListObjAppendElement(NULL, retval, Tcl_NewWideIntObj(pd->nullable));
|
||
}
|
||
}
|
||
Tcl_SetObjResult(interp, retval);
|
||
return TCL_OK;
|
||
}
|
||
|
||
/*
|
||
*-----------------------------------------------------------------------------
|
||
*
|
||
* StatementParamtypeMethod --
|
||
*
|
||
* Defines a parameter type in an ODBC 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 dummy, /* 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 */
|
||
int matchCount = 0; /* The number of variables in the given
|
||
* statement that match the given one */
|
||
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 */
|
||
Tcl_Obj* errorObj; /* Error message */
|
||
int i;
|
||
SQLSMALLINT dir = PARAM_IN | PARAM_KNOWN;
|
||
/* Direction of parameter transmssion */
|
||
SQLSMALLINT odbcType = SQL_VARCHAR;
|
||
/* ODBC type of the parameter */
|
||
int precision = 0; /* Length of the parameter */
|
||
int scale = 0; /* Precision of the parameter */
|
||
(void)dummy;
|
||
|
||
sdata = (StatementData*) Tcl_ObjectGetMetadata(thisObject,
|
||
&statementDataType);
|
||
/* Check parameters */
|
||
|
||
if (objc < 4) {
|
||
goto wrongNumArgs;
|
||
}
|
||
i = 3;
|
||
if (LookupOdbcConstant(NULL, OdbcParamDirections, "direction", objv[i],
|
||
&dir) == TCL_OK) {
|
||
++i;
|
||
}
|
||
if (i >= objc) {
|
||
goto wrongNumArgs;
|
||
}
|
||
if (LookupOdbcType(interp, objv[i], &odbcType) == 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;
|
||
}
|
||
|
||
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 = dir;
|
||
sdata->params[i].dataType = odbcType;
|
||
sdata->params[i].precision = precision;
|
||
sdata->params[i].scale = scale;
|
||
sdata->params[i].nullable = 1;
|
||
/* TODO - Update TIP so that user
|
||
* can specify nullable? */
|
||
}
|
||
}
|
||
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;
|
||
}
|
||
|
||
/*
|
||
*-----------------------------------------------------------------------------
|
||
*
|
||
* TablesStatementConstructor --
|
||
*
|
||
* C-level initialization for the object representing an ODBC query
|
||
* for table metadata
|
||
*
|
||
* Parameters:
|
||
* Accepts a 4-element 'objv': $object init $connection $pattern,
|
||
* where $connection is the ODBC connection object, and $pattern
|
||
* is the pattern to match table names.
|
||
*
|
||
* 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
|
||
TablesStatementConstructor(
|
||
ClientData dummy, /* 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);
|
||
/* The number of initial args to this call */
|
||
Tcl_Object connectionObject;
|
||
/* The database connection as a Tcl_Object */
|
||
ConnectionData* cdata; /* The connection object's data */
|
||
StatementData* sdata; /* The statement's object data */
|
||
RETCODE rc; /* Return code from ODBC */
|
||
(void)dummy;
|
||
|
||
/* Find the connection object, and get its data. */
|
||
|
||
if (objc != skip+2) {
|
||
Tcl_WrongNumArgs(interp, skip, objv, "connection pattern");
|
||
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 an ODBC connection", NULL);
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/*
|
||
* Allocate an object to hold data about this statement
|
||
*/
|
||
|
||
sdata = NewStatement(cdata, connectionObject);
|
||
|
||
/* Allocate an ODBC statement handle */
|
||
|
||
rc = SQLAllocHandle(SQL_HANDLE_STMT, cdata->hDBC, &(sdata->hStmt));
|
||
if (!SQL_SUCCEEDED(rc)) {
|
||
TransferSQLError(interp, SQL_HANDLE_DBC, cdata->hDBC,
|
||
"(allocating statement handle)");
|
||
goto freeSData;
|
||
}
|
||
|
||
/*
|
||
* Stash the table pattern in the statement data, and set a flag that
|
||
* that's what we have there.
|
||
*/
|
||
|
||
sdata->nativeSqlW = GetWCharStringFromObj(objv[skip+1],
|
||
&(sdata->nativeSqlLen));
|
||
sdata->nativeMatchPatternW = NULL;
|
||
sdata->flags |= STATEMENT_FLAG_TABLES;
|
||
|
||
/* 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 */
|
||
|
||
freeSData:
|
||
DecrStatementRefCount(sdata);
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/*
|
||
*-----------------------------------------------------------------------------
|
||
*
|
||
* ColumnsStatementConstructor --
|
||
*
|
||
* C-level initialization for the object representing an ODBC query
|
||
* for column metadata
|
||
*
|
||
* Parameters:
|
||
* Accepts a 5-element 'objv':
|
||
* columnsStatement new $connection $table $pattern,
|
||
* where $connection is the ODBC connection object, $table is the
|
||
* name of the table being queried, and $pattern is the pattern to
|
||
* match column names.
|
||
*
|
||
* 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
|
||
ColumnsStatementConstructor(
|
||
ClientData dummy, /* 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);
|
||
/* The number of parameters to skip */
|
||
Tcl_Object connectionObject;
|
||
/* The database connection as a Tcl_Object */
|
||
ConnectionData* cdata; /* The connection object's data */
|
||
StatementData* sdata; /* The statement's object data */
|
||
RETCODE rc; /* Return code from ODBC */
|
||
(void)dummy;
|
||
|
||
|
||
/* Check param count */
|
||
|
||
if (objc != skip+3) {
|
||
Tcl_WrongNumArgs(interp, skip, objv, "connection tableName pattern");
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/* Find the connection object, and get its data. */
|
||
|
||
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 an ODBC connection", NULL);
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/*
|
||
* Allocate an object to hold data about this statement
|
||
*/
|
||
|
||
sdata = NewStatement(cdata, connectionObject);
|
||
|
||
/* Allocate an ODBC statement handle */
|
||
|
||
rc = SQLAllocHandle(SQL_HANDLE_STMT, cdata->hDBC, &(sdata->hStmt));
|
||
if (!SQL_SUCCEEDED(rc)) {
|
||
TransferSQLError(interp, SQL_HANDLE_DBC, cdata->hDBC,
|
||
"(allocating statement handle)");
|
||
goto freeSData;
|
||
}
|
||
|
||
/*
|
||
* Stash the table name and match pattern in the statement data,
|
||
* and set a flag that that's what we have there.
|
||
*/
|
||
|
||
sdata->nativeSqlW = GetWCharStringFromObj(objv[skip+1],
|
||
&(sdata->nativeSqlLen));
|
||
sdata->nativeMatchPatternW =
|
||
GetWCharStringFromObj(objv[skip+2], &(sdata->nativeMatchPatLen));
|
||
sdata->flags = STATEMENT_FLAG_COLUMNS;
|
||
|
||
/* 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 */
|
||
|
||
freeSData:
|
||
DecrStatementRefCount(sdata);
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/*
|
||
*-----------------------------------------------------------------------------
|
||
*
|
||
* PrimarykeysStatementConstructor --
|
||
*
|
||
* C-level initialization for the object representing an ODBC query
|
||
* for primary key metadata
|
||
*
|
||
* Parameters:
|
||
* Accepts a 4-element 'objv':
|
||
* columnsStatement new $connection $table,
|
||
* where $connection is the ODBC connection object and $table is the
|
||
* name of the table being queried.
|
||
*
|
||
* 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
|
||
PrimarykeysStatementConstructor(
|
||
ClientData dummy, /* 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);
|
||
/* The number of parameters to skip */
|
||
Tcl_Object connectionObject;
|
||
/* The database connection as a Tcl_Object */
|
||
ConnectionData* cdata; /* The connection object's data */
|
||
StatementData* sdata; /* The statement's object data */
|
||
RETCODE rc; /* Return code from ODBC */
|
||
(void)dummy;
|
||
|
||
|
||
/* Check param count */
|
||
|
||
if (objc != skip+2) {
|
||
Tcl_WrongNumArgs(interp, skip, objv, "connection tableName");
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/* Find the connection object, and get its data. */
|
||
|
||
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 an ODBC connection", NULL);
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/*
|
||
* Allocate an object to hold data about this statement
|
||
*/
|
||
|
||
sdata = NewStatement(cdata, connectionObject);
|
||
|
||
/* Allocate an ODBC statement handle */
|
||
|
||
rc = SQLAllocHandle(SQL_HANDLE_STMT, cdata->hDBC, &(sdata->hStmt));
|
||
if (!SQL_SUCCEEDED(rc)) {
|
||
TransferSQLError(interp, SQL_HANDLE_DBC, cdata->hDBC,
|
||
"(allocating statement handle)");
|
||
goto freeSData;
|
||
}
|
||
|
||
/*
|
||
* Stash the table name in the statement data,
|
||
* and set a flag that that's what we have there.
|
||
*/
|
||
|
||
sdata->nativeSqlW = GetWCharStringFromObj(objv[skip+1],
|
||
&(sdata->nativeSqlLen));
|
||
sdata->flags = STATEMENT_FLAG_PRIMARYKEYS;
|
||
|
||
/* 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 */
|
||
|
||
freeSData:
|
||
DecrStatementRefCount(sdata);
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/*
|
||
*-----------------------------------------------------------------------------
|
||
*
|
||
* ForeignkeysStatementConstructor --
|
||
*
|
||
* C-level initialization for the object representing an ODBC query
|
||
* for foreign key metadata
|
||
*
|
||
* Parameters:
|
||
* Accepts a variadic 'objv':
|
||
* columnsStatement new $connection ?-keyword value?...
|
||
* where $connection is the ODBC connection object. The keyword options
|
||
* include '-primary', which gives the name of a primary table, and
|
||
* '-foreign', which gives the name of a foreign table.
|
||
*
|
||
* 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
|
||
ForeignkeysStatementConstructor(
|
||
ClientData dummy, /* 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);
|
||
/* The number of parameters to skip */
|
||
Tcl_Object connectionObject;
|
||
/* The database connection as a Tcl_Object */
|
||
ConnectionData* cdata; /* The connection object's data */
|
||
StatementData* sdata; /* The statement's object data */
|
||
RETCODE rc; /* Return code from ODBC */
|
||
static const char* options[] = { /* Option table */
|
||
"-foreign",
|
||
"-primary",
|
||
NULL
|
||
};
|
||
enum {
|
||
OPT_FOREIGN=0,
|
||
OPT_PRIMARY,
|
||
OPT__END
|
||
};
|
||
|
||
int i;
|
||
int paramIdx; /* Index of the current option in the option
|
||
* table */
|
||
unsigned char have[OPT__END];
|
||
/* Flags for whether given -keywords have been
|
||
* seen. */
|
||
Tcl_Obj* resultObj; /* Interpreter result */
|
||
(void)dummy;
|
||
|
||
/* Check param count */
|
||
|
||
if (objc < skip+1 || (objc-skip) % 2 != 1) {
|
||
Tcl_WrongNumArgs(interp, skip, objv, "connection ?-option value?...");
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/* Find the connection object, and get its data. */
|
||
|
||
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 an ODBC connection", NULL);
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/*
|
||
* Allocate an object to hold data about this statement
|
||
*/
|
||
|
||
sdata = NewStatement(cdata, connectionObject);
|
||
|
||
/* Absorb parameters */
|
||
|
||
have[OPT_FOREIGN] = have[OPT_PRIMARY] = 0;
|
||
for (i = skip+1; i+1 < objc; i+=2) {
|
||
if (Tcl_GetIndexFromObjStruct(interp, objv[i], options, sizeof(char *),
|
||
"option", 0, ¶mIdx) != TCL_OK) {
|
||
goto freeSData;
|
||
}
|
||
if (have[paramIdx]) {
|
||
resultObj = Tcl_NewStringObj("duplicate option \"", -1);
|
||
Tcl_AppendObjToObj(resultObj, objv[i]);
|
||
Tcl_AppendToObj(resultObj, "\"", -1);
|
||
Tcl_SetErrorCode(interp, "TDBC", "GENERAL_ERROR", "HY001",
|
||
"ODBC", "-1", NULL);
|
||
Tcl_SetObjResult(interp, resultObj);
|
||
goto freeSData;
|
||
}
|
||
switch(paramIdx) {
|
||
case OPT_FOREIGN:
|
||
sdata->nativeMatchPatternW =
|
||
GetWCharStringFromObj(objv[i+1], &(sdata->nativeMatchPatLen));
|
||
break;
|
||
case OPT_PRIMARY:
|
||
sdata->nativeSqlW =
|
||
GetWCharStringFromObj(objv[i+1], &(sdata->nativeSqlLen));
|
||
break;
|
||
}
|
||
have[paramIdx] = 1;
|
||
}
|
||
|
||
/* Allocate an ODBC statement handle */
|
||
|
||
rc = SQLAllocHandle(SQL_HANDLE_STMT, cdata->hDBC, &(sdata->hStmt));
|
||
if (!SQL_SUCCEEDED(rc)) {
|
||
TransferSQLError(interp, SQL_HANDLE_DBC, cdata->hDBC,
|
||
"(allocating statement handle)");
|
||
goto freeSData;
|
||
}
|
||
|
||
sdata->flags = STATEMENT_FLAG_FOREIGNKEYS;
|
||
|
||
/* 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 */
|
||
|
||
freeSData:
|
||
DecrStatementRefCount(sdata);
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/*
|
||
*-----------------------------------------------------------------------------
|
||
*
|
||
* TypesStatementConstructor --
|
||
*
|
||
* C-level initialization for the object representing an ODBC query
|
||
* for data type metadata
|
||
*
|
||
* Parameters:
|
||
* Accepts a 3- or 4-element 'objv':
|
||
* typesStatement new $connection ?$typeNum?
|
||
* where $connection is the ODBC connection object, and $typeNum,
|
||
* if present, makes the query match only the given type.
|
||
*
|
||
* 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
|
||
TypesStatementConstructor(
|
||
ClientData dummy, /* 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);
|
||
/* The number of leading args to skip */
|
||
Tcl_Object connectionObject;
|
||
/* The database connection as a Tcl_Object */
|
||
ConnectionData* cdata; /* The connection object's data */
|
||
StatementData* sdata; /* The statement's object data */
|
||
RETCODE rc; /* Return code from ODBC */
|
||
int typeNum; /* Data type number */
|
||
(void)dummy;
|
||
|
||
/* Parse args */
|
||
|
||
if (objc == skip+1) {
|
||
typeNum = SQL_ALL_TYPES;
|
||
} else if (objc == skip+2) {
|
||
if (Tcl_GetIntFromObj(interp, objv[skip+1], &typeNum) != TCL_OK) {
|
||
return TCL_ERROR;
|
||
}
|
||
} else {
|
||
Tcl_WrongNumArgs(interp, skip, objv, "connection ?typeNum?");
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/* Find the connection object, and get its data. */
|
||
|
||
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 an ODBC connection", NULL);
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/*
|
||
* Allocate an object to hold data about this statement
|
||
*/
|
||
|
||
sdata = NewStatement(cdata, connectionObject);
|
||
|
||
/* Allocate an ODBC statement handle */
|
||
|
||
rc = SQLAllocHandle(SQL_HANDLE_STMT, cdata->hDBC, &(sdata->hStmt));
|
||
if (!SQL_SUCCEEDED(rc)) {
|
||
TransferSQLError(interp, SQL_HANDLE_DBC, cdata->hDBC,
|
||
"(allocating statement handle)");
|
||
goto freeSData;
|
||
}
|
||
|
||
/*
|
||
* Stash the type number in the statement data, and set a flag
|
||
* that that's what we have there.
|
||
*/
|
||
|
||
sdata->typeNum = typeNum;
|
||
sdata->flags = STATEMENT_FLAG_TYPES;
|
||
|
||
/* 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 */
|
||
|
||
freeSData:
|
||
DecrStatementRefCount(sdata);
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/*
|
||
*-----------------------------------------------------------------------------
|
||
*
|
||
* DeleteStatementMetadata, DeleteStatement --
|
||
*
|
||
* Cleans up when an ODBC 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->hStmt != SQL_NULL_HANDLE) {
|
||
SQLFreeHandle(SQL_HANDLE_STMT, sdata->hStmt);
|
||
}
|
||
if (sdata->params != NULL) {
|
||
ckfree((char*) sdata->params);
|
||
}
|
||
Tcl_DecrRefCount(sdata->subVars);
|
||
if (sdata->nativeSqlW != NULL) {
|
||
ckfree((char*) sdata->nativeSqlW);
|
||
}
|
||
if (sdata->nativeMatchPatternW != NULL) {
|
||
ckfree((char*) sdata->nativeMatchPatternW);
|
||
}
|
||
DecrConnectionRefCount(sdata->cdata);
|
||
ckfree((char*)sdata);
|
||
}
|
||
|
||
/*
|
||
*-----------------------------------------------------------------------------
|
||
*
|
||
* CloneStatement --
|
||
*
|
||
* Attempts to clone an ODBC 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 */
|
||
) {
|
||
(void)metadata;
|
||
(void)newMetaData;
|
||
|
||
Tcl_SetObjResult(interp,
|
||
Tcl_NewStringObj("ODBC 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 -- The statement object to which the result set 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 dummy, /* 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 skipped args in the
|
||
* method invocation */
|
||
Tcl_Object statementObject; /* The current statement object */
|
||
ConnectionData* cdata; /* The ODBC connection object's data */
|
||
StatementData* sdata; /* The statement object's data */
|
||
ResultSetData* rdata; /* THe result set object's data */
|
||
int nParams; /* Number of substituted parameters in
|
||
* the statement */
|
||
int nBound; /* Number of substituted parameters that
|
||
* have been bound successfully */
|
||
SQLSMALLINT dataType; /* Data type of a parameter */
|
||
Tcl_Obj* paramNameObj; /* Name of a substituted parameter */
|
||
const char* paramName; /* Name of a substituted parameter */
|
||
Tcl_Obj* paramValObj; /* Value of a substituted parameter */
|
||
const char* paramVal; /* Value of a substituted parameter */
|
||
size_t paramLen; /* String length of the parameter value */
|
||
Tcl_DString paramExternal; /* Substituted parameter, converted to
|
||
* system encoding */
|
||
int paramExternalLen; /* Length of the substituted parameter
|
||
* after conversion */
|
||
SQLRETURN rc; /* Return code from ODBC calls */
|
||
unsigned char* byteArrayPtr; /* Pointer to a BINARY or VARBINARY
|
||
* parameter, expressed as a byte array.*/
|
||
int i;
|
||
(void)dummy;
|
||
|
||
/* Check parameter count */
|
||
|
||
if (objc != skip+1 && objc != skip+2) {
|
||
Tcl_WrongNumArgs(interp, skip, objv, "statement ?dictionary?");
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/* Initialize superclasses */
|
||
|
||
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 an ODBC statement", NULL);
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/*
|
||
* If there is no transaction in progress, turn on auto-commit so that
|
||
* this statement will execute directly.
|
||
*/
|
||
|
||
cdata = sdata->cdata;
|
||
if ((cdata->flags & (CONNECTION_FLAG_XCN_ACTIVE
|
||
| CONNECTION_FLAG_AUTOCOMMIT)) == 0) {
|
||
cdata->flags |= CONNECTION_FLAG_AUTOCOMMIT;
|
||
if (SetAutocommitFlag(interp, cdata, 1) != TCL_OK) {
|
||
return TCL_ERROR;
|
||
}
|
||
}
|
||
|
||
/* Allocate an object to hold data about this result set */
|
||
|
||
rdata = (ResultSetData*) ckalloc(sizeof(ResultSetData));
|
||
rdata->refCount = 1;
|
||
rdata->sdata = sdata;
|
||
rdata->hStmt = NULL;
|
||
rdata->results = NULL;
|
||
rdata->resultColNames = NULL;
|
||
IncrStatementRefCount(sdata);
|
||
Tcl_ObjectSetMetadata(thisObject, &resultSetDataType, (ClientData) rdata);
|
||
|
||
/*
|
||
* 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 & STATEMENT_FLAG_HSTMT_BUSY) {
|
||
rdata->hStmt = AllocAndPrepareStatement(interp, sdata);
|
||
if (rdata->hStmt == NULL) {
|
||
return TCL_ERROR;
|
||
}
|
||
} else {
|
||
rdata->hStmt = sdata->hStmt;
|
||
sdata->flags |= STATEMENT_FLAG_HSTMT_BUSY;
|
||
}
|
||
|
||
/* Allocate an array to hold SQLWCHAR strings with parameter data */
|
||
|
||
Tcl_ListObjLength(NULL, sdata->subVars, &nParams);
|
||
rdata->bindStrings = (SQLCHAR**) ckalloc(nParams * sizeof(SQLCHAR*));
|
||
rdata->bindStringLengths = (SQLLEN*) ckalloc(nParams * sizeof(SQLLEN));
|
||
for (i = 0; i < nParams; ++i) {
|
||
rdata->bindStrings[i] = NULL;
|
||
rdata->bindStringLengths[i] = SQL_NULL_DATA;
|
||
}
|
||
|
||
/* 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);
|
||
|
||
}
|
||
|
||
/*
|
||
* Choose the C->SQL data conversion based on the parameter type
|
||
*/
|
||
|
||
if (paramValObj != NULL) {
|
||
|
||
switch (sdata->params[nBound].dataType) {
|
||
|
||
case SQL_NUMERIC:
|
||
case SQL_DECIMAL:
|
||
|
||
/*
|
||
* A generic 'numeric' type may fit in an int, wide,
|
||
* or double, and gets converted specially if it does.
|
||
*/
|
||
|
||
if (sdata->params[nBound].scale == 0) {
|
||
if (sdata->params[nBound].precision < 10) {
|
||
goto is_integer;
|
||
} else if (sdata->params[nBound].precision < 19
|
||
&& (cdata->flags & CONNECTION_FLAG_HAS_BIGINT)) {
|
||
goto is_wide;
|
||
} else {
|
||
/*
|
||
* It is tempting to convert wider integers as bignums,
|
||
* but Tcl does not yet export its copy of libtommath
|
||
* into the public API.
|
||
*/
|
||
goto is_string;
|
||
}
|
||
} else if (sdata->params[nBound].precision <= 15) {
|
||
goto is_float;
|
||
} else {
|
||
goto is_string;
|
||
}
|
||
|
||
case SQL_REAL:
|
||
case SQL_DOUBLE:
|
||
is_float:
|
||
|
||
/* Pass floating point numbers through to SQL without
|
||
* conversion */
|
||
|
||
rdata->bindStrings[nBound] =
|
||
(SQLCHAR*) ckalloc(sizeof(double));
|
||
if (Tcl_GetDoubleFromObj(interp, paramValObj,
|
||
(double*)(rdata->bindStrings[nBound]))
|
||
!= TCL_OK) {
|
||
ckfree((char*)(rdata->bindStrings[nBound]));
|
||
goto is_string;
|
||
}
|
||
dataType = SQL_C_DOUBLE;
|
||
paramExternalLen = sizeof(double);
|
||
rdata->bindStringLengths[nBound] = paramExternalLen;
|
||
break;
|
||
|
||
case SQL_BIGINT:
|
||
is_wide:
|
||
|
||
/* Pass 64-bit integers through to SQL without conversion */
|
||
|
||
rdata->bindStrings[nBound] =
|
||
(SQLCHAR*) ckalloc(sizeof(SQLBIGINT));
|
||
if (Tcl_GetWideIntFromObj(interp, paramValObj,
|
||
(SQLBIGINT*)
|
||
(rdata->bindStrings[nBound]))
|
||
!= TCL_OK) {
|
||
ckfree((char*)(rdata->bindStrings[nBound]));
|
||
goto is_string;
|
||
}
|
||
dataType = SQL_C_SBIGINT;
|
||
paramExternalLen = sizeof(SQLBIGINT);
|
||
rdata->bindStringLengths[nBound] = paramExternalLen;
|
||
break;
|
||
|
||
case SQL_INTEGER:
|
||
case SQL_SMALLINT:
|
||
case SQL_TINYINT:
|
||
case SQL_BIT:
|
||
is_integer:
|
||
|
||
/* Pass integers through to SQL without conversion */
|
||
|
||
rdata->bindStrings[nBound] =
|
||
(SQLCHAR*) ckalloc(sizeof(long));
|
||
if (Tcl_GetLongFromObj(interp, paramValObj,
|
||
(long*)(rdata->bindStrings[nBound]))
|
||
!= TCL_OK) {
|
||
ckfree((char*)(rdata->bindStrings[nBound]));
|
||
goto is_string;
|
||
}
|
||
dataType = SQL_C_LONG;
|
||
paramExternalLen = sizeof(long);
|
||
rdata->bindStringLengths[nBound] = paramExternalLen;
|
||
break;
|
||
|
||
case SQL_BINARY:
|
||
case SQL_VARBINARY:
|
||
case SQL_LONGVARBINARY:
|
||
|
||
/*
|
||
* Binary strings are shipped as byte arrays. It would
|
||
* be nice to avoid an extra copy, but it's possible
|
||
* for the byte array to shimmer away before ODBC has
|
||
* a chance to work with it.
|
||
*/
|
||
byteArrayPtr = Tcl_GetByteArrayFromObj(paramValObj,
|
||
¶mExternalLen);
|
||
dataType = SQL_C_BINARY;
|
||
rdata->bindStringLengths[nBound] = paramExternalLen;
|
||
rdata->bindStrings[nBound] =
|
||
(SQLCHAR*) ckalloc(paramExternalLen);
|
||
memcpy(rdata->bindStrings[nBound], byteArrayPtr,
|
||
paramExternalLen);
|
||
break;
|
||
|
||
default:
|
||
is_string:
|
||
|
||
/* Everything else is converted as a string */
|
||
|
||
if (cdata->flags & CONNECTION_FLAG_HAS_WVARCHAR) {
|
||
|
||
/* We prefer to transfer strings in Unicode if possible */
|
||
|
||
dataType = SQL_C_WCHAR;
|
||
rdata->bindStrings[nBound] = (SQLCHAR*)
|
||
GetWCharStringFromObj(paramValObj, ¶mLen);
|
||
rdata->bindStringLengths[nBound] = paramExternalLen =
|
||
paramLen * sizeofSQLWCHAR;
|
||
|
||
} else {
|
||
|
||
/*
|
||
* We need to convert the character string to system
|
||
* encoding and store in rdata->bindStrings[nBound].
|
||
*/
|
||
dataType = SQL_C_CHAR;
|
||
paramVal = Tcl_GetString(paramValObj);
|
||
paramLen = paramValObj->length;
|
||
Tcl_DStringInit(¶mExternal);
|
||
Tcl_UtfToExternalDString(NULL, paramVal, paramLen,
|
||
¶mExternal);
|
||
paramExternalLen = Tcl_DStringLength(¶mExternal);
|
||
rdata->bindStrings[nBound] = (SQLCHAR*)
|
||
ckalloc(paramExternalLen + 1);
|
||
memcpy(rdata->bindStrings[nBound],
|
||
Tcl_DStringValue(¶mExternal),
|
||
paramExternalLen + 1);
|
||
rdata->bindStringLengths[nBound] = paramExternalLen;
|
||
Tcl_DStringFree(¶mExternal);
|
||
}
|
||
|
||
}
|
||
|
||
} else {
|
||
|
||
/* Parameter is NULL */
|
||
|
||
dataType = SQL_C_CHAR;
|
||
rdata->bindStrings[nBound] = NULL;
|
||
paramExternalLen = paramLen = 0;
|
||
rdata->bindStringLengths[nBound] = SQL_NULL_DATA;
|
||
}
|
||
rc = SQLBindParameter(rdata->hStmt,
|
||
nBound + 1,
|
||
SQL_PARAM_INPUT, /* TODO - Fix this! */
|
||
dataType,
|
||
sdata->params[nBound].dataType,
|
||
sdata->params[nBound].precision,
|
||
sdata->params[nBound].scale,
|
||
rdata->bindStrings[nBound],
|
||
paramExternalLen,
|
||
rdata->bindStringLengths + nBound);
|
||
if (!SQL_SUCCEEDED(rc)) {
|
||
char* info = (char *)ckalloc(80 * strlen(paramName));
|
||
sprintf(info, "(binding the '%s' parameter)", paramName);
|
||
TransferSQLError(interp, SQL_HANDLE_STMT, rdata->hStmt, info);
|
||
ckfree(info);
|
||
return TCL_ERROR;
|
||
}
|
||
}
|
||
|
||
/* Execute the statement */
|
||
|
||
if (sdata->flags & STATEMENT_FLAG_TABLES) {
|
||
rc = SQLTablesW(rdata->hStmt, NULL, 0, NULL, 0,
|
||
sdata->nativeSqlW, sdata->nativeSqlLen, NULL, 0);
|
||
} else if (sdata->flags & STATEMENT_FLAG_COLUMNS) {
|
||
rc = SQLColumnsW(rdata->hStmt, NULL, 0, NULL, 0,
|
||
sdata->nativeSqlW, sdata->nativeSqlLen,
|
||
sdata->nativeMatchPatternW, sdata->nativeMatchPatLen);
|
||
} else if (sdata->flags & STATEMENT_FLAG_TYPES) {
|
||
rc = SQLGetTypeInfo(rdata->hStmt, sdata->typeNum);
|
||
} else if (sdata->flags & STATEMENT_FLAG_PRIMARYKEYS) {
|
||
rc = SQLPrimaryKeysW(rdata->hStmt, NULL, 0, NULL, 0,
|
||
sdata->nativeSqlW, sdata->nativeSqlLen);
|
||
} else if (sdata->flags & STATEMENT_FLAG_FOREIGNKEYS) {
|
||
rc = SQLForeignKeysW(rdata->hStmt, NULL, 0, NULL, 0,
|
||
sdata->nativeSqlW, sdata->nativeSqlLen,
|
||
NULL, 0, NULL, 0,
|
||
sdata->nativeMatchPatternW,
|
||
sdata->nativeMatchPatLen);
|
||
} else {
|
||
rc = SQLExecute(rdata->hStmt);
|
||
}
|
||
if (!SQL_SUCCEEDED(rc) && rc != SQL_NO_DATA) {
|
||
TransferSQLError(interp, SQL_HANDLE_STMT, rdata->hStmt,
|
||
"(executing the statement)");
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/* Extract the column information for the result set. */
|
||
|
||
if (GetResultSetDescription(interp, rdata) != TCL_OK) {
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/* Determine and store the row count. Note: iodbc makes it illegal
|
||
* to call SQLRowCount after an operation has returned SQL_NO_DATA,
|
||
* so bypass the SQLRowCount call if there are no results.
|
||
*/
|
||
|
||
if (rc == SQL_NO_DATA) {
|
||
rdata->rowCount = 0;
|
||
} else {
|
||
rc = SQLRowCount(rdata->hStmt, &(rdata->rowCount));
|
||
if (!SQL_SUCCEEDED(rc)) {
|
||
TransferSQLError(interp, SQL_HANDLE_STMT, rdata->hStmt,
|
||
"(counting rows in the result)");
|
||
return TCL_ERROR;
|
||
}
|
||
}
|
||
|
||
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 dummy, /* 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);
|
||
(void)dummy;
|
||
|
||
if (objc != 2) {
|
||
Tcl_WrongNumArgs(interp, 2, objv, "");
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/* Extract the column information for the result set. */
|
||
|
||
if (rdata->resultColNames == NULL) {
|
||
if (GetResultSetDescription(interp, rdata) != TCL_OK) {
|
||
return TCL_ERROR;
|
||
}
|
||
}
|
||
|
||
Tcl_SetObjResult(interp, rdata->resultColNames);
|
||
return TCL_OK;
|
||
|
||
}
|
||
|
||
/*
|
||
*-----------------------------------------------------------------------------
|
||
*
|
||
* ResultSetNextresultsMethod --
|
||
*
|
||
* Advances a result set to the next group of rows (next result set
|
||
* from a query that returns multiple result sets)
|
||
*
|
||
* Usage:
|
||
* $resultSet nextresults
|
||
*
|
||
* Parameters:
|
||
* None.
|
||
*
|
||
* Results:
|
||
* Returns a standard Tcl result. If successful, the result is '1' if
|
||
* more results remain and '0' if no more results remain. In the event
|
||
* of failure, the result is a Tcl error message describing the problem.
|
||
*
|
||
*-----------------------------------------------------------------------------
|
||
*/
|
||
|
||
static int
|
||
ResultSetNextresultsMethod(
|
||
ClientData dummy, /* 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 */
|
||
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 */
|
||
SQLRETURN rc; /* Return code from ODBC operations */
|
||
(void)dummy;
|
||
(void)objc;
|
||
(void)objv;
|
||
|
||
/*
|
||
* Once we are advancing the results, any data that we think we know
|
||
* about the columns in the result set are incorrect. Discard them.
|
||
*/
|
||
|
||
DeleteResultSetDescription(rdata);
|
||
|
||
/* Advance to the next results */
|
||
|
||
rc = SQLMoreResults(rdata->hStmt);
|
||
if (rc == SQL_NO_DATA) {
|
||
Tcl_SetObjResult(interp, literals[LIT_0]);
|
||
return TCL_OK;
|
||
}
|
||
if (!SQL_SUCCEEDED(rc)) {
|
||
TransferSQLError(interp, SQL_HANDLE_STMT, rdata->hStmt,
|
||
"(advancing to next result set)");
|
||
return TCL_ERROR;
|
||
}
|
||
if (GetResultSetDescription(interp, rdata) != TCL_OK) {
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/* Determine and store the row count */
|
||
|
||
rc = SQLRowCount(rdata->hStmt, &(rdata->rowCount));
|
||
if (!SQL_SUCCEEDED(rc)) {
|
||
TransferSQLError(interp, SQL_HANDLE_STMT, rdata->hStmt,
|
||
"(counting rows in the result)");
|
||
return TCL_ERROR;
|
||
} else {
|
||
Tcl_SetObjResult(interp, literals[LIT_1]);
|
||
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, /* 1 if lists are to be returned, 0 if
|
||
* dicts are to be returned */
|
||
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; /* 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 */
|
||
SQLRETURN rc; /* Return code from ODBC operations */
|
||
int status = TCL_ERROR; /* Status return from this command */
|
||
|
||
int i;
|
||
|
||
if (objc != 3) {
|
||
Tcl_WrongNumArgs(interp, 2, objv, "varName");
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/* Extract the column information for the result set. */
|
||
|
||
if (rdata->resultColNames == NULL) {
|
||
if (GetResultSetDescription(interp, rdata) != TCL_OK) {
|
||
return TCL_ERROR;
|
||
}
|
||
}
|
||
Tcl_ListObjLength(NULL, rdata->resultColNames, &nColumns);
|
||
if (nColumns == 0) {
|
||
Tcl_SetObjResult(interp, literals[LIT_0]);
|
||
return TCL_OK;
|
||
}
|
||
|
||
/* Advance to the next row of the result set */
|
||
|
||
rc = SQLFetch(rdata->hStmt);
|
||
if (rc == SQL_NO_DATA) {
|
||
Tcl_SetObjResult(interp, literals[LIT_0]);
|
||
return TCL_OK;
|
||
} else if (!SQL_SUCCEEDED(rc)) {
|
||
TransferSQLError(interp, SQL_HANDLE_STMT, rdata->hStmt,
|
||
"(fetching the next row of the result set)");
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/* Walk through the current row, storing data for each column */
|
||
|
||
resultRow = Tcl_NewObj();
|
||
Tcl_IncrRefCount(resultRow);
|
||
for (i = 0; i < nColumns; ++i) {
|
||
if (GetCell(rdata, interp, i, &colObj) != TCL_OK) {
|
||
goto cleanup;
|
||
}
|
||
|
||
if (lists) {
|
||
if (colObj == NULL) {
|
||
colObj = Tcl_NewObj();
|
||
}
|
||
Tcl_ListObjAppendElement(NULL, resultRow, colObj);
|
||
} else {
|
||
if (colObj != NULL) {
|
||
Tcl_ListObjIndex(NULL, rdata->resultColNames, 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:
|
||
Tcl_DecrRefCount(resultRow);
|
||
return status;
|
||
}
|
||
|
||
/*
|
||
*-----------------------------------------------------------------------------
|
||
*
|
||
* GetCell --
|
||
*
|
||
* Service procedure to retrieve a single column in a row of a result
|
||
* set.
|
||
*
|
||
* Results:
|
||
* Returns a standard Tcl result.
|
||
*
|
||
* Side effects:
|
||
* If the result is TCL_OK, the column value is stored in *colObjPtr,
|
||
* with a zero refcount. (If the column value is NULL, NULL is stored.)
|
||
* If the result is TCL_ERROR, *colObjPtr is left alone, but an error
|
||
* message is stored in the interpreter result.
|
||
*
|
||
*-----------------------------------------------------------------------------
|
||
*/
|
||
|
||
static int
|
||
GetCell(
|
||
ResultSetData* rdata, /* Instance data for the result set */
|
||
Tcl_Interp* interp, /* Tcl interpreter */
|
||
int i, /* Column position */
|
||
Tcl_Obj** colObjPtr /* Returned: Tcl_Obj containing the content
|
||
* or NULL */
|
||
) {
|
||
|
||
#define BUFSIZE 256
|
||
StatementData* sdata = rdata->sdata;
|
||
ConnectionData* cdata = sdata->cdata;
|
||
SQLSMALLINT dataType; /* Type of character data to retrieve */
|
||
SQLWCHAR colWBuf[(BUFSIZE+1)*2];
|
||
/* Buffer to hold the string value of a
|
||
* column */
|
||
SQLCHAR* colBuf = (SQLCHAR*) colWBuf;
|
||
SQLCHAR* colPtr = colBuf; /* Pointer to the current allocated buffer
|
||
* (which may have grown) */
|
||
SQLLEN colAllocLen = BUFSIZE * sizeofSQLWCHAR;
|
||
/* Current allocated size of the buffer,
|
||
* in bytes */
|
||
SQLLEN colLen; /* Actual size of the return value, in bytes */
|
||
SQLINTEGER colLong; /* Integer value of the column */
|
||
SQLBIGINT colWide; /* Wide-integer value of the column */
|
||
SQLDOUBLE colDouble; /* Double value of the column */
|
||
Tcl_DString colDS; /* Column expressed as a Tcl_DString */
|
||
Tcl_Obj* colObj; /* Column expressed as a Tcl_Obj */
|
||
SQLRETURN rc; /* ODBC result code */
|
||
int retry; /* Flag that the last ODBC operation should
|
||
* be retried */
|
||
SQLINTEGER offset; /* Offset in the buffer for retrying large
|
||
* object operations */
|
||
|
||
colObj = NULL;
|
||
*colObjPtr = NULL;
|
||
switch(rdata->results[i].dataType) {
|
||
/* TODO: Need to return binary data as byte arrays. */
|
||
|
||
case SQL_NUMERIC:
|
||
case SQL_DECIMAL:
|
||
|
||
/*
|
||
* A generic 'numeric' type may fit in an int, wide,
|
||
* or double, and gets converted specially if it does.
|
||
*/
|
||
|
||
if (rdata->results[i].scale == 0) {
|
||
if (rdata->results[i].precision < 10) {
|
||
goto convertLong;
|
||
} else if (rdata->results[i].precision < 19
|
||
&& (cdata->flags & CONNECTION_FLAG_HAS_BIGINT)) {
|
||
goto convertWide;
|
||
} else {
|
||
/*
|
||
* It is tempting to convert wider integers as bignums,
|
||
* but Tcl does not yet export its copy of libtommath
|
||
* into the public API.
|
||
*/
|
||
goto convertUnknown;
|
||
}
|
||
} else if (rdata->results[i].precision <= 15) {
|
||
goto convertDouble;
|
||
} else {
|
||
goto convertUnknown;
|
||
}
|
||
|
||
case SQL_BIGINT:
|
||
convertWide:
|
||
/* A wide integer */
|
||
colLen = sizeof(colWide); colWide = 0;
|
||
rc = SQLGetData(rdata->hStmt, i+1, SQL_C_SBIGINT,
|
||
(SQLPOINTER) &colWide, sizeof(colWide), &colLen);
|
||
if (!SQL_SUCCEEDED(rc)) {
|
||
char info[80];
|
||
sprintf(info, "(retrieving result set column #%d)\n", i+1);
|
||
TransferSQLError(interp, SQL_HANDLE_STMT, rdata->hStmt, info);
|
||
return TCL_ERROR;
|
||
}
|
||
if (colLen != SQL_NULL_DATA && colLen != SQL_NO_TOTAL) {
|
||
colObj = Tcl_NewWideIntObj((Tcl_WideInt)colWide);
|
||
}
|
||
break;
|
||
|
||
case SQL_BIT:
|
||
case SQL_INTEGER:
|
||
case SQL_SMALLINT:
|
||
case SQL_TINYINT:
|
||
convertLong:
|
||
/* An integer no larger than 'long' */
|
||
colLen = sizeof(colLong); colLong = 0;
|
||
rc = SQLGetData(rdata->hStmt, i+1, SQL_C_SLONG,
|
||
(SQLPOINTER) &colLong, sizeof(colLong), &colLen);
|
||
if (!SQL_SUCCEEDED(rc)) {
|
||
char info[80];
|
||
sprintf(info, "(retrieving result set column #%d)\n", i+1);
|
||
TransferSQLError(interp, SQL_HANDLE_STMT, rdata->hStmt, info);
|
||
ckfree(info);
|
||
return TCL_ERROR;
|
||
}
|
||
if (colLen != SQL_NULL_DATA && colLen != SQL_NO_TOTAL) {
|
||
colObj = Tcl_NewWideIntObj(colLong);
|
||
}
|
||
break;
|
||
|
||
case SQL_FLOAT:
|
||
/*
|
||
* A 'float' is converted to a 'double' if it fits;
|
||
* to a string, otherwise.
|
||
*/
|
||
if (rdata->results[i].precision <= 53) {
|
||
goto convertDouble;
|
||
} else {
|
||
goto convertUnknown;
|
||
}
|
||
|
||
case SQL_REAL:
|
||
case SQL_DOUBLE:
|
||
convertDouble:
|
||
/*
|
||
* A single- or double-precision floating point number.
|
||
* Reals are widened to doubles.
|
||
*/
|
||
colLen = sizeof(colDouble); colDouble = 0.0;
|
||
rc = SQLGetData(rdata->hStmt, i+1, SQL_C_DOUBLE,
|
||
(SQLPOINTER) &colDouble, sizeof(colDouble),
|
||
&colLen);
|
||
if (!SQL_SUCCEEDED(rc)) {
|
||
char info[80];
|
||
sprintf(info, "(retrieving result set column #%d)\n", i+1);
|
||
TransferSQLError(interp, SQL_HANDLE_STMT, rdata->hStmt, info);
|
||
ckfree(info);
|
||
return TCL_ERROR;
|
||
}
|
||
if (colLen != SQL_NULL_DATA && colLen != SQL_NO_TOTAL) {
|
||
colObj = Tcl_NewDoubleObj(colDouble);
|
||
}
|
||
break;
|
||
|
||
case SQL_CHAR:
|
||
case SQL_VARCHAR:
|
||
case SQL_LONGVARCHAR:
|
||
dataType = SQL_C_CHAR;
|
||
goto convertString;
|
||
|
||
case SQL_WCHAR:
|
||
case SQL_WVARCHAR:
|
||
case SQL_WLONGVARCHAR:
|
||
dataType = SQL_C_WCHAR;
|
||
goto convertString;
|
||
|
||
case SQL_BINARY:
|
||
case SQL_VARBINARY:
|
||
case SQL_LONGVARBINARY:
|
||
dataType = SQL_C_BINARY;
|
||
goto convertString;
|
||
|
||
default:
|
||
convertUnknown:
|
||
if (cdata->flags & CONNECTION_FLAG_HAS_WVARCHAR) {
|
||
dataType = SQL_C_WCHAR;
|
||
} else {
|
||
dataType = SQL_C_CHAR;
|
||
}
|
||
goto convertString;
|
||
|
||
convertString:
|
||
/* Anything else is converted as a string */
|
||
offset = 0;
|
||
retry = 0;
|
||
do {
|
||
retry = 0;
|
||
/*
|
||
* It's possible that SQLGetData won't update colLen if
|
||
* SQL_ERROR is returned. Store a background of zero so
|
||
* that it's always initialized.
|
||
*/
|
||
colLen = 0;
|
||
|
||
/* Try to get the string */
|
||
|
||
rc = SQLGetData(rdata->hStmt, i+1, dataType,
|
||
(SQLPOINTER) (((char*)colPtr)+offset),
|
||
colAllocLen - offset,
|
||
&colLen);
|
||
if (rc == SQL_SUCCESS_WITH_INFO
|
||
&& SQLStateIs(SQL_HANDLE_STMT, rdata->hStmt, "01004")) {
|
||
/*
|
||
* The requested buffer was too small to hold the
|
||
* data.
|
||
*/
|
||
offset = colAllocLen;
|
||
if (dataType == SQL_C_BINARY) {
|
||
/* no NULL terminator */
|
||
} else if (dataType == SQL_C_CHAR) {
|
||
--offset;
|
||
} else {
|
||
offset -= sizeofSQLWCHAR;
|
||
}
|
||
if (colLen == SQL_NO_TOTAL) {
|
||
/*
|
||
* The driver wouldn't tell us how much space was
|
||
* needed, but we got a full bufferload (less the
|
||
* terminating NULL character)
|
||
*/
|
||
colAllocLen = 2 * colAllocLen;
|
||
} else {
|
||
colAllocLen += colLen;
|
||
}
|
||
if (colPtr == colBuf) {
|
||
colPtr = (SQLCHAR*) ckalloc(colAllocLen + sizeofSQLWCHAR);
|
||
memcpy(colPtr, colBuf, BUFSIZE * sizeofSQLWCHAR);
|
||
} else {
|
||
colPtr = (SQLCHAR*)
|
||
ckrealloc((char*)colPtr, colAllocLen + sizeofSQLWCHAR);
|
||
}
|
||
retry = 1;
|
||
}
|
||
} while (retry);
|
||
if (!SQL_SUCCEEDED(rc)) {
|
||
char info[80];
|
||
sprintf(info, "(retrieving result set column #%d)\n", i+1);
|
||
TransferSQLError(interp, SQL_HANDLE_STMT, rdata->hStmt, info);
|
||
if (colPtr != colBuf) {
|
||
ckfree((char*) colPtr);
|
||
}
|
||
return TCL_ERROR;
|
||
}
|
||
if (colLen >= 0) {
|
||
Tcl_DStringInit(&colDS);
|
||
if (dataType == SQL_C_BINARY) {
|
||
colObj = Tcl_NewByteArrayObj((const unsigned char*) colPtr,
|
||
(int) (colLen + offset));
|
||
} else {
|
||
if (dataType == SQL_C_CHAR) {
|
||
Tcl_ExternalToUtfDString(NULL, (char*) colPtr,
|
||
(int) (colLen + offset),
|
||
&colDS);
|
||
} else {
|
||
DStringAppendWChars(&colDS, (SQLWCHAR*) colPtr,
|
||
(int)((colLen + offset)
|
||
/ sizeofSQLWCHAR));
|
||
}
|
||
colObj = Tcl_NewStringObj(Tcl_DStringValue(&colDS),
|
||
Tcl_DStringLength(&colDS));
|
||
Tcl_DStringFree(&colDS);
|
||
}
|
||
}
|
||
if (colPtr != colBuf) {
|
||
ckfree((char*) colPtr);
|
||
}
|
||
break;
|
||
|
||
} /* end of switch */
|
||
|
||
*colObjPtr = colObj;
|
||
return TCL_OK;
|
||
}
|
||
|
||
/*
|
||
*-----------------------------------------------------------------------------
|
||
*
|
||
* ResultSetRowcountMethod --
|
||
*
|
||
* Returns (if known) the number of rows affected by an ODBC statement.
|
||
*
|
||
* Usage:
|
||
* $resultSet rowcount
|
||
*
|
||
* Results:
|
||
* Returns a standard Tcl result giving the number of affected rows.
|
||
*
|
||
*-----------------------------------------------------------------------------
|
||
*/
|
||
|
||
static int
|
||
ResultSetRowcountMethod(
|
||
ClientData dummy, /* 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 */
|
||
(void)dummy;
|
||
|
||
if (objc != 2) {
|
||
Tcl_WrongNumArgs(interp, 2, objv, "");
|
||
return TCL_ERROR;
|
||
}
|
||
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(rdata->rowCount));
|
||
return TCL_OK;
|
||
}
|
||
|
||
/*
|
||
*-----------------------------------------------------------------------------
|
||
*
|
||
* DeleteResultSetMetadata, DeleteResultSet --
|
||
*
|
||
* Cleans up when an ODBC 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;
|
||
FreeBoundParameters(rdata);
|
||
if (rdata->hStmt != NULL) {
|
||
if (rdata->hStmt != sdata->hStmt) {
|
||
SQLFreeHandle(SQL_HANDLE_STMT, rdata->hStmt);
|
||
} else {
|
||
SQLCloseCursor(rdata->hStmt);
|
||
sdata->flags &= ~STATEMENT_FLAG_HSTMT_BUSY;
|
||
}
|
||
}
|
||
DeleteResultSetDescription(rdata);
|
||
DecrStatementRefCount(rdata->sdata);
|
||
ckfree((char*)rdata);
|
||
}
|
||
static void
|
||
DeleteResultSetDescription(
|
||
ResultSetData* rdata /* Metadata for the result set */
|
||
) {
|
||
if (rdata->resultColNames != NULL) {
|
||
Tcl_DecrRefCount(rdata->resultColNames);
|
||
rdata->resultColNames = NULL;
|
||
}
|
||
if (rdata->results != NULL) {
|
||
ckfree((char*) (rdata->results));
|
||
rdata->results = NULL;
|
||
}
|
||
}
|
||
|
||
|
||
/*
|
||
*-----------------------------------------------------------------------------
|
||
*
|
||
* CloneResultSet --
|
||
*
|
||
* Attempts to clone an ODBC 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 */
|
||
) {
|
||
(void)metadata;
|
||
(void)newMetaData;
|
||
|
||
Tcl_SetObjResult(interp,
|
||
Tcl_NewStringObj("ODBC result sets are not clonable", -1));
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/*
|
||
*-----------------------------------------------------------------------------
|
||
*
|
||
* FreeBoundParameters --
|
||
*
|
||
* Frees the bound parameters in a result set after it has been executed
|
||
* or when an error prevents its execution
|
||
*
|
||
*-----------------------------------------------------------------------------
|
||
*/
|
||
|
||
static void
|
||
FreeBoundParameters(
|
||
ResultSetData* rdata /* Result set being abandoned */
|
||
) {
|
||
int nParams;
|
||
int i;
|
||
if (rdata->bindStrings != NULL) {
|
||
Tcl_ListObjLength(NULL, rdata->sdata->subVars, &nParams);
|
||
for (i = 0; i < nParams; ++i) {
|
||
if (rdata->bindStrings[i] != NULL) {
|
||
ckfree((char*) rdata->bindStrings[i]);
|
||
}
|
||
}
|
||
ckfree((char*) rdata->bindStrings);
|
||
ckfree((char*) rdata->bindStringLengths);
|
||
rdata->bindStrings = NULL;
|
||
}
|
||
}
|
||
|
||
/*
|
||
*-----------------------------------------------------------------------------
|
||
*
|
||
* Datasources_ObjCmd --
|
||
*
|
||
* Enumerates the ODBC data sources.
|
||
*
|
||
* Usage:
|
||
*
|
||
* tdbc::odbc::datasources ?-system | -user?
|
||
*
|
||
* Results:
|
||
* Returns a dictionary whose keys are the names of data sources and
|
||
* whose values are data source descriptions.
|
||
*
|
||
* The -system flag restricts the data sources to system data sources;
|
||
* the -user flag to user data sources. If no flag is specified, both types
|
||
* are returned.
|
||
*
|
||
*-----------------------------------------------------------------------------
|
||
*/
|
||
|
||
static int
|
||
DatasourcesObjCmd(
|
||
ClientData clientData, /* Opaque pointer to per-interp data */
|
||
Tcl_Interp* interp, /* Tcl interpreter */
|
||
int objc, /* Parameter count */
|
||
Tcl_Obj *const objv[] /* Parameter vector */
|
||
) {
|
||
PerInterpData* pidata = (PerInterpData*) clientData;
|
||
SQLSMALLINT initDirection = SQL_FETCH_FIRST;
|
||
SQLSMALLINT direction;
|
||
static const struct flag {
|
||
const char* name;
|
||
SQLSMALLINT value;
|
||
} flags[] = {
|
||
{ "-system", SQL_FETCH_FIRST_SYSTEM },
|
||
{ "-user", SQL_FETCH_FIRST_USER },
|
||
{ NULL, 0 }
|
||
};
|
||
int flagIndex;
|
||
SQLRETURN rc; /* SQL result code */
|
||
SQLWCHAR serverName[(SQL_MAX_DSN_LENGTH+1)*2];
|
||
/* Data source name */
|
||
SQLSMALLINT serverNameLen; /* Length of the DSN */
|
||
SQLWCHAR *description; /* Data source descroption */
|
||
SQLSMALLINT descLen; /* Length of the description */
|
||
SQLSMALLINT descAllocLen; /* Allocated size of the description */
|
||
SQLSMALLINT descLenNeeded; /* Length needed for the description */
|
||
Tcl_Obj* retval; /* Return value */
|
||
Tcl_DString nameDS; /* Buffer for a name or description */
|
||
Tcl_Obj* nameObj; /* Name or description as a Tcl object */
|
||
int finished; /* Flag == 1 if a complete list of data
|
||
* sources has been constructed */
|
||
int status = TCL_OK; /* Status return from this call */
|
||
|
||
/* Get the argument */
|
||
|
||
if (objc > 2) {
|
||
Tcl_WrongNumArgs(interp, 1, objv, "?-system|-user?");
|
||
return TCL_ERROR;
|
||
}
|
||
if (objc == 2) {
|
||
if (Tcl_GetIndexFromObjStruct(interp, objv[1], (const void*) flags,
|
||
sizeof(struct flag),
|
||
"option", 0, &flagIndex) != TCL_OK) {
|
||
return TCL_ERROR;
|
||
}
|
||
initDirection = flags[flagIndex].value;
|
||
}
|
||
|
||
/* Allocate memory */
|
||
|
||
retval = Tcl_NewObj();
|
||
Tcl_IncrRefCount(retval);
|
||
descLenNeeded = 32;
|
||
finished = 0;
|
||
|
||
while (!finished) {
|
||
|
||
direction = initDirection;
|
||
finished = 1;
|
||
descAllocLen = descLenNeeded;
|
||
description = (SQLWCHAR*)
|
||
ckalloc(sizeofSQLWCHAR * (descAllocLen + 1));
|
||
Tcl_SetListObj(retval, 0, NULL);
|
||
|
||
/* Enumerate the data sources */
|
||
|
||
while (1) {
|
||
rc = SQLDataSourcesW(pidata->hEnv, direction, serverName,
|
||
SQL_MAX_DSN_LENGTH + 1, &serverNameLen,
|
||
description, descAllocLen, &descLen);
|
||
direction = SQL_FETCH_NEXT;
|
||
|
||
if (rc == SQL_SUCCESS_WITH_INFO && descLen > descLenNeeded) {
|
||
|
||
/* The description buffer wasn't big enough. */
|
||
|
||
descLenNeeded = 2 * descLen;
|
||
finished = 0;
|
||
break;
|
||
|
||
} else if (SQL_SUCCEEDED(rc)) {
|
||
|
||
/* Got a data source; add key and value to the dictionary */
|
||
|
||
Tcl_DStringInit(&nameDS);
|
||
DStringAppendWChars(&nameDS, serverName, serverNameLen);
|
||
nameObj = Tcl_NewStringObj(Tcl_DStringValue(&nameDS),
|
||
Tcl_DStringLength(&nameDS));
|
||
Tcl_ListObjAppendElement(NULL, retval, nameObj);
|
||
Tcl_DStringFree(&nameDS);
|
||
|
||
Tcl_DStringInit(&nameDS);
|
||
DStringAppendWChars(&nameDS, description, descLen);
|
||
nameObj = Tcl_NewStringObj(Tcl_DStringValue(&nameDS),
|
||
Tcl_DStringLength(&nameDS));
|
||
Tcl_ListObjAppendElement(NULL, retval, nameObj);
|
||
Tcl_DStringFree(&nameDS);
|
||
|
||
} else if (rc == SQL_NO_DATA) {
|
||
|
||
/* End of data sources */
|
||
|
||
if (finished) {
|
||
Tcl_SetObjResult(interp, retval);
|
||
status = TCL_OK;
|
||
}
|
||
break;
|
||
|
||
} else {
|
||
|
||
/* Anything else is an error */
|
||
|
||
TransferSQLError(interp, SQL_HANDLE_ENV, pidata->hEnv,
|
||
"(retrieving data source names)");
|
||
status = TCL_ERROR;
|
||
finished = 1;
|
||
break;
|
||
}
|
||
}
|
||
|
||
ckfree((char*) description);
|
||
}
|
||
Tcl_DecrRefCount(retval);
|
||
|
||
return status;
|
||
}
|
||
|
||
/*
|
||
*-----------------------------------------------------------------------------
|
||
*
|
||
* Drivers_ObjCmd --
|
||
*
|
||
* Enumerates the ODBC drivers.
|
||
*
|
||
* Usage:
|
||
*
|
||
* tdbc::odbc::drivers
|
||
*
|
||
* Results:
|
||
* Returns a dictionary whose keys are the names of drivers and
|
||
* whose values are lists of attributes
|
||
*
|
||
*-----------------------------------------------------------------------------
|
||
*/
|
||
|
||
static int
|
||
DriversObjCmd(
|
||
ClientData clientData, /* Opaque pointer to per-interp data */
|
||
Tcl_Interp* interp, /* Tcl interpreter */
|
||
int objc, /* Parameter count */
|
||
Tcl_Obj *const objv[] /* Parameter vector */
|
||
) {
|
||
PerInterpData* pidata = (PerInterpData*) clientData;
|
||
SQLSMALLINT direction;
|
||
SQLRETURN rc; /* SQL result code */
|
||
SQLWCHAR *driver; /* Driver name */
|
||
SQLSMALLINT driverLen = 0; /* Length of the driver name */
|
||
SQLSMALLINT driverAllocLen; /* Allocated size of the driver name */
|
||
SQLSMALLINT driverLenNeeded; /* Required size of the driver name */
|
||
SQLWCHAR *attributes; /* Driver attributes */
|
||
SQLSMALLINT attrLen = 0; /* Length of the driver attributes */
|
||
SQLSMALLINT attrAllocLen; /* Allocated size of the driver attributes */
|
||
SQLSMALLINT attrLenNeeded; /* Length needed for the driver attributes */
|
||
Tcl_Obj* retval; /* Return value */
|
||
Tcl_Obj* attrObj; /* Tcl object to hold driver attribute list */
|
||
Tcl_DString nameDS; /* Buffer for a name or attribute */
|
||
Tcl_Obj* nameObj; /* Name or attribute as a Tcl object */
|
||
int finished; /* Flag == 1 if a complete list of drivers
|
||
* has been constructed */
|
||
int status = TCL_OK; /* Status return from this call */
|
||
int i, j;
|
||
|
||
/* Get the argument */
|
||
|
||
if (objc > 1) {
|
||
Tcl_WrongNumArgs(interp, 1, objv, "");
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/* Allocate memory */
|
||
|
||
retval = Tcl_NewObj();
|
||
Tcl_IncrRefCount(retval);
|
||
driverLenNeeded = 32;
|
||
attrLenNeeded = 32;
|
||
finished = 0;
|
||
|
||
while (!finished) {
|
||
|
||
finished = 1;
|
||
driverAllocLen = driverLenNeeded;
|
||
driver = (SQLWCHAR*)
|
||
ckalloc(sizeofSQLWCHAR * (driverAllocLen + 1));
|
||
*driver = 0;
|
||
attrAllocLen = attrLenNeeded;
|
||
attributes = (SQLWCHAR*)
|
||
ckalloc(sizeofSQLWCHAR * (attrAllocLen + 1));
|
||
*attributes = 0;
|
||
Tcl_SetListObj(retval, 0, NULL);
|
||
direction = SQL_FETCH_FIRST;
|
||
|
||
/* Enumerate the data sources */
|
||
|
||
while (1) {
|
||
rc = SQLDriversW(pidata->hEnv, direction, driver,
|
||
driverAllocLen, &driverLen,
|
||
attributes, attrAllocLen, &attrLen);
|
||
direction = SQL_FETCH_NEXT;
|
||
|
||
if (rc == SQL_SUCCESS_WITH_INFO && driverLen > driverLenNeeded) {
|
||
|
||
/* The description buffer wasn't big enough. */
|
||
|
||
driverLenNeeded = 2 * driverLen;
|
||
finished = 0;
|
||
break;
|
||
}
|
||
if (rc == SQL_SUCCESS_WITH_INFO && attrLen > attrLenNeeded) {
|
||
|
||
/* The attributes buffer wasn't big enough. */
|
||
|
||
attrLenNeeded = 2 * attrLen;
|
||
finished = 0;
|
||
break;
|
||
}
|
||
|
||
if (finished) {
|
||
if (SQL_SUCCEEDED(rc)) {
|
||
|
||
/* Got a data source; add key and value to the dictionary */
|
||
|
||
Tcl_DStringInit(&nameDS);
|
||
DStringAppendWChars(&nameDS, driver, driverLen);
|
||
nameObj = Tcl_NewStringObj(Tcl_DStringValue(&nameDS),
|
||
Tcl_DStringLength(&nameDS));
|
||
Tcl_ListObjAppendElement(NULL, retval, nameObj);
|
||
Tcl_DStringFree(&nameDS);
|
||
|
||
/*
|
||
* Attributes are a set of U+0000-terminated
|
||
* strings, ending with an extra U+0000
|
||
*/
|
||
attrObj = Tcl_NewObj();
|
||
for (i = 0; attributes[i] != 0; ) {
|
||
for (j = i; attributes[j] != 0; ++j) {
|
||
/* do nothing */
|
||
}
|
||
Tcl_DStringInit(&nameDS);
|
||
DStringAppendWChars(&nameDS, attributes+i, j-i);
|
||
nameObj = Tcl_NewStringObj(Tcl_DStringValue(&nameDS),
|
||
Tcl_DStringLength(&nameDS));
|
||
Tcl_ListObjAppendElement(NULL, attrObj, nameObj);
|
||
Tcl_DStringFree(&nameDS);
|
||
i = j + 1;
|
||
}
|
||
Tcl_ListObjAppendElement(NULL, retval, attrObj);
|
||
|
||
} else if (rc == SQL_NO_DATA) {
|
||
|
||
/* End of data sources */
|
||
|
||
if (finished) {
|
||
Tcl_SetObjResult(interp, retval);
|
||
status = TCL_OK;
|
||
}
|
||
break;
|
||
|
||
} else {
|
||
|
||
/* Anything else is an error */
|
||
|
||
TransferSQLError(interp, SQL_HANDLE_ENV, pidata->hEnv,
|
||
"(retrieving data source names)");
|
||
status = TCL_ERROR;
|
||
finished = 1;
|
||
break;
|
||
}
|
||
}
|
||
}
|
||
ckfree((char*) driver);
|
||
ckfree((char*) attributes);
|
||
}
|
||
Tcl_DecrRefCount(retval);
|
||
|
||
return status;
|
||
}
|
||
|
||
/*
|
||
*-----------------------------------------------------------------------------
|
||
*
|
||
* DatasourceObjCmdW --
|
||
*
|
||
* Command that does configuration of ODBC data sources when the
|
||
* ODBCCP32 library supports Unicode
|
||
*
|
||
* Usage:
|
||
* ::tdbc::odbc::datasource subcommand driver ?keyword=value?...
|
||
*
|
||
* Parameters:
|
||
* subcommand - One of 'add', 'add_system', 'configure',
|
||
* 'configure_system', 'remove', or 'remove_system'
|
||
* driver - Name of the ODBC driver to use in configuring the data source.
|
||
* keyword=value - Keyword-value pairs as defined by the driver.
|
||
*
|
||
* Results:
|
||
* Returns a standard Tcl result, which is empty if the operation
|
||
* is successful.
|
||
*
|
||
*-----------------------------------------------------------------------------
|
||
*/
|
||
|
||
static int
|
||
DatasourceObjCmdW(
|
||
ClientData dummy, /* Unused */
|
||
Tcl_Interp* interp, /* Tcl interpreter */
|
||
int objc, /* Parameter count */
|
||
Tcl_Obj *const objv[] /* Parameter vector */
|
||
) {
|
||
static const struct flag {
|
||
const char* name;
|
||
WORD value;
|
||
} flags[] = {
|
||
{ "add", ODBC_ADD_DSN },
|
||
{ "add_system", ODBC_ADD_SYS_DSN },
|
||
{ "configure", ODBC_CONFIG_DSN },
|
||
{ "configure_system", ODBC_CONFIG_SYS_DSN },
|
||
{ "remove", ODBC_REMOVE_DSN },
|
||
{ "remove_system", ODBC_REMOVE_SYS_DSN },
|
||
{ NULL, 0 }
|
||
};
|
||
int flagIndex; /* Index of the subcommand */
|
||
WCHAR* driverName; /* Name of the ODBC driver */
|
||
WCHAR* attributes; /* NULL-delimited attribute values */
|
||
char errorMessage[SQL_MAX_MESSAGE_LENGTH+1];
|
||
/* Error message from ODBC operations */
|
||
size_t driverNameLen; /* Length of the driver name */
|
||
Tcl_Obj* attrObj; /* NULL-delimited attribute values */
|
||
size_t attrLen; /* Length of the attribute values */
|
||
const char* sep; /* Separator for attribute values */
|
||
DWORD errorCode; /* Error code */
|
||
WORD errorMessageLen; /* Length of the returned error message */
|
||
RETCODE errorMessageStatus; /* Status of the error message formatting */
|
||
Tcl_DString retvalDS; /* Return value */
|
||
Tcl_DString errorMessageDS; /* DString to convert error message
|
||
* from system encoding */
|
||
Tcl_Obj* errorCodeObj; /* Tcl error code */
|
||
int i, j;
|
||
BOOL ok;
|
||
int status = TCL_OK;
|
||
int finished = 0;
|
||
(void)dummy;
|
||
|
||
/* Check args */
|
||
|
||
if (objc < 4) {
|
||
Tcl_WrongNumArgs(interp, 1, objv,
|
||
"operation driver ?keyword=value?...");
|
||
return TCL_ERROR;
|
||
}
|
||
if (Tcl_GetIndexFromObjStruct(interp, objv[1], flags, sizeof(struct flag),
|
||
"operation", 0, &flagIndex) != TCL_OK) {
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/* Convert driver name to the appropriate encoding */
|
||
|
||
driverName = GetWCharStringFromObj(objv[2], &driverNameLen);
|
||
|
||
/*
|
||
* Convert driver attributes to the appropriate encoding, separated
|
||
* by NUL bytes.
|
||
*/
|
||
|
||
attrObj = Tcl_NewObj();
|
||
Tcl_IncrRefCount(attrObj);
|
||
sep = "";
|
||
for (i = 3; i < objc; ++i) {
|
||
Tcl_AppendToObj(attrObj, sep, -1);
|
||
Tcl_AppendObjToObj(attrObj, objv[i]);
|
||
sep = "\xc0\x80";
|
||
}
|
||
Tcl_AppendToObj(attrObj, "\xc0\x80", 2);
|
||
attributes = GetWCharStringFromObj(attrObj, &attrLen);
|
||
Tcl_DecrRefCount(attrObj);
|
||
|
||
/*
|
||
* Configure the data source
|
||
*/
|
||
|
||
ok = SQLConfigDataSourceW(NULL, flags[flagIndex].value,
|
||
driverName, attributes);
|
||
ckfree((char*) attributes);
|
||
ckfree((char*) driverName);
|
||
|
||
/* Check the ODBC status return */
|
||
|
||
if (!ok) {
|
||
status = TCL_ERROR;
|
||
i = 1;
|
||
sep = "";
|
||
Tcl_DStringInit(&retvalDS);
|
||
errorCodeObj = Tcl_NewStringObj("TDBC ODBC", -1);
|
||
Tcl_IncrRefCount(errorCodeObj);
|
||
finished = 0;
|
||
while (!finished) {
|
||
errorMessageLen = SQL_MAX_MESSAGE_LENGTH;
|
||
errorMessageStatus =
|
||
SQLInstallerError(i, &errorCode, errorMessage,
|
||
SQL_MAX_MESSAGE_LENGTH-1, &errorMessageLen);
|
||
switch(errorMessageStatus) {
|
||
case SQL_SUCCESS:
|
||
Tcl_DStringAppend(&retvalDS, sep, -1);
|
||
Tcl_DStringInit(&errorMessageDS);
|
||
Tcl_ExternalToUtfDString(NULL, errorMessage, errorMessageLen,
|
||
&errorMessageDS);
|
||
Tcl_DStringAppend(&retvalDS,
|
||
Tcl_DStringValue(&errorMessageDS),
|
||
Tcl_DStringLength(&errorMessageDS));
|
||
Tcl_DStringFree(&errorMessageDS);
|
||
break;
|
||
case SQL_NO_DATA:
|
||
break;
|
||
default:
|
||
Tcl_DStringAppend(&retvalDS, sep, -1);
|
||
Tcl_DStringAppend(&retvalDS, "cannot retrieve error message",
|
||
-1);
|
||
break;
|
||
}
|
||
switch(errorMessageStatus) {
|
||
case SQL_SUCCESS:
|
||
case SQL_SUCCESS_WITH_INFO:
|
||
for (j = 0; OdbcErrorCodeNames[j].name != NULL; ++j) {
|
||
if (OdbcErrorCodeNames[j].value == (int)errorCode) {
|
||
break;
|
||
}
|
||
}
|
||
if (OdbcErrorCodeNames[j].name == NULL) {
|
||
Tcl_ListObjAppendElement(NULL, errorCodeObj,
|
||
Tcl_NewStringObj("?", -1));
|
||
} else {
|
||
Tcl_ListObjAppendElement(NULL, errorCodeObj,
|
||
Tcl_NewStringObj(OdbcErrorCodeNames[j].name, -1));
|
||
}
|
||
Tcl_ListObjAppendElement(NULL, errorCodeObj,
|
||
Tcl_NewWideIntObj(errorCode));
|
||
/* FALLTHRU */
|
||
case SQL_NO_DATA:
|
||
case SQL_ERROR:
|
||
finished = 1;
|
||
break;
|
||
}
|
||
|
||
sep = "\n";
|
||
++i;
|
||
}
|
||
Tcl_SetObjResult(interp,
|
||
Tcl_NewStringObj(Tcl_DStringValue(&retvalDS),
|
||
Tcl_DStringLength(&retvalDS)));
|
||
Tcl_DStringFree(&retvalDS);
|
||
Tcl_SetObjErrorCode(interp, errorCodeObj);
|
||
Tcl_DecrRefCount(errorCodeObj);
|
||
}
|
||
|
||
return status;
|
||
}
|
||
|
||
/*
|
||
*-----------------------------------------------------------------------------
|
||
*
|
||
* Datasource_ObjCmdA --
|
||
*
|
||
* Command that does configuration of ODBC data sources when the
|
||
* native ODBCCP32 library does not support Unicode
|
||
*
|
||
* Usage:
|
||
* ::tdbc::odbc::datasource subcommand driver ?keyword=value?...
|
||
*
|
||
* Parameters:
|
||
* subcommand - One of 'add', 'add_system', 'configure',
|
||
* 'configure_system', 'remove', or 'remove_system'
|
||
* driver - Name of the ODBC driver to use in configuring the data source.
|
||
* keyword=value - Keyword-value pairs as defined by the driver.
|
||
*
|
||
* Results:
|
||
* Returns a standard Tcl result, which is empty if the operation
|
||
* is successful.
|
||
*
|
||
*-----------------------------------------------------------------------------
|
||
*/
|
||
|
||
static int
|
||
DatasourceObjCmdA(
|
||
ClientData dummy, /* Unused */
|
||
Tcl_Interp* interp, /* Tcl interpreter */
|
||
int objc, /* Parameter count */
|
||
Tcl_Obj *const objv[] /* Parameter vector */
|
||
) {
|
||
static const struct flag {
|
||
const char* name;
|
||
WORD value;
|
||
} flags[] = {
|
||
{ "add", ODBC_ADD_DSN },
|
||
{ "add_system", ODBC_ADD_SYS_DSN },
|
||
{ "configure", ODBC_CONFIG_DSN },
|
||
{ "configure_system", ODBC_CONFIG_SYS_DSN },
|
||
{ "remove", ODBC_REMOVE_DSN },
|
||
{ "remove_system", ODBC_REMOVE_SYS_DSN },
|
||
{ NULL, 0 }
|
||
};
|
||
int flagIndex; /* Index of the subcommand */
|
||
Tcl_DString driverNameDS;
|
||
Tcl_DString attributesDS;
|
||
char* driverName; /* Name of the ODBC driver in system
|
||
* encoding */
|
||
char* attributes; /* Attributes of the data source in
|
||
* system encoding */
|
||
char errorMessage[SQL_MAX_MESSAGE_LENGTH+1];
|
||
/* Error message from ODBC operations */
|
||
Tcl_DString errorMessageDS; /* Error message in UTF-8 */
|
||
char* p;
|
||
size_t driverNameLen; /* Length of the driver name */
|
||
Tcl_Obj* attrObj; /* NULL-delimited attribute values */
|
||
size_t attrLen; /* Length of the attribute values */
|
||
const char* sep; /* Separator for attribute values */
|
||
DWORD errorCode; /* Error code */
|
||
WORD errorMessageLen; /* Length of the returned error message */
|
||
RETCODE errorMessageStatus; /* Status of the error message formatting */
|
||
Tcl_DString retvalDS; /* Return value */
|
||
Tcl_Obj* errorCodeObj; /* Tcl error code */
|
||
int i, j;
|
||
BOOL ok;
|
||
int status = TCL_OK;
|
||
int finished = 0;
|
||
(void)dummy;
|
||
|
||
/* Check args */
|
||
|
||
if (objc < 4) {
|
||
Tcl_WrongNumArgs(interp, 1, objv,
|
||
"operation driver ?keyword=value?...");
|
||
return TCL_ERROR;
|
||
}
|
||
if (Tcl_GetIndexFromObjStruct(interp, objv[1], flags, sizeof(struct flag),
|
||
"operation", 0, &flagIndex) != TCL_OK) {
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/* Convert driver name to the appropriate encoding */
|
||
|
||
Tcl_DStringInit(&driverNameDS);
|
||
p = Tcl_GetString(objv[2]);
|
||
driverNameLen = objv[2]->length;
|
||
Tcl_UtfToExternalDString(NULL, p, driverNameLen, &driverNameDS);
|
||
driverName = Tcl_DStringValue(&driverNameDS);
|
||
driverNameLen = Tcl_DStringLength(&driverNameDS);
|
||
|
||
/*
|
||
* Convert driver attributes to the appropriate encoding, separated
|
||
* by NUL bytes.
|
||
*/
|
||
|
||
attrObj = Tcl_NewObj();
|
||
Tcl_IncrRefCount(attrObj);
|
||
sep = "";
|
||
for (i = 3; i < objc; ++i) {
|
||
Tcl_AppendToObj(attrObj, sep, -1);
|
||
Tcl_AppendObjToObj(attrObj, objv[i]);
|
||
sep = "\xc0\x80";
|
||
}
|
||
Tcl_AppendToObj(attrObj, "\xc0\x80", 2);
|
||
Tcl_DStringInit(&attributesDS);
|
||
p = Tcl_GetString(attrObj);
|
||
attrLen = attrObj->length;
|
||
Tcl_UtfToExternalDString(NULL, p, attrLen, &attributesDS);
|
||
attributes = Tcl_DStringValue(&attributesDS);
|
||
attrLen = Tcl_DStringLength(&attributesDS);
|
||
Tcl_DecrRefCount(attrObj);
|
||
|
||
/*
|
||
* Configure the data source
|
||
*/
|
||
|
||
ok = SQLConfigDataSource(NULL, flags[flagIndex].value,
|
||
driverName, attributes);
|
||
Tcl_DStringFree(&attributesDS);
|
||
Tcl_DStringFree(&driverNameDS);
|
||
|
||
/* Check the ODBC status return */
|
||
|
||
if (!ok) {
|
||
status = TCL_ERROR;
|
||
i = 1;
|
||
sep = "";
|
||
Tcl_DStringInit(&retvalDS);
|
||
errorCodeObj = Tcl_NewStringObj("TDBC ODBC", -1);
|
||
Tcl_IncrRefCount(errorCodeObj);
|
||
finished = 0;
|
||
while (!finished) {
|
||
errorMessageLen = SQL_MAX_MESSAGE_LENGTH;
|
||
errorMessageStatus =
|
||
SQLInstallerError(i, &errorCode, errorMessage,
|
||
SQL_MAX_MESSAGE_LENGTH-1, &errorMessageLen);
|
||
switch(errorMessageStatus) {
|
||
case SQL_SUCCESS:
|
||
Tcl_DStringAppend(&retvalDS, sep, -1);
|
||
Tcl_DStringInit(&errorMessageDS);
|
||
Tcl_ExternalToUtfDString(NULL, errorMessage, errorMessageLen,
|
||
&errorMessageDS);
|
||
Tcl_DStringAppend(&retvalDS,
|
||
Tcl_DStringValue(&errorMessageDS),
|
||
Tcl_DStringLength(&errorMessageDS));
|
||
Tcl_DStringFree(&errorMessageDS);
|
||
break;
|
||
case SQL_NO_DATA:
|
||
break;
|
||
default:
|
||
Tcl_DStringAppend(&retvalDS, sep, -1);
|
||
Tcl_DStringAppend(&retvalDS, "cannot retrieve error message",
|
||
-1);
|
||
break;
|
||
}
|
||
switch(errorMessageStatus) {
|
||
case SQL_SUCCESS:
|
||
case SQL_SUCCESS_WITH_INFO:
|
||
for (j = 0; OdbcErrorCodeNames[j].name != NULL; ++j) {
|
||
if (OdbcErrorCodeNames[j].value == (int)errorCode) {
|
||
break;
|
||
}
|
||
}
|
||
if (OdbcErrorCodeNames[j].name == NULL) {
|
||
Tcl_ListObjAppendElement(NULL, errorCodeObj,
|
||
Tcl_NewStringObj("?", -1));
|
||
} else {
|
||
Tcl_ListObjAppendElement(NULL, errorCodeObj,
|
||
Tcl_NewStringObj(OdbcErrorCodeNames[j].name, -1));
|
||
}
|
||
Tcl_ListObjAppendElement(NULL, errorCodeObj,
|
||
Tcl_NewWideIntObj(errorCode));
|
||
|
||
/* FALLTHRU */
|
||
case SQL_NO_DATA:
|
||
case SQL_ERROR:
|
||
finished = 1;
|
||
break;
|
||
}
|
||
|
||
sep = "\n";
|
||
++i;
|
||
}
|
||
Tcl_SetObjResult(interp,
|
||
Tcl_NewStringObj(Tcl_DStringValue(&retvalDS),
|
||
Tcl_DStringLength(&retvalDS)));
|
||
Tcl_DStringFree(&retvalDS);
|
||
Tcl_SetObjErrorCode(interp, errorCodeObj);
|
||
Tcl_DecrRefCount(errorCodeObj);
|
||
}
|
||
|
||
return status;
|
||
}
|
||
|
||
/*
|
||
*-----------------------------------------------------------------------------
|
||
*
|
||
* Tdbcodbc_Init --
|
||
*
|
||
* Initializes the TDBC-ODBC bridge when this library is loaded.
|
||
*
|
||
* Side effects:
|
||
* Creates the ::tdbc::odbc namespace and the commands that reside in it.
|
||
* Initializes the ODBC environment.
|
||
*
|
||
*-----------------------------------------------------------------------------
|
||
*/
|
||
|
||
#ifdef __cplusplus
|
||
extern "C" {
|
||
#endif /* __cplusplus */
|
||
DLLEXPORT int
|
||
Tdbcodbc_Init(
|
||
Tcl_Interp* interp /* Tcl interpreter */
|
||
) {
|
||
SQLHENV hEnv; /* ODBC environemnt */
|
||
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_PkgProvideEx(interp, "tdbc::odbc", PACKAGE_VERSION, NULL) == TCL_ERROR) {
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/* Initialize the ODBC environment */
|
||
|
||
hEnv = GetHEnv(interp);
|
||
if (hEnv == SQL_NULL_HANDLE) {
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/*
|
||
* Create per-interpreter data for the package
|
||
*/
|
||
|
||
pidata = (PerInterpData*) ckalloc(sizeof(PerInterpData));
|
||
pidata->refCount = 0;
|
||
pidata->hEnv = GetHEnv(NULL);
|
||
for (i = 0; i < LIT__END; ++i) {
|
||
pidata->literals[i] = Tcl_NewStringObj(LiteralValues[i], -1);
|
||
Tcl_IncrRefCount(pidata->literals[i]);
|
||
}
|
||
|
||
/*
|
||
* Find the connection class, and attach the constructor to
|
||
* it. Hold the SQLENV in the method's client data.
|
||
*/
|
||
|
||
nameObj = Tcl_NewStringObj("::tdbc::odbc::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);
|
||
IncrPerInterpRefCount(pidata);
|
||
Tcl_ClassSetConstructor(interp, curClass,
|
||
Tcl_NewMethod(interp, curClass, NULL, 0,
|
||
&ConnectionConstructorType,
|
||
(ClientData) pidata));
|
||
|
||
/* Attach the other methods to the connection class */
|
||
|
||
nameObj = Tcl_NewStringObj("commit", -1);
|
||
Tcl_IncrRefCount(nameObj);
|
||
Tcl_NewMethod(interp, curClass, nameObj, 1,
|
||
&ConnectionEndXcnMethodType, (ClientData) SQL_COMMIT);
|
||
Tcl_DecrRefCount(nameObj);
|
||
nameObj = Tcl_NewStringObj("rollback", -1);
|
||
Tcl_IncrRefCount(nameObj);
|
||
Tcl_NewMethod(interp, curClass, nameObj, 1,
|
||
&ConnectionEndXcnMethodType, (ClientData) SQL_ROLLBACK);
|
||
Tcl_DecrRefCount(nameObj);
|
||
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::odbc::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 'tablesStatement' class */
|
||
|
||
nameObj = Tcl_NewStringObj("::tdbc::odbc::tablesStatement", -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 'tablesStatement' class */
|
||
|
||
Tcl_ClassSetConstructor(interp, curClass,
|
||
Tcl_NewMethod(interp, curClass, NULL, 1,
|
||
&TablesStatementConstructorType,
|
||
(ClientData) NULL));
|
||
|
||
/* Look up the 'columnsStatement' class */
|
||
|
||
nameObj = Tcl_NewStringObj("::tdbc::odbc::columnsStatement", -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 'columnsStatement' class */
|
||
|
||
Tcl_ClassSetConstructor(interp, curClass,
|
||
Tcl_NewMethod(interp, curClass, NULL, 1,
|
||
&ColumnsStatementConstructorType,
|
||
(ClientData) NULL));
|
||
|
||
/* Look up the 'primarykeysStatement' class */
|
||
|
||
nameObj = Tcl_NewStringObj("::tdbc::odbc::primarykeysStatement", -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 'primarykeysStatement' class */
|
||
|
||
Tcl_ClassSetConstructor(interp, curClass,
|
||
Tcl_NewMethod(interp, curClass, NULL, 1,
|
||
&PrimarykeysStatementConstructorType,
|
||
(ClientData) NULL));
|
||
|
||
/* Look up the 'typesStatement' class */
|
||
|
||
nameObj = Tcl_NewStringObj("::tdbc::odbc::typesStatement", -1);
|
||
Tcl_IncrRefCount(nameObj);
|
||
if ((curClassObject = Tcl_GetObjectFromObj(interp, nameObj)) == NULL) {
|
||
Tcl_DecrRefCount(nameObj);
|
||
return TCL_ERROR;
|
||
}
|
||
Tcl_DecrRefCount(nameObj);
|
||
curClass = Tcl_GetObjectAsClass(curClassObject);
|
||
|
||
/* Look up the 'foreignkeysStatement' class */
|
||
|
||
nameObj = Tcl_NewStringObj("::tdbc::odbc::foreignkeysStatement", -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 'foreignkeysStatement' class */
|
||
|
||
Tcl_ClassSetConstructor(interp, curClass,
|
||
Tcl_NewMethod(interp, curClass, NULL, 1,
|
||
&ForeignkeysStatementConstructorType,
|
||
(ClientData) NULL));
|
||
|
||
/* Look up the 'typesStatement' class */
|
||
|
||
nameObj = Tcl_NewStringObj("::tdbc::odbc::typesStatement", -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 'typesStatement' class */
|
||
|
||
Tcl_ClassSetConstructor(interp, curClass,
|
||
Tcl_NewMethod(interp, curClass, NULL, 1,
|
||
&TypesStatementConstructorType,
|
||
(ClientData) NULL));
|
||
|
||
/* Look up the 'resultSet' class */
|
||
|
||
nameObj = Tcl_NewStringObj("::tdbc::odbc::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);
|
||
|
||
IncrPerInterpRefCount(pidata);
|
||
Tcl_CreateObjCommand(interp, "tdbc::odbc::datasources",
|
||
DatasourcesObjCmd, (ClientData) pidata, DeleteCmd);
|
||
IncrPerInterpRefCount(pidata);
|
||
Tcl_CreateObjCommand(interp, "tdbc::odbc::drivers",
|
||
DriversObjCmd, (ClientData) pidata, DeleteCmd);
|
||
|
||
if (SQLConfigDataSourceW != NULL && SQLInstallerError != NULL) {
|
||
Tcl_CreateObjCommand(interp, "tdbc::odbc::datasource",
|
||
DatasourceObjCmdW, NULL, NULL);
|
||
} else if (SQLConfigDataSource != NULL && SQLInstallerError != NULL) {
|
||
Tcl_CreateObjCommand(interp, "tdbc::odbc::datasource",
|
||
DatasourceObjCmdA, NULL, NULL);
|
||
}
|
||
|
||
DismissHEnv();
|
||
return TCL_OK;
|
||
}
|
||
#ifdef __cplusplus
|
||
}
|
||
#endif /* __cplusplus */
|
||
|
||
/*
|
||
*-----------------------------------------------------------------------------
|
||
*
|
||
* DeletePerInterpData --
|
||
*
|
||
* Delete per-interpreter data when the ODBC 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;
|
||
DismissHEnv();
|
||
for (i = 0; i < LIT__END; ++i) {
|
||
Tcl_DecrRefCount(pidata->literals[i]);
|
||
}
|
||
ckfree((char *) pidata);
|
||
}
|