- database connection (not the result handle) to extract the copy data.
- For copy outs, read until the standard EOF indication is encountered.
- I/O attempts will cause a Tcl error.
+++ /dev/null
-/*-------------------------------------------------------------------------
- *
- * pgtclCmds.c
- * C functions which implement pg_* tcl commands
- *
- * Portions Copyright (c) 1996-2003, PostgreSQL Global Development Group
- * Portions Copyright (c) 1994, Regents of the University of California
- *
- *
- * IDENTIFICATION
- * $PostgreSQL: pgsql/src/interfaces/libpgtcl/pgtclCmds.c,v 1.77 2004/01/07 18:56:29 neilc Exp $
- *
- *-------------------------------------------------------------------------
- */
-#include "postgres_fe.h"
-
-#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, CONST84 char *array_varname,
- PGresult *result, int tupno);
-
-
-#ifdef TCL_ARRAYS
-
-#define ISOCTAL(c) (((c) >= '0') && ((c) <= '7'))
-#define DIGIT(c) ((c) - '0')
-
-
-/*
- * translate_escape()
- *
- * This function performs in-place translation of a single C-style
- * escape sequence pointed by p. Curly braces { } and double-quote
- * are left escaped if they appear inside an array.
- * The value returned is the pointer to the last character (the one
- * just before the rest of the buffer).
- */
-
-static inline char *
-translate_escape(char *p, int isArray)
-{
- char c,
- *q,
- *s;
-
-#ifdef TCL_ARRAYS_DEBUG_ESCAPE
- printf(" escape = '%s'\n", p);
-#endif
- /* Address of the first character after the escape sequence */
- s = p + 2;
- switch (c = *(p + 1))
- {
- case '0':
- case '1':
- case '2':
- case '3':
- case '4':
- case '5':
- case '6':
- case '7':
- c = DIGIT(c);
- if (ISOCTAL(*s))
- c = (c << 3) + DIGIT(*s++);
- if (ISOCTAL(*s))
- c = (c << 3) + DIGIT(*s++);
- *p = c;
- break;
- case 'b':
- *p = '\b';
- break;
- case 'f':
- *p = '\f';
- break;
- case 'n':
- *p = '\n';
- break;
- case 'r':
- *p = '\r';
- break;
- case 't':
- *p = '\t';
- break;
- case 'v':
- *p = '\v';
- break;
- case '\\':
- case '{':
- case '}':
- case '"':
-
- /*
- * Backslahes, curly braces and double-quotes are left escaped
- * if they appear inside an array. They will be unescaped by
- * Tcl in Tcl_AppendElement. The buffer position is advanced
- * by 1 so that the this character is not processed again by
- * the caller.
- */
- if (isArray)
- return p + 1;
- else
- *p = c;
- break;
- case '\0':
-
- /*
- * This means a backslash at the end of the string. It should
- * never happen but in that case replace the \ with a \0 but
- * don't shift the rest of the buffer so that the caller can
- * see the end of the string and terminate.
- */
- *p = c;
- return p;
- break;
- default:
-
- /*
- * Default case, store the escaped character over the
- * backslash and shift the buffer over itself.
- */
- *p = c;
- }
- /* Shift the rest of the buffer over itself after the current char */
- q = p + 1;
- for (; *s;)
- *q++ = *s++;
- *q = '\0';
-#ifdef TCL_ARRAYS_DEBUG_ESCAPE
- printf(" after = '%s'\n", p);
-#endif
- return p;
-}
-
-/*
- * tcl_value()
- *
- * This function does in-line conversion of a value returned by libpq
- * into a tcl string or into a tcl list if the value looks like the
- * representation of a postgres array.
- */
-
-static char *
-tcl_value(char *value)
-{
- int literal,
- last;
- char *p;
-
- if (!value)
- return NULL;
-
-#ifdef TCL_ARRAYS_DEBUG
- printf("pq_value = '%s'\n", value);
-#endif
- last = strlen(value) - 1;
- if ((last >= 1) && (value[0] == '{') && (value[last] == '}'))
- {
- /* Looks like an array, replace ',' with spaces */
- /* Remove the outer pair of { }, the last first! */
- value[last] = '\0';
- value++;
- literal = 0;
- for (p = value; *p; p++)
- {
- if (!literal)
- {
- /* We are at the list level, look for ',' and '"' */
- switch (*p)
- {
- case '"': /* beginning of literal */
- literal = 1;
- break;
- case ',': /* replace the ',' with space */
- *p = ' ';
- break;
- }
- }
- else
- {
- /* We are inside a C string */
- switch (*p)
- {
- case '"': /* end of literal */
- literal = 0;
- break;
- case '\\':
-
- /*
- * escape sequence, translate it
- */
- p = translate_escape(p, 1);
- break;
- }
- }
- if (!*p)
- break;
- }
- }
- else
- {
- /* Looks like a normal scalar value */
- for (p = value; *p; p++)
- {
- if (*p == '\\')
- {
- /*
- * escape sequence, translate it
- */
- p = translate_escape(p, 0);
- }
- if (!*p)
- break;
- }
- }
-#ifdef TCL_ARRAYS_DEBUG
- printf("tcl_value = '%s'\n\n", value);
-#endif
- return value;
-}
-#endif /* TCL_ARRAYS */
-
-
-/**********************************
- * 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 argc, CONST84 char *argv[])
-{
- PQconninfoOption *options = PQconndefaults();
- PQconninfoOption *option;
- Tcl_DString result;
- char ibuf[32];
-
- if (options)
- {
- Tcl_DStringInit(&result);
-
- for (option = options; option->keyword != NULL; option++)
- {
- char *val = option->val ? option->val : "";
-
- sprintf(ibuf, "%d", option->dispsize);
- Tcl_DStringStartSublist(&result);
- Tcl_DStringAppendElement(&result, option->keyword);
- Tcl_DStringAppendElement(&result, option->label);
- Tcl_DStringAppendElement(&result, option->dispchar);
- Tcl_DStringAppendElement(&result, ibuf);
- Tcl_DStringAppendElement(&result, val);
- Tcl_DStringEndSublist(&result);
- }
- Tcl_DStringResult(interp, &result);
-
- 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 argc, CONST84 char *argv[])
-{
- const char *pghost = NULL;
- const char *pgtty = NULL;
- const char *pgport = NULL;
- const char *pgoptions = NULL;
- const char *dbName;
- int i;
- PGconn *conn;
-
- if (argc == 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;
-
- }
-
- if (!strcmp("-conninfo", argv[1]))
- {
- /*
- * Establish a connection using the new PQconnectdb() interface
- */
- if (argc != 3)
- {
- Tcl_AppendResult(interp, "pg_connect: syntax error\n", 0);
- Tcl_AppendResult(interp, "pg_connect -conninfo conninfoString", 0);
- return TCL_ERROR;
- }
- conn = PQconnectdb(argv[2]);
- }
- else
- {
- /*
- * Establish a connection using the old PQsetdb() interface
- */
- if (argc > 2)
- {
- /* parse for pg environment settings */
- i = 2;
- while (i + 1 < argc)
- {
- if (strcmp(argv[i], "-host") == 0)
- {
- pghost = argv[i + 1];
- i += 2;
- }
- else if (strcmp(argv[i], "-port") == 0)
- {
- pgport = argv[i + 1];
- i += 2;
- }
- else if (strcmp(argv[i], "-tty") == 0)
- {
- pgtty = argv[i + 1];
- i += 2;
- }
- else if (strcmp(argv[i], "-options") == 0)
- {
- pgoptions = argv[i + 1];
- i += 2;
- }
- else
- {
- Tcl_AppendResult(interp, "Bad option to pg_connect: ",
- argv[i], 0);
- Tcl_AppendResult(interp, "\npg_connect databaseName [-host hostName] [-port portNumber] [-tty pgtty]", 0);
- return TCL_ERROR;
- }
- } /* while */
- if ((i % 2 != 0) || i != argc)
- {
- Tcl_AppendResult(interp, "wrong # of arguments to pg_connect: ",
- argv[i], 0);
- Tcl_AppendResult(interp, "\npg_connect databaseName [-host hostName] [-port portNumber] [-tty pgtty]", 0);
- return TCL_ERROR;
- }
- }
- dbName = argv[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 argc, CONST84 char *argv[])
-{
- PGconn *conn;
- Tcl_Channel conn_chan;
-
- if (argc != 2)
- {
- Tcl_AppendResult(interp, "Wrong # of arguments\n", "pg_disconnect connection", 0);
- return TCL_ERROR;
- }
-
- conn_chan = Tcl_GetChannel(interp, argv[1], 0);
- if (conn_chan == NULL)
- {
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, argv[1], " is not a valid connection", 0);
- return TCL_ERROR;
- }
-
- /* Check that it is a PG connection and not something else */
- conn = PgGetConnectionId(interp, argv[1], NULL);
- if (conn == NULL)
- return TCL_ERROR;
-
- return Tcl_UnregisterChannel(interp, conn_chan);
-}
-
-/**********************************
- * pg_exec
- send a query string to the backend connection
-
- syntax:
- pg_exec connection query
-
- 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 argc, CONST84 char *argv[])
-{
- Pg_ConnectionId *connid;
- PGconn *conn;
- PGresult *result;
-
- if (argc != 3)
- {
- Tcl_AppendResult(interp, "Wrong # of arguments\n",
- "pg_exec connection queryString", 0);
- return TCL_ERROR;
- }
-
- conn = PgGetConnectionId(interp, argv[1], &connid);
- if (conn == NULL)
- return TCL_ERROR;
-
- if (connid->res_copyStatus != RES_COPY_NONE)
- {
- Tcl_SetResult(interp, "Attempt to query while COPY in progress", TCL_STATIC);
- return TCL_ERROR;
- }
-
- result = PQexec(conn, argv[2]);
-
- /* Transfer any notify events from libpq to Tcl event queue. */
- PgNotifyTransferEvents(connid);
-
- if (result)
- {
- int rId = PgSetResultId(interp, argv[1], result);
-
- ExecStatusType 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;
- }
- else
- {
- /* error occurred during the query */
- Tcl_SetResult(interp, PQerrorMessage(conn), TCL_VOLATILE);
- return TCL_ERROR;
- }
-}
-
-/**********************************
- * 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 the error message, if the status indicates error; otherwise
- an empty string
-
- -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 the number of tuples affected by the query
-
- -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
-
- -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
-
- -clear clear the result buffer. Do not reuse after this
-
- **********************************/
-int
-Pg_result(ClientData cData, Tcl_Interp *interp, int argc, CONST84 char *argv[])
-{
- PGresult *result;
- const char *opt;
- int i;
- int tupno;
- CONST84 char *arrVar;
- char nameBuffer[256];
- const char *appendstr;
-
- if (argc < 3 || argc > 5)
- {
- Tcl_AppendResult(interp, "Wrong # of arguments\n", 0);
- goto Pg_result_errReturn; /* append help info */
- }
-
- result = PgGetResultId(interp, argv[1]);
- if (result == NULL)
- {
- Tcl_AppendResult(interp, "\n",
- argv[1], " is not a valid query result", 0);
- return TCL_ERROR;
- }
-
- opt = argv[2];
-
- if (strcmp(opt, "-status") == 0)
- {
- Tcl_AppendResult(interp, PQresStatus(PQresultStatus(result)), 0);
- return TCL_OK;
- }
- else if (strcmp(opt, "-error") == 0)
- {
- Tcl_SetResult(interp, (char *) PQresultErrorMessage(result),
- TCL_STATIC);
- return TCL_OK;
- }
- else if (strcmp(opt, "-conn") == 0)
- return PgGetConnByResultId(interp, argv[1]);
- else if (strcmp(opt, "-oid") == 0)
- {
- sprintf(interp->result, "%u", PQoidValue(result));
- return TCL_OK;
- }
- else if (strcmp(opt, "-clear") == 0)
- {
- PgDelResultId(interp, argv[1]);
- PQclear(result);
- return TCL_OK;
- }
- else if (strcmp(opt, "-numTuples") == 0)
- {
- sprintf(interp->result, "%d", PQntuples(result));
- return TCL_OK;
- }
- else if (strcmp(opt, "-cmdTuples") == 0)
- {
- sprintf(interp->result, "%s", PQcmdTuples(result));
- return TCL_OK;
- }
- else if (strcmp(opt, "-numAttrs") == 0)
- {
- sprintf(interp->result, "%d", PQnfields(result));
- return TCL_OK;
- }
- else if (strcmp(opt, "-assign") == 0)
- {
- if (argc != 4)
- {
- Tcl_AppendResult(interp, "-assign option must be followed by a variable name", 0);
- return TCL_ERROR;
- }
- arrVar = argv[3];
-
- /*
- * 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). Note we expect field
- * names not to exceed a few dozen characters, so truncating to
- * prevent buffer overflow shouldn't be a problem.
- */
- for (tupno = 0; tupno < PQntuples(result); tupno++)
- {
- for (i = 0; i < PQnfields(result); i++)
- {
- sprintf(nameBuffer, "%d,%.200s", tupno, PQfname(result, i));
- if (Tcl_SetVar2(interp, arrVar, nameBuffer,
-#ifdef TCL_ARRAYS
- tcl_value(PQgetvalue(result, tupno, i)),
-#else
- PQgetvalue(result, tupno, i),
-#endif
- TCL_LEAVE_ERR_MSG) == NULL)
- return TCL_ERROR;
- }
- }
- Tcl_AppendResult(interp, arrVar, 0);
- return TCL_OK;
- }
- else if (strcmp(opt, "-assignbyidx") == 0)
- {
- if (argc != 4 && argc != 5)
- {
- Tcl_AppendResult(interp, "-assignbyidx option requires an array name and optionally an append string", 0);
- return TCL_ERROR;
- }
- arrVar = argv[3];
- appendstr = (argc == 5) ? (const char *) argv[4] : "";
-
- /*
- * 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 < PQntuples(result); tupno++)
- {
- const char *field0 =
-#ifdef TCL_ARRAYS
- tcl_value(PQgetvalue(result, tupno, 0));
-
-#else
- PQgetvalue(result, tupno, 0);
-#endif
- char *workspace = malloc(strlen(field0) + strlen(appendstr) + 210);
-
- for (i = 1; i < PQnfields(result); i++)
- {
- sprintf(workspace, "%s,%.200s%s", field0, PQfname(result, i),
- appendstr);
- if (Tcl_SetVar2(interp, arrVar, workspace,
-#ifdef TCL_ARRAYS
- tcl_value(PQgetvalue(result, tupno, i)),
-#else
- PQgetvalue(result, tupno, i),
-#endif
- TCL_LEAVE_ERR_MSG) == NULL)
- {
- free(workspace);
- return TCL_ERROR;
- }
- }
- free(workspace);
- }
- Tcl_AppendResult(interp, arrVar, 0);
- return TCL_OK;
- }
- else if (strcmp(opt, "-getTuple") == 0)
- {
- if (argc != 4)
- {
- Tcl_AppendResult(interp, "-getTuple option must be followed by a tuple number", 0);
- return TCL_ERROR;
- }
- tupno = atoi(argv[3]);
- if (tupno < 0 || tupno >= PQntuples(result))
- {
- Tcl_AppendResult(interp, "argument to getTuple cannot exceed number of tuples - 1", 0);
- return TCL_ERROR;
- }
-#ifdef TCL_ARRAYS
- for (i = 0; i < PQnfields(result); i++)
- Tcl_AppendElement(interp, tcl_value(PQgetvalue(result, tupno, i)));
-#else
- for (i = 0; i < PQnfields(result); i++)
- Tcl_AppendElement(interp, PQgetvalue(result, tupno, i));
-#endif
- return TCL_OK;
- }
- else if (strcmp(opt, "-tupleArray") == 0)
- {
- if (argc != 5)
- {
- Tcl_AppendResult(interp, "-tupleArray option must be followed by a tuple number and array name", 0);
- return TCL_ERROR;
- }
- tupno = atoi(argv[3]);
- if (tupno < 0 || tupno >= PQntuples(result))
- {
- Tcl_AppendResult(interp, "argument to tupleArray cannot exceed number of tuples - 1", 0);
- return TCL_ERROR;
- }
- for (i = 0; i < PQnfields(result); i++)
- {
- if (Tcl_SetVar2(interp, argv[4], PQfname(result, i),
-#ifdef TCL_ARRAYS
- tcl_value(PQgetvalue(result, tupno, i)),
-#else
- PQgetvalue(result, tupno, i),
-#endif
- TCL_LEAVE_ERR_MSG) == NULL)
- return TCL_ERROR;
- }
- return TCL_OK;
- }
- else if (strcmp(opt, "-attributes") == 0)
- {
- for (i = 0; i < PQnfields(result); i++)
- Tcl_AppendElement(interp, PQfname(result, i));
- return TCL_OK;
- }
- else if (strcmp(opt, "-lAttributes") == 0)
- {
- for (i = 0; i < PQnfields(result); i++)
- {
- /* start a sublist */
- if (i > 0)
- Tcl_AppendResult(interp, " {", 0);
- else
- Tcl_AppendResult(interp, "{", 0);
- Tcl_AppendElement(interp, PQfname(result, i));
- sprintf(nameBuffer, "%ld", (long) PQftype(result, i));
- Tcl_AppendElement(interp, nameBuffer);
- sprintf(nameBuffer, "%ld", (long) PQfsize(result, i));
- Tcl_AppendElement(interp, nameBuffer);
- /* end the sublist */
- Tcl_AppendResult(interp, "}", 0);
- }
- return TCL_OK;
- }
- else
- {
- Tcl_AppendResult(interp, "Invalid option\n", 0);
- goto Pg_result_errReturn; /* append help info */
- }
-
-
-Pg_result_errReturn:
- Tcl_AppendResult(interp,
- "pg_result result ?option? where option is\n",
- "\t-status\n",
- "\t-error\n",
- "\t-conn\n",
- "\t-oid\n",
- "\t-numTuples\n",
- "\t-cmdTuples\n",
- "\t-numAttrs\n"
- "\t-assign arrayVarName\n",
- "\t-assignbyidx arrayVarName ?appendstr?\n",
- "\t-getTuple tupleNumber\n",
- "\t-tupleArray tupleNumber arrayVarName\n",
- "\t-attributes\n"
- "\t-lAttributes\n"
- "\t-clear\n",
- (char *) 0);
- return TCL_ERROR;
-
-
-}
-
-
-/**********************************
- * 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 argc, CONST84 char *argv[])
-{
- Pg_ConnectionId *connid;
- PGconn *conn;
- PGresult *result;
- int i;
- int tupno;
- int ntup;
- int loop_rc;
- CONST84 char *oid_varname = NULL;
- CONST84 char *array_varname = NULL;
- char buf[64];
-
- char *usage = "Wrong # of arguments\n"
- "pg_execute ?-array arrayname? ?-oid varname? "
- "connection queryString ?loop_body?";
-
- /*
- * First we parse the options
- */
- i = 1;
- while (i < argc)
- {
- if (argv[i][0] != '-')
- break;
-
- if (strcmp(argv[i], "-array") == 0)
- {
- /*
- * The rows should appear in an array vs. to single variables
- */
- i++;
- if (i == argc)
- {
- Tcl_SetResult(interp, usage, TCL_VOLATILE);
- return TCL_ERROR;
- }
- array_varname = argv[i++];
- continue;
- }
-
- if (strcmp(argv[i], "-oid") == 0)
- {
- /*
- * We should place PQoidValue() somewhere
- */
- i++;
- if (i == argc)
- {
- Tcl_SetResult(interp, usage, TCL_VOLATILE);
- return TCL_ERROR;
- }
- oid_varname = argv[i++];
- continue;
- }
-
- Tcl_AppendResult(interp, "Unknown option '", argv[i], "'", NULL);
- return TCL_ERROR;
- }
-
- /*
- * Check that after option parsing at least 'connection' and 'query'
- * are left
- */
- if (argc - i < 2)
- {
- Tcl_SetResult(interp, usage, TCL_VOLATILE);
- return TCL_ERROR;
- }
-
- /*
- * Get the connection and make sure no COPY command is pending
- */
- conn = PgGetConnectionId(interp, argv[i++], &connid);
- if (conn == NULL)
- return TCL_ERROR;
-
- if (connid->res_copyStatus != RES_COPY_NONE)
- {
- Tcl_SetResult(interp, "Attempt to query while COPY in progress", TCL_STATIC);
- return TCL_ERROR;
- }
-
- /*
- * Execute the query
- */
- result = PQexec(conn, argv[i++]);
-
- /*
- * 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_varname != NULL)
- {
- char oid_buf[32];
-
- sprintf(oid_buf, "%u", PQoidValue(result));
- if (Tcl_SetVar(interp, oid_varname, oid_buf,
- 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:
- case PGRES_COPY_IN:
- case PGRES_COPY_OUT:
- /* tell the number of affected tuples for non-SELECT queries */
- Tcl_SetResult(interp, PQcmdTuples(result), TCL_VOLATILE);
- PQclear(result);
- return TCL_OK;
-
- default:
- /* anything else must be an error */
- Tcl_ResetResult(interp);
- Tcl_AppendElement(interp, PQresStatus(PQresultStatus(result)));
- Tcl_AppendElement(interp, PQresultErrorMessage(result));
- PQclear(result);
- return TCL_ERROR;
- }
-
- /*
- * We reach here only for queries that returned tuples
- */
- if (i == argc)
- {
- /*
- * 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;
- }
- }
-
- sprintf(buf, "%d", PQntuples(result));
- Tcl_SetResult(interp, buf, TCL_VOLATILE);
- 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);
- 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_Eval(interp, argv[i]);
-
- /* The returncode of the loop body controls the loop execution */
- if (loop_rc == TCL_OK || loop_rc == TCL_CONTINUE)
- /* OK or CONTINUE means start next loop invocation */
- continue;
- if (loop_rc == TCL_RETURN)
- {
- /* RETURN means hand up the given interpreter result */
- PQclear(result);
- return TCL_RETURN;
- }
- if (loop_rc == TCL_BREAK)
- /* BREAK means leave the loop */
- break;
-
- PQclear(result);
- return TCL_ERROR;
- }
-
- /*
- * At the end of the loop we put the number of rows we got into the
- * interpreter result and clear the result set.
- */
- sprintf(buf, "%d", ntup);
- Tcl_SetResult(interp, buf, TCL_VOLATILE);
- PQclear(result);
- return TCL_OK;
-}
-
-
-/**********************************
- * 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, CONST84 char *array_varname,
- PGresult *result, int tupno)
-{
- int i;
- int n;
- char *fname;
- char *value;
-
- /*
- * 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++)
- {
- fname = PQfname(result, i);
- value = PQgetvalue(result, tupno, i);
-
- if (array_varname != NULL)
- {
- if (Tcl_SetVar2(interp, array_varname, fname, value,
- TCL_LEAVE_ERR_MSG) == NULL)
- return TCL_ERROR;
- }
- else
- {
- if (Tcl_SetVar(interp, fname, value, TCL_LEAVE_ERR_MSG) == NULL)
- return TCL_ERROR;
- }
- }
-
- 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'
-**********************/
-
-int
-Pg_lo_open(ClientData cData, Tcl_Interp *interp, int argc, CONST84 char *argv[])
-{
- PGconn *conn;
- int lobjId;
- int mode;
- int fd;
-
- if (argc != 4)
- {
- Tcl_AppendResult(interp, "Wrong # of arguments\n",
- "pg_lo_open connection lobjOid mode", 0);
- return TCL_ERROR;
- }
-
- conn = PgGetConnectionId(interp, argv[1], NULL);
- if (conn == NULL)
- return TCL_ERROR;
-
- lobjId = atoi(argv[2]);
- if (strlen(argv[3]) < 1 ||
- strlen(argv[3]) > 2)
- {
- Tcl_AppendResult(interp, "mode argument must be 'r', 'w', or 'rw'", 0);
- return TCL_ERROR;
- }
- switch (argv[3][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 (argv[3][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);
- sprintf(interp->result, "%d", fd);
- return TCL_OK;
-}
-
-/**********************************
- * pg_lo_close
- close a large object
-
- syntax:
- pg_lo_close conn fd
-
-**********************/
-int
-Pg_lo_close(ClientData cData, Tcl_Interp *interp, int argc, CONST84 char *argv[])
-{
- PGconn *conn;
- int fd;
-
- if (argc != 3)
- {
- Tcl_AppendResult(interp, "Wrong # of arguments\n",
- "pg_lo_close connection fd", 0);
- return TCL_ERROR;
- }
-
- conn = PgGetConnectionId(interp, argv[1], NULL);
- if (conn == NULL)
- return TCL_ERROR;
-
- fd = atoi(argv[2]);
- sprintf(interp->result, "%d", lo_close(conn, fd));
- 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
-
-**********************/
-#ifdef PGTCL_USE_TCLOBJ
-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_AppendResult(interp, "Wrong # of arguments\n",
- " pg_lo_read conn fd bufVar len", 0);
- return TCL_ERROR;
- }
-
- conn = PgGetConnectionId(interp, Tcl_GetStringFromObj(objv[1], NULL),
- NULL);
- if (conn == 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(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;
-}
-
-#else
-int
-Pg_lo_read(ClientData cData, Tcl_Interp *interp, int argc, CONST84 char *argv[])
-{
- PGconn *conn;
- int fd;
- int nbytes = 0;
- char *buf;
- char *bufVar;
- int len;
-
- if (argc != 5)
- {
- Tcl_AppendResult(interp, "Wrong # of arguments\n",
- " pg_lo_read conn fd bufVar len", 0);
- return TCL_ERROR;
- }
-
- conn = PgGetConnectionId(interp, argv[1], NULL);
- if (conn == NULL)
- return TCL_ERROR;
-
- fd = atoi(argv[2]);
-
- bufVar = argv[3];
-
- len = atoi(argv[4]);
-
- if (len <= 0)
- {
- sprintf(interp->result, "%d", nbytes);
- return TCL_OK;
- }
- buf = ckalloc(len + 1);
-
- nbytes = lo_read(conn, fd, buf, len);
-
- if (nbytes >= 0)
- Tcl_SetVar(interp, bufVar, buf, TCL_LEAVE_ERR_MSG);
-
- sprintf(interp->result, "%d", nbytes);
- ckfree(buf);
- return TCL_OK;
-
-}
-#endif
-
-/***********************************
-Pg_lo_write
- write at most len bytes to a large object
-
- syntax:
- pg_lo_write conn fd buf len
-
-***********************************/
-#ifdef PGTCL_USE_TCLOBJ
-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_AppendResult(interp, "Wrong # of arguments\n",
- "pg_lo_write conn fd buf len", 0);
- return TCL_ERROR;
- }
-
- conn = PgGetConnectionId(interp, Tcl_GetStringFromObj(objv[1], NULL),
- NULL);
- if (conn == 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 = 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)
- {
- Tcl_SetObjResult(interp, Tcl_NewIntObj(0));
- return TCL_OK;
- }
-
- nbytes = lo_write(conn, fd, buf, len);
- Tcl_SetObjResult(interp, Tcl_NewIntObj(nbytes));
- return TCL_OK;
-}
-
-#else
-int
-Pg_lo_write(ClientData cData, Tcl_Interp *interp, int argc, CONST84 char *argv[])
-{
- PGconn *conn;
- char *buf;
- int fd;
- int nbytes = 0;
- int len;
-
- if (argc != 5)
- {
- Tcl_AppendResult(interp, "Wrong # of arguments\n",
- "pg_lo_write conn fd buf len", 0);
- return TCL_ERROR;
- }
-
- conn = PgGetConnectionId(interp, argv[1], NULL);
- if (conn == NULL)
- return TCL_ERROR;
-
- fd = atoi(argv[2]);
-
- buf = argv[3];
-
- len = atoi(argv[4]);
-
- if (len <= 0)
- {
- sprintf(interp->result, "%d", nbytes);
- return TCL_OK;
- }
-
- nbytes = lo_write(conn, fd, buf, len);
- sprintf(interp->result, "%d", nbytes);
- return TCL_OK;
-}
-#endif
-
-/***********************************
-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"
-***********************************/
-int
-Pg_lo_lseek(ClientData cData, Tcl_Interp *interp, int argc, CONST84 char *argv[])
-{
- PGconn *conn;
- int fd;
- const char *whenceStr;
- int offset,
- whence;
-
- if (argc != 5)
- {
- Tcl_AppendResult(interp, "Wrong # of arguments\n",
- "pg_lo_lseek conn fd offset whence", 0);
- return TCL_ERROR;
- }
-
- conn = PgGetConnectionId(interp, argv[1], NULL);
- if (conn == NULL)
- return TCL_ERROR;
-
- fd = atoi(argv[2]);
-
- offset = atoi(argv[3]);
-
- whenceStr = argv[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, "the whence argument to Pg_lo_lseek must be SEEK_SET, SEEK_CUR or SEEK_END", 0);
- return TCL_ERROR;
- }
-
- sprintf(interp->result, "%d", lo_lseek(conn, fd, offset, whence));
- 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.
-
-***********************************/
-int
-Pg_lo_creat(ClientData cData, Tcl_Interp *interp, int argc, CONST84 char *argv[])
-{
- PGconn *conn;
- char *modeStr;
- char *modeWord;
- int mode;
-
- if (argc != 3)
- {
- Tcl_AppendResult(interp, "Wrong # of arguments\n",
- "pg_lo_creat conn mode", 0);
- return TCL_ERROR;
- }
-
- conn = PgGetConnectionId(interp, argv[1], NULL);
- if (conn == NULL)
- return TCL_ERROR;
-
- modeStr = strdup(argv[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,
- "invalid mode argument to Pg_lo_creat\nmode argument must be some OR'd combination of INV_READ, and INV_WRITE",
- 0);
- free(modeStr);
- return TCL_ERROR;
- }
-
- while ((modeWord = strtok(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,
- "invalid mode argument to Pg_lo_creat\nmode argument must be some OR'd combination of INV_READ, INV_WRITE",
- 0);
- free(modeStr);
- return TCL_ERROR;
- }
- }
- sprintf(interp->result, "%d", lo_creat(conn, mode));
- free(modeStr);
- return TCL_OK;
-}
-
-/***********************************
-Pg_lo_tell
- returns the current seek location of the large object
-
- syntax:
- pg_lo_tell conn fd
-
-***********************************/
-int
-Pg_lo_tell(ClientData cData, Tcl_Interp *interp, int argc, CONST84 char *argv[])
-{
- PGconn *conn;
- int fd;
-
- if (argc != 3)
- {
- Tcl_AppendResult(interp, "Wrong # of arguments\n",
- "pg_lo_tell conn fd", 0);
- return TCL_ERROR;
- }
-
- conn = PgGetConnectionId(interp, argv[1], NULL);
- if (conn == NULL)
- return TCL_ERROR;
-
- fd = atoi(argv[2]);
-
- sprintf(interp->result, "%d", lo_tell(conn, fd));
- return TCL_OK;
-
-}
-
-/***********************************
-Pg_lo_unlink
- unlink a file based on lobject id
-
- syntax:
- pg_lo_unlink conn lobjId
-
-
-***********************************/
-int
-Pg_lo_unlink(ClientData cData, Tcl_Interp *interp, int argc, CONST84 char *argv[])
-{
- PGconn *conn;
- int lobjId;
- int retval;
-
- if (argc != 3)
- {
- Tcl_AppendResult(interp, "Wrong # of arguments\n",
- "pg_lo_tell conn fd", 0);
- return TCL_ERROR;
- }
-
- conn = PgGetConnectionId(interp, argv[1], NULL);
- if (conn == NULL)
- return TCL_ERROR;
-
- lobjId = atoi(argv[2]);
-
- retval = lo_unlink(conn, lobjId);
- if (retval == -1)
- {
- sprintf(interp->result, "Pg_lo_unlink of '%d' failed", lobjId);
- return TCL_ERROR;
- }
-
- sprintf(interp->result, "%d", retval);
- return TCL_OK;
-}
-
-/***********************************
-Pg_lo_import
- import a Unix file into an (inversion) large objct
- returns the oid of that object upon success
- returns InvalidOid upon failure
-
- syntax:
- pg_lo_import conn filename
-
-***********************************/
-
-int
-Pg_lo_import(ClientData cData, Tcl_Interp *interp, int argc, CONST84 char *argv[])
-{
- PGconn *conn;
- const char *filename;
- Oid lobjId;
-
- if (argc != 3)
- {
- Tcl_AppendResult(interp, "Wrong # of arguments\n",
- "pg_lo_import conn filename", 0);
- return TCL_ERROR;
- }
-
- conn = PgGetConnectionId(interp, argv[1], NULL);
- if (conn == NULL)
- return TCL_ERROR;
-
- filename = argv[2];
-
- lobjId = lo_import(conn, filename);
- if (lobjId == InvalidOid)
- {
- /*
- * What is the maximum size of this? FIXME if this is not a good
- * quess
- */
- snprintf(interp->result, 128, "Pg_lo_import of '%s' failed", filename);
- return TCL_ERROR;
- }
- sprintf(interp->result, "%u", lobjId);
- return TCL_OK;
-}
-
-/***********************************
-Pg_lo_export
- export an Inversion large object to a Unix file
-
- syntax:
- pg_lo_export conn lobjId filename
-
-***********************************/
-
-int
-Pg_lo_export(ClientData cData, Tcl_Interp *interp, int argc, CONST84 char *argv[])
-{
- PGconn *conn;
- const char *filename;
- Oid lobjId;
- int retval;
-
- if (argc != 4)
- {
- Tcl_AppendResult(interp, "Wrong # of arguments\n",
- "pg_lo_export conn lobjId filename", 0);
- return TCL_ERROR;
- }
-
- conn = PgGetConnectionId(interp, argv[1], NULL);
- if (conn == NULL)
- return TCL_ERROR;
-
- lobjId = atoi(argv[2]);
- filename = argv[3];
-
- retval = lo_export(conn, lobjId, filename);
- if (retval == -1)
- {
- sprintf(interp->result, "Pg_lo_export %u %s failed", lobjId, filename);
- 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 argc, CONST84 char *argv[])
-{
- Pg_ConnectionId *connid;
- PGconn *conn;
- PGresult *result;
- int r,
- retval;
- int tupno,
- column,
- ncols;
- Tcl_DString headers;
- char buffer[2048];
- struct info_s
- {
- char *cname;
- int change;
- } *info;
-
- if (argc != 5)
- {
- Tcl_AppendResult(interp, "Wrong # of arguments\n",
- "pg_select connection queryString var proc", 0);
- return TCL_ERROR;
- }
-
- conn = PgGetConnectionId(interp, argv[1], &connid);
- if (conn == NULL)
- return TCL_ERROR;
-
- if ((result = PQexec(conn, argv[2])) == 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;
- }
-
- if ((info = (struct info_s *) ckalloc(sizeof(*info) * (ncols = PQnfields(result)))) == NULL)
- {
- Tcl_AppendResult(interp, "Not enough memory", 0);
- PQclear(result);
- return TCL_ERROR;
- }
-
- Tcl_DStringInit(&headers);
-
- for (column = 0; column < ncols; column++)
- {
- info[column].cname = PQfname(result, column);
- info[column].change = 0;
- Tcl_DStringAppendElement(&headers, info[column].cname);
- }
-
- Tcl_SetVar2(interp, argv[3], ".headers", Tcl_DStringValue(&headers), 0);
- Tcl_DStringFree(&headers);
- sprintf(buffer, "%d", ncols);
- Tcl_SetVar2(interp, argv[3], ".numcols", buffer, 0);
-
- retval = TCL_OK;
-
- for (tupno = 0; tupno < PQntuples(result); tupno++)
- {
- sprintf(buffer, "%d", tupno);
- Tcl_SetVar2(interp, argv[3], ".tupno", buffer, 0);
-
- for (column = 0; column < ncols; column++)
- Tcl_SetVar2(interp, argv[3], info[column].cname,
-#ifdef TCL_ARRAYS
- tcl_value(PQgetvalue(result, tupno, column)),
-#else
- PQgetvalue(result, tupno, column),
-#endif
- 0);
-
- Tcl_SetVar2(interp, argv[3], ".command", "update", 0);
-
- if ((r = Tcl_Eval(interp, argv[4])) != 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 *) info);
- Tcl_UnsetVar(interp, argv[3], 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 argc, CONST84 char *argv[])
-{
- const char *origrelname;
- char *caserelname;
- char *callback = NULL;
- Pg_TclNotifies *notifies;
- Tcl_HashEntry *entry;
- Pg_ConnectionId *connid;
- PGconn *conn;
- PGresult *result;
- int new;
-
- if (argc < 3 || argc > 4)
- {
- Tcl_AppendResult(interp, "wrong # args, should be \"",
- argv[0], " connection relname ?callback?\"", 0);
- 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.
- */
- conn = PgGetConnectionId(interp, argv[1], &connid);
- if (conn == NULL)
- 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 = argv[2];
- caserelname = (char *) ckalloc((unsigned) (strlen(origrelname) + 1));
- if (*origrelname == '"')
- {
- /* Copy a quoted string without downcasing */
- strcpy(caserelname, origrelname + 1);
- caserelname[strlen(caserelname) - 1] = '\0';
- }
- else
- {
- /* Downcase it */
- const char *rels = origrelname;
- char *reld = caserelname;
-
- while (*rels)
- *reld++ = tolower((unsigned char) *rels++);
- *reld = '\0';
- }
-
- if ((argc > 3) && *argv[3])
- {
- callback = (char *) ckalloc((unsigned) (strlen(argv[3]) + 1));
- strcpy(callback, argv[3]);
- }
-
- /* 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) (strlen(origrelname) + 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) (strlen(origrelname) + 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_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 argc, CONST84 char *argv[])
-{
- char *callback = NULL;
- Pg_TclNotifies *notifies;
- Pg_ConnectionId *connid;
- PGconn *conn;
-
- if (argc < 2 || argc > 3)
- {
- Tcl_AppendResult(interp, "wrong # args, should be \"",
- argv[0], " connection ?callback?\"", 0);
- return TCL_ERROR;
- }
-
- /*
- * Get the command arguments.
- */
- conn = PgGetConnectionId(interp, argv[1], &connid);
- if (conn == NULL)
- return TCL_ERROR;
-
- if ((argc > 2) && *argv[2])
- {
- callback = (char *) ckalloc((unsigned) (strlen(argv[2]) + 1));
- strcpy(callback, argv[2]);
- }
-
- /* 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;
-}
+++ /dev/null
-/*-------------------------------------------------------------------------
- *
- * pgtclId.c
- *
- * Contains Tcl "channel" interface routines, plus useful routines
- * to convert between strings and pointers. These are needed because
- * everything in Tcl is a string, but in C, pointers to data structures
- * are needed.
- *
- * ASSUMPTION: sizeof(long) >= sizeof(void*)
- *
- * Portions Copyright (c) 1996-2003, PostgreSQL Global Development Group
- * Portions Copyright (c) 1994, Regents of the University of California
- *
- * IDENTIFICATION
- * $PostgreSQL: pgsql/src/interfaces/libpgtcl/pgtclId.c,v 1.45 2004/01/07 18:56:29 neilc Exp $
- *
- *-------------------------------------------------------------------------
- */
-#include "postgres_fe.h"
-
-#include
-
-#include "pgtclCmds.h"
-#include "pgtclId.h"
-
-
-static int
-PgEndCopy(Pg_ConnectionId * connid, int *errorCodePtr)
-{
- connid->res_copyStatus = RES_COPY_NONE;
- if (PQendcopy(connid->conn))
- {
- PQclear(connid->results[connid->res_copy]);
- connid->results[connid->res_copy] =
- PQmakeEmptyPGresult(connid->conn, PGRES_BAD_RESPONSE);
- connid->res_copy = -1;
- *errorCodePtr = EIO;
- return -1;
- }
- else
- {
- PQclear(connid->results[connid->res_copy]);
- connid->results[connid->res_copy] =
- PQmakeEmptyPGresult(connid->conn, PGRES_COMMAND_OK);
- connid->res_copy = -1;
- return 0;
- }
-}
-
-/*
- * Called when reading data (via gets) for a copy to stdout.
- */
-int
-PgInputProc(DRIVER_INPUT_PROTO)
-{
- Pg_ConnectionId *connid;
- PGconn *conn;
- int avail;
-
- connid = (Pg_ConnectionId *) cData;
- conn = connid->conn;
-
- if (connid->res_copy < 0 ||
- PQresultStatus(connid->results[connid->res_copy]) != PGRES_COPY_OUT)
- {
- *errorCodePtr = EBUSY;
- return -1;
- }
-
- /*
- * Read any newly arrived data into libpq's buffer, thereby clearing
- * the socket's read-ready condition.
- */
- if (!PQconsumeInput(conn))
- {
- *errorCodePtr = EIO;
- return -1;
- }
-
- /* Move data from libpq's buffer to Tcl's. */
-
- avail = PQgetlineAsync(conn, buf, bufSize);
-
- if (avail < 0)
- {
- /* Endmarker detected, change state and return 0 */
- return PgEndCopy(connid, errorCodePtr);
- }
-
- return avail;
-}
-
-/*
- * Called when writing data (via puts) for a copy from stdin
- */
-int
-PgOutputProc(DRIVER_OUTPUT_PROTO)
-{
- Pg_ConnectionId *connid;
- PGconn *conn;
-
- connid = (Pg_ConnectionId *) cData;
- conn = connid->conn;
-
- if (connid->res_copy < 0 ||
- PQresultStatus(connid->results[connid->res_copy]) != PGRES_COPY_IN)
- {
- *errorCodePtr = EBUSY;
- return -1;
- }
-
- if (PQputnbytes(conn, buf, bufSize))
- {
- *errorCodePtr = EIO;
- return -1;
- }
-
- /*
- * This assumes Tcl script will write the terminator line in a single
- * operation; maybe not such a good assumption?
- */
- if (bufSize >= 3 && strncmp(&buf[bufSize - 3], "\\.\n", 3) == 0)
- {
- if (PgEndCopy(connid, errorCodePtr) == -1)
- return -1;
- }
- return bufSize;
-}
-
-#if HAVE_TCL_GETFILEPROC
-
-Tcl_File
-PgGetFileProc(ClientData cData, int direction)
-{
- return NULL;
-}
-#endif
-
-/*
- * The WatchProc and GetHandleProc are no-ops but must be present.
- */
-static void
-PgWatchProc(ClientData instanceData, int mask)
-{
-}
-
-static int
-PgGetHandleProc(ClientData instanceData, int direction,
- ClientData *handlePtr)
-{
- return TCL_ERROR;
-}
-
-Tcl_ChannelType Pg_ConnType = {
- "pgsql", /* channel type */
- NULL, /* blockmodeproc */
- PgDelConnectionId, /* closeproc */
- PgInputProc, /* inputproc */
- PgOutputProc, /* outputproc */
- NULL, /* SeekProc, Not used */
- NULL, /* SetOptionProc, Not used */
- NULL, /* GetOptionProc, Not used */
- PgWatchProc, /* WatchProc, must be defined */
- PgGetHandleProc, /* GetHandleProc, must be defined */
- NULL /* Close2Proc, Not used */
-};
-
-/*
- * Create and register a new channel for the connection
- */
-void
-PgSetConnectionId(Tcl_Interp *interp, PGconn *conn)
-{
- Tcl_Channel conn_chan;
- Pg_ConnectionId *connid;
- int i;
-
- connid = (Pg_ConnectionId *) ckalloc(sizeof(Pg_ConnectionId));
- connid->conn = conn;
- connid->res_count = 0;
- connid->res_last = -1;
- connid->res_max = RES_START;
- connid->res_hardmax = RES_HARD_MAX;
- connid->res_copy = -1;
- connid->res_copyStatus = RES_COPY_NONE;
- connid->results = (PGresult **) ckalloc(sizeof(PGresult *) * RES_START);
- for (i = 0; i < RES_START; i++)
- connid->results[i] = NULL;
- connid->notify_list = NULL;
- connid->notifier_running = 0;
-
- sprintf(connid->id, "pgsql%d", PQsocket(conn));
-
-#if TCL_MAJOR_VERSION >= 8
- connid->notifier_channel = Tcl_MakeTcpClientChannel((ClientData) PQsocket(conn));
- Tcl_RegisterChannel(NULL, connid->notifier_channel);
-#else
- connid->notifier_socket = -1;
-#endif
-
-#if TCL_MAJOR_VERSION == 7 && TCL_MINOR_VERSION == 5
- /* Original signature (only seen in Tcl 7.5) */
- conn_chan = Tcl_CreateChannel(&Pg_ConnType, connid->id, NULL, NULL, (ClientData) connid);
-#else
- /* Tcl 7.6 and later use this */
- conn_chan = Tcl_CreateChannel(&Pg_ConnType, connid->id, (ClientData) connid,
- TCL_READABLE | TCL_WRITABLE);
-#endif
-
- Tcl_SetChannelOption(interp, conn_chan, "-buffering", "line");
- Tcl_SetResult(interp, connid->id, TCL_VOLATILE);
- Tcl_RegisterChannel(interp, conn_chan);
-}
-
-
-/*
- * Get back the connection from the Id
- */
-PGconn *
-PgGetConnectionId(Tcl_Interp *interp, CONST84 char *id,
- Pg_ConnectionId ** connid_p)
-{
- Tcl_Channel conn_chan;
- Pg_ConnectionId *connid;
-
- conn_chan = Tcl_GetChannel(interp, id, 0);
- if (conn_chan == NULL || Tcl_GetChannelType(conn_chan) != &Pg_ConnType)
- {
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, id, " is not a valid postgresql connection", 0);
- if (connid_p)
- *connid_p = NULL;
- return NULL;
- }
-
- connid = (Pg_ConnectionId *) Tcl_GetChannelInstanceData(conn_chan);
- if (connid_p)
- *connid_p = connid;
- return connid->conn;
-}
-
-
-/*
- * Remove a connection Id from the hash table and
- * close all portals the user forgot.
- */
-int
-PgDelConnectionId(DRIVER_DEL_PROTO)
-{
- Tcl_HashEntry *entry;
- Tcl_HashSearch hsearch;
- Pg_ConnectionId *connid;
- Pg_TclNotifies *notifies;
- int i;
-
- connid = (Pg_ConnectionId *) cData;
-
- for (i = 0; i < connid->res_max; i++)
- {
- if (connid->results[i])
- PQclear(connid->results[i]);
- }
- ckfree((void *) connid->results);
-
- /* Release associated notify info */
- while ((notifies = connid->notify_list) != NULL)
- {
- connid->notify_list = notifies->next;
- for (entry = Tcl_FirstHashEntry(¬ifies->notify_hash, &hsearch);
- entry != NULL;
- entry = Tcl_NextHashEntry(&hsearch))
- ckfree((char *) Tcl_GetHashValue(entry));
- Tcl_DeleteHashTable(¬ifies->notify_hash);
- if (notifies->conn_loss_cmd)
- ckfree((void *) notifies->conn_loss_cmd);
- if (notifies->interp)
- Tcl_DontCallWhenDeleted(notifies->interp, PgNotifyInterpDelete,
- (ClientData) notifies);
- ckfree((void *) notifies);
- }
-
- /*
- * Turn off the Tcl event source for this connection, and delete any
- * pending notify and connection-loss events.
- */
- PgStopNotifyEventSource(connid, true);
-
- /* Close the libpq connection too */
- PQfinish(connid->conn);
- connid->conn = NULL;
-
- /*
- * Kill the notifier channel, too. We must not do this until after
- * we've closed the libpq connection, because Tcl will try to close
- * the socket itself!
- *
- * XXX Unfortunately, while this works fine if we are closing due to
- * explicit pg_disconnect, all Tcl versions through 8.4.1 dump core if
- * we try to do it during interpreter shutdown. Not clear why. For
- * now, we kill the channel during pg_disconnect, but during interp
- * shutdown we just accept leakage of the (fairly small) amount of
- * memory taken for the channel state representation. (Note we are not
- * leaking a socket, since libpq closed that already.) We tell the
- * difference between pg_disconnect and interpreter shutdown by
- * testing for interp != NULL, which is an undocumented but apparently
- * safe way to tell.
- */
-#if TCL_MAJOR_VERSION >= 8
- if (connid->notifier_channel != NULL && interp != NULL)
- Tcl_UnregisterChannel(NULL, connid->notifier_channel);
-#endif
-
- /*
- * We must use Tcl_EventuallyFree because we don't want the connid
- * struct to vanish instantly if Pg_Notify_EventProc is active for it.
- * (Otherwise, closing the connection from inside a pg_listen callback
- * could lead to coredump.) Pg_Notify_EventProc can detect that the
- * connection has been deleted from under it by checking connid->conn.
- */
- Tcl_EventuallyFree((ClientData) connid, TCL_DYNAMIC);
-
- return 0;
-}
-
-
-/*
- * Find a slot for a new result id. If the table is full, expand it by
- * a factor of 2. However, do not expand past the hard max, as the client
- * is probably just not clearing result handles like they should.
- */
-int
-PgSetResultId(Tcl_Interp *interp, CONST84 char *connid_c, PGresult *res)
-{
- Tcl_Channel conn_chan;
- Pg_ConnectionId *connid;
- int resid,
- i;
- char buf[32];
-
-
- conn_chan = Tcl_GetChannel(interp, connid_c, 0);
- if (conn_chan == NULL)
- return TCL_ERROR;
- connid = (Pg_ConnectionId *) Tcl_GetChannelInstanceData(conn_chan);
-
- /* search, starting at slot after the last one used */
- resid = connid->res_last;
- for (;;)
- {
- /* advance, with wraparound */
- if (++resid >= connid->res_max)
- resid = 0;
- /* this slot empty? */
- if (!connid->results[resid])
- {
- connid->res_last = resid;
- break; /* success exit */
- }
- /* checked all slots? */
- if (resid == connid->res_last)
- break; /* failure exit */
- }
-
- if (connid->results[resid])
- {
- /* no free slot found, so try to enlarge array */
- if (connid->res_max >= connid->res_hardmax)
- {
- Tcl_SetResult(interp, "hard limit on result handles reached",
- TCL_STATIC);
- return TCL_ERROR;
- }
- connid->res_last = resid = connid->res_max;
- connid->res_max *= 2;
- if (connid->res_max > connid->res_hardmax)
- connid->res_max = connid->res_hardmax;
- connid->results = (PGresult **) ckrealloc((void *) connid->results,
- sizeof(PGresult *) * connid->res_max);
- for (i = connid->res_last; i < connid->res_max; i++)
- connid->results[i] = NULL;
- }
-
- connid->results[resid] = res;
- sprintf(buf, "%s.%d", connid_c, resid);
- Tcl_SetResult(interp, buf, TCL_VOLATILE);
- return resid;
-}
-
-static int
-getresid(Tcl_Interp *interp, CONST84 char *id, Pg_ConnectionId ** connid_p)
-{
- Tcl_Channel conn_chan;
- char *mark;
- int resid;
- Pg_ConnectionId *connid;
-
- if (!(mark = strchr(id, '.')))
- return -1;
- *mark = '\0';
- conn_chan = Tcl_GetChannel(interp, id, 0);
- *mark = '.';
- if (conn_chan == NULL || Tcl_GetChannelType(conn_chan) != &Pg_ConnType)
- {
- Tcl_SetResult(interp, "Invalid connection handle", TCL_STATIC);
- return -1;
- }
-
- if (Tcl_GetInt(interp, mark + 1, &resid) == TCL_ERROR)
- {
- Tcl_SetResult(interp, "Poorly formated result handle", TCL_STATIC);
- return -1;
- }
-
- connid = (Pg_ConnectionId *) Tcl_GetChannelInstanceData(conn_chan);
-
- if (resid < 0 || resid >= connid->res_max || connid->results[resid] == NULL)
- {
- Tcl_SetResult(interp, "Invalid result handle", TCL_STATIC);
- return -1;
- }
-
- *connid_p = connid;
-
- return resid;
-}
-
-
-/*
- * Get back the result pointer from the Id
- */
-PGresult *
-PgGetResultId(Tcl_Interp *interp, CONST84 char *id)
-{
- Pg_ConnectionId *connid;
- int resid;
-
- if (!id)
- return NULL;
- resid = getresid(interp, id, &connid);
- if (resid == -1)
- return NULL;
- return connid->results[resid];
-}
-
-
-/*
- * Remove a result Id from the hash tables
- */
-void
-PgDelResultId(Tcl_Interp *interp, CONST84 char *id)
-{
- Pg_ConnectionId *connid;
- int resid;
-
- resid = getresid(interp, id, &connid);
- if (resid == -1)
- return;
- connid->results[resid] = 0;
-}
-
-
-/*
- * Get the connection Id from the result Id
- */
-int
-PgGetConnByResultId(Tcl_Interp *interp, CONST84 char *resid_c)
-{
- char *mark;
- Tcl_Channel conn_chan;
-
- if (!(mark = strchr(resid_c, '.')))
- goto error_out;
- *mark = '\0';
- conn_chan = Tcl_GetChannel(interp, resid_c, 0);
- *mark = '.';
- if (conn_chan && Tcl_GetChannelType(conn_chan) == &Pg_ConnType)
- {
- Tcl_SetResult(interp, (char *) Tcl_GetChannelName(conn_chan),
- TCL_VOLATILE);
- return TCL_OK;
- }
-
-error_out:
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, resid_c, " is not a valid connection\n", 0);
- return TCL_ERROR;
-}
-
-
-
-
-/*-------------------------------------------
- Notify event source
-
- These functions allow asynchronous notify messages arriving from
- the SQL server to be dispatched as Tcl events. See the Tcl
- Notifier(3) man page for more info.
-
- The main trick in this code is that we have to cope with status changes
- between the queueing and the execution of a Tcl event. For example,
- if the user changes or cancels the pg_listen callback command, we should
- use the new setting; we do that by not resolving the notify relation
- name until the last possible moment.
- We also have to handle closure of the channel or deletion of the interpreter
- to be used for the callback (note that with multiple interpreters,
- the channel can outlive the interpreter it was created by!)
- Upon closure of the channel, we immediately delete the file event handler
- for it, which has the effect of disabling any file-ready events that might
- be hanging about in the Tcl event queue. But for interpreter deletion,
- we just set any matching interp pointers in the Pg_TclNotifies list to NULL.
- The list item stays around until the connection is deleted. (This avoids
- trouble with walking through a list whose members may get deleted under us.)
-
- Another headache is that Ousterhout keeps changing the Tcl I/O interfaces.
- libpgtcl currently claims to work with Tcl 7.5, 7.6, and 8.0, and each of
- 'em is different. Worse, the Tcl_File type went away in 8.0, which means
- there is no longer any platform-independent way of waiting for file ready.
- So we now have to use a Unix-specific interface. Grumble.
-
- In the current design, Pg_Notify_FileHandler is a file handler that
- we establish by calling Tcl_CreateFileHandler(). It gets invoked from
- the Tcl event loop whenever the underlying PGconn's socket is read-ready.
- We suck up any available data (to clear the OS-level read-ready condition)
- and then transfer any available PGnotify events into the Tcl event queue.
- Eventually these events will be dispatched to Pg_Notify_EventProc. When
- we do an ordinary PQexec, we must also transfer PGnotify events into Tcl's
- event queue, since libpq might have read them when we weren't looking.
- ------------------------------------------*/
-
-typedef struct
-{
- Tcl_Event header; /* Standard Tcl event info */
- PGnotify *notify; /* Notify event from libpq, or NULL */
- /* We use a NULL notify pointer to denote a connection-loss event */
- Pg_ConnectionId *connid; /* Connection for server */
-} NotifyEvent;
-
-/* Dispatch a NotifyEvent that has reached the front of the event queue */
-
-static int
-Pg_Notify_EventProc(Tcl_Event *evPtr, int flags)
-{
- NotifyEvent *event = (NotifyEvent *) evPtr;
- Pg_TclNotifies *notifies;
- char *callback;
- char *svcallback;
-
- /* We classify SQL notifies as Tcl file events. */
- if (!(flags & TCL_FILE_EVENTS))
- return 0;
-
- /* If connection's been closed, just forget the whole thing. */
- if (event->connid == NULL)
- {
- if (event->notify)
- PQfreemem(event->notify);
- return 1;
- }
-
- /*
- * Preserve/Release to ensure the connection struct doesn't disappear
- * underneath us.
- */
- Tcl_Preserve((ClientData) event->connid);
-
- /*
- * Loop for each interpreter that has ever registered on the
- * connection. Each one can get a callback.
- */
-
- for (notifies = event->connid->notify_list;
- notifies != NULL;
- notifies = notifies->next)
- {
- Tcl_Interp *interp = notifies->interp;
-
- if (interp == NULL)
- continue; /* ignore deleted interpreter */
-
- /*
- * Find the callback to be executed for this interpreter, if any.
- */
- if (event->notify)
- {
- /* Ordinary NOTIFY event */
- Tcl_HashEntry *entry;
-
- entry = Tcl_FindHashEntry(¬ifies->notify_hash,
- event->notify->relname);
- if (entry == NULL)
- continue; /* no pg_listen in this interpreter */
- callback = (char *) Tcl_GetHashValue(entry);
- }
- else
- {
- /* Connection-loss event */
- callback = notifies->conn_loss_cmd;
- }
-
- if (callback == NULL)
- continue; /* nothing to do for this interpreter */
-
- /*
- * We have to copy the callback string in case the user executes a
- * new pg_listen or pg_on_connection_loss during the callback.
- */
- svcallback = (char *) ckalloc((unsigned) (strlen(callback) + 1));
- strcpy(svcallback, callback);
-
- /*
- * Execute the callback.
- */
- Tcl_Preserve((ClientData) interp);
- if (Tcl_GlobalEval(interp, svcallback) != TCL_OK)
- {
- if (event->notify)
- Tcl_AddErrorInfo(interp, "\n (\"pg_listen\" script)");
- else
- Tcl_AddErrorInfo(interp, "\n (\"pg_on_connection_loss\" script)");
- Tcl_BackgroundError(interp);
- }
- Tcl_Release((ClientData) interp);
- ckfree(svcallback);
-
- /*
- * Check for the possibility that the callback closed the
- * connection.
- */
- if (event->connid->conn == NULL)
- break;
- }
-
- Tcl_Release((ClientData) event->connid);
-
- if (event->notify)
- PQfreemem(event->notify);
-
- return 1;
-}
-
-/*
- * Transfer any notify events available from libpq into the Tcl event queue.
- * Note that this must be called after each PQexec (to capture notifies
- * that arrive during command execution) as well as in Pg_Notify_FileHandler
- * (to capture notifies that arrive when we're idle).
- */
-
-void
-PgNotifyTransferEvents(Pg_ConnectionId * connid)
-{
- PGnotify *notify;
-
- while ((notify = PQnotifies(connid->conn)) != NULL)
- {
- NotifyEvent *event = (NotifyEvent *) ckalloc(sizeof(NotifyEvent));
-
- event->header.proc = Pg_Notify_EventProc;
- event->notify = notify;
- event->connid = connid;
- Tcl_QueueEvent((Tcl_Event *) event, TCL_QUEUE_TAIL);
- }
-
- /*
- * This is also a good place to check for unexpected closure of the
- * connection (ie, backend crash), in which case we must shut down the
- * notify event source to keep Tcl from trying to select() on the now-
- * closed socket descriptor. But don't kill on-connection-loss
- * events; in fact, register one.
- */
- if (PQsocket(connid->conn) < 0)
- PgConnLossTransferEvents(connid);
-}
-
-/*
- * Handle a connection-loss event
- */
-void
-PgConnLossTransferEvents(Pg_ConnectionId * connid)
-{
- if (connid->notifier_running)
- {
- /* Put the on-connection-loss event in the Tcl queue */
- NotifyEvent *event = (NotifyEvent *) ckalloc(sizeof(NotifyEvent));
-
- event->header.proc = Pg_Notify_EventProc;
- event->notify = NULL;
- event->connid = connid;
- Tcl_QueueEvent((Tcl_Event *) event, TCL_QUEUE_TAIL);
- }
-
- /*
- * Shut down the notify event source to keep Tcl from trying to
- * select() on the now-closed socket descriptor. And zap any
- * unprocessed notify events ... but not, of course, the
- * connection-loss event.
- */
- PgStopNotifyEventSource(connid, false);
-}
-
-/*
- * Cleanup code for coping when an interpreter or a channel is deleted.
- *
- * PgNotifyInterpDelete is registered as an interpreter deletion callback
- * for each extant Pg_TclNotifies structure.
- * NotifyEventDeleteProc is used by PgStopNotifyEventSource to cancel
- * pending Tcl NotifyEvents that reference a dying connection.
- */
-
-void
-PgNotifyInterpDelete(ClientData clientData, Tcl_Interp *interp)
-{
- /* Mark the interpreter dead, but don't do anything else yet */
- Pg_TclNotifies *notifies = (Pg_TclNotifies *) clientData;
-
- notifies->interp = NULL;
-}
-
-/*
- * Comparison routines for detecting events to be removed by Tcl_DeleteEvents.
- * NB: In (at least) Tcl versions 7.6 through 8.0.3, there is a serious
- * bug in Tcl_DeleteEvents: if there are multiple events on the queue and
- * you tell it to delete the last one, the event list pointers get corrupted,
- * with the result that events queued immediately thereafter get lost.
- * Therefore we daren't tell Tcl_DeleteEvents to actually delete anything!
- * We simply use it as a way of scanning the event queue. Events matching
- * the about-to-be-deleted connid are marked dead by setting their connid
- * fields to NULL. Then Pg_Notify_EventProc will do nothing when those
- * events are executed.
- */
-static int
-NotifyEventDeleteProc(Tcl_Event *evPtr, ClientData clientData)
-{
- Pg_ConnectionId *connid = (Pg_ConnectionId *) clientData;
-
- if (evPtr->proc == Pg_Notify_EventProc)
- {
- NotifyEvent *event = (NotifyEvent *) evPtr;
-
- if (event->connid == connid && event->notify != NULL)
- event->connid = NULL;
- }
- return 0;
-}
-
-/* This version deletes on-connection-loss events too */
-static int
-AllNotifyEventDeleteProc(Tcl_Event *evPtr, ClientData clientData)
-{
- Pg_ConnectionId *connid = (Pg_ConnectionId *) clientData;
-
- if (evPtr->proc == Pg_Notify_EventProc)
- {
- NotifyEvent *event = (NotifyEvent *) evPtr;
-
- if (event->connid == connid)
- event->connid = NULL;
- }
- return 0;
-}
-
-/*
- * File handler callback: called when Tcl has detected read-ready on socket.
- * The clientData is a pointer to the associated connection.
- * We can ignore the condition mask since we only ever ask about read-ready.
- */
-
-static void
-Pg_Notify_FileHandler(ClientData clientData, int mask)
-{
- Pg_ConnectionId *connid = (Pg_ConnectionId *) clientData;
-
- /*
- * Consume any data available from the SQL server (this just buffers
- * it internally to libpq; but it will clear the read-ready
- * condition).
- */
- if (PQconsumeInput(connid->conn))
- {
- /* Transfer notify events from libpq to Tcl event queue. */
- PgNotifyTransferEvents(connid);
- }
- else
- {
- /*
- * If there is no input but we have read-ready, assume this means
- * we lost the connection.
- */
- PgConnLossTransferEvents(connid);
- }
-}
-
-
-/*
- * Start and stop the notify event source for a connection.
- *
- * We do not bother to run the notifier unless at least one pg_listen
- * or pg_on_connection_loss has been executed on the connection. Currently,
- * once started the notifier is run until the connection is closed.
- *
- * FIXME: if PQreset is executed on the underlying PGconn, the active
- * socket number could change. How and when should we test for this
- * and update the Tcl file handler linkage? (For that matter, we'd
- * also have to reissue LISTEN commands for active LISTENs, since the
- * new backend won't know about 'em. I'm leaving this problem for
- * another day.)
- */
-
-void
-PgStartNotifyEventSource(Pg_ConnectionId * connid)
-{
- /* Start the notify event source if it isn't already running */
- if (!connid->notifier_running)
- {
- int pqsock = PQsocket(connid->conn);
-
- if (pqsock >= 0)
- {
-#if TCL_MAJOR_VERSION >= 8
- Tcl_CreateChannelHandler(connid->notifier_channel,
- TCL_READABLE,
- Pg_Notify_FileHandler,
- (ClientData) connid);
-#else
- /* In Tcl 7.5 and 7.6, we need to gin up a Tcl_File. */
- Tcl_File tclfile = Tcl_GetFile((ClientData) pqsock, TCL_UNIX_FD);
-
- Tcl_CreateFileHandler(tclfile, TCL_READABLE,
- Pg_Notify_FileHandler, (ClientData) connid);
- connid->notifier_socket = pqsock;
-#endif
- connid->notifier_running = 1;
- }
- }
-}
-
-void
-PgStopNotifyEventSource(Pg_ConnectionId * connid, bool allevents)
-{
- /* Remove the event source */
- if (connid->notifier_running)
- {
-#if TCL_MAJOR_VERSION >= 8
- Tcl_DeleteChannelHandler(connid->notifier_channel,
- Pg_Notify_FileHandler,
- (ClientData) connid);
-#else
- /* In Tcl 7.5 and 7.6, we need to gin up a Tcl_File. */
- Tcl_File tclfile = Tcl_GetFile((ClientData) connid->notifier_socket,
- TCL_UNIX_FD);
-
- Tcl_DeleteFileHandler(tclfile);
-#endif
- connid->notifier_running = 0;
- }
-
- /* Kill queued Tcl events that reference this channel */
- if (allevents)
- Tcl_DeleteEvents(AllNotifyEventDeleteProc, (ClientData) connid);
- else
- Tcl_DeleteEvents(NotifyEventDeleteProc, (ClientData) connid);
-}
projects / postgresql.git / commitdiff