/* *----------------------------------------------------------------------------- * * tdbcpostgres.c -- * * C code for the driver to interface TDBC and Postgres * * Copyright (c) 2009 by Slawomir Cygan. * Copyright (c) 2010 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. * *----------------------------------------------------------------------------- */ #ifdef _MSC_VER # define _CRT_SECURE_NO_DEPRECATE #endif #include #include #include #include #include #ifdef HAVE_STDINT_H # include #endif #ifdef HAVE_SYS_TYPES_H # include #endif #include "int2ptr_ptr2int.h" #ifdef USE_NATIVE_POSTGRES # include #else # include "fakepq.h" #endif /* Include the files needed to locate htons() and htonl() */ #ifdef _WIN32 typedef int int32_t; typedef short int16_t; # define WIN32_LEAN_AND_MEAN # include # include # ifdef _MSC_VER # pragma comment (lib, "ws2_32") # endif #else # include #endif #ifdef _MSC_VER # define snprintf _snprintf #endif /* Static data contained within this file */ static Tcl_Mutex pgMutex; /* Mutex protecting per-process structures */ static int pgRefCount = 0; /* Reference count for the PG load handle */ static Tcl_LoadHandle pgLoadHandle = NULL; /* Load handle of the PG library */ /* Pool of literal values used to avoid excess Tcl_NewStringObj calls */ static const char *const LiteralValues[] = { "", "0", "1", "direction", "in", "inout", "name", "nullable", "out", "precision", "scale", "type", NULL }; enum LiteralIndex { LIT_EMPTY, LIT_0, LIT_1, LIT_DIRECTION, LIT_IN, LIT_INOUT, LIT_NAME, LIT_NULLABLE, LIT_OUT, LIT_PRECISION, LIT_SCALE, LIT_TYPE, LIT__END }; /* Object IDs for the Postgres data types */ #define UNTYPEDOID 0 #define BYTEAOID 17 #define INT8OID 20 #define INT2OID 21 #define INT4OID 23 #define TEXTOID 25 #define FLOAT4OID 700 #define FLOAT8OID 701 #define BPCHAROID 1042 #define VARCHAROID 1043 #define DATEOID 1082 #define TIMEOID 1083 #define TIMESTAMPOID 1114 #define BITOID 1560 #define NUMERICOID 1700 typedef struct PostgresDataType { const char* name; /* Type name */ Oid oid; /* Type number */ } PostgresDataType; static const PostgresDataType dataTypes[] = { { "NULL", UNTYPEDOID}, { "smallint", INT2OID }, { "integer", INT4OID }, { "tinyint", INT2OID }, { "float", FLOAT8OID }, { "real", FLOAT4OID }, { "double", FLOAT8OID }, { "timestamp", TIMESTAMPOID }, { "bigint", INT8OID }, { "date", DATEOID }, { "time", TIMEOID }, { "bit", BITOID }, { "numeric", NUMERICOID }, { "decimal", NUMERICOID }, { "text", TEXTOID }, { "varbinary", BYTEAOID }, { "varchar", VARCHAROID } , { "char", BPCHAROID }, { NULL, 0 } }; /* Configuration options for Postgres connections */ /* Data types of configuration options */ enum OptType { TYPE_STRING, /* Arbitrary character string */ TYPE_PORT, /* Port number */ TYPE_ENCODING, /* Encoding name */ TYPE_ISOLATION, /* Transaction isolation level */ TYPE_READONLY, /* Read-only indicator */ }; /* Locations of the string options in the string array */ enum OptStringIndex { INDX_HOST, INDX_HOSTA, INDX_PORT, INDX_DB, INDX_USER, INDX_PASS, INDX_OPT, INDX_TTY, INDX_SERV, INDX_TOUT, INDX_SSLM, INDX_RSSL, INDX_KERB, INDX_MAX }; /* Names of string options for Postgres PGconnectdb() */ static const char *const optStringNames[] = { "host", "hostaddr", "port", "dbname", "user", "password", "options", "tty", "service", "connect_timeout", "sslmode", "requiressl", "krbsrvname" }; /* Flags in the configuration table */ #define CONN_OPT_FLAG_MOD 0x1 /* Configuration value changable at runtime */ #define CONN_OPT_FLAG_ALIAS 0x2 /* Configuration option is an alias */ /* * Relay functions to allow Stubbed functions in the configuration options * table. */ static char* _PQdb(const PGconn* conn) { return PQdb(conn); } static char* _PQhost(const PGconn* conn) { return PQhost(conn); } static char* _PQoptions(const PGconn* conn) { return PQoptions(conn); } static char* _PQpass(const PGconn* conn) { return PQpass(conn); } static char* _PQport(const PGconn* conn) { return PQport(conn); } static char* _PQuser(const PGconn* conn) { return PQuser(conn); } static char* _PQtty(const PGconn* conn) { return PQtty(conn); } /* Table of configuration options */ static const struct { const char * name; /* Option name */ enum OptType type; /* Option data type */ int info; /* Option index or flag value */ int flags; /* Flags - modifiable; SSL related; * is an alias */ char *(*queryF)(const PGconn*); /* Function used to determine the * option value */ } ConnOptions [] = { { "-host", TYPE_STRING, INDX_HOST, 0, _PQhost}, { "-hostaddr", TYPE_STRING, INDX_HOSTA, 0, _PQhost}, { "-port", TYPE_PORT, INDX_PORT, 0, _PQport}, { "-database", TYPE_STRING, INDX_DB, 0, _PQdb}, { "-db", TYPE_STRING, INDX_DB, CONN_OPT_FLAG_ALIAS, _PQdb}, { "-user", TYPE_STRING, INDX_USER, 0, _PQuser}, { "-password", TYPE_STRING, INDX_PASS, 0, _PQpass}, { "-options", TYPE_STRING, INDX_OPT, 0, _PQoptions}, { "-tty", TYPE_STRING, INDX_TTY, 0, _PQtty}, { "-service", TYPE_STRING, INDX_SERV, 0, NULL}, { "-timeout", TYPE_STRING, INDX_TOUT, 0, NULL}, { "-sslmode", TYPE_STRING, INDX_SSLM, 0, NULL}, { "-requiressl", TYPE_STRING, INDX_RSSL, 0, NULL}, { "-krbsrvname", TYPE_STRING, INDX_KERB, 0, NULL}, { "-encoding", TYPE_ENCODING, 0, CONN_OPT_FLAG_MOD, NULL}, { "-isolation", TYPE_ISOLATION, 0, CONN_OPT_FLAG_MOD, NULL}, { "-readonly", TYPE_READONLY, 0, CONN_OPT_FLAG_MOD, NULL}, { NULL, TYPE_STRING, 0, 0, NULL} }; /* * Structure that holds per-interpreter data for the Postgres package. * * This structure is reference counted, because it cannot be destroyed * until all connections, statements and result sets that refer to * it are destroyed. */ typedef struct PerInterpData { int refCount; /* Reference count */ Tcl_Obj* literals[LIT__END]; /* Literal pool */ Tcl_HashTable typeNumHash; /* Lookup table for type numbers */ } PerInterpData; #define IncrPerInterpRefCount(x) \ do { \ ++((x)->refCount); \ } while(0) #define DecrPerInterpRefCount(x) \ do { \ PerInterpData* _pidata = x; \ if ((--(_pidata->refCount)) <= 0) { \ DeletePerInterpData(_pidata); \ } \ } while(0) /* * Structure that carries the data for a Postgres connection * * This structure is reference counted, to enable deferring its * destruction until the last statement or result set that refers * to it is destroyed. */ typedef struct ConnectionData { int refCount; /* Reference count. */ PerInterpData* pidata; /* Per-interpreter data */ PGconn* pgPtr; /* Postgres connection handle */ int stmtCounter; /* Counter for naming statements */ int flags; int isolation; /* Current isolation level */ int readOnly; /* Read only connection indicator */ char * savedOpts[INDX_MAX]; /* Saved configuration options */ } ConnectionData; /* * Flags for the state of an POSTGRES connection */ #define CONN_FLAG_IN_XCN 0x1 /* Transaction is in progress */ #define IncrConnectionRefCount(x) \ do { \ ++((x)->refCount); \ } while(0) #define DecrConnectionRefCount(x) \ do { \ ConnectionData* conn = x; \ if ((--(conn->refCount)) <= 0) { \ DeleteConnection(conn); \ } \ } while(0) /* * Structure that carries the data for a Postgres prepared statement. * * Just as with connections, statements need to defer taking down * their client data until other objects (i.e., result sets) that * refer to them have had a chance to clean up. Hence, this * structure is reference counted as well. */ typedef struct StatementData { int refCount; /* Reference count */ ConnectionData* cdata; /* Data for the connection to which this * statement pertains. */ Tcl_Obj* subVars; /* List of variables to be substituted, in the * order in which they appear in the * statement */ Tcl_Obj* nativeSql; /* Native SQL statement to pass into * Postgres */ char* stmtName; /* Name identyfing the statement */ Tcl_Obj* columnNames; /* Column names in the result set */ struct ParamData *params; /* Attributes of parameters */ int nParams; /* Number of parameters */ Oid* paramDataTypes; /* Param data types list */ int paramTypesChanged; /* Indicator of changed param types */ int flags; } StatementData; #define IncrStatementRefCount(x) \ do { \ ++((x)->refCount); \ } while (0) #define DecrStatementRefCount(x) \ do { \ StatementData* stmt = (x); \ if (--(stmt->refCount) <= 0) { \ DeleteStatement(stmt); \ } \ } while(0) /* Flags in the 'StatementData->flags' word */ #define STMT_FLAG_BUSY 0x1 /* Statement handle is in use */ /* * Structure describing the data types of substituted parameters in * a SQL statement. */ typedef struct ParamData { int flags; /* Flags regarding the parameters - see below */ int precision; /* Size of the expected data */ int scale; /* Digits after decimal point of the * expected data */ } ParamData; #define PARAM_KNOWN 1<<0 /* Something is known about the parameter */ #define PARAM_IN 1<<1 /* Parameter is an input parameter */ #define PARAM_OUT 1<<2 /* Parameter is an output parameter */ /* (Both bits are set if parameter is * an INOUT parameter) */ /* * Structure describing a Postgres result set. The object that the Tcl * API terms a "result set" actually has to be represented by a Postgres * "statement", since a Postgres statement can have only one set of results * at any given time. */ typedef struct ResultSetData { int refCount; /* Reference count */ StatementData* sdata; /* Statement that generated this result set */ PGresult* execResult; /* Structure containing result of prepared statement execution */ char* stmtName; /* Name identyfing the statement */ int rowCount; /* Number of already retreived rows */ } ResultSetData; #define IncrResultSetRefCount(x) \ do { \ ++((x)->refCount); \ } while (0) #define DecrResultSetRefCount(x) \ do { \ ResultSetData* rs = (x); \ if (rs->refCount-- <= 1) { \ DeleteResultSet(rs); \ } \ } while(0) /* Tables of isolation levels: Tcl, SQL and Postgres C API */ static const char *const TclIsolationLevels[] = { "readuncommitted", "readcommitted", "repeatableread", "serializable", NULL }; static const char *const SqlIsolationLevels[] = { "SET TRANSACTION ISOLATION LEVEL READ UNCOMMITTED", "SET TRANSACTION ISOLATION LEVEL READ COMMITTED", "SET TRANSACTION ISOLATION LEVEL REPEATABLE READ", "SET TRANSACTION ISOLATION LEVEL SERIALIZABLE", NULL }; enum IsolationLevel { ISOL_READ_UNCOMMITTED, ISOL_READ_COMMITTED, ISOL_REPEATABLE_READ, ISOL_SERIALIZABLE, ISOL_NONE = -1 }; /* Static functions defined within this file */ static int DeterminePostgresMajorVersion(Tcl_Interp* interp, ConnectionData* cdata, int* versionPtr); static void DummyNoticeProcessor(void*, const PGresult*); static int ExecSimpleQuery(Tcl_Interp* interp, PGconn * pgPtr, const char * query, PGresult** resOut); static void TransferPostgresError(Tcl_Interp* interp, PGconn * pgPtr); static int TransferResultError(Tcl_Interp* interp, PGresult * res); static Tcl_Obj* QueryConnectionOption(ConnectionData* cdata, Tcl_Interp* interp, int optionNum); static int ConfigureConnection(ConnectionData* cdata, Tcl_Interp* interp, int objc, Tcl_Obj *const objv[], int skip); static int ConnectionConstructor(ClientData clientData, Tcl_Interp* interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const objv[]); static int ConnectionBegintransactionMethod(ClientData clientData, Tcl_Interp* interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const objv[]); static int ConnectionColumnsMethod(ClientData clientData, Tcl_Interp* interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const objv[]); static int ConnectionCommitMethod(ClientData clientData, Tcl_Interp* interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const objv[]); static int ConnectionConfigureMethod(ClientData clientData, Tcl_Interp* interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const objv[]); static int ConnectionRollbackMethod(ClientData clientData, Tcl_Interp* interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const objv[]); static int ConnectionTablesMethod(ClientData clientData, Tcl_Interp* interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const objv[]); static void DeleteConnectionMetadata(ClientData clientData); static void DeleteConnection(ConnectionData* cdata); static int CloneConnection(Tcl_Interp* interp, ClientData oldClientData, ClientData* newClientData); static char* GenStatementName(ConnectionData* cdata); static void UnallocateStatement(PGconn* pgPtr, char* stmtName); static StatementData* NewStatement(ConnectionData* cdata); static PGresult* PrepareStatement(Tcl_Interp* interp, StatementData* sdata, char* stmtName); static Tcl_Obj* ResultDescToTcl(PGresult* resultDesc, int flags); static int StatementConstructor(ClientData clientData, Tcl_Interp* interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const objv[]); static int StatementParamtypeMethod(ClientData clientData, Tcl_Interp* interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const objv[]); static int StatementParamsMethod(ClientData clientData, Tcl_Interp* interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const objv[]); static void DeleteStatementMetadata(ClientData clientData); static void DeleteStatement(StatementData* sdata); static int CloneStatement(Tcl_Interp* interp, ClientData oldClientData, ClientData* newClientData); static int ResultSetConstructor(ClientData clientData, Tcl_Interp* interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const objv[]); static int ResultSetColumnsMethod(ClientData clientData, Tcl_Interp* interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const objv[]); static int ResultSetNextrowMethod(ClientData clientData, Tcl_Interp* interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const objv[]); static int ResultSetRowcountMethod(ClientData clientData, Tcl_Interp* interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const objv[]); static void DeleteResultSetMetadata(ClientData clientData); static void DeleteResultSet(ResultSetData* rdata); static int CloneResultSet(Tcl_Interp* interp, ClientData oldClientData, ClientData* newClientData); static void DeleteCmd(ClientData clientData); static int CloneCmd(Tcl_Interp* interp, ClientData oldMetadata, ClientData* newMetadata); static void DeletePerInterpData(PerInterpData* pidata); /* Metadata type that holds connection data */ const static Tcl_ObjectMetadataType connectionDataType = { TCL_OO_METADATA_VERSION_CURRENT, /* version */ "ConnectionData", /* name */ DeleteConnectionMetadata, /* deleteProc */ CloneConnection /* cloneProc - should cause an error * 'cuz connections aren't clonable */ }; /* Metadata type that holds statement data */ const static Tcl_ObjectMetadataType statementDataType = { TCL_OO_METADATA_VERSION_CURRENT, /* version */ "StatementData", /* name */ DeleteStatementMetadata, /* deleteProc */ CloneStatement /* cloneProc - should cause an error * 'cuz statements aren't clonable */ }; /* Metadata type for result set data */ const static Tcl_ObjectMetadataType resultSetDataType = { TCL_OO_METADATA_VERSION_CURRENT, /* version */ "ResultSetData", /* name */ DeleteResultSetMetadata, /* deleteProc */ CloneResultSet /* cloneProc - should cause an error * 'cuz result sets aren't clonable */ }; /* Method types of the result set methods that are implemented in C */ const static Tcl_MethodType ResultSetConstructorType = { TCL_OO_METHOD_VERSION_CURRENT, /* version */ "CONSTRUCTOR", /* name */ ResultSetConstructor, /* callProc */ NULL, /* deleteProc */ NULL /* cloneProc */ }; const static Tcl_MethodType ResultSetColumnsMethodType = { TCL_OO_METHOD_VERSION_CURRENT, /* version */ "columns", /* name */ ResultSetColumnsMethod, /* callProc */ NULL, /* deleteProc */ NULL /* cloneProc */ }; const static Tcl_MethodType ResultSetNextrowMethodType = { TCL_OO_METHOD_VERSION_CURRENT, /* version */ "nextrow", /* name */ ResultSetNextrowMethod, /* callProc */ NULL, /* deleteProc */ NULL /* cloneProc */ }; const static Tcl_MethodType ResultSetRowcountMethodType = { TCL_OO_METHOD_VERSION_CURRENT, /* version */ "rowcount", /* name */ ResultSetRowcountMethod, /* callProc */ NULL, /* deleteProc */ NULL /* cloneProc */ }; /* Methods to create on the result set class */ const static Tcl_MethodType* ResultSetMethods[] = { &ResultSetColumnsMethodType, &ResultSetRowcountMethodType, NULL }; /* Method types of the connection methods that are implemented in C */ const static Tcl_MethodType ConnectionConstructorType = { TCL_OO_METHOD_VERSION_CURRENT, /* version */ "CONSTRUCTOR", /* name */ ConnectionConstructor, /* callProc */ DeleteCmd, /* deleteProc */ CloneCmd /* cloneProc */ }; const static Tcl_MethodType ConnectionBegintransactionMethodType = { TCL_OO_METHOD_VERSION_CURRENT, /* version */ "begintransaction", /* name */ ConnectionBegintransactionMethod, /* callProc */ NULL, /* deleteProc */ NULL /* cloneProc */ }; const static Tcl_MethodType ConnectionColumnsMethodType = { TCL_OO_METHOD_VERSION_CURRENT, /* version */ "columns", /* name */ ConnectionColumnsMethod, /* callProc */ NULL, /* deleteProc */ NULL /* cloneProc */ }; const static Tcl_MethodType ConnectionCommitMethodType = { TCL_OO_METHOD_VERSION_CURRENT, /* version */ "commit", /* name */ ConnectionCommitMethod, /* callProc */ NULL, /* deleteProc */ NULL /* cloneProc */ }; const static Tcl_MethodType ConnectionConfigureMethodType = { TCL_OO_METHOD_VERSION_CURRENT, /* version */ "configure", /* name */ ConnectionConfigureMethod, /* callProc */ NULL, /* deleteProc */ NULL /* cloneProc */ }; const static Tcl_MethodType ConnectionRollbackMethodType = { TCL_OO_METHOD_VERSION_CURRENT, /* version */ "rollback", /* name */ ConnectionRollbackMethod, /* callProc */ NULL, /* deleteProc */ NULL /* cloneProc */ }; const static Tcl_MethodType ConnectionTablesMethodType = { TCL_OO_METHOD_VERSION_CURRENT, /* version */ "tables", /* name */ ConnectionTablesMethod, /* callProc */ NULL, /* deleteProc */ NULL /* cloneProc */ }; const static Tcl_MethodType* ConnectionMethods[] = { &ConnectionBegintransactionMethodType, &ConnectionColumnsMethodType, &ConnectionCommitMethodType, &ConnectionConfigureMethodType, &ConnectionRollbackMethodType, &ConnectionTablesMethodType, NULL }; /* Method types of the statement methods that are implemented in C */ const static Tcl_MethodType StatementConstructorType = { TCL_OO_METHOD_VERSION_CURRENT, /* version */ "CONSTRUCTOR", /* name */ StatementConstructor, /* callProc */ NULL, /* deleteProc */ NULL /* cloneProc */ }; const static Tcl_MethodType StatementParamsMethodType = { TCL_OO_METHOD_VERSION_CURRENT, /* version */ "params", /* name */ StatementParamsMethod, /* callProc */ NULL, /* deleteProc */ NULL /* cloneProc */ }; const static Tcl_MethodType StatementParamtypeMethodType = { TCL_OO_METHOD_VERSION_CURRENT, /* version */ "paramtype", /* name */ StatementParamtypeMethod, /* callProc */ NULL, /* deleteProc */ NULL /* cloneProc */ }; /* * Methods to create on the statement class. */ const static Tcl_MethodType* StatementMethods[] = { &StatementParamsMethodType, &StatementParamtypeMethodType, NULL }; /* *----------------------------------------------------------------------------- * * DummyNoticeReceiver -- * * Ignores warnings and notices from the PostgreSQL client library * * Results: * None. * * Side effects: * None. * * This procedure does precisely nothing. * *----------------------------------------------------------------------------- */ static void DummyNoticeProcessor(void* clientData, const PGresult* message) { (void)clientData; (void)message; } /* *----------------------------------------------------------------------------- * * ExecSimpleQuery -- * * Executes given query. * * Results: * TCL_OK on success or the error was non fatal otherwise TCL_ERROR . * * Side effects: * Sets the interpreter result and error code appropiately to * query execution process. Optionally, when res parameter is * not NULL and the execution is successful, it returns the * PGResult * struct by this parameter. This struct should be * freed with PQclear() when no longer needed. * *----------------------------------------------------------------------------- */ static int ExecSimpleQuery( Tcl_Interp* interp, /* Tcl interpreter */ PGconn * pgPtr, /* Connection handle */ const char * query, /* Query to execute */ PGresult** resOut /* Optional handle to result struct */ ) { PGresult * res; /* Query result */ /* Execute the query */ res = PQexec(pgPtr, query); /* Return error if the query was unsuccessful */ if (res == NULL) { TransferPostgresError(interp, pgPtr); return TCL_ERROR; } if (TransferResultError(interp, res) != TCL_OK) { PQclear(res); return TCL_ERROR; } /* Transfer query result to the caller */ if (resOut != NULL) { *resOut = res; } else { PQclear(res); } return TCL_OK; } /* *----------------------------------------------------------------------------- * * TransferPostgresError -- * * Obtains the connection related error message from the Postgres * client library and transfers them into the Tcl interpreter. * Unfortunately we cannot get error number or SQL state in * connection context. * * Results: * None. * * Side effects: * * Sets the interpreter result and error code to describe the SQL * connection error. * *----------------------------------------------------------------------------- */ static void TransferPostgresError( Tcl_Interp* interp, /* Tcl interpreter */ PGconn* pgPtr /* Postgres connection handle */ ) { Tcl_Obj* errorCode = Tcl_NewObj(); Tcl_ListObjAppendElement(NULL, errorCode, Tcl_NewStringObj("TDBC", -1)); Tcl_ListObjAppendElement(NULL, errorCode, Tcl_NewStringObj("GENERAL_ERROR", -1)); Tcl_ListObjAppendElement(NULL, errorCode, Tcl_NewStringObj("HY000", -1)); Tcl_ListObjAppendElement(NULL, errorCode, Tcl_NewStringObj("POSTGRES", -1)); Tcl_ListObjAppendElement(NULL, errorCode, Tcl_NewWideIntObj(-1)); Tcl_SetObjErrorCode(interp, errorCode); Tcl_SetObjResult(interp, Tcl_NewStringObj(PQerrorMessage(pgPtr), -1)); } /* *----------------------------------------------------------------------------- * * TransferPostgresError -- * * Check if there is any error related to given PGresult object. * If there was an error, it obtains error message, SQL state * and error number from the Postgres client library and transfers * thenm into the Tcl interpreter. * * Results: * TCL_OK if no error exists or the error was non fatal, * otherwise TCL_ERROR is returned * * Side effects: * * Sets the interpreter result and error code to describe the SQL * connection error. * *----------------------------------------------------------------------------- */ static int TransferResultError( Tcl_Interp* interp, PGresult * res ) { ExecStatusType error = PQresultStatus(res); const char* sqlstate; if (error == PGRES_BAD_RESPONSE || error == PGRES_EMPTY_QUERY || error == PGRES_NONFATAL_ERROR || error == PGRES_FATAL_ERROR) { Tcl_Obj* errorCode = Tcl_NewObj(); Tcl_ListObjAppendElement(NULL, errorCode, Tcl_NewStringObj("TDBC", -1)); sqlstate = PQresultErrorField(res, PG_DIAG_SQLSTATE); if (sqlstate == NULL) { sqlstate = "HY000"; } Tcl_ListObjAppendElement(NULL, errorCode, Tcl_NewStringObj(Tdbc_MapSqlState(sqlstate), -1)); Tcl_ListObjAppendElement(NULL, errorCode, Tcl_NewStringObj(sqlstate, -1)); Tcl_ListObjAppendElement(NULL, errorCode, Tcl_NewStringObj("POSTGRES", -1)); Tcl_ListObjAppendElement(NULL, errorCode, Tcl_NewWideIntObj(error)); Tcl_SetObjErrorCode(interp, errorCode); if (error == PGRES_EMPTY_QUERY) { Tcl_SetObjResult(interp, Tcl_NewStringObj("empty query", -1)); } else { Tcl_SetObjResult(interp, Tcl_NewStringObj( PQresultErrorField(res, PG_DIAG_MESSAGE_PRIMARY), -1)); } } if (error == PGRES_BAD_RESPONSE || error == PGRES_EMPTY_QUERY || error == PGRES_FATAL_ERROR) { return TCL_ERROR; } else { return TCL_OK; } } /* *----------------------------------------------------------------------------- * * DeterminePostgresMajorVersion -- * * Determine the major version of the PostgreSQL server at the * other end of a connection. * * Results: * Returns a standard Tcl error code. * * Side effects: * Stores the version number in '*versionPtr' if successful. * *----------------------------------------------------------------------------- */ static int DeterminePostgresMajorVersion(Tcl_Interp* interp, /* Tcl interpreter */ ConnectionData* cdata, /* Connection data */ int* versionPtr) /* OUTPUT: PostgreSQL server version */ { PGresult* res; /* Result of a Postgres query */ int status = TCL_ERROR; /* Status return */ char* versionStr; /* Version information from server */ if (ExecSimpleQuery(interp, cdata->pgPtr, "SELECT version()", &res) == TCL_OK) { versionStr = PQgetvalue(res, 0, 0); if (sscanf(versionStr, " PostgreSQL %d", versionPtr) == 1) { status = TCL_OK; } else { Tcl_Obj* result = Tcl_NewStringObj("unable to parse PostgreSQL " "version: \"", -1); Tcl_AppendToObj(result, versionStr, -1); Tcl_AppendToObj(result, "\"", -1); Tcl_SetErrorCode(interp, "TDBC", "GENERAL_ERROR", "HY000", "POSTGRES", "-1", NULL); } PQclear(res); } return status; } /* *----------------------------------------------------------------------------- * * QueryConnectionOption -- * * Determine the current value of a connection option. * * Results: * Returns a Tcl object containing the value if successful, or NULL * if unsuccessful. If unsuccessful, stores error information in the * Tcl interpreter. * *----------------------------------------------------------------------------- */ static Tcl_Obj* QueryConnectionOption ( ConnectionData* cdata, /* Connection data */ Tcl_Interp* interp, /* Tcl interpreter */ int optionNum /* Position of the option in the table */ ) { PerInterpData* pidata = cdata->pidata; /* Per-interpreter data */ Tcl_Obj** literals = pidata->literals; char * value; /* Return value as C string */ /* Suppress attempts to query the password */ if (ConnOptions[optionNum].info == INDX_PASS) { return Tcl_NewObj(); } if (ConnOptions[optionNum].type == TYPE_ENCODING) { value = (char* )pg_encoding_to_char(PQclientEncoding(cdata->pgPtr)); return Tcl_NewStringObj(value, -1); } if (ConnOptions[optionNum].type == TYPE_ISOLATION) { if (cdata->isolation == ISOL_NONE) { PGresult * res; char * isoName; int i = 0; /* The isolation level wasn't set - get default value */ if (ExecSimpleQuery(interp, cdata->pgPtr, "SHOW default_transaction_isolation", &res) != TCL_OK) { return NULL; } value = PQgetvalue(res, 0, 0); isoName = (char*) ckalloc(strlen(value) + 1); strcpy(isoName, value); PQclear(res); /* get rid of space */ while (isoName[i] != ' ' && isoName[i] != '\0') { i+=1; } if (isoName[i] == ' ') { while (isoName[i] != '\0') { isoName[i] = isoName[i+1]; i+=1; } } /* Search for isolation level name in predefined table */ i=0; while (TclIsolationLevels[i] != NULL && strcmp(isoName, TclIsolationLevels[i])) { i += 1; } ckfree(isoName); if (TclIsolationLevels[i] != NULL) { cdata->isolation = i; } else { return NULL; } } return Tcl_NewStringObj( TclIsolationLevels[cdata->isolation], -1); } if (ConnOptions[optionNum].type == TYPE_READONLY) { if (cdata->readOnly == 0) { return literals[LIT_0]; } else { return literals[LIT_1]; } } if (ConnOptions[optionNum].queryF != NULL) { value = ConnOptions[optionNum].queryF(cdata->pgPtr); if (value != NULL) { return Tcl_NewStringObj(value, -1); } } if (ConnOptions[optionNum].type == TYPE_STRING && ConnOptions[optionNum].info != -1) { /* Fallback: get value saved ealier */ value = cdata->savedOpts[ConnOptions[optionNum].info]; if (value != NULL) { return Tcl_NewStringObj(value, -1); } } return literals[LIT_EMPTY]; } /* *----------------------------------------------------------------------------- * * ConfigureConnection -- * * Applies configuration settings to a Postrgre connection. * * Results: * Returns a Tcl result. If the result is TCL_ERROR, error information * is stored in the interpreter. * * Side effects: * Updates configuration in the connection data. Opens a connection * if none is yet open. * *----------------------------------------------------------------------------- */ static int ConfigureConnection( ConnectionData* cdata, /* Connection data */ Tcl_Interp* interp, /* Tcl interpreter */ int objc, /* Parameter count */ Tcl_Obj* const objv[], /* Parameter data */ int skip /* Number of parameters to skip */ ) { int optionIndex; /* Index of the current option in * ConnOptions */ int optionValue; /* Integer value of the current option */ int i; size_t j; char portval[10]; /* String representation of port number */ char * encoding = NULL; /* Selected encoding name */ int isolation = ISOL_NONE; /* Isolation level */ int readOnly = -1; /* Read only indicator */ #define CONNINFO_LEN 1000 char connInfo[CONNINFO_LEN]; /* Configuration string for PQconnectdb() */ Tcl_Obj* retval; Tcl_Obj* optval; int vers; /* PostgreSQL major version */ if (cdata->pgPtr != NULL) { /* Query configuration options on an existing connection */ if (objc == skip) { /* Return all options as a dict */ retval = Tcl_NewObj(); for (i = 0; ConnOptions[i].name != NULL; ++i) { if (ConnOptions[i].flags & CONN_OPT_FLAG_ALIAS) continue; optval = QueryConnectionOption(cdata, interp, i); if (optval == NULL) { return TCL_ERROR; } Tcl_DictObjPut(NULL, retval, Tcl_NewStringObj(ConnOptions[i].name, -1), optval); } Tcl_SetObjResult(interp, retval); return TCL_OK; } else if (objc == skip+1) { /* Return one option value */ if (Tcl_GetIndexFromObjStruct(interp, objv[skip], (void*) ConnOptions, sizeof(ConnOptions[0]), "option", 0, &optionIndex) != TCL_OK) { return TCL_ERROR; } retval = QueryConnectionOption(cdata, interp, optionIndex); if (retval == NULL) { return TCL_ERROR; } else { Tcl_SetObjResult(interp, retval); return TCL_OK; } } } /* In all cases number of parameters must be even */ if ((objc-skip) % 2 != 0) { Tcl_WrongNumArgs(interp, skip, objv, "?-option value?..."); return TCL_ERROR; } /* Extract options from the command line */ for (i = 0; i < INDX_MAX; ++i) { cdata->savedOpts[i] = NULL; } for (i = skip; i < objc; i += 2) { /* Unknown option */ if (Tcl_GetIndexFromObjStruct(interp, objv[i], (void*) ConnOptions, sizeof(ConnOptions[0]), "option", 0, &optionIndex) != TCL_OK) { return TCL_ERROR; } /* Unmodifiable option */ if (cdata->pgPtr != NULL && !(ConnOptions[optionIndex].flags & CONN_OPT_FLAG_MOD)) { Tcl_Obj* msg = Tcl_NewStringObj("\"", -1); Tcl_AppendObjToObj(msg, objv[i]); Tcl_AppendToObj(msg, "\" option cannot be changed dynamically", -1); Tcl_SetObjResult(interp, msg); Tcl_SetErrorCode(interp, "TDBC", "GENERAL_ERROR", "HY000", "POSTGRES", "-1", NULL); return TCL_ERROR; } /* Record option value */ switch (ConnOptions[optionIndex].type) { case TYPE_STRING: cdata->savedOpts[ConnOptions[optionIndex].info] = Tcl_GetString(objv[i+1]); break; case TYPE_ENCODING: encoding = Tcl_GetString(objv[i+1]); break; case TYPE_ISOLATION: if (Tcl_GetIndexFromObjStruct(interp, objv[i+1], TclIsolationLevels, sizeof(char *), "isolation level", TCL_EXACT, &isolation) != TCL_OK) { return TCL_ERROR; } break; case TYPE_PORT: if (Tcl_GetIntFromObj(interp, objv[i+1], &optionValue) != TCL_OK) { return TCL_ERROR; } if (optionValue < 0 || optionValue > 0xffff) { Tcl_SetObjResult(interp, Tcl_NewStringObj("port number must " "be in range " "[0..65535]", -1)); Tcl_SetErrorCode(interp, "TDBC", "GENERAL_ERROR", "HY000", "POSTGRES", "-1", NULL); return TCL_ERROR; } sprintf(portval, "%d", optionValue); cdata->savedOpts[INDX_PORT] = portval; break; case TYPE_READONLY: if (Tcl_GetBooleanFromObj(interp, objv[i+1], &readOnly) != TCL_OK) { return TCL_ERROR; } break; } } if (cdata->pgPtr == NULL) { j=0; connInfo[0] = '\0'; for (i=0; isavedOpts[i] != NULL ) { /* TODO escape values */ strncpy(&connInfo[j], optStringNames[i], CONNINFO_LEN - j); j+=strlen(optStringNames[i]); strncpy(&connInfo[j], " = '", CONNINFO_LEN - j); j+=strlen(" = '"); strncpy(&connInfo[j], cdata->savedOpts[i], CONNINFO_LEN - j); j+=strlen(cdata->savedOpts[i]); strncpy(&connInfo[j], "' ", CONNINFO_LEN - j); j+=strlen("' "); } } cdata->pgPtr = PQconnectdb(connInfo); if (cdata->pgPtr == NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj("PQconnectdb() failed, " "propably out of memory.", -1)); Tcl_SetErrorCode(interp, "TDBC", "GENERAL_ERROR", "HY001", "POSTGRES", "NULL", NULL); return TCL_ERROR; } if (PQstatus(cdata->pgPtr) != CONNECTION_OK) { TransferPostgresError(interp, cdata->pgPtr); return TCL_ERROR; } PQsetNoticeProcessor(cdata->pgPtr, DummyNoticeProcessor, NULL); } /* Character encoding */ if (encoding != NULL ) { if (PQsetClientEncoding(cdata->pgPtr, encoding) != 0) { TransferPostgresError(interp, cdata->pgPtr); return TCL_ERROR; } } /* Transaction isolation level */ if (isolation != ISOL_NONE) { if (ExecSimpleQuery(interp, cdata->pgPtr, SqlIsolationLevels[isolation], NULL) != TCL_OK) { return TCL_ERROR; } cdata->isolation = isolation; } /* Readonly indicator */ if (readOnly != -1) { if (readOnly == 0) { if (ExecSimpleQuery(interp, cdata->pgPtr, "SET TRANSACTION READ WRITE", NULL) != TCL_OK) { return TCL_ERROR; } } else { if (ExecSimpleQuery(interp, cdata->pgPtr, "SET TRANSACTION READ ONLY", NULL) != TCL_OK) { return TCL_ERROR; } } cdata->readOnly = readOnly; } /* Determine the PostgreSQL version in use */ if (DeterminePostgresMajorVersion(interp, cdata, &vers) != TCL_OK) { return TCL_ERROR; } /* * On PostgreSQL 9.0 and later, change 'bytea_output' to the * backward-compatible 'escape' setting, so that the code in * ResultSetNextrowMethod will retrieve byte array values correctly * on either 8.x or 9.x servers. */ if (vers >= 9) { if (ExecSimpleQuery(interp, cdata->pgPtr, "SET bytea_output = 'escape'", NULL) != TCL_OK) { return TCL_ERROR; } } return TCL_OK; } /* *----------------------------------------------------------------------------- * * ConnectionConstructor -- * * Constructor for ::tdbc::postgres::connection, which represents a * database connection. * * Results: * Returns a standard Tcl result. * * The ConnectionInitMethod takes alternating keywords and values giving * the configuration parameters of the connection, and attempts to connect * to the database. * *----------------------------------------------------------------------------- */ static int ConnectionConstructor( ClientData clientData, /* Environment handle */ Tcl_Interp* interp, /* Tcl interpreter */ Tcl_ObjectContext context, /* Object context */ int objc, /* Parameter count */ Tcl_Obj *const objv[] /* Parameter vector */ ) { PerInterpData* pidata = (PerInterpData*) clientData; /* Per-interp data for the POSTGRES package */ Tcl_Object thisObject = Tcl_ObjectContextObject(context); /* The current object */ int skip = Tcl_ObjectContextSkippedArgs(context); /* The number of leading arguments to skip */ ConnectionData* cdata; /* Per-connection data */ /* Hang client data on this connection */ cdata = (ConnectionData*) ckalloc(sizeof(ConnectionData)); memset(cdata, 0, sizeof(ConnectionData)); cdata->refCount = 1; cdata->pidata = pidata; cdata->pgPtr = NULL; cdata->stmtCounter = 0; cdata->flags = 0; cdata->isolation = ISOL_NONE; cdata->readOnly = 0; IncrPerInterpRefCount(pidata); Tcl_ObjectSetMetadata(thisObject, &connectionDataType, (ClientData) cdata); /* Configure the connection */ if (ConfigureConnection(cdata, interp, objc, objv, skip) != TCL_OK) { return TCL_ERROR; } return TCL_OK; } /* *----------------------------------------------------------------------------- * * ConnectionBegintransactionMethod -- * * Method that requests that following operations on an POSTGRES * 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 & CONN_FLAG_IN_XCN) { Tcl_SetObjResult(interp, Tcl_NewStringObj("Postgres does not support " "nested transactions", -1)); Tcl_SetErrorCode(interp, "TDBC", "GENERAL_ERROR", "HYC00", "POSTGRES", "-1", NULL); return TCL_ERROR; } cdata->flags |= CONN_FLAG_IN_XCN; /* Execute begin trasnaction block command */ return ExecSimpleQuery(interp, cdata->pgPtr, "BEGIN", NULL); } /* *----------------------------------------------------------------------------- * * ConnectionCommitMethod -- * * Method that requests that a pending transaction against a database * be committed. * * Usage: * $connection commit * * Parameters: * None. * * Results: * Returns an empty Tcl result if successful, and throws an error * otherwise. * *----------------------------------------------------------------------------- */ static int ConnectionCommitMethod( ClientData 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) { Tcl_WrongNumArgs(interp, 2, objv, ""); return TCL_ERROR; } /* Reject the request if no transaction is in progress */ if (!(cdata->flags & CONN_FLAG_IN_XCN)) { Tcl_SetObjResult(interp, Tcl_NewStringObj("no transaction is in " "progress", -1)); Tcl_SetErrorCode(interp, "TDBC", "GENERAL_ERROR", "HY010", "POSTGRES", "-1", NULL); return TCL_ERROR; } cdata->flags &= ~ CONN_FLAG_IN_XCN; /* Execute commit SQL command */ return ExecSimpleQuery(interp, cdata->pgPtr, "COMMIT", NULL); } /* *----------------------------------------------------------------------------- * * ConnectionColumnsMethod -- * * Method that asks for the names of columns in a table * in the database (optionally matching a given pattern) * * Usage: * $connection columns table ?pattern? * * Parameters: * None. * * Results: * Returns the list of tables * *----------------------------------------------------------------------------- */ static int ConnectionColumnsMethod( ClientData 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 */ PerInterpData* pidata = cdata->pidata; /* Per-interpreter data */ Tcl_Obj** literals = pidata->literals; /* Literal pool */ PGresult* res,* resType; /* Results of libpq call */ char* columnName; /* Name of the column */ Oid typeOid; /* Oid of column type */ Tcl_Obj* retval; /* List of table names */ Tcl_Obj* attrs; /* Attributes of the column */ Tcl_Obj* name; /* Name of a column */ Tcl_Obj* sqlQuery = Tcl_NewStringObj("SELECT * FROM ", -1); /* Query used */ (void)dummy; Tcl_IncrRefCount(sqlQuery); /* Check parameters */ if (objc < 3 || objc > 4) { Tcl_WrongNumArgs(interp, 2, objv, "table ?pattern?"); return TCL_ERROR; } /* Check if table exists by retreiving one row. * The result wille be later used to determine column types (oids) */ Tcl_AppendObjToObj(sqlQuery, objv[2]); if (ExecSimpleQuery(interp, cdata->pgPtr, Tcl_GetString(sqlQuery), &resType) != TCL_OK) { Tcl_DecrRefCount(sqlQuery); return TCL_ERROR; } Tcl_DecrRefCount(sqlQuery); /* Retreive column attributes */ sqlQuery = Tcl_NewStringObj("SELECT " " column_name," " numeric_precision," " character_maximum_length," " numeric_scale," " is_nullable" " FROM information_schema.columns" " WHERE table_name='", -1); Tcl_IncrRefCount(sqlQuery); Tcl_AppendObjToObj(sqlQuery, objv[2]); if (objc == 4) { Tcl_AppendToObj(sqlQuery,"' AND column_name LIKE '", -1); Tcl_AppendObjToObj(sqlQuery, objv[3]); } Tcl_AppendToObj(sqlQuery,"'", -1); if (ExecSimpleQuery(interp, cdata->pgPtr, Tcl_GetString(sqlQuery), &res) != TCL_OK) { Tcl_DecrRefCount(sqlQuery); PQclear(resType); return TCL_ERROR; } else { int i, j; retval = Tcl_NewObj(); Tcl_IncrRefCount(retval); for (i = 0; i < PQntuples(res); i += 1) { attrs = Tcl_NewObj(); /* 0 is column_name column number */ columnName = PQgetvalue(res, i, 0); name = Tcl_NewStringObj(columnName, -1); Tcl_DictObjPut(NULL, attrs, literals[LIT_NAME], name); /* Get the type name, by retrieving type oid */ j = PQfnumber(resType, columnName); if (j >= 0) { typeOid = PQftype(resType, j); /* TODO: bsearch or sthing */ j = 0 ; while (dataTypes[j].name != NULL && dataTypes[j].oid != typeOid) { j+=1; } if ( dataTypes[j].name != NULL) { Tcl_DictObjPut(NULL, attrs, literals[LIT_TYPE], Tcl_NewStringObj(dataTypes[j].name, -1)); } } /* 1 is numeric_precision column number */ if (!PQgetisnull(res, i, 1)) { Tcl_DictObjPut(NULL, attrs, literals[LIT_PRECISION], Tcl_NewStringObj(PQgetvalue(res, i, 1), -1)); } else { /* 2 is character_maximum_length column number */ if (!PQgetisnull(res, i, 2)) { Tcl_DictObjPut(NULL, attrs, literals[LIT_PRECISION], Tcl_NewStringObj(PQgetvalue(res, i, 2), -1)); } } /* 3 is character_maximum_length column number */ if (!PQgetisnull(res, i, 3)) { /* This is for numbers */ Tcl_DictObjPut(NULL, attrs, literals[LIT_SCALE], Tcl_NewStringObj(PQgetvalue(res, i, 3), -1)); } /* 4 is is_nullable column number */ Tcl_DictObjPut(NULL, attrs, literals[LIT_NULLABLE], Tcl_NewWideIntObj(strcmp("YES", PQgetvalue(res, i, 4)) == 0)); Tcl_DictObjPut(NULL, retval, name, attrs); } Tcl_DecrRefCount(sqlQuery); Tcl_SetObjResult(interp, retval); Tcl_DecrRefCount(retval); PQclear(resType); PQclear(res); return TCL_OK; } } /* *----------------------------------------------------------------------------- * * ConnectionConfigureMethod -- * * Change configuration parameters on an open connection. * * Usage: * $connection configure ?-keyword? ?value? ?-keyword value ...? * * Parameters: * Keyword-value pairs (or a single keyword, or an empty set) * of configuration options. * * Options: * The following options are supported; * -database * Name of the database to use by default in queries * -encoding * Character encoding to use with the server. (Must be utf-8) * -isolation * Transaction isolation level. * -readonly * Read-only flag (must be a false Boolean value) * -timeout * Timeout value (both wait_timeout and interactive_timeout) * * Other options supported by the constructor are here in read-only * mode; any attempt to change them will result in an error. * *----------------------------------------------------------------------------- */ static int ConnectionConfigureMethod( ClientData dummy, Tcl_Interp* interp, Tcl_ObjectContext objectContext, int objc, Tcl_Obj *const objv[] ) { Tcl_Object thisObject = Tcl_ObjectContextObject(objectContext); /* The current connection object */ int skip = Tcl_ObjectContextSkippedArgs(objectContext); /* Number of arguments to skip */ ConnectionData* cdata = (ConnectionData*) Tcl_ObjectGetMetadata(thisObject, &connectionDataType); /* Instance data */ (void)dummy; return ConfigureConnection(cdata, interp, objc, objv, skip); } /* *----------------------------------------------------------------------------- * * ConnectionRollbackMethod -- * * Method that requests that a pending transaction against a database * be rolled back. * * Usage: * $connection rollback * * Parameters: * None. * * Results: * Returns an empty Tcl result if successful, and throws an error * otherwise. * *----------------------------------------------------------------------------- */ static int ConnectionRollbackMethod( ClientData 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) { Tcl_WrongNumArgs(interp, 2, objv, ""); return TCL_ERROR; } /* Reject the request if no transaction is in progress */ if (!(cdata->flags & CONN_FLAG_IN_XCN)) { Tcl_SetObjResult(interp, Tcl_NewStringObj("no transaction is in " "progress", -1)); Tcl_SetErrorCode(interp, "TDBC", "GENERAL_ERROR", "HY010", "POSTGRES", "-1", NULL); return TCL_ERROR; } cdata->flags &= ~CONN_FLAG_IN_XCN; /* Send end transaction SQL command */ return ExecSimpleQuery(interp, cdata->pgPtr, "ROLLBACK", NULL); } /* *----------------------------------------------------------------------------- * * ConnectionTablesMethod -- * * Method that asks for the names of tables in the database (optionally * matching a given pattern * * Usage: * $connection tables ?pattern? * * Parameters: * None. * * Results: * Returns the list of tables * *----------------------------------------------------------------------------- */ static int ConnectionTablesMethod( ClientData 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 */ Tcl_Obj** literals = cdata->pidata->literals; /* Literal pool */ PGresult* res; /* Result of libpq call */ char * field; /* Field value from SQL result */ Tcl_Obj* retval; /* List of table names */ Tcl_Obj* sqlQuery = Tcl_NewStringObj("SELECT tablename" " FROM pg_tables" " WHERE schemaname = 'public'", -1); /* SQL query for table list */ int i; (void)dummy; Tcl_IncrRefCount(sqlQuery); /* Check parameters */ if (objc < 2 || objc > 3) { Tcl_WrongNumArgs(interp, 2, objv, ""); return TCL_ERROR; } if (objc == 3) { /* Pattern string is given */ Tcl_AppendToObj(sqlQuery, " AND tablename LIKE '", -1); Tcl_AppendObjToObj(sqlQuery, objv[2]); Tcl_AppendToObj(sqlQuery, "'", -1); } /* Retrieve the table list */ if (ExecSimpleQuery(interp, cdata ->pgPtr, Tcl_GetString(sqlQuery), &res) != TCL_OK) { Tcl_DecrRefCount(sqlQuery); return TCL_ERROR; } Tcl_DecrRefCount(sqlQuery); /* Iterate through the tuples and make the Tcl result */ retval = Tcl_NewObj(); for (i = 0; i < PQntuples(res); i+=1) { if (!PQgetisnull(res, i, 0)) { field = PQgetvalue(res, i, 0); if (field) { Tcl_ListObjAppendElement(NULL, retval, Tcl_NewStringObj(field, -1)); Tcl_ListObjAppendElement(NULL, retval, literals[LIT_EMPTY]); } } } PQclear(res); Tcl_SetObjResult(interp, retval); return TCL_OK; } /* *----------------------------------------------------------------------------- * * DeleteConnectionMetadata, DeleteConnection -- * * Cleans up when a database connection is deleted. * * Results: * None. * * Side effects: * Terminates the connection and frees all system resources associated * with it. * *----------------------------------------------------------------------------- */ static void DeleteConnectionMetadata( ClientData clientData /* Instance data for the connection */ ) { DecrConnectionRefCount((ConnectionData*)clientData); } static void DeleteConnection( ConnectionData* cdata /* Instance data for the connection */ ) { if (cdata->pgPtr != NULL) { PQfinish(cdata->pgPtr); } DecrPerInterpRefCount(cdata->pidata); ckfree(cdata); } /* *----------------------------------------------------------------------------- * * CloneConnection -- * * Attempts to clone an Postgres 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("Postgres connections are not clonable", -1)); return TCL_ERROR; } /* *----------------------------------------------------------------------------- * * 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 POSTGRES 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 POSTGRES 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; *newClientData = oldClientData; return TCL_OK; } /* *----------------------------------------------------------------------------- * * GenStatementName -- * * Generates a unique name for a Postgre statement * * Results: * Null terminated, free-able, string containg the name. * *----------------------------------------------------------------------------- */ static char* GenStatementName( ConnectionData* cdata /* Instance data for the connection */ ) { char stmtName[30]; char* retval; cdata->stmtCounter += 1; snprintf(stmtName, 30, "statement%d", cdata->stmtCounter); retval = (char *)ckalloc(strlen(stmtName) + 1); strcpy(retval, stmtName); return retval; } /* *----------------------------------------------------------------------------- * * UnallocateStatement -- * * Tries tu unallocate prepared statement using SQL query. No * errors are reported on failure. * * Results: * Nothing. * *----------------------------------------------------------------------------- */ static void UnallocateStatement( PGconn * pgPtr, /* Connection handle */ char* stmtName /* Statement name */ ) { Tcl_Obj * sqlQuery = Tcl_NewStringObj("DEALLOCATE ", -1); Tcl_IncrRefCount(sqlQuery); Tcl_AppendToObj(sqlQuery, stmtName, -1); PQclear(PQexec(pgPtr, Tcl_GetString(sqlQuery))); Tcl_DecrRefCount(sqlQuery); } /* *----------------------------------------------------------------------------- * * NewStatement -- * * Creates an empty object to hold statement data. * * Results: * Returns a pointer to the newly-created object. * *----------------------------------------------------------------------------- */ static StatementData* NewStatement( ConnectionData* cdata /* Instance data for the connection */ ) { StatementData* sdata = (StatementData*) ckalloc(sizeof(StatementData)); memset(sdata, 0, sizeof(StatementData)); sdata->refCount = 1; sdata->cdata = cdata; IncrConnectionRefCount(cdata); sdata->subVars = Tcl_NewObj(); Tcl_IncrRefCount(sdata->subVars); sdata->params = NULL; sdata->paramDataTypes = NULL; sdata->nativeSql = NULL; sdata->columnNames = NULL; sdata->flags = 0; sdata->stmtName = GenStatementName(cdata); sdata->paramTypesChanged = 0; return sdata; } /* *----------------------------------------------------------------------------- * * PrepareStatement -- * * Prepare a PostgreSQL statement. When stmtName equals to * NULL, statement name is taken from sdata strucure. * * Results: * Returns the Posgres result object if successful, and NULL on failure. * * Side effects: * Prepares the statement. * Stores error message and error code in the interpreter on failure. * *----------------------------------------------------------------------------- */ static PGresult* PrepareStatement( Tcl_Interp* interp, /* Tcl interpreter for error reporting */ StatementData* sdata, /* Statement data */ char * stmtName /* Overriding name of the statement */ ) { ConnectionData* cdata = sdata->cdata; /* Connection data */ const char* nativeSqlStr; /* Native SQL statement to prepare */ int nativeSqlLen; /* Length of the statement */ PGresult* res; /* result of statement preparing*/ PGresult* res2; int i; if (stmtName == NULL) { stmtName = sdata->stmtName; } /* * Prepare the statement. Rather than giving parameter types, try * to let PostgreSQL infer all of them. */ nativeSqlStr = Tcl_GetStringFromObj(sdata->nativeSql, &nativeSqlLen); res = PQprepare(cdata->pgPtr, stmtName, nativeSqlStr, 0, NULL); if (res == NULL) { TransferPostgresError(interp, cdata->pgPtr); return NULL; } /* * Report on what parameter types were inferred. */ res2 = PQdescribePrepared(cdata->pgPtr, stmtName); if (res2 == NULL) { TransferPostgresError(interp, cdata->pgPtr); PQclear(res); return NULL; } for (i = 0; i < PQnparams(res2); ++i) { sdata->paramDataTypes[i] = PQparamtype(res2, i); sdata->params[i].precision = 0; sdata->params[i].scale = 0; } PQclear(res2); return res; } /* *----------------------------------------------------------------------------- * * ResultDescToTcl -- * * Converts a Postgres result description for return as a Tcl list. * * Results: * Returns a Tcl object holding the result description * * If any column names are duplicated, they are disambiguated by * appending '#n' where n increments once for each occurrence of the * column name. * *----------------------------------------------------------------------------- */ static Tcl_Obj* ResultDescToTcl( PGresult* result, /* Result set description */ int flags /* Flags governing the conversion */ ) { Tcl_Obj* retval = Tcl_NewObj(); Tcl_HashTable names; /* Hash table to resolve name collisions */ char * fieldName; Tcl_InitHashTable(&names, TCL_STRING_KEYS); if (result != NULL) { unsigned int fieldCount = PQnfields(result); unsigned int i; char numbuf[16]; (void)flags; for (i = 0; i < fieldCount; ++i) { int isNew; int count = 1; Tcl_Obj* nameObj; Tcl_HashEntry* entry; fieldName = PQfname(result, i); nameObj = Tcl_NewStringObj(fieldName, -1); Tcl_IncrRefCount(nameObj); entry = Tcl_CreateHashEntry(&names, fieldName, &isNew); while (!isNew) { count = PTR2INT(Tcl_GetHashValue(entry)); ++count; Tcl_SetHashValue(entry, INT2PTR(count)); sprintf(numbuf, "#%d", count); Tcl_AppendToObj(nameObj, numbuf, -1); entry = Tcl_CreateHashEntry(&names, Tcl_GetString(nameObj), &isNew); } Tcl_SetHashValue(entry, INT2PTR(count)); Tcl_ListObjAppendElement(NULL, retval, nameObj); Tcl_DecrRefCount(nameObj); } } Tcl_DeleteHashTable(&names); return retval; } /* *----------------------------------------------------------------------------- * * StatementConstructor -- * * C-level initialization for the object representing an Postgres prepared * statement. * * Usage: * statement new connection statementText * statement create name connection statementText * * Parameters: * connection -- the Postgres connection object * statementText -- text of the statement to prepare. * * Results: * Returns a standard Tcl result * * Side effects: * Prepares the statement, and stores it (plus a reference to the * connection) in instance metadata. * *----------------------------------------------------------------------------- */ static int StatementConstructor( ClientData 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); /* Number of args to skip before the * payload arguments */ Tcl_Object connectionObject; /* The database connection as a Tcl_Object */ ConnectionData* cdata; /* The connection object's data */ StatementData* sdata; /* The statement's object data */ Tcl_Obj* tokens; /* The tokens of the statement to be prepared */ int tokenc; /* Length of the 'tokens' list */ Tcl_Obj** tokenv; /* Exploded tokens from the list */ Tcl_Obj* nativeSql; /* SQL statement mapped to native form */ char* tokenStr; /* Token string */ int tokenLen; /* Length of a token */ PGresult* res; /* Temporary result of libpq calls */ char tmpstr[30]; /* Temporary array for strings */ int i, j; (void)dummy; /* Find the connection object, and get its data. */ thisObject = Tcl_ObjectContextObject(context); if (objc != skip+2) { Tcl_WrongNumArgs(interp, skip, objv, "connection statementText"); return TCL_ERROR; } connectionObject = Tcl_GetObjectFromObj(interp, objv[skip]); if (connectionObject == NULL) { return TCL_ERROR; } cdata = (ConnectionData*) Tcl_ObjectGetMetadata(connectionObject, &connectionDataType); if (cdata == NULL) { Tcl_AppendResult(interp, Tcl_GetString(objv[skip]), " does not refer to a Postgres connection", NULL); return TCL_ERROR; } /* * Allocate an object to hold data about this statement */ sdata = NewStatement(cdata); /* Tokenize the statement */ tokens = Tdbc_TokenizeSql(interp, Tcl_GetString(objv[skip+1])); if (tokens == NULL) { goto freeSData; } Tcl_IncrRefCount(tokens); /* * Rewrite the tokenized statement to Postgres syntax. Reject the * statement if it is actually multiple statements. */ if (Tcl_ListObjGetElements(interp, tokens, &tokenc, &tokenv) != TCL_OK) { goto freeTokens; } nativeSql = Tcl_NewObj(); Tcl_IncrRefCount(nativeSql); j=0; for (i = 0; i < tokenc; ++i) { tokenStr = Tcl_GetStringFromObj(tokenv[i], &tokenLen); switch (tokenStr[0]) { case '$': case ':': /* * A PostgreSQL cast is not a parameter! */ if (tokenStr[0] == ':' && tokenStr[1] == tokenStr[0]) { Tcl_AppendToObj(nativeSql, tokenStr, tokenLen); break; } j+=1; snprintf(tmpstr, 30, "$%d", j); Tcl_AppendToObj(nativeSql, tmpstr, -1); Tcl_ListObjAppendElement(NULL, sdata->subVars, Tcl_NewStringObj(tokenStr+1, tokenLen-1)); break; case ';': Tcl_SetObjResult(interp, Tcl_NewStringObj("tdbc::postgres" " does not support semicolons " "in statements", -1)); goto freeNativeSql; break; default: Tcl_AppendToObj(nativeSql, tokenStr, tokenLen); break; } } sdata->nativeSql = nativeSql; Tcl_DecrRefCount(tokens); Tcl_ListObjLength(NULL, sdata->subVars, &sdata->nParams); sdata->params = (ParamData*) ckalloc(sdata->nParams * sizeof(ParamData)); memset(sdata->params, 0, sdata->nParams * sizeof(ParamData)); sdata->paramDataTypes = (Oid*) ckalloc(sdata->nParams * sizeof(Oid)); memset(sdata->paramDataTypes, 0, sdata->nParams * sizeof(Oid)); for (i = 0; i < sdata->nParams; ++i) { sdata->params[i].flags = PARAM_IN; sdata->paramDataTypes[i] = UNTYPEDOID ; sdata->params[i].precision = 0; sdata->params[i].scale = 0; } /* Prepare the statement */ res = PrepareStatement(interp, sdata, NULL); if (res == NULL) { goto freeSData; } if (TransferResultError(interp, res) != TCL_OK) { PQclear(res); goto freeSData; } PQclear(res); /* Attach the current statement data as metadata to the current object */ Tcl_ObjectSetMetadata(thisObject, &statementDataType, (ClientData) sdata); return TCL_OK; /* On error, unwind all the resource allocations */ freeNativeSql: Tcl_DecrRefCount(nativeSql); freeTokens: Tcl_DecrRefCount(tokens); freeSData: DecrStatementRefCount(sdata); return TCL_ERROR; } /* *----------------------------------------------------------------------------- * * StatementParamsMethod -- * * Lists the parameters in a Postgres statement. * * Usage: * $statement params * * Results: * Returns a standard Tcl result containing a dictionary. The keys * of the dictionary are parameter names, and the values are parameter * types, themselves expressed as dictionaries containing the keys, * 'name', 'direction', 'type', 'precision', 'scale' and 'nullable'. * * *----------------------------------------------------------------------------- */ static int StatementParamsMethod( ClientData 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 */ = (StatementData*) Tcl_ObjectGetMetadata(thisObject, &statementDataType); ConnectionData* cdata = sdata->cdata; PerInterpData* pidata = cdata->pidata; /* Per-interp data */ Tcl_Obj** literals = pidata->literals; /* Literal pool */ Tcl_Obj* paramName; /* Name of a parameter */ Tcl_Obj* paramDesc; /* Description of one parameter */ Tcl_Obj* dataTypeName; /* Name of a parameter's data type */ Tcl_Obj* retVal; /* Return value from this command */ Tcl_HashEntry* typeHashEntry; int i; (void)dummy; if (objc != 2) { Tcl_WrongNumArgs(interp, 2, objv, ""); return TCL_ERROR; } retVal = Tcl_NewObj(); for (i = 0; i < sdata->nParams; ++i) { paramDesc = Tcl_NewObj(); Tcl_ListObjIndex(NULL, sdata->subVars, i, ¶mName); Tcl_DictObjPut(NULL, paramDesc, literals[LIT_NAME], paramName); switch (sdata->params[i].flags & (PARAM_IN | PARAM_OUT)) { case PARAM_IN: Tcl_DictObjPut(NULL, paramDesc, literals[LIT_DIRECTION], literals[LIT_IN]); break; case PARAM_OUT: Tcl_DictObjPut(NULL, paramDesc, literals[LIT_DIRECTION], literals[LIT_OUT]); break; case PARAM_IN | PARAM_OUT: Tcl_DictObjPut(NULL, paramDesc, literals[LIT_DIRECTION], literals[LIT_INOUT]); break; default: break; } typeHashEntry = Tcl_FindHashEntry(&(pidata->typeNumHash), INT2PTR(sdata->paramDataTypes[i])); if (typeHashEntry != NULL) { dataTypeName = (Tcl_Obj*) Tcl_GetHashValue(typeHashEntry); Tcl_DictObjPut(NULL, paramDesc, literals[LIT_TYPE], dataTypeName); } Tcl_DictObjPut(NULL, paramDesc, literals[LIT_PRECISION], Tcl_NewWideIntObj(sdata->params[i].precision)); Tcl_DictObjPut(NULL, paramDesc, literals[LIT_SCALE], Tcl_NewWideIntObj(sdata->params[i].scale)); Tcl_DictObjPut(NULL, retVal, paramName, paramDesc); } Tcl_SetObjResult(interp, retVal); return TCL_OK; } /* *----------------------------------------------------------------------------- * * StatementParamtypeMethod -- * * Defines a parameter type in a Postgres 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 */ = (StatementData*) Tcl_ObjectGetMetadata(thisObject, &statementDataType); static const struct { const char* name; int flags; } directions[] = { { "in", PARAM_IN }, { "out", PARAM_OUT }, { "inout", PARAM_IN | PARAM_OUT }, { NULL, 0 } }; int direction; int typeNum; /* Data type number of a parameter */ int precision; /* Data precision */ int scale; /* Data scale */ const char* paramName; /* Name of the parameter being set */ Tcl_Obj* targetNameObj; /* Name of the ith parameter in the statement */ const char* targetName; /* Name of a candidate parameter in the * statement */ int matchCount = 0; /* Number of parameters matching the name */ Tcl_Obj* errorObj; /* Error message */ int i; (void)dummy; /* Check parameters */ if (objc < 4) { goto wrongNumArgs; } i = 3; if (Tcl_GetIndexFromObjStruct(interp, objv[i], directions, sizeof(directions[0]), "direction", TCL_EXACT, &direction) != TCL_OK) { direction = PARAM_IN; Tcl_ResetResult(interp); } else { ++i; } if (i >= objc) goto wrongNumArgs; if (Tcl_GetIndexFromObjStruct(interp, objv[i], dataTypes, sizeof(dataTypes[0]), "SQL data type", TCL_EXACT, &typeNum) == TCL_OK) { ++i; } else { return TCL_ERROR; } if (i < objc) { if (Tcl_GetIntFromObj(interp, objv[i], &precision) == TCL_OK) { ++i; } else { return TCL_ERROR; } } if (i < objc) { if (Tcl_GetIntFromObj(interp, objv[i], &scale) == TCL_OK) { ++i; } else { return TCL_ERROR; } } if (i != objc) { goto wrongNumArgs; } /* Look up parameters by name. */ paramName = Tcl_GetString(objv[2]); for (i = 0; i < sdata->nParams; ++i) { Tcl_ListObjIndex(NULL, sdata->subVars, i, &targetNameObj); targetName = Tcl_GetString(targetNameObj); if (!strcmp(paramName, targetName)) { ++matchCount; sdata->params[i].flags = direction; if (sdata->paramDataTypes[i] != dataTypes[typeNum].oid) { sdata->paramTypesChanged = 1; } sdata->paramDataTypes[i] = dataTypes[typeNum].oid; sdata->params[i].precision = precision; sdata->params[i].scale = scale; } } if (matchCount == 0) { errorObj = Tcl_NewStringObj("unknown parameter \"", -1); Tcl_AppendToObj(errorObj, paramName, -1); Tcl_AppendToObj(errorObj, "\": must be ", -1); for (i = 0; i < sdata->nParams; ++i) { Tcl_ListObjIndex(NULL, sdata->subVars, i, &targetNameObj); Tcl_AppendObjToObj(errorObj, targetNameObj); if (i < sdata->nParams-2) { Tcl_AppendToObj(errorObj, ", ", -1); } else if (i == sdata->nParams-2) { Tcl_AppendToObj(errorObj, " or ", -1); } } Tcl_SetObjResult(interp, errorObj); return TCL_ERROR; } return TCL_OK; wrongNumArgs: Tcl_WrongNumArgs(interp, 2, objv, "name ?direction? type ?precision ?scale??"); return TCL_ERROR; } /* *----------------------------------------------------------------------------- * * DeleteStatementMetadata, DeleteStatement -- * * Cleans up when a Postgres statement is no longer required. * * Side effects: * Frees all resources associated with the statement. * *----------------------------------------------------------------------------- */ static void DeleteStatementMetadata( ClientData clientData /* Instance data for the connection */ ) { DecrStatementRefCount((StatementData*)clientData); } static void DeleteStatement( StatementData* sdata /* Metadata for the statement */ ) { if (sdata->columnNames != NULL) { Tcl_DecrRefCount(sdata->columnNames); } if (sdata->stmtName != NULL) { UnallocateStatement(sdata->cdata->pgPtr, sdata->stmtName); ckfree(sdata->stmtName); } if (sdata->nativeSql != NULL) { Tcl_DecrRefCount(sdata->nativeSql); } if (sdata->params != NULL) { ckfree(sdata->params); } if (sdata->paramDataTypes != NULL) { ckfree(sdata->paramDataTypes); } Tcl_DecrRefCount(sdata->subVars); DecrConnectionRefCount(sdata->cdata); ckfree(sdata); } /* *----------------------------------------------------------------------------- * * CloneStatement -- * * Attempts to clone a Postgres 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("Postgres statements are not clonable", -1)); return TCL_ERROR; } /* *----------------------------------------------------------------------------- * * ResultSetConstructor -- * * Constructs a new result set. * * Usage: * $resultSet new statement ?dictionary? * $resultSet create name statement ?dictionary? * * Parameters: * statement -- Statement handle to which this resultset belongs * dictionary -- Dictionary containing the substitutions for named * parameters in the given statement. * * Results: * Returns a standard Tcl result. On error, the interpreter result * contains an appropriate message. * *----------------------------------------------------------------------------- */ static int ResultSetConstructor( ClientData 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 args to skip */ Tcl_Object statementObject; /* The current statement object */ ConnectionData* cdata; /* The Postgres connection object's data */ StatementData* sdata; /* The statement object's data */ ResultSetData* rdata; /* THe result set object's data */ Tcl_Obj* paramNameObj; /* Name of the current parameter */ const char* paramName; /* Name of the current parameter */ Tcl_Obj* paramValObj; /* Value of the current parameter */ const char** paramValues; /* Table of values */ int* paramLengths; /* Table of parameter lengths */ int* paramFormats; /* Table of parameter formats * (binary or string) */ char* paramNeedsFreeing; /* Flags for whether a parameter needs * its memory released */ Tcl_Obj** paramTempObjs; /* Temporary parameter objects allocated * to canonicalize numeric parameter values */ PGresult* res; /* Temporary result */ int i; int status = TCL_ERROR; /* Return status */ (void)dummy; /* Check parameter count */ if (objc != skip+1 && objc != skip+2) { Tcl_WrongNumArgs(interp, skip, objv, "statement ?dictionary?"); return TCL_ERROR; } /* Initialize the base classes */ Tcl_ObjectContextInvokeNext(interp, context, skip, objv, skip); /* Find the statement object, and get the statement data */ statementObject = Tcl_GetObjectFromObj(interp, objv[skip]); if (statementObject == NULL) { return TCL_ERROR; } sdata = (StatementData*) Tcl_ObjectGetMetadata(statementObject, &statementDataType); if (sdata == NULL) { Tcl_AppendResult(interp, Tcl_GetString(objv[skip]), " does not refer to a Postgres statement", NULL); return TCL_ERROR; } cdata = sdata->cdata; rdata = (ResultSetData*) ckalloc(sizeof(ResultSetData)); memset(rdata, 0, sizeof(ResultSetData)); rdata->refCount = 1; rdata->sdata = sdata; rdata->stmtName = NULL; rdata->execResult = NULL; rdata->rowCount = 0; 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 & STMT_FLAG_BUSY) { rdata->stmtName = GenStatementName(cdata); res = PrepareStatement(interp, sdata, rdata->stmtName); if (res == NULL) { return TCL_ERROR; } if (TransferResultError(interp, res) != TCL_OK) { PQclear(res); return TCL_ERROR; } PQclear(res); } else { rdata->stmtName = sdata->stmtName; sdata->flags |= STMT_FLAG_BUSY; /* We need to check if parameter types changed since the * statement was prepared. If so, the statement is no longer * usable, so we prepare it once again */ if (sdata->paramTypesChanged) { UnallocateStatement(cdata->pgPtr, sdata->stmtName); ckfree(sdata->stmtName); sdata->stmtName = GenStatementName(cdata); rdata->stmtName = sdata->stmtName; res = PrepareStatement(interp, sdata, NULL); if (res == NULL) { return TCL_ERROR; } if (TransferResultError(interp, res) != TCL_OK) { PQclear(res); return TCL_ERROR; } PQclear(res); sdata->paramTypesChanged = 0; } } paramValues = (const char**) ckalloc(sdata->nParams * sizeof(char* )); paramLengths = (int*) ckalloc(sdata->nParams * sizeof(int*)); paramFormats = (int*) ckalloc(sdata->nParams * sizeof(int*)); paramNeedsFreeing = (char *)ckalloc(sdata->nParams); paramTempObjs = (Tcl_Obj**) ckalloc(sdata->nParams * sizeof(Tcl_Obj*)); memset(paramNeedsFreeing, 0, sdata->nParams); for (i = 0; i < sdata->nParams; i++) { paramTempObjs[i] = NULL; } for (i=0; inParams; i++) { Tcl_ListObjIndex(NULL, sdata->subVars, i, ¶mNameObj); paramName = Tcl_GetString(paramNameObj); if (objc == skip+2) { /* Param from a dictionary */ if (Tcl_DictObjGet(interp, objv[skip+1], paramNameObj, ¶mValObj) != TCL_OK) { goto freeParamTables; } } else { /* Param from a variable */ paramValObj = Tcl_GetVar2Ex(interp, paramName, NULL, TCL_LEAVE_ERR_MSG); } /* At this point, paramValObj contains the parameter value */ if (paramValObj != NULL) { char * bufPtr; int32_t tmp32; int16_t tmp16; switch (sdata->paramDataTypes[i]) { case INT2OID: bufPtr = (char *)ckalloc(sizeof(int)); if (Tcl_GetIntFromObj(interp, paramValObj, (int*) bufPtr) != TCL_OK) { goto freeParamTables; } paramValues[i] = (char *)ckalloc(sizeof(int16_t)); paramNeedsFreeing[i] = 1; tmp16 = *(int*) bufPtr; ckfree(bufPtr); *(int16_t*)(paramValues[i])=htons(tmp16); paramFormats[i] = 1; paramLengths[i] = sizeof(int16_t); break; case INT4OID: bufPtr = (char *)ckalloc(sizeof(long)); if (Tcl_GetLongFromObj(interp, paramValObj, (long*) bufPtr) != TCL_OK) { goto freeParamTables; } paramValues[i] = (char *)ckalloc(sizeof(int32_t)); paramNeedsFreeing[i] = 1; tmp32 = *(long*) bufPtr; ckfree(bufPtr); *((int32_t*)(paramValues[i]))=htonl(tmp32); paramFormats[i] = 1; paramLengths[i] = sizeof(int32_t); break; /* * With INT8, FLOAT4, FLOAT8, and NUMERIC, we will be passing * the parameter as text, but it may not be in a canonical * format, because Tcl will recognize binary, octal, and hex * constants where Postgres will not. Begin by extracting * wide int, float, or bignum from the parameter. If that * succeeds, reconvert the result to text to canonicalize * it, and send that text over. */ case INT8OID: case NUMERICOID: { Tcl_WideInt val; if (Tcl_GetWideIntFromObj(NULL, paramValObj, &val) == TCL_OK) { paramTempObjs[i] = Tcl_NewWideIntObj(val); Tcl_IncrRefCount(paramTempObjs[i]); paramFormats[i] = 0; paramValues[i] = Tcl_GetStringFromObj(paramTempObjs[i], ¶mLengths[i]); } else { goto convertString; /* If Tcl can't parse it, let SQL try */ } } break; case FLOAT4OID: case FLOAT8OID: { double val; if (Tcl_GetDoubleFromObj(NULL, paramValObj, &val) == TCL_OK) { paramTempObjs[i] = Tcl_NewDoubleObj(val); Tcl_IncrRefCount(paramTempObjs[i]); paramFormats[i] = 0; paramValues[i] = Tcl_GetStringFromObj(paramTempObjs[i], ¶mLengths[i]); } else { goto convertString; /* If Tcl can't parse it, let SQL try */ } } break; case BYTEAOID: paramFormats[i] = 1; paramValues[i] = (char*)Tcl_GetByteArrayFromObj(paramValObj, ¶mLengths[i]); break; default: convertString: paramFormats[i] = 0; paramValues[i] = Tcl_GetStringFromObj(paramValObj, ¶mLengths[i]); break; } } else { paramValues[i] = NULL; paramFormats[i] = 0; } } /* Execute the statement */ rdata->execResult = PQexecPrepared(cdata->pgPtr, rdata->stmtName, sdata->nParams, paramValues, paramLengths, paramFormats, 0); if (TransferResultError(interp, rdata->execResult) != TCL_OK) { goto freeParamTables; } sdata->columnNames = ResultDescToTcl(rdata->execResult, 0); Tcl_IncrRefCount(sdata->columnNames); status = TCL_OK; /* Clean up allocated memory */ freeParamTables: for (i = 0; i < sdata->nParams; ++i) { if (paramNeedsFreeing[i]) { ckfree((void *)paramValues[i]); } if (paramTempObjs[i] != NULL) { Tcl_DecrRefCount(paramTempObjs[i]); } } ckfree(paramValues); ckfree(paramLengths); ckfree(paramFormats); ckfree(paramNeedsFreeing); ckfree(paramTempObjs); return status; } /* *----------------------------------------------------------------------------- * * 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); StatementData* sdata = (StatementData*) rdata->sdata; (void)dummy; if (objc != 2) { Tcl_WrongNumArgs(interp, 2, objv, "?pattern?"); return TCL_ERROR; } Tcl_SetObjResult(interp, (sdata->columnNames)); return TCL_OK; } /* *----------------------------------------------------------------------------- * * ResultSetNextrowMethod -- * * Retrieves the next row from a result set. * * Usage: * $resultSet nextrow ?-as lists|dicts? ?--? variableName * * Options: * -as Selects the desired form for returning the results. * * Parameters: * variableName -- Variable in which the results are to be returned * * Results: * Returns a standard Tcl result. The interpreter result is 1 if there * are more rows remaining, and 0 if no more rows remain. * * Side effects: * Stores in the given variable either a list or a dictionary * containing one row of the result set. * *----------------------------------------------------------------------------- */ static int ResultSetNextrowMethod( ClientData clientData, /* Not used */ Tcl_Interp* interp, /* Tcl interpreter */ Tcl_ObjectContext context, /* Object context */ int objc, /* Parameter count */ Tcl_Obj *const objv[] /* Parameter vector */ ) { int lists = PTR2INT(clientData); 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; int nColumns = 0; /* Number of columns in the result set */ Tcl_Obj* colObj; /* Column obtained from the row */ Tcl_Obj* colName; /* Name of the current column */ Tcl_Obj* resultRow; /* Row of the result set under construction */ int status = TCL_ERROR; /* Status return from this command */ char * buffer; /* buffer containing field value */ int buffSize; /* size of buffer containing field value */ int i; if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "varName"); return TCL_ERROR; } /* Check if row counter haven't already rech the last row */ if (rdata->rowCount >= PQntuples(rdata->execResult)) { Tcl_SetObjResult(interp, literals[LIT_0]); return TCL_OK; } /* Get the column names in the result set. */ Tcl_ListObjLength(NULL, sdata->columnNames, &nColumns); if (nColumns == 0) { Tcl_SetObjResult(interp, literals[LIT_0]); return TCL_OK; } resultRow = Tcl_NewObj(); Tcl_IncrRefCount(resultRow); /* Retrieve one column at a time. */ for (i = 0; i < nColumns; ++i) { colObj = NULL; if (PQgetisnull(rdata->execResult, rdata->rowCount, i) == 0) { buffSize = PQgetlength(rdata->execResult, rdata->rowCount, i); buffer = PQgetvalue(rdata->execResult, rdata->rowCount, i); if (PQftype(rdata->execResult, i) == BYTEAOID) { /* * Postgres returns backslash-escape sequences for * binary data. Substitute them away. */ Tcl_Obj* toSubst; toSubst = Tcl_NewStringObj(buffer, buffSize); Tcl_IncrRefCount(toSubst); colObj = Tcl_SubstObj(interp, toSubst, TCL_SUBST_BACKSLASHES); Tcl_DecrRefCount(toSubst); } else { colObj = Tcl_NewStringObj((char*)buffer, buffSize); } } if (lists) { if (colObj == NULL) { colObj = Tcl_NewObj(); } Tcl_ListObjAppendElement(NULL, resultRow, colObj); } else { if (colObj != NULL) { Tcl_ListObjIndex(NULL, sdata->columnNames, i, &colName); Tcl_DictObjPut(NULL, resultRow, colName, colObj); } } } /* Advance to the next row */ rdata->rowCount += 1; /* 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; } /* *----------------------------------------------------------------------------- * * DeleteResultSetMetadata, DeleteResultSet -- * * Cleans up when a Postgres 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; if (rdata->stmtName != NULL) { if (rdata->stmtName != sdata->stmtName) { UnallocateStatement(sdata->cdata->pgPtr, rdata->stmtName); ckfree(rdata->stmtName); } else { sdata->flags &= ~ STMT_FLAG_BUSY; } } if (rdata->execResult != NULL) { PQclear(rdata->execResult); } DecrStatementRefCount(rdata->sdata); ckfree(rdata); } /* *----------------------------------------------------------------------------- * * CloneResultSet -- * * Attempts to clone a PostreSQL 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("Postgres result sets are not clonable", -1)); return TCL_ERROR; } /* *----------------------------------------------------------------------------- * * ResultSetRowcountMethod -- * * Returns (if known) the number of rows affected by a Postgres 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 */ ) { char * nTuples; 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 = rdata->sdata; /* The current statement */ ConnectionData* cdata = sdata->cdata; PerInterpData* pidata = cdata->pidata; /* Per-interp data */ Tcl_Obj** literals = pidata->literals; /* Literal pool */ (void)dummy; if (objc != 2) { Tcl_WrongNumArgs(interp, 2, objv, ""); return TCL_ERROR; } nTuples = PQcmdTuples(rdata->execResult); if (strlen(nTuples) == 0) { Tcl_SetObjResult(interp, literals[LIT_0]); } else { Tcl_SetObjResult(interp, Tcl_NewStringObj(nTuples, -1)); } return TCL_OK; } /* *----------------------------------------------------------------------------- * * Tdbcpostgres_Init -- * * Initializes the TDBC-POSTGRES bridge when this library is loaded. * * Side effects: * Creates the ::tdbc::postgres namespace and the commands that reside in it. * Initializes the POSTGRES environment. * *----------------------------------------------------------------------------- */ #ifdef __cplusplus extern "C" { #endif /* __cplusplus */ DLLEXPORT int Tdbcpostgres_Init( Tcl_Interp* interp /* Tcl interpreter */ ) { PerInterpData* pidata; /* Per-interpreter data for this package */ Tcl_Obj* nameObj; /* Name of a class or method being looked up */ Tcl_Object curClassObject; /* Tcl_Object representing the current class */ Tcl_Class curClass; /* Tcl_Class representing the current class */ int i; 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::postgres", PACKAGE_VERSION, NULL) != TCL_OK) { return TCL_ERROR; } /* * Create per-interpreter data for the package */ pidata = (PerInterpData*) ckalloc(sizeof(PerInterpData)); pidata->refCount = 1; for (i = 0; i < LIT__END; ++i) { pidata->literals[i] = Tcl_NewStringObj(LiteralValues[i], -1); Tcl_IncrRefCount(pidata->literals[i]); } Tcl_InitHashTable(&(pidata->typeNumHash), TCL_ONE_WORD_KEYS); for (i = 0; dataTypes[i].name != NULL; ++i) { int isNew; Tcl_HashEntry* entry = Tcl_CreateHashEntry(&(pidata->typeNumHash), INT2PTR(dataTypes[i].oid), &isNew); Tcl_Obj* nameObj = Tcl_NewStringObj(dataTypes[i].name, -1); Tcl_IncrRefCount(nameObj); Tcl_SetHashValue(entry, (ClientData) nameObj); } /* * Find the connection class, and attach an 'init' method to it. */ nameObj = Tcl_NewStringObj("::tdbc::postgres::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); Tcl_ClassSetConstructor(interp, curClass, Tcl_NewMethod(interp, curClass, NULL, 1, &ConnectionConstructorType, (ClientData) pidata)); /* Attach the methods to the 'connection' class */ for (i = 0; ConnectionMethods[i] != NULL; ++i) { nameObj = Tcl_NewStringObj(ConnectionMethods[i]->name, -1); Tcl_IncrRefCount(nameObj); Tcl_NewMethod(interp, curClass, nameObj, 1, ConnectionMethods[i], (ClientData) NULL); Tcl_DecrRefCount(nameObj); } /* Look up the 'statement' class */ nameObj = Tcl_NewStringObj("::tdbc::postgres::statement", -1); Tcl_IncrRefCount(nameObj); if ((curClassObject = Tcl_GetObjectFromObj(interp, nameObj)) == NULL) { Tcl_DecrRefCount(nameObj); return TCL_ERROR; } Tcl_DecrRefCount(nameObj); curClass = Tcl_GetObjectAsClass(curClassObject); /* Attach the constructor to the 'statement' class */ Tcl_ClassSetConstructor(interp, curClass, Tcl_NewMethod(interp, curClass, NULL, 1, &StatementConstructorType, (ClientData) NULL)); /* Attach the methods to the 'statement' class */ for (i = 0; StatementMethods[i] != NULL; ++i) { nameObj = Tcl_NewStringObj(StatementMethods[i]->name, -1); Tcl_IncrRefCount(nameObj); Tcl_NewMethod(interp, curClass, nameObj, 1, StatementMethods[i], (ClientData) NULL); Tcl_DecrRefCount(nameObj); } /* Look up the 'resultSet' class */ nameObj = Tcl_NewStringObj("::tdbc::postgres::resultset", -1); Tcl_IncrRefCount(nameObj); if ((curClassObject = Tcl_GetObjectFromObj(interp, nameObj)) == NULL) { Tcl_DecrRefCount(nameObj); return TCL_ERROR; } Tcl_DecrRefCount(nameObj); curClass = Tcl_GetObjectAsClass(curClassObject); /* Attach the constructor to the 'resultSet' class */ Tcl_ClassSetConstructor(interp, curClass, Tcl_NewMethod(interp, curClass, NULL, 1, &ResultSetConstructorType, (ClientData) NULL)); /* Attach the methods to the 'resultSet' class */ for (i = 0; ResultSetMethods[i] != NULL; ++i) { nameObj = Tcl_NewStringObj(ResultSetMethods[i]->name, -1); Tcl_IncrRefCount(nameObj); Tcl_NewMethod(interp, curClass, nameObj, 1, ResultSetMethods[i], (ClientData) NULL); Tcl_DecrRefCount(nameObj); } nameObj = Tcl_NewStringObj("nextlist", -1); Tcl_IncrRefCount(nameObj); Tcl_NewMethod(interp, curClass, nameObj, 1, &ResultSetNextrowMethodType, (ClientData) 1); Tcl_DecrRefCount(nameObj); nameObj = Tcl_NewStringObj("nextdict", -1); Tcl_IncrRefCount(nameObj); Tcl_NewMethod(interp, curClass, nameObj, 1, &ResultSetNextrowMethodType, (ClientData) 0); Tcl_DecrRefCount(nameObj); /* * Initialize the PostgreSQL library if this is the first interp using it. */ Tcl_MutexLock(&pgMutex); if (pgRefCount == 0) { if ((pgLoadHandle = PostgresqlInitStubs(interp)) == NULL) { Tcl_MutexUnlock(&pgMutex); return TCL_ERROR; } } ++pgRefCount; Tcl_MutexUnlock(&pgMutex); return TCL_OK; } #ifdef __cplusplus } #endif /* __cplusplus */ /* *----------------------------------------------------------------------------- * * DeletePerInterpData -- * * Delete per-interpreter data when the POSTGRES package is finalized * * Side effects: * * Releases the (presumably last) reference on the environment handle, * cleans up the literal pool, and deletes the per-interp data structure. * *----------------------------------------------------------------------------- */ static void DeletePerInterpData( PerInterpData* pidata /* Data structure to clean up */ ) { int i; Tcl_HashSearch search; Tcl_HashEntry *entry; for (entry = Tcl_FirstHashEntry(&(pidata->typeNumHash), &search); entry != NULL; entry = Tcl_NextHashEntry(&search)) { Tcl_Obj* nameObj = (Tcl_Obj*) Tcl_GetHashValue(entry); Tcl_DecrRefCount(nameObj); } Tcl_DeleteHashTable(&(pidata->typeNumHash)); for (i = 0; i < LIT__END; ++i) { Tcl_DecrRefCount(pidata->literals[i]); } ckfree(pidata); Tcl_MutexLock(&pgMutex); if (--pgRefCount == 0) { Tcl_FSUnloadFile(NULL, pgLoadHandle); pgLoadHandle = NULL; } Tcl_MutexUnlock(&pgMutex); } /* * Local Variables: * mode: c * c-basic-offset: 4 * End: */