/*------------------------------------------------------------------------- * * pgtclCmds.c * C functions which implement pg_* tcl commands * * Portions Copyright (c) 1996-2004, PostgreSQL Global Development Group * Portions Copyright (c) 1994, Regents of the University of California * * * IDENTIFICATION * $Id: pgtclCmds.c,v 1.3 2007-01-01 14:19:26+00 lbayuk Exp $ * *------------------------------------------------------------------------- */ #include #include #include "pgtclCmds.h" #include "pgtclId.h" #include "libpq/libpq-fs.h" /* large-object interface */ /* * Local function forward declarations */ static int execute_put_values(Tcl_Interp *interp, char *array_varname, PGresult *result, int tupno); static Tcl_Obj *result_get_obj(PGresult *result, int tupno, int colno); static Tcl_Obj *get_row_list_obj(Tcl_Interp *interp, PGresult *result, int tupno); /********************************** * pg_conndefaults syntax: pg_conndefaults the return result is a list describing the possible options and their current default values for a call to pg_connect with the new -conninfo syntax. Each entry in the list is a sublist of the format: {optname label dispchar dispsize value} **********************************/ int Pg_conndefaults(ClientData cData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { PQconninfoOption *options = PQconndefaults(); PQconninfoOption *option; if (objc != 1) { Tcl_WrongNumArgs(interp, 1, objv, ""); return TCL_ERROR; } if (options) { Tcl_Obj *resultList = Tcl_GetObjResult(interp); Tcl_SetListObj(resultList, 0, NULL); for (option = options; option->keyword != NULL; option++) { char *val = option->val ? option->val : ""; /* start a sublist */ Tcl_Obj *subList = Tcl_NewListObj(0, NULL); if (Tcl_ListObjAppendElement(interp, subList, Tcl_NewStringObj(option->keyword, -1)) == TCL_ERROR) return TCL_ERROR; if (Tcl_ListObjAppendElement(interp, subList, Tcl_NewStringObj(option->label, -1)) == TCL_ERROR) return TCL_ERROR; if (Tcl_ListObjAppendElement(interp, subList, Tcl_NewStringObj(option->dispchar, -1)) == TCL_ERROR) return TCL_ERROR; if (Tcl_ListObjAppendElement(interp, subList, Tcl_NewIntObj(option->dispsize)) == TCL_ERROR) return TCL_ERROR; if (Tcl_ListObjAppendElement(interp, subList, Tcl_NewStringObj(val, -1)) == TCL_ERROR) return TCL_ERROR; if (Tcl_ListObjAppendElement(interp, resultList, subList) == TCL_ERROR) return TCL_ERROR; } PQconninfoFree(options); } return TCL_OK; } /********************************** * pg_connect make a connection to a backend. syntax: pg_connect dbName [-host hostName] [-port portNumber] [-tty pqtty]] the return result is either an error message or a handle for a database connection. Handles start with the prefix "pgp" **********************************/ int Pg_connect(ClientData cData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { const char *pghost = NULL; const char *pgtty = NULL; const char *pgport = NULL; const char *pgoptions = NULL; const char *dbName; int i; PGconn *conn; char *firstArg; char *conninfoString; int optIndex; static CONST84 char *options[] = { "-host", "-port", "-tty", "-options", (char *)NULL }; enum options { OPT_HOST, OPT_PORT, OPT_TTY, OPT_OPTIONS }; if (objc == 1) { Tcl_AppendResult(interp, "pg_connect: database name missing\n", 0); Tcl_AppendResult(interp, "pg_connect databaseName [-host hostName] [-port portNumber] [-tty pgtty]\n", 0); Tcl_AppendResult(interp, "pg_connect -conninfo conninfoString", 0); return TCL_ERROR; } firstArg = Tcl_GetString(objv[1]); if (strcmp(firstArg, "-conninfo") == 0) { /* * Establish a connection using the new PQconnectdb() interface */ if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "conninfoString"); return TCL_ERROR; } conninfoString = Tcl_GetString(objv[2]); conn = PQconnectdb(conninfoString); } else { /* * Establish a connection using the old PQsetdb() interface */ if (objc > 2) { /* parse for pg environment settings */ i = 2; while (i + 1 < objc) { char *nextArg = Tcl_GetString(objv[i + 1]); /* process command options */ if (Tcl_GetIndexFromObj(interp, objv[i], options, "switch", TCL_EXACT, &optIndex) != TCL_OK) return TCL_ERROR; switch ((enum options) optIndex) { case OPT_HOST: { pghost = nextArg; i += 2; break; } case OPT_PORT: { pgport = nextArg; i += 2; break; } case OPT_TTY: { pgtty = nextArg; i += 2; break; } case OPT_OPTIONS: { pgoptions = nextArg; i += 2; } } } if ((i % 2 != 0) || i != objc) { Tcl_WrongNumArgs(interp, 1, objv, "databaseName ?-host hostName? ?-port portNumber? ?-tty pgtty? ?-options pgoptions?"); return TCL_ERROR; } } dbName = Tcl_GetString(objv[1]); conn = PQsetdb(pghost, pgport, pgoptions, pgtty, dbName); } if (PQstatus(conn) == CONNECTION_OK) { PgSetConnectionId(interp, conn); return TCL_OK; } else { Tcl_AppendResult(interp, "Connection to database failed\n", PQerrorMessage(conn), 0); PQfinish(conn); return TCL_ERROR; } } /********************************** * pg_disconnect close a backend connection syntax: pg_disconnect connection The argument passed in must be a connection pointer. **********************************/ int Pg_disconnect(ClientData cData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { PGconn *conn; Tcl_Channel conn_chan; char *connString; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "connection"); return TCL_ERROR; } connString = Tcl_GetString(objv[1]); conn_chan = Tcl_GetChannel(interp, connString, 0); if (conn_chan == NULL) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, connString, " is not a valid connection", 0); return TCL_ERROR; } /* Check that it is a PG connection and not something else */ conn = PgGetConnectionId(interp, connString, (Pg_ConnectionId **) NULL); if (conn == (PGconn *) NULL) return TCL_ERROR; return Tcl_UnregisterChannel(interp, conn_chan); } /********************************** * get_result_format - Helper for pg_exec_prepared and pg_exec_params Parse resultListObj and make resultFormat argument. The Tcl command syntax supports per-column result formats, but libpq does not (yet), so make sure the caller isn't asking for something that libpq can't handle. Take the first value, and make sure the remaining ones match. On success, store the result format in *resultFormat and return TCL_OK. On error, store a message in the interp and return TCL_ERROR. **********************************/ static int get_result_format(Tcl_Interp *interp, Tcl_Obj *resultListObj, int *resultFormat) { int listLen; Tcl_Obj **objp; int i; if (Tcl_ListObjGetElements(interp, resultListObj, &listLen, &objp) != TCL_OK) { Tcl_SetResult(interp, "Invalid resultFormatList parameter", TCL_STATIC); return TCL_ERROR; } if (listLen > 0) { *resultFormat = (*Tcl_GetString(objp[0]) == 'B'); for (i = 1; i < listLen; i++) if (*resultFormat != (*Tcl_GetString(objp[i]) == 'B')) { Tcl_SetResult(interp, "Mixed resultFormat values are not supported", TCL_STATIC); return TCL_ERROR; } } else *resultFormat = 0; /* Empty list => All TEXT */ return TCL_OK;; } /********************************** * get_param_formats - Helper for pg_exec_prepared and pg_exec_params Parse argFormat list and make paramFormats argument. The parameter must either be empty (all TEXT), a single word T*|B* (all that format), or nParams values, one per query parameter. The libpq call will accept a null pointer for this argument, meaning all text, so we can avoid the allocation in that most common case. Set the allParamsText flag in that case. On success, set or clear the allParamsText flag, store a NULL pointer or a pointer to nParams ints in paramFormatsResult, and return TCL_OK. (Caller must free paramFormatsResult.) On error, store a message in the interp and return TCL_ERROR. **********************************/ static int get_param_formats(Tcl_Interp *interp, Tcl_Obj *argFormatListObj, int nParams, int *allParamsText, int **paramFormatsResult) { int listLen; Tcl_Obj **objp; int *paramFormats; int i; if (Tcl_ListObjGetElements(interp, argFormatListObj, &listLen, &objp) != TCL_OK) { Tcl_SetResult(interp, "Invalid argFormatList parameter", TCL_STATIC); return TCL_ERROR; } paramFormats = NULL; *allParamsText = 1; if (listLen == 1) { if (*Tcl_GetString(objp[0]) == 'B') { paramFormats = (int *)Tcl_Alloc(nParams * sizeof(int)); for (i = 0; i < nParams; i++) paramFormats[i] = 1; *allParamsText = 0; } } else if (listLen > 1) { if (listLen != nParams) { Tcl_SetResult(interp, "Mismatched argFormatList and parameter count", TCL_STATIC); return TCL_ERROR; } paramFormats = (int *)Tcl_Alloc(nParams * sizeof(int)); for (i = 0; i < nParams; i++) if ((paramFormats[i] = (*Tcl_GetString(objp[i]) == 'B'))) *allParamsText = 0; } *paramFormatsResult = paramFormats; return TCL_OK; } /********************************** * get_param_values - Helper for pg_exec, pg_exec_prepared, and pg_exec_params For each query parameter, we need its address in an array paramValues. For each binary-format query parameter, we need its length in an array paramLengths. (Length is ignored for text-format parameters.) If there are no binary parameters, paramLengths will be NULL. (If this is known in advance, and the allParamText flag is 1, then the the paramLengths_result argument can be supplied as NULL. This is used by the extended form of pg_exec.) If there are no query parameters, both arrays are NULL. CHECK: Currently uses ByteArray for binary, String for text, but it is unclear if this is correct. Stores the results in *paramLengths_result and *paramValues_result, which the caller must free if not NULL. No errors, void return. **********************************/ static void get_param_values(Tcl_Interp *interp, Tcl_Obj *CONST *objv, int nParams, int allParamsText, int *paramFormats, const char *const **paramValues_result, int **paramLengths_result) { int i; int *paramLengths; const char **paramValues; paramLengths = NULL; paramValues = NULL; if (nParams > 0) { paramValues = (const char **)Tcl_Alloc(nParams * sizeof(char *)); if (!allParamsText) paramLengths = (int *)Tcl_Alloc(nParams * sizeof(int)); for (i = 0; i < nParams; i++) { if (paramFormats && paramFormats[i]) /* Binary Format */ paramValues[i] = (char *)Tcl_GetByteArrayFromObj(*objv, ¶mLengths[i]); else /* Text Format */ paramValues[i] = Tcl_GetString(*objv); objv++; } } *paramValues_result = paramValues; if (paramLengths_result) *paramLengths_result = paramLengths; } /********************************** * get_param_types - Helper for pg_exec_params Build an array of type OIDs from the supplied list. The list must either be empty or contain nParams items. Stores the result in *paramTypes, which the caller must free if not NULL. This will be either NULL or a pointer to nParams Oids. Returns TCL_OK if OK. On error, store a message in the interp and return TCL_ERROR. **********************************/ static int get_param_types(Tcl_Interp *interp, Tcl_Obj *argTypeListObj, int nParams, Oid **paramTypesResult) { int listLen; Tcl_Obj **objp; Oid *paramTypes; int i; if (Tcl_ListObjGetElements(interp, argTypeListObj, &listLen, &objp) != TCL_OK) { Tcl_SetResult(interp, "Invalid argTypeList parameter", TCL_STATIC); return TCL_ERROR; } paramTypes = NULL; if (listLen > 0) { if (listLen != nParams) { Tcl_SetResult(interp, "Mismatched argTypeList and parameter count", TCL_STATIC); return TCL_ERROR; } paramTypes = (Oid *)Tcl_Alloc(nParams * sizeof(int)); for (i = 0; i < nParams; i++) { /* * Note: paramTypes[i] is Oid which is unsigned int, and * Tcl_GetIntFromObj() expects a pointer to a signed int. * There is no direct support for unsigned in Tcl, but tests * and code examination show it will work for values that * will fit in unsigned but not signed. Anyway, it's the best * we can do. */ if (Tcl_GetIntFromObj(interp, objp[i], (int *)¶mTypes[i]) != TCL_OK) { Tcl_Free((char *)paramTypes); return TCL_ERROR; } } } *paramTypesResult = paramTypes; return TCL_OK; } /********************************** * PgQueryOK - Check that it is OK to send a query. This checks that the connection ID is valid, no COPY is in progress, and (if asyncOK is 0) no asynchronous query callback is active. Returns 1 if OK, else 0. On error, stores an error message in the interp (if applicable). *********************************/ static int PgQueryOK(Tcl_Interp *interp, PGconn *conn, Pg_ConnectionId *connid, int asyncOK) { if (conn == NULL) return 0; if (connid->res_copyStatus != RES_COPY_NONE) { Tcl_SetResult(interp, "Operation not allowed while COPY is in progress", TCL_STATIC); return 0; } if (!asyncOK && connid->callbackPtr) { Tcl_SetResult(interp, "Operation not allowed while waiting for callback", TCL_STATIC); return 0; } return 1; } /********************************** * pg_exec send a query string to the backend connection syntax: pg_exec connection query ?param...? Optional args are used as parameters to PQexecParams(). This is a simplified version of Pg_exec_params using text-only, untyped parameters. With no optional args, use regular PQexec(). the return result is either an error message or a handle for a query result. Handles start with the prefix "pgp" **********************************/ int Pg_exec(ClientData cData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { Pg_ConnectionId *connid; PGconn *conn; PGresult *result; char *connString; char *execString; const char *const *paramValues; int nParams; nParams = objc - 3; if (nParams < 0) { Tcl_WrongNumArgs(interp, 1, objv, "connection queryString ?param...?"); return TCL_ERROR; } connString = Tcl_GetString(objv[1]); conn = PgGetConnectionId(interp, connString, &connid); if (!PgQueryOK(interp, conn, connid, 0)) return TCL_ERROR; execString = Tcl_GetString(objv[2]); if (nParams > 0) { get_param_values(interp, &objv[3], nParams, /* allParamsText = */ 1, /* paramFormats = */ NULL, ¶mValues, /* paramLengths_result = */ NULL); result = PQexecParams(conn, execString, nParams, NULL, paramValues, NULL, NULL, /* resultFormat= */ 0); if (paramValues) Tcl_Free((char *)paramValues); } else { result = PQexec(conn, execString); } /* Transfer any notify events from libpq to Tcl event queue. */ PgNotifyTransferEvents(connid); if (result) { int rId = PgSetResultId(interp, connString, result); ExecStatusType rStat; if (rId == -1) { /* * Query response was OK, but unable to allocate result slot. * This is bad news, since the caller will think the query failed, * but the query may have worked and modified the database. * But there isn't much choice at this point. */ PQclear(result); return TCL_ERROR; } rStat = PQresultStatus(result); if (rStat == PGRES_COPY_IN || rStat == PGRES_COPY_OUT) { connid->res_copyStatus = RES_COPY_INPROGRESS; connid->res_copy = rId; connid->copyBuf = NULL; } return TCL_OK; } else { /* error occurred during the query */ Tcl_SetObjResult(interp, Tcl_NewStringObj(PQerrorMessage(conn), -1)); return TCL_ERROR; } } /********************************** * pg_exec_prepared Execute a pre-prepared query with supplied parameters Syntax: pg_exec_prepared connection statementName resultFormatList \ argFormatList ?param...? argFormatList is empty (= same as T), a single word T|B|TEXT|BINARY, or a list of those words, describing each argument as text or binary. If a single word, it applies to all arguments. (Actually, anything starting with B means Binary, and anything else means Text. There is no error checking.) resultFormatList is similar to argFormatList except that it applies to the columns of the results. Currently, all result parameters must be text, or all must be binary (this is a libpq limitation, not a PostgreSQL limitation). So you might as well specify a single word BINARY or leave it empty. The return result is either an error message or a handle for a query result. **********************************/ int Pg_exec_prepared(ClientData cData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { Pg_ConnectionId *connid; PGconn *conn; char *connString; PGresult *result; char *statementName; int nParams; int allParamsText; int resultFormat; int *paramFormats; int *paramLengths; const char *const *paramValues; int returnValue; nParams = objc - 5; if (nParams < 0) { Tcl_WrongNumArgs(interp, 1, objv, "connection statementName " "resultFormat argFormatList ?param...?"); return TCL_ERROR; } connString = Tcl_GetString(objv[1]); conn = PgGetConnectionId(interp, connString, &connid); if (!PgQueryOK(interp, conn, connid, 0)) return TCL_ERROR; statementName = Tcl_GetString(objv[2]); /* Parse resultFormatList and make resultFormat argument. */ if (get_result_format(interp, objv[3], &resultFormat) != TCL_OK) return TCL_ERROR; /* Parse argFormat list and make paramFormats argument and all-text flag */ if (get_param_formats(interp, objv[4], nParams, &allParamsText, ¶mFormats) != TCL_OK) return TCL_ERROR; /* Copy query parameters, and lengths if binary format */ get_param_values(interp, &objv[5], nParams, allParamsText, paramFormats, ¶mValues, ¶mLengths); /* Now execute the prepared query */ result = PQexecPrepared(conn, statementName, nParams, paramValues, paramLengths, paramFormats, resultFormat); /* Transfer any notify events from libpq to Tcl event queue. */ PgNotifyTransferEvents(connid); /* * Note: You can't use this command to start a COPY, so there is no * need to check for PGRES_COPY_* status like pg_exec does. */ if (!result) { /* error occurred during the query */ Tcl_SetObjResult(interp, Tcl_NewStringObj(PQerrorMessage(conn), -1)); returnValue = TCL_ERROR; } else if (PgSetResultId(interp, connString, result) == -1) { /* Query response was OK, but unable to allocate result slot. */ PQclear(result); returnValue = TCL_ERROR; } else returnValue = TCL_OK; if (paramFormats) Tcl_Free((char *)paramFormats); if (paramLengths) Tcl_Free((char *)paramLengths); if (paramValues) Tcl_Free((char *)paramValues); return returnValue; } /********************************** * pg_exec_params Parse, bind parameters, and execute a query Syntax: pg_exec_params connection query resultFormatList argFormatList argTypeList param... query is an SQL statement with parameter placeholders specified as $1, $2, etc. argFormatList is empty (= same as T), a single word T|B|TEXT|BINARY, or a list of those words, describing each argument as text or binary. If a single word, it applies to all arguments. (Actually, anything starting with B means Binary, and anything else means Text. There is no error checking.) resultFormatList is similar to argFormatList except that it applies to the columns of the results. Currently, all result parameters must be text, or all must be binary (this is a libpq limitation, not a PostgreSQL limitation). So you might as well specify a single word BINARY or leave it empty. argTypeList is a list of PostgreSQL type OIDs for the query parameter arguments. Type OIDs must be supplied for each binary-format argument. If there are any binary format arguments, the argTypeList must contain an entry for each argument, although the actual value will be ignored for text-mode arguments. Note: If you are using all text arguments, it is easier to use pg_exec with the optional parameter arguments. The return result is either an error message or a handle for a query result. **********************************/ int Pg_exec_params(ClientData cData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { Pg_ConnectionId *connid; PGconn *conn; char *connString; PGresult *result; char *queryString; int nParams; int allParamsText; int resultFormat; int *paramFormats; int *paramLengths; const char *const *paramValues; Oid *paramTypes; int returnValue; nParams = objc - 6; if (nParams < 0) { Tcl_WrongNumArgs(interp, 1, objv, "connection queryString " "resultFormat argFormatList argTypeList ?param...?"); return TCL_ERROR; } connString = Tcl_GetString(objv[1]); conn = PgGetConnectionId(interp, connString, &connid); if (!PgQueryOK(interp, conn, connid, 0)) return TCL_ERROR; queryString = Tcl_GetString(objv[2]); /* Parse resultFormatList and make resultFormat argument. */ if (get_result_format(interp, objv[3], &resultFormat) != TCL_OK) return TCL_ERROR; /* Parse argFormat list and make paramFormats argument and all-text flag */ if (get_param_formats(interp, objv[4], nParams, &allParamsText, ¶mFormats) != TCL_OK) return TCL_ERROR; /* Get the parameter type OID list into an array */ if (get_param_types(interp, objv[5], nParams, ¶mTypes) != TCL_OK) { if (paramFormats) Tcl_Free((char *)paramFormats); return TCL_ERROR; } /* Copy query parameters, and lengths if binary format */ get_param_values(interp, &objv[6], nParams, allParamsText, paramFormats, ¶mValues, ¶mLengths); /* Now execute the parameterized query */ result = PQexecParams(conn, queryString, nParams, paramTypes, paramValues, paramLengths, paramFormats, resultFormat); /* Transfer any notify events from libpq to Tcl event queue. */ PgNotifyTransferEvents(connid); /* * Note: You can't use this command to start a COPY, so there is no * need to check for PGRES_COPY_* status like pg_exec does. */ if (!result) { /* error occurred during the query */ Tcl_SetObjResult(interp, Tcl_NewStringObj(PQerrorMessage(conn), -1)); returnValue = TCL_ERROR; } else if (PgSetResultId(interp, connString, result) == -1) { /* Query response was OK, but unable to allocate result slot. */ PQclear(result); returnValue = TCL_ERROR; } else returnValue = TCL_OK; if (paramFormats) Tcl_Free((char *)paramFormats); if (paramLengths) Tcl_Free((char *)paramLengths); if (paramValues) Tcl_Free((char *)paramValues); if (paramTypes) Tcl_Free((char *)paramTypes); return returnValue; } /********************************** * pg_result_errorfield_code Translate error fieldName to fieldCode for pg_result -error?Field? Valid fieldNames are strings matching the constant name without PG_DIAG_, such as "SEVERITY", or the single letter code which is the value of the constant, like 'S'. See postgres_ext.h for the list. For compatibility with Gborg pgtcl-1.4, these changes have been made: Accept field names without MESSAGE_, SOURCE_, STATEMENT_ prefix. Do case insensitive compares (Gborg pgtcl uses lower case names only, and previous versions of this code used upper case only.) Returns a valid PG_DIAG_* constant, or 0 if there is no match. **********************************/ static int pg_result_errorfield_code(char *fieldName) { static struct errorfield_names_t { char *fieldName, fieldCode; } errorfield_names[] = { { "SEVERITY", PG_DIAG_SEVERITY }, { "SQLSTATE", PG_DIAG_SQLSTATE }, { "MESSAGE_PRIMARY", PG_DIAG_MESSAGE_PRIMARY }, { "MESSAGE_DETAIL", PG_DIAG_MESSAGE_DETAIL }, { "MESSAGE_HINT", PG_DIAG_MESSAGE_HINT }, { "STATEMENT_POSITION", PG_DIAG_STATEMENT_POSITION }, { "CONTEXT", PG_DIAG_CONTEXT }, { "SOURCE_FILE", PG_DIAG_SOURCE_FILE }, { "SOURCE_LINE", PG_DIAG_SOURCE_LINE }, { "SOURCE_FUNCTION", PG_DIAG_SOURCE_FUNCTION }, /* These are for compatibility with Gborg pgtcl-1.4: */ { "PRIMARY", PG_DIAG_MESSAGE_PRIMARY }, { "DETAIL", PG_DIAG_MESSAGE_DETAIL }, { "HINT", PG_DIAG_MESSAGE_HINT }, { "POSITION", PG_DIAG_STATEMENT_POSITION }, { "FILE", PG_DIAG_SOURCE_FILE }, { "LINE", PG_DIAG_SOURCE_LINE }, { "FUNCTION", PG_DIAG_SOURCE_FUNCTION }, { 0, '\0'}}; struct errorfield_names_t *ep = errorfield_names; char field1; if (!fieldName || !fieldName[0]) return 0; if (fieldName[1]) { /* Check for exact word match if length>1, case insensitively */ while (ep->fieldName && !Tcl_StringCaseMatch(fieldName, ep->fieldName, 1)) ep++; } else { /* Check for single-character code match, case insensitive. Note these are being checked against the PG_DIAG_* values, which are defined in postgres_ext.h as single upper-case chars. */ field1 = toupper(fieldName[0]); while (ep->fieldCode && ep->fieldCode != field1) ep++; } return ep->fieldCode; } /********************************** * pg_result get information about the results of a query syntax: pg_result result ?option? the options are: -status the status of the result -error ?code? -errorField ?code? If the status does not indicate an error, returns an empty string. Else, if no code is provided, returns the current error message. Else, the code names an error message subfield or abbreviation, and the value of that error field is returned if valid and available. Else, an empty string is returned. Note: -errorField was introduced first, but for compatibility with Gborg pgtcl 1.4 the error field code was made optional to -error and now we implement both of these as the same. -conn the connection that produced the result -oid if command was an INSERT, the OID of the inserted tuple -numTuples the number of tuples in the query -cmdTuples Same as -numTuples, but for DELETE and UPDATE -cmdStatus returns the command status tag, e.g. "INSERT ... ..." -numAttrs returns the number of attributes returned by the query -assign arrayName assign the results to an array, using subscripts of the form (tupno,attributeName) -assignbyidx arrayName ?appendstr? assign the results to an array using the first field's value as a key. All but the first field of each tuple are stored, using subscripts of the form (field0value,attributeNameappendstr) -getTuple tupleNumber returns the values of the tuple in a list -getNull tupleNumber returns a list indicating if each value in the tuple is NULL -tupleArray tupleNumber arrayName stores the values of the tuple in array arrayName, indexed by the attributes returned -attributes returns a list of the name/type pairs of the tuple attributes -lAttributes returns a list of the {name type len} entries of the tuple attributes -lxAttributes returns an extended list of the tuple attributes in the form: {name type size size_modifier format table_oid table_column} -list returns one list of all of the data -llist returns a list of lists, where each embedded list represents a tuple in the result -clear clear the result buffer. Do not reuse after this **********************************/ int Pg_result(ClientData cData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { PGresult *result; int i; int tupno; char *queryResultString; int optIndex; static CONST84 char *options[] = { "-status", "-error", "-errorField", "-conn", "-oid", "-numTuples", "-cmdTuples", "-numAttrs", "-assign", "-assignbyidx", "-getTuple", "-tupleArray", "-attributes", "-lAttributes", "-lxAttributes", "-clear", "-list", "-llist", "-getNull", "-cmdStatus", (char *)NULL }; enum options { OPT_STATUS, OPT_ERROR, OPT_ERRORFIELD, OPT_CONN, OPT_OID, OPT_NUMTUPLES, OPT_CMDTUPLES, OPT_NUMATTRS, OPT_ASSIGN, OPT_ASSIGNBYIDX, OPT_GETTUPLE, OPT_TUPLEARRAY, OPT_ATTRIBUTES, OPT_LATTRIBUTES, OPT_LXATTRIBUTES, OPT_CLEAR, OPT_LIST, OPT_LLIST, OPT_GETNULL, OPT_CMDSTATUS }; /* * Check for resultHandle and switch. Subfunctions will further check * their argument counts. Note: Common Tcl practice is that with too * few args, the command reports "wrong # args: should be..." and just * summarizes the usage. With an invalid arg, the command lists all * valid args: "bad option "...": must be A, B, ...". * pg_result now does this; please don't change it back. */ if (objc < 3) { Tcl_WrongNumArgs(interp, 1, objv, "resultHandle switch ?arg ...?"); return TCL_ERROR; } /* figure out the query result handle and look it up */ queryResultString = Tcl_GetString(objv[1]); result = PgGetResultId(interp, queryResultString); if (result == (PGresult *)NULL) { Tcl_AppendResult(interp, "\n", queryResultString, " is not a valid query result", (char *)NULL); return TCL_ERROR; } /* process command options */ if (Tcl_GetIndexFromObj(interp, objv[2], options, "switch", TCL_EXACT, &optIndex) != TCL_OK) return TCL_ERROR; switch ((enum options) optIndex) { case OPT_STATUS: { char *resultStatus; if (objc != 3) { Tcl_WrongNumArgs(interp, 3, objv, NULL); return TCL_ERROR; } resultStatus = PQresStatus(PQresultStatus(result)); Tcl_SetObjResult(interp, Tcl_NewStringObj(resultStatus, -1)); return TCL_OK; } case OPT_ERROR: /* Fall through - these subcommands are now identical */ case OPT_ERRORFIELD: { char *fieldName; int fieldCode; char *errorField; if (objc == 3) { Tcl_SetObjResult(interp, Tcl_NewStringObj(PQresultErrorMessage(result), -1)); return TCL_OK; } if (objc != 4) { Tcl_WrongNumArgs(interp, 3, objv, "?fieldName?"); return TCL_ERROR; } fieldName = Tcl_GetString(objv[3]); if ((fieldCode = pg_result_errorfield_code(fieldName)) != 0 && (errorField = PQresultErrorField(result, fieldCode)) != NULL) Tcl_SetObjResult(interp, Tcl_NewStringObj(errorField, -1)); return TCL_OK; } case OPT_CONN: { if (objc != 3) { Tcl_WrongNumArgs(interp, 3, objv, NULL); return TCL_ERROR; } return PgGetConnByResultId(interp, queryResultString); } case OPT_OID: { if (objc != 3) { Tcl_WrongNumArgs(interp, 3, objv, NULL); return TCL_ERROR; } Tcl_SetLongObj(Tcl_GetObjResult(interp), PQoidValue(result)); return TCL_OK; } case OPT_CLEAR: { if (objc != 3) { Tcl_WrongNumArgs(interp, 3, objv, NULL); return TCL_ERROR; } PgDelResultId(interp, queryResultString); PQclear(result); return TCL_OK; } case OPT_NUMTUPLES: { if (objc != 3) { Tcl_WrongNumArgs(interp, 3, objv, NULL); return TCL_ERROR; } Tcl_SetIntObj(Tcl_GetObjResult(interp), PQntuples(result)); return TCL_OK; } case OPT_CMDTUPLES: { if (objc != 3) { Tcl_WrongNumArgs(interp, 3, objv, NULL); return TCL_ERROR; } Tcl_SetStringObj(Tcl_GetObjResult(interp), PQcmdTuples(result), -1); return TCL_OK; } case OPT_CMDSTATUS: { if (objc != 3) { Tcl_WrongNumArgs(interp, 3, objv, NULL); return TCL_ERROR; } Tcl_SetStringObj(Tcl_GetObjResult(interp), PQcmdStatus(result), -1); return TCL_OK; } case OPT_NUMATTRS: { if (objc != 3) { Tcl_WrongNumArgs(interp, 3, objv, NULL); return TCL_ERROR; } Tcl_SetIntObj(Tcl_GetObjResult(interp), PQnfields(result)); return TCL_OK; } case OPT_ASSIGN: { Tcl_Obj *fieldNameObj; Tcl_Obj *arrVarObj; int ncols = PQnfields(result); int nrows = PQntuples(result); if (objc != 4) { Tcl_WrongNumArgs(interp, 3, objv, "arrayName"); return TCL_ERROR; } arrVarObj = objv[3]; fieldNameObj = Tcl_NewObj (); /* * this assignment assigns the table of result tuples into * a giant array with the name given in the argument. The * indices of the array are of the form (tupno,attrName). */ for (tupno = 0; tupno < nrows; tupno++) { for (i = 0; i < ncols; i++) { /* * construct the array element name consisting * of the tuple number, a comma, and the field * name. * this is a little kludgey -- we set the obj * to an int but the append following will force a * string conversion. */ Tcl_SetIntObj(fieldNameObj, tupno); Tcl_AppendToObj(fieldNameObj, ",", 1); Tcl_AppendToObj(fieldNameObj, PQfname(result, i), -1); if (Tcl_ObjSetVar2(interp, arrVarObj, fieldNameObj, result_get_obj(result, tupno, i), TCL_LEAVE_ERR_MSG) == NULL) { Tcl_DecrRefCount (fieldNameObj); return TCL_ERROR; } } } Tcl_DecrRefCount (fieldNameObj); return TCL_OK; } case OPT_ASSIGNBYIDX: { Tcl_Obj *fieldNameObj; Tcl_Obj *arrVarObj; Tcl_Obj *appendstrObj; Tcl_Obj *field0; int ncols = PQnfields(result); int nrows = PQntuples(result); if ((objc != 4) && (objc != 5)) { Tcl_WrongNumArgs(interp, 3, objv, "arrayName ?append_string?"); return TCL_ERROR; } arrVarObj = objv[3]; fieldNameObj = Tcl_NewObj(); Tcl_IncrRefCount(fieldNameObj); if (objc == 5) appendstrObj = objv[4]; else appendstrObj = NULL; /* * this assignment assigns the table of result tuples into * a giant array with the name given in the argument. The * indices of the array are of the form * (field0Value,attrNameappendstr). Here, we still assume * PQfname won't exceed 200 characters, but we dare not * make the same assumption about the data in field 0 nor * the append string. */ for (tupno = 0; tupno < nrows; tupno++) { field0 = result_get_obj(result, tupno, 0); Tcl_IncrRefCount(field0); for (i = 1; i < ncols; i++) { Tcl_SetObjLength(fieldNameObj, 0); Tcl_AppendObjToObj(fieldNameObj, field0); Tcl_AppendToObj(fieldNameObj, ",", 1); Tcl_AppendToObj(fieldNameObj, PQfname(result, i), -1); if (appendstrObj != NULL) Tcl_AppendObjToObj(fieldNameObj, appendstrObj); if (Tcl_ObjSetVar2(interp, arrVarObj, fieldNameObj, result_get_obj(result, tupno, i), TCL_LEAVE_ERR_MSG) == NULL) { Tcl_DecrRefCount(fieldNameObj); Tcl_DecrRefCount(field0); return TCL_ERROR; } } Tcl_DecrRefCount(field0); } Tcl_DecrRefCount(fieldNameObj); return TCL_OK; } case OPT_GETTUPLE: { Tcl_Obj *resultObj; if (objc != 4) { Tcl_WrongNumArgs(interp, 3, objv, "tuple_number"); return TCL_ERROR; } if (Tcl_GetIntFromObj(interp, objv[3], &tupno) == TCL_ERROR) return TCL_ERROR; if (tupno < 0 || tupno >= PQntuples(result)) { Tcl_AppendResult(interp, "argument to getTuple cannot exceed number of tuples - 1", 0); return TCL_ERROR; } /* set the result object to be the list of values */ resultObj = get_row_list_obj(interp, result, tupno); if (!resultObj) return TCL_ERROR; Tcl_IncrRefCount(resultObj); /* Make this object the interpreter result */ Tcl_SetObjResult(interp, resultObj); Tcl_DecrRefCount(resultObj); return TCL_OK; } case OPT_TUPLEARRAY: { char *arrayName; int ncols = PQnfields(result); if (objc != 5) { Tcl_WrongNumArgs(interp, 3, objv, "tuple_number array_name"); return TCL_ERROR; } if (Tcl_GetIntFromObj(interp, objv[3], &tupno) == TCL_ERROR) return TCL_ERROR; if (tupno < 0 || tupno >= PQntuples(result)) { Tcl_AppendResult(interp, "argument to tupleArray cannot exceed number of tuples - 1", 0); return TCL_ERROR; } arrayName = Tcl_GetString(objv[4]); for (i = 0; i < ncols; i++) { if (Tcl_SetVar2Ex(interp, arrayName, PQfname(result, i), result_get_obj(result, tupno, i), TCL_LEAVE_ERR_MSG) == NULL) return TCL_ERROR; } return TCL_OK; } case OPT_ATTRIBUTES: { Tcl_Obj *resultObj = Tcl_GetObjResult(interp); int ncols = PQnfields(result); if (objc != 3) { Tcl_WrongNumArgs(interp, 3, objv, NULL); return TCL_ERROR; } Tcl_SetListObj(resultObj, 0, NULL); for (i = 0; i < ncols; i++) { Tcl_ListObjAppendElement(interp, resultObj, Tcl_NewStringObj(PQfname(result, i), -1)); } return TCL_OK; } case OPT_LATTRIBUTES: { Tcl_Obj *resultObj = Tcl_GetObjResult(interp); int ncols = PQnfields(result); if (objc != 3) { Tcl_WrongNumArgs(interp, 3, objv, NULL); return TCL_ERROR; } Tcl_SetListObj(resultObj, 0, NULL); /* For each column: {name type size} */ for (i = 0; i < ncols; i++) { Tcl_Obj *subList = Tcl_NewListObj(0, NULL); Tcl_IncrRefCount(subList); if (Tcl_ListObjAppendElement(interp, subList, Tcl_NewStringObj(PQfname(result, i), -1) ) == TCL_ERROR || Tcl_ListObjAppendElement(interp, subList, Tcl_NewLongObj((long)PQftype(result, i)) ) == TCL_ERROR || Tcl_ListObjAppendElement(interp, subList, Tcl_NewIntObj(PQfsize(result, i)) ) == TCL_ERROR || Tcl_ListObjAppendElement(interp, resultObj, subList) == TCL_ERROR) { Tcl_DecrRefCount(subList); return TCL_ERROR; } Tcl_DecrRefCount(subList); } return TCL_OK; } case OPT_LXATTRIBUTES: { Tcl_Obj *resultObj = Tcl_GetObjResult(interp); int ncols = PQnfields(result); if (objc != 3) { Tcl_WrongNumArgs(interp, 3, objv, NULL); return TCL_ERROR; } Tcl_SetListObj(resultObj, 0, NULL); /* For each column: {name type size sizemod format tblOid tblCol} */ for (i = 0; i < ncols; i++) { Tcl_Obj *subList = Tcl_NewListObj(0, NULL); Tcl_IncrRefCount(subList); if (Tcl_ListObjAppendElement(interp, subList, Tcl_NewStringObj(PQfname(result, i), -1) ) == TCL_ERROR || Tcl_ListObjAppendElement(interp, subList, Tcl_NewLongObj((long)PQftype(result, i)) ) == TCL_ERROR || Tcl_ListObjAppendElement(interp, subList, Tcl_NewIntObj(PQfsize(result, i)) ) == TCL_ERROR || Tcl_ListObjAppendElement(interp, subList, Tcl_NewIntObj(PQfmod(result, i)) ) == TCL_ERROR || Tcl_ListObjAppendElement(interp, subList, Tcl_NewIntObj(PQfformat(result, i)) ) == TCL_ERROR || Tcl_ListObjAppendElement(interp, subList, Tcl_NewLongObj((long)PQftable(result, i)) ) == TCL_ERROR || Tcl_ListObjAppendElement(interp, subList, Tcl_NewLongObj((long)PQftablecol(result, i)) ) == TCL_ERROR || Tcl_ListObjAppendElement(interp, resultObj, subList) == TCL_ERROR) { Tcl_DecrRefCount(subList); return TCL_ERROR; } Tcl_DecrRefCount(subList); } return TCL_OK; } case OPT_LIST: { Tcl_Obj *listObj; Tcl_Obj *subListObj; int nrows = PQntuples(result); if (objc != 3) { Tcl_WrongNumArgs(interp, 3, objv, NULL); return TCL_ERROR; } listObj = Tcl_NewListObj(0, (Tcl_Obj **) NULL); Tcl_IncrRefCount(listObj); /* ** Loop through the tuple, and append each ** value to the list ** ** This option appends all of the values ** for each tuple to the same list ** ** According to brett, it performs better when you make a ** sublist for each tuple and append the sublist to a main ** list, rather than appending each value separately. ** That's why this uses get_row_list_obj(). */ for (tupno = 0; tupno < nrows; tupno++) { subListObj = get_row_list_obj(interp, result, tupno); if (!subListObj) { Tcl_DecrRefCount(listObj); return TCL_ERROR; } Tcl_IncrRefCount(subListObj); if (Tcl_ListObjAppendList(interp, listObj, subListObj) != TCL_OK) { Tcl_DecrRefCount(listObj); Tcl_DecrRefCount(subListObj); return TCL_ERROR; } Tcl_DecrRefCount(subListObj); } Tcl_SetObjResult(interp, listObj); Tcl_DecrRefCount(listObj); return TCL_OK; } case OPT_LLIST: { Tcl_Obj *listObj; Tcl_Obj *subListObj; int nrows = PQntuples(result); if (objc != 3) { Tcl_WrongNumArgs(interp, 3, objv, NULL); return TCL_ERROR; } listObj = Tcl_NewListObj(0, (Tcl_Obj **) NULL); Tcl_IncrRefCount(listObj); /* ** This is the top level list. This ** contains the other lists ** ** This option contructs a list of ** values for each tuple, and ** appends that to the main list. ** This is a list of lists */ for (tupno = 0; tupno < nrows; tupno++) { subListObj = get_row_list_obj(interp, result, tupno); if (!subListObj) { Tcl_DecrRefCount(listObj); return TCL_ERROR; } Tcl_IncrRefCount(subListObj); if (Tcl_ListObjAppendElement(interp, listObj, subListObj) != TCL_OK) { Tcl_DecrRefCount(listObj); Tcl_DecrRefCount(subListObj); return TCL_ERROR; } Tcl_DecrRefCount(subListObj); } Tcl_SetObjResult(interp, listObj); Tcl_DecrRefCount(listObj); return TCL_OK; } case OPT_GETNULL: { Tcl_Obj *resultObj = Tcl_GetObjResult(interp); int ncols = PQnfields(result); Tcl_Obj *trueObj, *falseObj; if (objc != 4) { Tcl_WrongNumArgs(interp, 3, objv, "tuple_number"); return TCL_ERROR; } if (Tcl_GetIntFromObj(interp, objv[3], &tupno) == TCL_ERROR) return TCL_ERROR; if (tupno < 0 || tupno >= PQntuples(result)) { Tcl_AppendResult(interp, "argument to getNull cannot exceed number of tuples - 1", 0); return TCL_ERROR; } Tcl_SetListObj(resultObj, 0, NULL); trueObj = Tcl_NewBooleanObj(1); Tcl_IncrRefCount(trueObj); falseObj = Tcl_NewBooleanObj(0); Tcl_IncrRefCount(falseObj); for (i = 0; i < ncols; i++) { Tcl_ListObjAppendElement(interp, resultObj, PQgetisnull(result, tupno, i) ? trueObj : falseObj); } Tcl_DecrRefCount(trueObj); Tcl_DecrRefCount(falseObj); return TCL_OK; } default: /* * Note: This should never happend, since Tcl_GetIndexFromObj * already checked for a valid switch. */ Tcl_AppendResult(interp, "pg_result: invalid option\n", NULL); return TCL_ERROR; } } /********************************** * result_get_obj Return a single result value as a Tcl_Obj. For Text format columns, return a StringObj. For Binary format columns, return a ByteArray object. The returned object has reference count 0. Note: This should be the *only* place in the package where we fetch a value from a query result - the only place libpq's PQgetvalue is used. **********************************/ static Tcl_Obj * result_get_obj(PGresult *result, int tupno, int colno) { if (PQfformat(result, colno) == 0) /* This is a Text format column */ return Tcl_NewStringObj(PQgetvalue(result, tupno, colno), -1); /* This is a Binary format column */ return Tcl_NewByteArrayObj((unsigned char *)PQgetvalue(result, tupno, colno), PQgetlength(result, tupno, colno)); } /********************************** * get_row_list_obj Return the values for a result row as a list object. The row number tupno must be within range (checked by caller). On error (unlikely), returns NULL and leaves an error message in the interpreter. The returned object has reference count 0. **********************************/ static Tcl_Obj * get_row_list_obj(Tcl_Interp *interp, PGresult *result, int tupno) { int colno; Tcl_Obj *resultObj = Tcl_NewListObj(0, NULL); int ncols = PQnfields(result); for (colno = 0; colno < ncols; colno++) { if (Tcl_ListObjAppendElement(interp, resultObj, result_get_obj(result, tupno, colno)) == TCL_ERROR) { Tcl_DecrRefCount(resultObj); /* Free the object */ return NULL; } } return resultObj; /* Return an object with refCount=0 */ } /********************************** * pg_execute send a query string to the backend connection and process the result syntax: pg_execute ?-array name? ?-oid varname? connection query ?loop_body? the return result is the number of tuples processed. If the query returns tuples (i.e. a SELECT statement), the result is placed into variables **********************************/ int Pg_execute(ClientData cData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { Pg_ConnectionId *connid; PGconn *conn; PGresult *result; int i; int tupno; int ntup; int loop_rc = TCL_OK; char *array_varname = NULL; char *arg; char *connString; char *queryString; Tcl_Obj *oid_varnameObj = NULL; Tcl_Obj *evalObj; Tcl_Obj *resultObj; char *usage = "?-array arrayname? ?-oid varname? " "connection queryString ?loop_body?"; /* * First we parse the options */ i = 1; while (i < objc) { arg = Tcl_GetString(objv[i]); if (arg[0] != '-') break; if (strcmp(arg, "-array") == 0) { /* * The rows should appear in an array vs. to single variables */ i++; if (i == objc) { Tcl_WrongNumArgs(interp, 1, objv, usage); return TCL_ERROR; } array_varname = Tcl_GetString(objv[i++]); continue; } arg = Tcl_GetString(objv[i]); if (strcmp(arg, "-oid") == 0) { /* * We should place PQoidValue() somewhere */ i++; if (i == objc) { Tcl_WrongNumArgs(interp, 1, objv, usage); return TCL_ERROR; } oid_varnameObj = objv[i++]; continue; } Tcl_WrongNumArgs(interp, 1, objv, usage); return TCL_ERROR; } /* * Check that after option parsing at least 'connection' and 'query' * are left */ if (objc - i < 2) { Tcl_WrongNumArgs(interp, 1, objv, usage); return TCL_ERROR; } /* * Get the connection and make sure no COPY command is pending */ connString = Tcl_GetString(objv[i++]); conn = PgGetConnectionId(interp, connString, &connid); if (!PgQueryOK(interp, conn, connid, 0)) return TCL_ERROR; /* * Execute the query */ queryString = Tcl_GetString(objv[i++]); result = PQexec(conn, queryString); /* * Transfer any notify events from libpq to Tcl event queue. */ PgNotifyTransferEvents(connid); /* * Check for errors */ if (result == NULL) { Tcl_SetResult(interp, PQerrorMessage(conn), TCL_VOLATILE); return TCL_ERROR; } /* * Set the oid variable to the returned oid of an INSERT statement if * requested (or 0 if it wasn't an INSERT) */ if (oid_varnameObj != NULL) { if (Tcl_ObjSetVar2(interp, oid_varnameObj, NULL, Tcl_NewLongObj((long)PQoidValue(result)), TCL_LEAVE_ERR_MSG) == NULL) { PQclear(result); return TCL_ERROR; } } /* * Decide how to go on based on the result status */ switch (PQresultStatus(result)) { case PGRES_TUPLES_OK: /* fall through if we have tuples */ break; case PGRES_EMPTY_QUERY: case PGRES_COMMAND_OK: /* tell the number of affected tuples for non-SELECT queries */ Tcl_SetObjResult(interp, Tcl_NewStringObj(PQcmdTuples(result), -1)); PQclear(result); return TCL_OK; /* * Note: COPY_IN and COPY_OUT are not allowed with pg_execute * because there is no result handle returned, and copy needs one. * Return an error, but it probably is not recoverable because * the connection is already in COPY mode. */ case PGRES_COPY_IN: case PGRES_COPY_OUT: Tcl_SetResult(interp, "Not allowed to start COPY with pg_execute", TCL_STATIC); PQclear(result); return TCL_ERROR; default: /* anything else must be an error */ /* set the result object to be an empty list */ resultObj = Tcl_GetObjResult(interp); Tcl_SetListObj(resultObj, 0, NULL); if (Tcl_ListObjAppendElement(interp, resultObj, Tcl_NewStringObj(PQresStatus(PQresultStatus(result)), -1)) == TCL_ERROR) return TCL_ERROR; if (Tcl_ListObjAppendElement(interp, resultObj, Tcl_NewStringObj(PQresultErrorMessage(result), -1)) == TCL_ERROR) return TCL_ERROR; PQclear(result); return TCL_ERROR; } /* * We reach here only for queries that returned tuples */ if (i == objc) { /* * We don't have a loop body. If we have at least one result row, * we set all the variables to the first one and return. */ if (PQntuples(result) > 0) { if (execute_put_values(interp, array_varname, result, 0) != TCL_OK) { PQclear(result); return TCL_ERROR; } } Tcl_SetObjResult(interp, Tcl_NewIntObj(PQntuples(result))); PQclear(result); return TCL_OK; } /* * We have a loop body. For each row in the result set, put the values * into the Tcl variables and execute the body. */ ntup = PQntuples(result); evalObj = objv[i]; for (tupno = 0; tupno < ntup; tupno++) { if (execute_put_values(interp, array_varname, result, tupno) != TCL_OK) { PQclear(result); return TCL_ERROR; } loop_rc = Tcl_EvalObjEx(interp, evalObj, 0); /* The returncode of the loop body controls the loop execution */ if (loop_rc != TCL_OK && loop_rc != TCL_CONTINUE) { if (loop_rc == TCL_ERROR) { /* Show where the error occurred */ char msg[60]; sprintf(msg, "\n (\"pg_execute\" body line %d)", interp->errorLine); Tcl_AddErrorInfo(interp, msg); } else if (loop_rc == TCL_BREAK) { /* On break, break out but return OK */ loop_rc = TCL_OK; } break; } } /* * At the end of the loop we put the number of rows we got into the * interpreter result, but only on normal return, and clear the result set. */ if (loop_rc == TCL_OK) Tcl_SetObjResult(interp, Tcl_NewIntObj(ntup)); PQclear(result); return loop_rc; } /********************************** * execute_put_values Put the values of one tuple into Tcl variables named like the column names, or into an array indexed by the column names. **********************************/ static int execute_put_values(Tcl_Interp *interp, char *array_varname, PGresult *result, int tupno) { int i; int n; Tcl_Obj *value; /* * Note: "gcc -Wall" reports that the following two variables * "may be used uninitialized", but that is not true. */ char *varname; char *indexname; /* * Loop-invariant parts of variable name varname(indexname): */ if (array_varname != NULL) varname = array_varname; else indexname = NULL; /* * For each column get the column name and value and put it into a Tcl * variable (either scalar or array item) */ n = PQnfields(result); for (i = 0; i < n; i++) { value = result_get_obj(result, tupno, i); Tcl_IncrRefCount(value); /* * Loop-variant parts of variable name varname(indexname): */ if (array_varname != NULL) indexname = PQfname(result, i); else varname = PQfname(result, i); if (Tcl_SetVar2Ex(interp, varname, indexname, value, TCL_LEAVE_ERR_MSG) == NULL) { Tcl_DecrRefCount(value); return TCL_ERROR; } Tcl_DecrRefCount(value); } return TCL_OK; } /********************************** * pg_lo_open open a large object syntax: pg_lo_open conn objOid mode where mode can be either 'r', 'w', or 'rw' returns: a large object file ID on error: throws a Tcl error. **********************/ int Pg_lo_open(ClientData cData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { PGconn *conn; int lobjId; int mode; int fd; char *connString; char *modeString; int modeStringLen; if (objc != 4) { Tcl_WrongNumArgs(interp, 1, objv, "connection lobjOid mode"); return TCL_ERROR; } connString = Tcl_GetString(objv[1]); conn = PgGetConnectionId(interp, connString, (Pg_ConnectionId **) NULL); if (conn == (PGconn *)NULL) return TCL_ERROR; if (Tcl_GetIntFromObj(interp, objv[2], &lobjId) == TCL_ERROR) return TCL_ERROR; modeString = Tcl_GetStringFromObj(objv[3], &modeStringLen); if ((modeStringLen < 1) || (modeStringLen > 2)) { Tcl_AppendResult(interp, "mode argument must be 'r', 'w', or 'rw'", 0); return TCL_ERROR; } switch (modeString[0]) { case 'r': case 'R': mode = INV_READ; break; case 'w': case 'W': mode = INV_WRITE; break; default: Tcl_AppendResult(interp, "mode argument must be 'r', 'w', or 'rw'", 0); return TCL_ERROR; } switch (modeString[1]) { case '\0': break; case 'r': case 'R': mode |= INV_READ; break; case 'w': case 'W': mode |= INV_WRITE; break; default: Tcl_AppendResult(interp, "mode argument must be 'r', 'w', or 'rw'", 0); return TCL_ERROR; } fd = lo_open(conn, lobjId, mode); /* Note: undocumented but true, lo_open returns -1 on error */ if (fd == -1) { Tcl_AppendResult(interp, "Large Object open failed\n", PQerrorMessage(conn), NULL); return TCL_ERROR; } Tcl_SetObjResult(interp, Tcl_NewIntObj(fd)); return TCL_OK; } /********************************** * pg_lo_close close a large object syntax: pg_lo_close conn fd returns: nothing on error: throws a Tcl error. **********************/ int Pg_lo_close(ClientData cData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { PGconn *conn; int fd; char *connString; if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "connection fd"); return TCL_ERROR; } connString = Tcl_GetString(objv[1]); conn = PgGetConnectionId(interp, connString, (Pg_ConnectionId **) NULL); if (conn == (PGconn *)NULL) return TCL_ERROR; if (Tcl_GetIntFromObj(interp, objv[2], &fd) != TCL_OK) return TCL_ERROR; if (lo_close(conn, fd) < 0) { Tcl_AppendResult(interp, "Large Object close failed\n", PQerrorMessage(conn), NULL); return TCL_ERROR; } return TCL_OK; } /********************************** * pg_lo_read reads at most len bytes from a large object into a variable named bufVar syntax: pg_lo_read conn fd bufVar len bufVar is the name of a variable in which to store the contents of the read returns: the number of bytes read. on error: on parameter error, throws a Tcl error, but on a database error returns a negative number and status TCL_OK. It should throw an error in this case too, but too late - it was already documented to work this way. **********************/ int Pg_lo_read(ClientData cData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { PGconn *conn; int fd; int nbytes = 0; char *buf; Tcl_Obj *bufVar; Tcl_Obj *bufObj; int len; int rc = TCL_OK; if (objc != 5) { Tcl_WrongNumArgs(interp, 1, objv, "conn fd bufVar len"); return TCL_ERROR; } conn = PgGetConnectionId(interp, Tcl_GetString(objv[1]), (Pg_ConnectionId **) NULL); if (conn == (PGconn *)NULL) return TCL_ERROR; if (Tcl_GetIntFromObj(interp, objv[2], &fd) != TCL_OK) return TCL_ERROR; bufVar = objv[3]; if (Tcl_GetIntFromObj(interp, objv[4], &len) != TCL_OK) return TCL_ERROR; if (len <= 0) { Tcl_SetObjResult(interp, Tcl_NewIntObj(nbytes)); return TCL_OK; } buf = ckalloc(len + 1); nbytes = lo_read(conn, fd, buf, len); if (nbytes >= 0) { #if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION >= 1 || TCL_MAJOR_VERSION > 8 bufObj = Tcl_NewByteArrayObj((unsigned char *)buf, nbytes); #else bufObj = Tcl_NewStringObj(buf, nbytes); #endif if (Tcl_ObjSetVar2(interp, bufVar, NULL, bufObj, TCL_LEAVE_ERR_MSG | TCL_PARSE_PART1) == NULL) rc = TCL_ERROR; } if (rc == TCL_OK) Tcl_SetObjResult(interp, Tcl_NewIntObj(nbytes)); ckfree(buf); return rc; } /*********************************** Pg_lo_write write at most len bytes to a large object syntax: pg_lo_write conn fd buf len returns: the number of bytes written. on error: on parameter error, throws a Tcl error, but on a database error returns a negative number and status TCL_OK. It should throw an error in this case too, but too late - it was already documented to work this way. ***********************************/ int Pg_lo_write(ClientData cData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { PGconn *conn; char *buf; int fd; int nbytes = 0; int len; if (objc != 5) { Tcl_WrongNumArgs(interp, 1, objv, "conn fd buf len"); return TCL_ERROR; } conn = PgGetConnectionId(interp, Tcl_GetString(objv[1]), (Pg_ConnectionId **) NULL); if (conn == (PGconn *)NULL) return TCL_ERROR; if (Tcl_GetIntFromObj(interp, objv[2], &fd) != TCL_OK) return TCL_ERROR; #if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION >= 1 || TCL_MAJOR_VERSION > 8 buf = (char *)Tcl_GetByteArrayFromObj(objv[3], &nbytes); #else buf = Tcl_GetStringFromObj(objv[3], &nbytes); #endif if (Tcl_GetIntFromObj(interp, objv[4], &len) != TCL_OK) return TCL_ERROR; if (len > nbytes) len = nbytes; if (len <= 0) nbytes = 0; else nbytes = lo_write(conn, fd, buf, len); Tcl_SetObjResult(interp, Tcl_NewIntObj(nbytes)); return TCL_OK; } /*********************************** Pg_lo_lseek seek to a certain position in a large object syntax pg_lo_lseek conn fd offset whence whence can be either "SEEK_CUR", "SEEK_END", or "SEEK_SET" returns: the new position in the object, but this isn't currently documented on error: throws a Tcl error. ***********************************/ int Pg_lo_lseek(ClientData cData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { PGconn *conn; int fd; char *whenceStr; int offset; int whence; char *connString; int newOffset; if (objc != 5) { Tcl_WrongNumArgs(interp, 1, objv, "conn fd offset whence"); return TCL_ERROR; } connString = Tcl_GetString(objv[1]); conn = PgGetConnectionId(interp, connString, (Pg_ConnectionId **) NULL); if (conn == (PGconn *)NULL) return TCL_ERROR; if (Tcl_GetIntFromObj(interp, objv[2], &fd) != TCL_OK) return TCL_ERROR; if (Tcl_GetIntFromObj(interp, objv[3], &offset) == TCL_ERROR) return TCL_ERROR; whenceStr = Tcl_GetString(objv[4]); if (strcmp(whenceStr, "SEEK_SET") == 0) whence = SEEK_SET; else if (strcmp(whenceStr, "SEEK_CUR") == 0) whence = SEEK_CUR; else if (strcmp(whenceStr, "SEEK_END") == 0) whence = SEEK_END; else { Tcl_AppendResult(interp, "'whence' must be SEEK_SET, SEEK_CUR or SEEK_END", 0); return TCL_ERROR; } newOffset = lo_lseek(conn, fd, offset, whence); /* Note: undocumented but true, lo_lseek returns -1 on error */ if (newOffset == -1) { Tcl_AppendResult(interp, "Large Object seek failed\n", PQerrorMessage(conn), NULL); return TCL_ERROR; } Tcl_SetObjResult(interp, Tcl_NewIntObj(newOffset)); return TCL_OK; } /*********************************** Pg_lo_creat create a new large object with mode syntax: pg_lo_creat conn mode mode can be any OR'ing together of INV_READ, INV_WRITE, for now, we don't support any additional storage managers. returns: a large object OID on error: throws a Tcl error. ***********************************/ int Pg_lo_creat(ClientData cData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { PGconn *conn; char *modeStr; char *modeWord; int mode; char *connString; int loid; if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "conn mode"); return TCL_ERROR; } connString = Tcl_GetString(objv[1]); conn = PgGetConnectionId(interp, connString, (Pg_ConnectionId **) NULL); if (conn == (PGconn *)NULL) return TCL_ERROR; modeStr = Tcl_GetString(objv[2]); modeWord = strtok(modeStr, "|"); if (strcmp(modeWord, "INV_READ") == 0) mode = INV_READ; else if (strcmp(modeWord, "INV_WRITE") == 0) mode = INV_WRITE; else { Tcl_AppendResult(interp, "mode must be some OR'd combination of INV_READ, and INV_WRITE", 0); return TCL_ERROR; } while ((modeWord = strtok((char *)NULL, "|")) != NULL) { if (strcmp(modeWord, "INV_READ") == 0) mode |= INV_READ; else if (strcmp(modeWord, "INV_WRITE") == 0) mode |= INV_WRITE; else { Tcl_AppendResult(interp, "mode must be some OR'd combination of INV_READ, INV_WRITE", 0); return TCL_ERROR; } } loid = lo_creat(conn, mode); /* Note: undocumented but true, lo_creat returns InvalidOid on error */ if (loid == InvalidOid) { Tcl_AppendResult(interp, "Large Object create failed\n", PQerrorMessage(conn), NULL); return TCL_ERROR; } Tcl_SetObjResult(interp, Tcl_NewIntObj(loid)); return TCL_OK; } /*********************************** Pg_lo_tell returns the current seek location of the large object syntax: pg_lo_tell conn fd returns: the current position in the object on error: throws a Tcl error. ***********************************/ int Pg_lo_tell(ClientData cData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { PGconn *conn; int fd; char *connString; int offset; if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "conn fd"); return TCL_ERROR; } connString = Tcl_GetString(objv[1]); conn = PgGetConnectionId(interp, connString, (Pg_ConnectionId **) NULL); if (conn == (PGconn *)NULL) return TCL_ERROR; if (Tcl_GetIntFromObj(interp, objv[2], &fd) != TCL_OK) return TCL_ERROR; offset = lo_tell(conn, fd); /* Note: lo_tell returns -1 on error, but is documented to return a negative number on error. I would rather test for -1, but: */ if (offset < 0) { Tcl_AppendResult(interp, "Large Object tell offset failed\n", PQerrorMessage(conn), NULL); return TCL_ERROR; } Tcl_SetObjResult(interp, Tcl_NewIntObj(offset)); return TCL_OK; } /*********************************** Pg_lo_unlink unlink a file based on lobject id syntax: pg_lo_unlink conn lobjId returns: nothing on error: throws a Tcl error. ***********************************/ int Pg_lo_unlink(ClientData cData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { PGconn *conn; int lobjId; char *connString; if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "conn fd"); return TCL_ERROR; } connString = Tcl_GetString(objv[1]); conn = PgGetConnectionId(interp, connString, (Pg_ConnectionId **) NULL); if (conn == (PGconn *)NULL) return TCL_ERROR; if (Tcl_GetIntFromObj(interp, objv[2], &lobjId) == TCL_ERROR) return TCL_ERROR; if (lo_unlink(conn, lobjId) < 0) { Tcl_AppendResult(interp, "Large Object unlink failed\n", PQerrorMessage(conn), NULL); return TCL_ERROR; } return TCL_OK; } /*********************************** Pg_lo_import import a Unix file into an (inversion) large objct syntax: pg_lo_import conn filename returns: OID of the imported large object on error: throws a Tcl error. ***********************************/ int Pg_lo_import(ClientData cData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { PGconn *conn; const char *filename; Oid lobjId; char *connString; if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "conn filename"); return TCL_ERROR; } connString = Tcl_GetString(objv[1]); conn = PgGetConnectionId(interp, connString, (Pg_ConnectionId **) NULL); if (conn == (PGconn *)NULL) return TCL_ERROR; filename = Tcl_GetString(objv[2]); lobjId = lo_import(conn, filename); if (lobjId == InvalidOid) { Tcl_AppendResult(interp, "Large Object import of '", filename, "' failed\n", PQerrorMessage(conn), NULL); return TCL_ERROR; } Tcl_SetLongObj(Tcl_GetObjResult(interp), (long)lobjId); return TCL_OK; } /*********************************** Pg_lo_export export an Inversion large object to a Unix file syntax: pg_lo_export conn lobjId filename returns: nothing on error: throws a Tcl error. ***********************************/ int Pg_lo_export(ClientData cData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { PGconn *conn; const char *filename; Oid lobjId; char *connString; if (objc != 4) { Tcl_WrongNumArgs(interp, 1, objv, "conn lobjId filename"); return TCL_ERROR; } connString = Tcl_GetString(objv[1]); conn = PgGetConnectionId(interp, connString, (Pg_ConnectionId **) NULL); if (conn == (PGconn *)NULL) return TCL_ERROR; /* * Note: casting Oid lobjId to int for GetIntFromObj just hides the * real problem - lack of unsigned int in Tcl objects. */ if (Tcl_GetIntFromObj(interp, objv[2], (int *)&lobjId) == TCL_ERROR) return TCL_ERROR; filename = Tcl_GetString(objv[3]); if (lo_export(conn, lobjId, filename) == -1) { Tcl_AppendResult(interp, "Large Object export to '", filename, "' failed\n", PQerrorMessage(conn), NULL); return TCL_ERROR; } return TCL_OK; } /********************************** * pg_select send a select query string to the backend connection syntax: pg_select connection query var proc The query must be a select statement The var is used in the proc as an array The proc is run once for each row found Originally I was also going to update changes but that has turned out to be not so simple. Instead, the caller should get the OID of any table they want to update and update it themself in the loop. I may try to write a simplified table lookup and update function to make that task a little easier. The return is either TCL_OK, TCL_ERROR or TCL_RETURN and interp->result may contain more information. **********************************/ int Pg_select(ClientData cData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { Pg_ConnectionId *connid; PGconn *conn; PGresult *result; int r, retval; int tupno, column, ncols; char *connString; char *queryString; char *varNameString; Tcl_Obj *varNameObj; Tcl_Obj *procStringObj; Tcl_Obj *columnListObj; Tcl_Obj **columnNameObjs; if (objc != 5) { Tcl_WrongNumArgs(interp, 1, objv, "connection queryString var proc"); return TCL_ERROR; } connString = Tcl_GetString(objv[1]); queryString = Tcl_GetString(objv[2]); varNameObj = objv[3]; varNameString = Tcl_GetString(varNameObj); procStringObj = objv[4]; conn = PgGetConnectionId(interp, connString, &connid); if (!PgQueryOK(interp, conn, connid, 0)) return TCL_ERROR; if ((result = PQexec(conn, queryString)) == 0) { /* error occurred sending the query */ Tcl_SetResult(interp, PQerrorMessage(conn), TCL_VOLATILE); return TCL_ERROR; } /* Transfer any notify events from libpq to Tcl event queue. */ PgNotifyTransferEvents(connid); if (PQresultStatus(result) != PGRES_TUPLES_OK) { /* query failed, or it wasn't SELECT */ Tcl_SetResult(interp, (char *)PQresultErrorMessage(result), TCL_VOLATILE); PQclear(result); return TCL_ERROR; } ncols = PQnfields(result); columnNameObjs = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj) * ncols); for (column = 0; column < ncols; column++) columnNameObjs[column] = Tcl_NewStringObj(PQfname(result, column), -1); columnListObj = Tcl_NewListObj(ncols, columnNameObjs); Tcl_SetVar2Ex(interp, varNameString, ".headers", columnListObj, 0); Tcl_SetVar2Ex(interp, varNameString, ".numcols", Tcl_NewIntObj(ncols), 0); /* What is this for? Why was it inside the loop? -ljb */ Tcl_SetVar2(interp, varNameString, ".command", "update", 0); retval = TCL_OK; for (tupno = 0; tupno < PQntuples(result); tupno++) { Tcl_SetVar2Ex(interp, varNameString, ".tupno", Tcl_NewIntObj(tupno), 0); for (column = 0; column < ncols; column++) { Tcl_Obj *valueObj; valueObj = result_get_obj(result, tupno, column); Tcl_IncrRefCount(valueObj); Tcl_ObjSetVar2(interp, varNameObj, columnNameObjs[column], valueObj, 0); Tcl_DecrRefCount(valueObj); } r = Tcl_EvalObjEx(interp, procStringObj, 0); if ((r != TCL_OK) && (r != TCL_CONTINUE)) { if (r == TCL_BREAK) break; /* exit loop, but return TCL_OK */ if (r == TCL_ERROR) { char msg[60]; sprintf(msg, "\n (\"pg_select\" body line %d)", interp->errorLine); Tcl_AddErrorInfo(interp, msg); } retval = r; break; } } ckfree((void *)columnNameObjs); Tcl_UnsetVar(interp, varNameString, 0); PQclear(result); return retval; } /* * Test whether any callbacks are registered on this connection for * the given relation name. NB: supplied name must be case-folded already. */ static int Pg_have_listener(Pg_ConnectionId * connid, CONST char *relname) { Pg_TclNotifies *notifies; Tcl_HashEntry *entry; for (notifies = connid->notify_list; notifies != NULL; notifies = notifies->next) { Tcl_Interp *interp = notifies->interp; if (interp == NULL) continue; /* ignore deleted interpreter */ entry = Tcl_FindHashEntry(¬ifies->notify_hash, (char *)relname); if (entry == NULL) continue; /* no pg_listen in this interpreter */ return TRUE; /* OK, there is a listener */ } return FALSE; /* Found no listener */ } /*********************************** Pg_listen create or remove a callback request for notifies on a given name syntax: pg_listen conn notifyname ?callbackcommand? With a fourth arg, creates or changes the callback command for notifies on the given name; without, cancels the callback request. Callbacks can occur whenever Tcl is executing its event loop. This is the normal idle loop in Tk; in plain tclsh applications, vwait or update can be used to enter the Tcl event loop. ***********************************/ int Pg_listen(ClientData cData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { const char *origrelname; char *caserelname; char *callback = NULL; Pg_TclNotifies *notifies; Tcl_HashEntry *entry; Pg_ConnectionId *connid; PGconn *conn; PGresult *result; int new; char *connString; int callbackStrlen = 0; int origrelnameStrlen; if (objc < 3 || objc > 4) { Tcl_WrongNumArgs(interp, 1, objv, "connection relname ?callback?"); return TCL_ERROR; } /* * Get the command arguments. Note that the relation name will be * copied by Tcl_CreateHashEntry while the callback string must be * allocated by us. */ connString = Tcl_GetString(objv[1]); conn = PgGetConnectionId(interp, connString, &connid); if (!PgQueryOK(interp, conn, connid, 0)) return TCL_ERROR; /* * LISTEN/NOTIFY do not preserve case unless the relation name is * quoted. We have to do the same thing to ensure that we will find * the desired pg_listen item. */ origrelname = Tcl_GetStringFromObj(objv[2], &origrelnameStrlen); caserelname = (char *)ckalloc((unsigned)(origrelnameStrlen + 1)); if (*origrelname == '"') { /* Copy a quoted string without downcasing */ strcpy(caserelname, origrelname + 1); caserelname[origrelnameStrlen - 2] = '\0'; } else { /* Downcase it */ const char *rels = origrelname; char *reld = caserelname; while (*rels) *reld++ = tolower((unsigned char)*rels++); *reld = '\0'; } if (objc > 3) { char *callbackStr; callbackStr = Tcl_GetStringFromObj(objv[3], &callbackStrlen); callback = ckalloc(callbackStrlen + 1); strcpy(callback, callbackStr); } /* Find or make a Pg_TclNotifies struct for this interp and connection */ for (notifies = connid->notify_list; notifies; notifies = notifies->next) { if (notifies->interp == interp) break; } if (notifies == NULL) { notifies = (Pg_TclNotifies *) ckalloc(sizeof(Pg_TclNotifies)); notifies->interp = interp; Tcl_InitHashTable(¬ifies->notify_hash, TCL_STRING_KEYS); notifies->conn_loss_cmd = NULL; notifies->next = connid->notify_list; connid->notify_list = notifies; Tcl_CallWhenDeleted(interp, PgNotifyInterpDelete, (ClientData)notifies); } if (callback) { /* * Create or update a callback for a relation */ int alreadyHadListener = Pg_have_listener(connid, caserelname); entry = Tcl_CreateHashEntry(¬ifies->notify_hash, caserelname, &new); /* If update, free the old callback string */ if (!new) ckfree((char *)Tcl_GetHashValue(entry)); /* Store the new callback string */ Tcl_SetHashValue(entry, callback); /* Start the notify event source if it isn't already running */ PgStartNotifyEventSource(connid); /* * Send a LISTEN command if this is the first listener. */ if (!alreadyHadListener) { char *cmd = (char *)ckalloc((unsigned)(origrelnameStrlen + 8)); sprintf(cmd, "LISTEN %s", origrelname); result = PQexec(conn, cmd); ckfree(cmd); /* Transfer any notify events from libpq to Tcl event queue. */ PgNotifyTransferEvents(connid); if (PQresultStatus(result) != PGRES_COMMAND_OK) { /* Error occurred during the execution of command */ PQclear(result); Tcl_DeleteHashEntry(entry); ckfree(callback); ckfree(caserelname); Tcl_SetResult(interp, PQerrorMessage(conn), TCL_VOLATILE); return TCL_ERROR; } PQclear(result); } } else { /* * Remove a callback for a relation */ entry = Tcl_FindHashEntry(¬ifies->notify_hash, caserelname); if (entry == NULL) { Tcl_AppendResult(interp, "not listening on ", origrelname, 0); ckfree(caserelname); return TCL_ERROR; } ckfree((char *)Tcl_GetHashValue(entry)); Tcl_DeleteHashEntry(entry); /* * Send an UNLISTEN command if that was the last listener. Note: * we don't attempt to turn off the notify mechanism if no LISTENs * remain active; not worth the trouble. */ if (!Pg_have_listener(connid, caserelname)) { char *cmd = (char *) ckalloc((unsigned)(origrelnameStrlen + 10)); sprintf(cmd, "UNLISTEN %s", origrelname); result = PQexec(conn, cmd); ckfree(cmd); /* Transfer any notify events from libpq to Tcl event queue. */ PgNotifyTransferEvents(connid); if (PQresultStatus(result) != PGRES_COMMAND_OK) { /* Error occurred during the execution of command */ PQclear(result); ckfree(caserelname); Tcl_SetResult(interp, PQerrorMessage(conn), TCL_VOLATILE); return TCL_ERROR; } PQclear(result); } } ckfree(caserelname); return TCL_OK; } /********************************** * pg_sendquery send a query string to the backend connection syntax: pg_sendquery connection query ?param...? Optional args are used as parameters to PQsendQueryParams(). This allows only text format, untyped parameters. Returns OK status if the command was dispatched, or throws a Tcl error on error. **********************************/ int Pg_sendquery(ClientData cData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { Pg_ConnectionId *connid; PGconn *conn; char *connString; char *execString; int status; const char *const *paramValues; int nParams; nParams = objc - 3; if (nParams < 0) { Tcl_WrongNumArgs(interp, 1, objv, "connection queryString ?param...?"); return TCL_ERROR; } connString = Tcl_GetString(objv[1]); conn = PgGetConnectionId(interp, connString, &connid); if (!PgQueryOK(interp, conn, connid, 1)) return TCL_ERROR; execString = Tcl_GetString(objv[2]); if (nParams > 0) { get_param_values(interp, &objv[3], nParams, /* allParamsText = */ 1, /* paramFormats = */ NULL, ¶mValues, /* paramLengths_result = */ NULL); status = PQsendQueryParams(conn, execString, nParams, NULL, paramValues, NULL, NULL, /* resultFormat= */ 0); if (paramValues) Tcl_Free((char *)paramValues); } else { status = PQsendQuery(conn, execString); } /* Transfer any notify events from libpq to Tcl event queue. */ PgNotifyTransferEvents(connid); if (status) return TCL_OK; else { /* error occurred during the query */ Tcl_SetObjResult(interp, Tcl_NewStringObj(PQerrorMessage(conn), -1)); return TCL_ERROR; } } /********************************** * pg_sendquery_prepared send a query using a prepared query to the backend connection syntax: pg_sendquery_prepared connection statementName resultFormatList \ argFormatList ?param...? This is similar to pg_exec_prepared, but asynchronous like pg_sendquery. argFormatList is empty (= same as T), a single word T|B|TEXT|BINARY, or a list of those words, describing each argument as text or binary. If a single word, it applies to all arguments. (Actually, anything starting with B means Binary, and anything else means Text. There is no error checking.) resultFormatList is similar to argFormatList except that it applies to the columns of the results. Currently, all result parameters must be text, or all must be binary (this is a libpq limitation, not a PostgreSQL limitation). So you might as well specify a single word BINARY or leave it empty. Returns OK status if the command was dispatched, or throws a Tcl error on error. **********************************/ int Pg_sendquery_prepared(ClientData cData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { Pg_ConnectionId *connid; PGconn *conn; char *connString; char *statementName; int nParams; int allParamsText; int resultFormat; int *paramFormats; int *paramLengths; const char *const *paramValues; int returnValue; int status; nParams = objc - 5; if (nParams < 0) { Tcl_WrongNumArgs(interp, 1, objv, "connection statementName " "resultFormat argFormatList ?param...?"); return TCL_ERROR; } connString = Tcl_GetString(objv[1]); conn = PgGetConnectionId(interp, connString, &connid); if (!PgQueryOK(interp, conn, connid, 1)) return TCL_ERROR; statementName = Tcl_GetString(objv[2]); /* Parse resultFormatList and make resultFormat argument. */ if (get_result_format(interp, objv[3], &resultFormat) != TCL_OK) return TCL_ERROR; /* Parse argFormat list and make paramFormats argument and all-text flag */ if (get_param_formats(interp, objv[4], nParams, &allParamsText, ¶mFormats) != TCL_OK) return TCL_ERROR; /* Copy query parameters, and lengths if binary format */ get_param_values(interp, &objv[5], nParams, allParamsText, paramFormats, ¶mValues, ¶mLengths); /* Now dispatch the prepared query */ status = PQsendQueryPrepared(conn, statementName, nParams, paramValues, paramLengths, paramFormats, resultFormat); /* Transfer any notify events from libpq to Tcl event queue. */ PgNotifyTransferEvents(connid); if (status) returnValue = TCL_OK; else { /* error occurred when sending the query */ Tcl_SetObjResult(interp, Tcl_NewStringObj(PQerrorMessage(conn), -1)); returnValue = TCL_ERROR; } if (paramFormats) Tcl_Free((char *)paramFormats); if (paramLengths) Tcl_Free((char *)paramLengths); if (paramValues) Tcl_Free((char *)paramValues); return returnValue; } /********************************** * pg_sendquery_params Parse, bind parameters, and send a query using a prepared query to the backend connection for asynchronous execution. syntax: pg_sendquery_params connection query resultFormatList argFormatList \ argTypeList ?param...? query is an SQL statement with parameter placeholders specified as $1, $2, etc. argFormatList is empty (= same as T), a single word T|B|TEXT|BINARY, or a list of those words, describing each argument as text or binary. If a single word, it applies to all arguments. (Actually, anything starting with B means Binary, and anything else means Text. There is no error checking.) resultFormatList is similar to argFormatList except that it applies to the columns of the results. Currently, all result parameters must be text, or all must be binary (this is a libpq limitation, not a PostgreSQL limitation). So you might as well specify a single word BINARY or leave it empty. argTypeList is a list of PostgreSQL type OIDs for the query parameter arguments. Type OIDs must be supplied for each binary-format argument. If there are any binary format arguments, the argTypeList must contain an entry for each argument, although the actual value will be ignored for text-mode arguments. This is similar to pg_exec_params, but asynchronous like pg_sendquery. Note: If you are using all text arguments, it is easier to use pg_sendquery with the optional parameter arguments. Returns OK status if the command was dispatched, or throws a Tcl error on error. **********************************/ int Pg_sendquery_params(ClientData cData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { Pg_ConnectionId *connid; PGconn *conn; char *connString; char *queryString; int nParams; int allParamsText; int resultFormat; int *paramFormats; int *paramLengths; const char *const *paramValues; Oid *paramTypes; int returnValue; int status; nParams = objc - 6; if (nParams < 0) { Tcl_WrongNumArgs(interp, 1, objv, "connection queryString " "resultFormat argFormatList argTypeList ?param...?"); return TCL_ERROR; } connString = Tcl_GetString(objv[1]); conn = PgGetConnectionId(interp, connString, &connid); if (!PgQueryOK(interp, conn, connid, 1)) return TCL_ERROR; queryString = Tcl_GetString(objv[2]); /* Parse resultFormatList and make resultFormat argument. */ if (get_result_format(interp, objv[3], &resultFormat) != TCL_OK) return TCL_ERROR; /* Parse argFormat list and make paramFormats argument and all-text flag */ if (get_param_formats(interp, objv[4], nParams, &allParamsText, ¶mFormats) != TCL_OK) return TCL_ERROR; /* Get the parameter type OID list into an array */ if (get_param_types(interp, objv[5], nParams, ¶mTypes) != TCL_OK) { if (paramFormats) Tcl_Free((char *)paramFormats); return TCL_ERROR; } /* Copy query parameters, and lengths if binary format */ get_param_values(interp, &objv[6], nParams, allParamsText, paramFormats, ¶mValues, ¶mLengths); /* Now dispatch the parameterized query to the backend */ status = PQsendQueryParams(conn, queryString, nParams, paramTypes, paramValues, paramLengths, paramFormats, resultFormat); /* Transfer any notify events from libpq to Tcl event queue. */ PgNotifyTransferEvents(connid); if (status) returnValue = TCL_OK; else { /* error occurred when sending the query */ Tcl_SetObjResult(interp, Tcl_NewStringObj(PQerrorMessage(conn), -1)); returnValue = TCL_ERROR; } if (paramFormats) Tcl_Free((char *)paramFormats); if (paramLengths) Tcl_Free((char *)paramLengths); if (paramValues) Tcl_Free((char *)paramValues); if (paramTypes) Tcl_Free((char *)paramTypes); return returnValue; } /********************************** * pg_result_callback register or remove a callback for the next pg_sendquery to complete syntax: pg_result_callback connection ?callback? Original version written by msofer **********************************/ int Pg_result_callback(ClientData cData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { Pg_ConnectionId *connid; PGconn *conn; char *connString; if (objc < 2 || 3 < objc) { Tcl_WrongNumArgs(interp, 1, objv, "connection ?callback?"); return TCL_ERROR; } connString = Tcl_GetString(objv[1]); conn = PgGetConnectionId(interp, connString, &connid); if (conn == NULL) return TCL_ERROR; /* Forget any existing result callback */ PgClearResultCallback(connid); if (objc > 2) { /* Establish a result callback */ /* Start the notify event source if it isn't already running */ PgStartNotifyEventSource(connid); connid->callbackPtr = objv[2]; connid->callbackInterp = interp; Tcl_IncrRefCount(objv[2]); Tcl_Preserve((ClientData) interp); } return TCL_OK; } /********************************** * pg_getresult wait for the next result from a prior pg_sendquery syntax: pg_getresult connection the return result is either an error message, nothing, or a handle for a query result. Handles start with the prefix "pgp" **********************************/ int Pg_getresult(ClientData cData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { Pg_ConnectionId *connid; PGconn *conn; PGresult *result; char *connString; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "connection"); return TCL_ERROR; } connString = Tcl_GetString(objv[1]); conn = PgGetConnectionId(interp, connString, &connid); if (conn == (PGconn *)NULL) return TCL_ERROR; /* Cancel any callback script: the user lost patience */ PgClearResultCallback(connid); result = PQgetResult(conn); /* Transfer any notify events from libpq to Tcl event queue. */ PgNotifyTransferEvents(connid); /* if there's a non-null result, give the caller the handle */ if (result) { int rId = PgSetResultId(interp, connString, result); ExecStatusType rStat; if (rId == -1) { /* There is a result available, but unable to allocate a result * slot for it. Return error; PgSetResultId left a message. */ PQclear(result); return TCL_ERROR; } rStat = PQresultStatus(result); if (rStat == PGRES_COPY_IN || rStat == PGRES_COPY_OUT) { connid->res_copyStatus = RES_COPY_INPROGRESS; connid->res_copy = rId; } } return TCL_OK; } /********************************** * pg_isbusy see if a query is busy, i.e. pg_getresult would block. syntax: pg_isbusy connection return is 1 if it's busy and pg_getresult would block, 0 otherwise **********************************/ int Pg_isbusy(ClientData cData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { PGconn *conn; char *connString; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "connection"); return TCL_ERROR; } connString = Tcl_GetString(objv[1]); conn = PgGetConnectionId(interp, connString, (Pg_ConnectionId **) NULL); if (conn == (PGconn *)NULL) return TCL_ERROR; PQconsumeInput(conn); Tcl_SetIntObj(Tcl_GetObjResult(interp), PQisBusy(conn)); return TCL_OK; } /********************************** * pg_blocking see or set whether or not a connection is set to blocking or nonblocking Syntax: pg_blocking connection ?newSetting? returns: If newSetting is provided, returns the blocking state - 1 if blocking, 0 if non-blocking - before changing to the new setting. If newSetting is not provided, returns the current blocking state. **********************************/ int Pg_blocking(ClientData cData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { PGconn *conn; char *connString; int boolean; if ((objc < 2) || (objc > 3)) { Tcl_WrongNumArgs(interp, 1, objv, "connection ?bool?"); return TCL_ERROR; } connString = Tcl_GetString(objv[1]); conn = PgGetConnectionId(interp, connString, (Pg_ConnectionId **) NULL); if (conn == (PGconn *)NULL) return TCL_ERROR; /* Return the current value */ Tcl_SetBooleanObj(Tcl_GetObjResult(interp), !PQisnonblocking(conn)); /* If new setting provided, change it: */ if (objc == 3) { if (Tcl_GetBooleanFromObj(interp, objv[2], &boolean) == TCL_ERROR) return TCL_ERROR; PQsetnonblocking(conn, !boolean); /* Non-blocking if arg is 1 */ } return TCL_OK; } /********************************** * pg_cancelrequest request that postgresql abandon processing of the current command syntax: pg_cancelrequest connection returns nothing if the command successfully dispatched or if nothing was going on, otherwise an error **********************************/ int Pg_cancelrequest(ClientData cData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { Pg_ConnectionId *connid; PGconn *conn; char *connString; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "connection"); return TCL_ERROR; } connString = Tcl_GetString(objv[1]); conn = PgGetConnectionId(interp, connString, &connid); if (conn == NULL) return TCL_ERROR; /* Cancel any callback script */ PgClearResultCallback(connid); if (PQrequestCancel(conn) == 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj(PQerrorMessage(conn), -1)); return TCL_ERROR; } return TCL_OK; } /*********************************** Pg_on_connection_loss create or remove a callback request for unexpected connection loss syntax: pg_on_connection_loss conn ?callbackcommand? With a third arg, creates or changes the callback command for connection loss; without, cancels the callback request. Callbacks can occur whenever Tcl is executing its event loop. This is the normal idle loop in Tk; in plain tclsh applications, vwait or update can be used to enter the Tcl event loop. ***********************************/ int Pg_on_connection_loss(ClientData cData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { char *callback = NULL; Pg_TclNotifies *notifies; Pg_ConnectionId *connid; PGconn *conn; char *connString; if (objc < 2 || objc > 3) { Tcl_WrongNumArgs(interp, 1, objv, "connection ?callback?"); return TCL_ERROR; } /* * Get the command arguments. */ connString = Tcl_GetString(objv[1]); conn = PgGetConnectionId(interp, connString, &connid); if (conn == (PGconn *) NULL) return TCL_ERROR; if (objc > 2) { int callbackStrLen; char *callbackStr; /* there is probably a better way to do this, like incrementing * the reference count (?) */ callbackStr = Tcl_GetStringFromObj(objv[2], &callbackStrLen); callback = (char *) ckalloc((unsigned) (callbackStrLen + 1)); strcpy(callback, callbackStr); } /* Find or make a Pg_TclNotifies struct for this interp and connection */ for (notifies = connid->notify_list; notifies; notifies = notifies->next) { if (notifies->interp == interp) break; } if (notifies == NULL) { notifies = (Pg_TclNotifies *) ckalloc(sizeof(Pg_TclNotifies)); notifies->interp = interp; Tcl_InitHashTable(¬ifies->notify_hash, TCL_STRING_KEYS); notifies->conn_loss_cmd = NULL; notifies->next = connid->notify_list; connid->notify_list = notifies; Tcl_CallWhenDeleted(interp, PgNotifyInterpDelete, (ClientData) notifies); } /* Store new callback setting */ if (notifies->conn_loss_cmd) ckfree((void *) notifies->conn_loss_cmd); notifies->conn_loss_cmd = callback; if (callback) { /* * Start the notify event source if it isn't already running. The * notify source will cause Tcl to watch read-ready on the * connection socket, so that we find out quickly if the * connection drops. */ PgStartNotifyEventSource(connid); } return TCL_OK; } /*********************************** Pg_escape_string escape string for inclusion in SQL queries See also Pg_quote syntax: pg_escape_string string ***********************************/ int Pg_escape_string(ClientData cData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { char *fromString; char *toString; int fromStringLen; int toStringLen; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "string"); return TCL_ERROR; } /* * Get the "from" string. */ fromString = Tcl_GetStringFromObj(objv[1], &fromStringLen); /* * Allocate the "to" string. Max size is documented in the * PostgreSQL docs as 2 * fromStringLen + 1 */ toString = (char *) ckalloc((2 * fromStringLen) + 1); /* * Call the library routine to escape the string, and return * the command result as a Tcl object. */ toStringLen = PQescapeString (toString, fromString, fromStringLen); Tcl_SetObjResult(interp, Tcl_NewStringObj(toString, toStringLen)); ckfree(toString); return TCL_OK; } /*********************************** Pg_quote escape and quote string for inclusion in SQL queries See also Pg_escape_string Note: First there was pg_escape_string, based on libpq PQescapeString. This was added to Gborg libpgtcl CVS after 1.4b3. About a year later, pg_escape_string was removed and pg_quote was added instead. But both pgintcl and pgtcl-ng already released a version with pg_escape_string. I'm not about to break things, so both are supported. syntax: pg_quote string ***********************************/ int Pg_quote(ClientData cData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { char *fromString; char *toString; int fromStringLen; int toStringLen; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "string"); return TCL_ERROR; } /* * Get the "from" string. */ fromString = Tcl_GetStringFromObj(objv[1], &fromStringLen); /* * Allocate the "to" string. Max size is documented in the * PostgreSQL docs as 2 * fromStringLen + 1. Add 2 for quotes, * and subtract 1 because NewStringObj doesn't need the ending null. */ toString = (char *) ckalloc((2 * fromStringLen) + 2); /* * Call the library routine to escape the string, and return * the command result as a Tcl object with quote marks around it. */ toString[0] = '\''; toStringLen = 1 + PQescapeString (toString+1, fromString, fromStringLen); toString[toStringLen++] = '\''; Tcl_SetObjResult(interp, Tcl_NewStringObj(toString, toStringLen)); ckfree(toString); return TCL_OK; } /*********************************** * Pg_escape_bytea Escape a binary string for inclusion in SQL queries as a bytea type. See libpq PQescapeBytea. In summary, this produces octal escapes as \\nnn (with 2 literal backslashes before) and \' for single quote and \\\\ (4 backslashes) for backslash. The doubling of backslashes is due to PostgreSQL parsing the data once for SQL syntax, and again for bytea input. Note: This function is NOT the inverse of Pg_unescape_bytea (cf). Syntax: pg_escape_bytea binary_string ***********************************/ int Pg_escape_bytea(ClientData cData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { unsigned char *from_binary; int from_len; unsigned char *to_string; size_t to_len; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "binaryString"); return TCL_ERROR; } /* * Get the source data as a Tcl ByteArray object */ from_binary = Tcl_GetByteArrayFromObj(objv[1], &from_len); /* * Escape the data. libpq allocates the memory for us. * Note to_len includes the terminating null byte. * (The libpq documentation doesn't say, but this can return NULL.) */ to_string = PQescapeBytea(from_binary, from_len, &to_len); if (!to_string) { Tcl_AppendResult(interp, "pg_escape_bytea: failed to get memory\n", 0); return TCL_ERROR; } /* * Copy the result to the interpreter as a string object. */ Tcl_SetObjResult(interp, Tcl_NewStringObj(to_string, to_len-1)); /* * Free libpq-allocated memory */ PQfreemem(to_string); return TCL_OK; } /*********************************** * Pg_unescape_bytea Unescape a string from a PostgreSQL bytea data type and return the original binary data as a Tcl binary object. See libpq PQunescapeBytea. In summary, this takes \nnn octal escapes and produces the byte equivalent to nnn, and any other \c becomes c. Note: This function is NOT the inverse of Pg_escape_bytea. That function produces doubled backslashes, and this function expects single backslashes. That's because pg_escape_bytea is meant to escape binary data for quoted SQL strings in SELECT, INSERT, etc. which goes through two levels of parsing. pg_unescape_bytea is used to retrieve binary data returned by a query on a bytea column, which has only had one level of escaping performed on it. Syntax: pg_unescape_bytea string ***********************************/ int Pg_unescape_bytea(ClientData cData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { unsigned char *to_binary; size_t to_len; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "string"); return TCL_ERROR; } /* * Unescape the data. libpq allocates the memory for us. */ to_binary = PQunescapeBytea(Tcl_GetString(objv[1]), &to_len); if (!to_binary) { Tcl_AppendResult(interp, "pg_unescape_bytea: failed to get memory\n", 0); return TCL_ERROR; } /* * Copy the result to the interpreter as a ByteArray (binary) object. */ Tcl_SetObjResult(interp, Tcl_NewByteArrayObj(to_binary, to_len)); /* * Free libpq-allocated memory */ PQfreemem(to_binary); return TCL_OK; } /********************************** * pg_transaction_status Return the transaction status of a connection syntax: pg_transaction_status connection The argument passed in must be a connection pointer. Returns one of the following strings: IDLE ACTIVE INTRANS INERROR UNKNOWN For more information, see the PostgreSQL libpq PQtransactionStatus() function. **********************************/ int Pg_transaction_status(ClientData cData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { PGconn *conn; char *connString; char *result; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "connection"); return TCL_ERROR; } connString = Tcl_GetString(objv[1]); /* Get and validate the libpq connection handle. */ conn = PgGetConnectionId(interp, connString, (Pg_ConnectionId **) NULL); if (!conn) return TCL_ERROR; switch (PQtransactionStatus(conn)) { case PQTRANS_IDLE: result = "IDLE"; break; case PQTRANS_ACTIVE: result = "ACTIVE"; break; case PQTRANS_INTRANS: result = "INTRANS"; break; case PQTRANS_INERROR: result = "INERROR"; break; /* Treat anything else as PQTRANS_UNKNOWN */ default: result = "UNKNOWN"; break; } Tcl_SetResult(interp, result, TCL_STATIC); return TCL_OK; } /********************************** * pg_parameter_status Return the value of a server-side parameter Syntax: pg_parameter_status connection parameter_name The return value is the value of the named server parameter, or an empty string if there is no such parameter. This does not communicate with the server, but requires a valid connection, as libpq stores all the parameters sent by the server at connect time. For more information, see the PostgreSQL libpq PQparameterStatus() function. **********************************/ int Pg_parameter_status(ClientData cData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { PGconn *conn; char *connString; char *paramName; CONST char *paramValue; if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "connection parameterName"); return TCL_ERROR; } connString = Tcl_GetString(objv[1]); conn = PgGetConnectionId(interp, connString, (Pg_ConnectionId **) NULL); if (!conn) return TCL_ERROR; paramName = Tcl_GetString(objv[2]); if ((paramValue = PQparameterStatus(conn, paramName)) != NULL) /* paramValue points to storage owned by libpq, so let Tcl copy it */ Tcl_SetResult(interp, (char *)paramValue, TCL_VOLATILE); return TCL_OK; } /* * Notice handler procedure. Arg is a pointer to the Pg_ConnectionId * structure describing the connection. This includes a pointer to the * Tcl interpreter, which is needed to execute code. The Tcl code to execute * can be found in the Tcl object connid->notice_command. If NULL, do * nothing, else append the message and execute. Errors are ignored. * It is probably a bad idea to borrow the interpreter to execute the handler * code, but it will only happen during a query sending command (PQexec) * so it should be safe. Also the interp value is saved and restored to * ensure the handler doesn't overwrite anything. */ static void PgNoticeProcessor(void *arg, const char *message) { Pg_ConnectionId *connid = (Pg_ConnectionId *)arg; Tcl_Interp *interp = connid->interp; Tcl_Obj *messageObj; Tcl_Obj *cmdObj; Tcl_Obj *savedInterpResult; /* Empty handler command means ignore messages. */ if (connid->notice_command == NULL || interp == NULL) return; /* Build the command with the message appended as a single list element */ cmdObj = Tcl_DuplicateObj(connid->notice_command); Tcl_IncrRefCount(cmdObj); messageObj = Tcl_NewStringObj(message, -1); Tcl_IncrRefCount(messageObj); savedInterpResult = Tcl_DuplicateObj(Tcl_GetObjResult(interp)); Tcl_IncrRefCount(savedInterpResult); if (Tcl_ListObjAppendElement(interp, cmdObj, messageObj) == TCL_OK) { /* * Ignore the return status, since the interpreter isn't expecting * anything to happen at this point. */ Tcl_EvalObjEx(interp, cmdObj, TCL_EVAL_GLOBAL); } Tcl_DecrRefCount(messageObj); Tcl_DecrRefCount(cmdObj); Tcl_SetObjResult(interp, savedInterpResult); Tcl_DecrRefCount(savedInterpResult); } /********************************** * pg_notice_handler Establish a Tcl command to call on Notice or Warning messages. Syntax: pg_set_notice_handler connection ?command? If command is supplied, it becomes the new Notice handler. The text of the message is appended to the command as a list element. If command is empty, ignore notice and warning messages. Returns: The current value of the notice handler command (before it is changed by a supplied command argument, if any). **********************************/ int Pg_notice_handler(ClientData cData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { PGconn *conn; Pg_ConnectionId *connid; char *command; static char default_notice_handler[] = "puts -nonewline stderr"; if (objc < 2 || objc > 3) { Tcl_WrongNumArgs(interp, 0, objv, "connection ?command?"); return TCL_ERROR; } conn = PgGetConnectionId(interp, Tcl_GetString(objv[1]), &connid); if (!conn) return TCL_ERROR; if (objc == 3) command = Tcl_GetString(objv[2]); else command = NULL; /* * Return the previous notice handler. If no handler was set, * pretend that "puts -nonewline stderr" is the notice handler, * since that is equivalent to the libpq default handler. */ if (connid->notice_command) Tcl_SetObjResult(interp, connid->notice_command); else Tcl_SetResult(interp, default_notice_handler, TCL_STATIC); if (command) { /* * Change the notice handler. * If this is the first time the handler is being set, establish * the notice processor function using libpq. The first-time * handler setup is indicated by a null "interp" field. A null * notice_command, on the other hand, means ignore notices. */ if (connid->interp == NULL) { connid->notice_command = Tcl_NewStringObj(default_notice_handler, -1); Tcl_IncrRefCount(connid->notice_command); PQsetNoticeProcessor(conn, PgNoticeProcessor, (void *)connid); } /* * Remember which interp last set a handler. This is the * interpreter which will be used to execute the handler. */ connid->interp = interp; /* * Free any previous handler, and store the new handler command: */ if (connid->notice_command) Tcl_DecrRefCount(connid->notice_command); if (*command) { connid->notice_command = Tcl_NewStringObj(command, -1); Tcl_IncrRefCount(connid->notice_command); } else connid->notice_command = NULL; } return TCL_OK; }