This patch covers several to-do items that I had for libpgtcl:
* It works under both Tcl 7.6 and Tcl 8.0 now. (The code claims to work under Tcl 7.5 as well, but I have no way to test that --- if anyone still cares, please check it with 7.5.) * pg_listen suppresses extra LISTEN commands and correctly sends an UNLISTEN when the last listen request for a relation is cancelled. (Note this means it will not work with pre-6.4 backends, but that was true already because it depends on the current libpq, which only speaks protocol 2.0.) * Added -error option to pg_result so that there's some way to find out what you did wrong ;-) * Miscellaneous cleanups of code comments and overenthusiastic #includes. BTW, I bumped the package version number from 1.2 to 1.3. Is this premature? Does someone run around and do that routinely before each pgsql release? regards, tom lane
This commit is contained in:
Bruce Momjian
parent
b0297d806b
commit
4b048fbfaa
|
|
@ -1,12 +1,13 @@
|
|||
/*-------------------------------------------------------------------------
|
||||
*
|
||||
* libpgtcl.h--
|
||||
* libpgtcl is a tcl package for front-ends to interface with pglite
|
||||
* It's the tcl equivalent of the old libpq C interface.
|
||||
*
|
||||
* libpgtcl is a tcl package for front-ends to interface with PostgreSQL.
|
||||
* It's a Tcl wrapper for libpq.
|
||||
*
|
||||
* Copyright (c) 1994, Regents of the University of California
|
||||
*
|
||||
* $Id: libpgtcl.h,v 1.5 1998/09/01 04:39:53 momjian Exp $
|
||||
* $Id: libpgtcl.h,v 1.6 1998/09/21 01:01:58 momjian Exp $
|
||||
*
|
||||
*-------------------------------------------------------------------------
|
||||
*/
|
||||
|
|
|
|||
|
|
@ -2,14 +2,14 @@
|
|||
*
|
||||
* pgtcl.c--
|
||||
*
|
||||
* libpgtcl is a tcl package for front-ends to interface with pglite
|
||||
* It's the tcl equivalent of the old libpq C interface.
|
||||
* libpgtcl is a tcl package for front-ends to interface with PostgreSQL.
|
||||
* It's a Tcl wrapper for libpq.
|
||||
*
|
||||
* Copyright (c) 1994, Regents of the University of California
|
||||
*
|
||||
*
|
||||
* IDENTIFICATION
|
||||
* $Header: /cvsroot/pgsql/src/interfaces/libpgtcl/Attic/pgtcl.c,v 1.12 1998/09/01 04:39:55 momjian Exp $
|
||||
* $Header: /cvsroot/pgsql/src/interfaces/libpgtcl/Attic/pgtcl.c,v 1.13 1998/09/21 01:02:00 momjian Exp $
|
||||
*
|
||||
*-------------------------------------------------------------------------
|
||||
*/
|
||||
|
|
@ -17,14 +17,13 @@
|
|||
#include <stdlib.h>
|
||||
|
||||
#include "postgres.h"
|
||||
#include "tcl.h"
|
||||
#include "libpgtcl.h"
|
||||
#include "pgtclCmds.h"
|
||||
#include "pgtclId.h"
|
||||
|
||||
/*
|
||||
* Pgtcl_Init
|
||||
* initialization package for the PGLITE Tcl package
|
||||
* initialization package for the PGTCL Tcl package
|
||||
*
|
||||
*/
|
||||
|
||||
|
|
@ -35,7 +34,7 @@ Pgtcl_Init(Tcl_Interp * interp)
|
|||
/*
|
||||
* finish off the ChannelType struct. Much easier to do it here then
|
||||
* to guess where it might be by position in the struct. This is
|
||||
* needed for Tcl7.6 and beyond, which have the getfileproc.
|
||||
* needed for Tcl7.6 *only*, which has the getfileproc.
|
||||
*/
|
||||
#if HAVE_TCL_GETFILEPROC
|
||||
Pg_ConnType.getFileProc = PgGetFileProc;
|
||||
|
|
@ -127,7 +126,7 @@ Pgtcl_Init(Tcl_Interp * interp)
|
|||
Pg_listen,
|
||||
(ClientData) NULL, (Tcl_CmdDeleteProc *) NULL);
|
||||
|
||||
Tcl_PkgProvide(interp, "Pgtcl", "1.2");
|
||||
Tcl_PkgProvide(interp, "Pgtcl", "1.3");
|
||||
|
||||
return TCL_OK;
|
||||
}
|
||||
|
|
|
|||
|
|
@ -7,7 +7,7 @@
|
|||
*
|
||||
*
|
||||
* IDENTIFICATION
|
||||
* $Header: /cvsroot/pgsql/src/interfaces/libpgtcl/Attic/pgtclCmds.c,v 1.34 1998/09/04 05:02:58 momjian Exp $
|
||||
* $Header: /cvsroot/pgsql/src/interfaces/libpgtcl/Attic/pgtclCmds.c,v 1.35 1998/09/21 01:02:01 momjian Exp $
|
||||
*
|
||||
*-------------------------------------------------------------------------
|
||||
*/
|
||||
|
|
@ -16,16 +16,14 @@
|
|||
#include <stdlib.h>
|
||||
#include <string.h>
|
||||
#include <ctype.h>
|
||||
#include <tcl.h>
|
||||
|
||||
#include "postgres.h"
|
||||
#include "libpq/pqcomm.h"
|
||||
#include "libpq-fe.h"
|
||||
#include "libpq/libpq-fs.h"
|
||||
#include "pgtclCmds.h"
|
||||
#include "pgtclId.h"
|
||||
#include "libpq/libpq-fs.h" /* large-object interface */
|
||||
|
||||
#ifdef TCL_ARRAYS
|
||||
|
||||
#define ISOCTAL(c) (((c) >= '0') && ((c) <= '7'))
|
||||
#define DIGIT(c) ((c) - '0')
|
||||
|
||||
|
|
@ -221,7 +219,8 @@ tcl_value(char *value)
|
|||
return value;
|
||||
}
|
||||
|
||||
#endif
|
||||
#endif /* TCL_ARRAYS */
|
||||
|
||||
|
||||
/**********************************
|
||||
* pg_conndefaults
|
||||
|
|
@ -476,8 +475,16 @@ Pg_exec(ClientData cData, Tcl_Interp * interp, int argc, char *argv[])
|
|||
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
|
||||
-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)
|
||||
|
|
@ -485,19 +492,15 @@ Pg_exec(ClientData cData, Tcl_Interp * interp, int argc, char *argv[])
|
|||
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)
|
||||
-numTuples
|
||||
the number of tuples in the query
|
||||
-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
|
||||
-numAttrs
|
||||
returns the number of attributes returned by the query
|
||||
-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
|
||||
**********************************/
|
||||
|
|
@ -505,6 +508,7 @@ int
|
|||
Pg_result(ClientData cData, Tcl_Interp * interp, int argc, char *argv[])
|
||||
{
|
||||
PGresult *result;
|
||||
PGconn *conn;
|
||||
char *opt;
|
||||
int i;
|
||||
int tupno;
|
||||
|
|
@ -515,13 +519,13 @@ Pg_result(ClientData cData, Tcl_Interp * interp, int argc, char *argv[])
|
|||
if (argc < 3 || argc > 5)
|
||||
{
|
||||
Tcl_AppendResult(interp, "Wrong # of arguments\n", 0);
|
||||
goto Pg_result_errReturn;
|
||||
goto Pg_result_errReturn; /* append help info */
|
||||
}
|
||||
|
||||
result = PgGetResultId(interp, argv[1]);
|
||||
if (result == (PGresult *) NULL)
|
||||
{
|
||||
Tcl_AppendResult(interp, "First argument is not a valid query result", 0);
|
||||
Tcl_AppendResult(interp, argv[1], " is not a valid query result", 0);
|
||||
return TCL_ERROR;
|
||||
}
|
||||
|
||||
|
|
@ -532,13 +536,35 @@ Pg_result(ClientData cData, Tcl_Interp * interp, int argc, char *argv[])
|
|||
Tcl_AppendResult(interp, pgresStatus[PQresultStatus(result)], 0);
|
||||
return TCL_OK;
|
||||
}
|
||||
else if (strcmp(opt, "-error") == 0)
|
||||
{
|
||||
switch (PQresultStatus(result)) {
|
||||
case PGRES_EMPTY_QUERY:
|
||||
case PGRES_COMMAND_OK:
|
||||
case PGRES_TUPLES_OK:
|
||||
case PGRES_COPY_OUT:
|
||||
case PGRES_COPY_IN:
|
||||
Tcl_ResetResult(interp);
|
||||
break;
|
||||
default:
|
||||
if (PgGetConnByResultId(interp, argv[1]) != TCL_OK)
|
||||
return TCL_ERROR;
|
||||
conn = PgGetConnectionId(interp, interp->result,
|
||||
(Pg_ConnectionId **) NULL);
|
||||
if (conn == (PGconn *) NULL)
|
||||
return TCL_ERROR;
|
||||
Tcl_SetResult(interp, PQerrorMessage(conn), TCL_VOLATILE);
|
||||
break;
|
||||
}
|
||||
return TCL_OK;
|
||||
}
|
||||
else if (strcmp(opt, "-conn") == 0)
|
||||
return PgGetConnByResultId(interp, argv[1]);
|
||||
else if (strcmp(opt, "-oid") == 0)
|
||||
{
|
||||
Tcl_AppendResult(interp, PQoidStatus(result), 0);
|
||||
return TCL_OK;
|
||||
}
|
||||
else if (strcmp(opt, "-conn") == 0)
|
||||
return PgGetConnByResultId(interp, argv[1]);
|
||||
else if (strcmp(opt, "-clear") == 0)
|
||||
{
|
||||
PgDelResultId(interp, argv[1]);
|
||||
|
|
@ -696,26 +722,27 @@ Pg_result(ClientData cData, Tcl_Interp * interp, int argc, char *argv[])
|
|||
}
|
||||
else
|
||||
{
|
||||
Tcl_AppendResult(interp, "Invalid option", 0);
|
||||
goto Pg_result_errReturn;
|
||||
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",
|
||||
"pg_result result ?option? where option is\n",
|
||||
"\t-status\n",
|
||||
"\t-error\n",
|
||||
"\t-conn\n",
|
||||
"\t-assign arrayVarName\n",
|
||||
"\t-assignbyidx arrayVarName ?appendstr?\n",
|
||||
"\t-oid\n",
|
||||
"\t-numTuples\n",
|
||||
"\t-numAttrs\n"
|
||||
"\t-attributes\n"
|
||||
"\t-lAttributes\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",
|
||||
"\t-oid\n",
|
||||
(char *) 0);
|
||||
return TCL_ERROR;
|
||||
|
||||
|
|
@ -1244,7 +1271,7 @@ Pg_select(ClientData cData, Tcl_Interp * interp, int argc, char **argv)
|
|||
if ((result = PQexec(conn, argv[2])) == 0)
|
||||
{
|
||||
/* error occurred during the query */
|
||||
Tcl_SetResult(interp, PQerrorMessage(conn), TCL_STATIC);
|
||||
Tcl_SetResult(interp, PQerrorMessage(conn), TCL_VOLATILE);
|
||||
return TCL_ERROR;
|
||||
}
|
||||
|
||||
|
|
@ -1305,6 +1332,36 @@ Pg_select(ClientData cData, Tcl_Interp * interp, int argc, char **argv)
|
|||
return TCL_OK;
|
||||
}
|
||||
|
||||
/*
|
||||
* 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, 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
|
||||
|
|
@ -1342,7 +1399,7 @@ Pg_listen(ClientData cData, Tcl_Interp * interp, int argc, char *argv[])
|
|||
/*
|
||||
* Get the command arguments. Note that the relation name will be
|
||||
* copied by Tcl_CreateHashEntry while the callback string must be
|
||||
* allocated.
|
||||
* allocated by us.
|
||||
*/
|
||||
conn = PgGetConnectionId(interp, argv[1], &connid);
|
||||
if (conn == (PGconn *) NULL)
|
||||
|
|
@ -1396,17 +1453,30 @@ Pg_listen(ClientData cData, Tcl_Interp * interp, int argc, char *argv[])
|
|||
(ClientData) notifies);
|
||||
}
|
||||
|
||||
/*
|
||||
* Set or update a callback for a relation
|
||||
*/
|
||||
if (callback)
|
||||
{
|
||||
entry = Tcl_CreateHashEntry(¬ifies->notify_hash, caserelname, &new);
|
||||
if (new)
|
||||
{
|
||||
/* New callback, execute a listen command on the relation */
|
||||
char *cmd = (char *) ckalloc((unsigned) (strlen(origrelname) + 8));
|
||||
/*
|
||||
* 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);
|
||||
|
|
@ -1416,32 +1486,20 @@ Pg_listen(ClientData cData, Tcl_Interp * interp, int argc, char *argv[])
|
|||
{
|
||||
/* Error occurred during the execution of command */
|
||||
PQclear(result);
|
||||
Tcl_DeleteHashEntry(entry);
|
||||
ckfree(callback);
|
||||
ckfree(caserelname);
|
||||
Tcl_DeleteHashEntry(entry);
|
||||
Tcl_SetResult(interp, PQerrorMessage(conn), TCL_VOLATILE);
|
||||
return TCL_ERROR;
|
||||
}
|
||||
PQclear(result);
|
||||
}
|
||||
else
|
||||
{
|
||||
/* Update, free the old callback string */
|
||||
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);
|
||||
}
|
||||
|
||||
/*
|
||||
* Remove a callback for a relation. There is no way to un-listen a
|
||||
* relation, so we simply remove the callback from the notify hash
|
||||
* table.
|
||||
*/
|
||||
if (callback == NULL)
|
||||
else
|
||||
{
|
||||
/*
|
||||
* Remove a callback for a relation
|
||||
*/
|
||||
entry = Tcl_FindHashEntry(¬ifies->notify_hash, caserelname);
|
||||
if (entry == NULL)
|
||||
{
|
||||
|
|
@ -1451,6 +1509,30 @@ Pg_listen(ClientData cData, Tcl_Interp * interp, int argc, char *argv[])
|
|||
}
|
||||
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);
|
||||
|
|
|
|||
|
|
@ -5,7 +5,7 @@
|
|||
*
|
||||
* Copyright (c) 1994, Regents of the University of California
|
||||
*
|
||||
* $Id: pgtclCmds.h,v 1.11 1998/09/01 04:39:57 momjian Exp $
|
||||
* $Id: pgtclCmds.h,v 1.12 1998/09/21 01:02:02 momjian Exp $
|
||||
*
|
||||
*-------------------------------------------------------------------------
|
||||
*/
|
||||
|
|
@ -54,9 +54,10 @@ typedef struct Pg_ConnectionId_s
|
|||
|
||||
Pg_TclNotifies *notify_list;/* head of list of notify info */
|
||||
int notifier_running; /* notify event source is live */
|
||||
|
||||
int notifier_socket; /* PQsocket on which notifier is listening */
|
||||
} Pg_ConnectionId;
|
||||
|
||||
/* Values of res_copyStatus */
|
||||
#define RES_COPY_NONE 0
|
||||
#define RES_COPY_INPROGRESS 1
|
||||
#define RES_COPY_FIN 2
|
||||
|
|
|
|||
|
|
@ -1,18 +1,18 @@
|
|||
/*-------------------------------------------------------------------------
|
||||
*
|
||||
* pgtclId.c--
|
||||
* useful routines to convert between strings and pointers
|
||||
* Needed because everything in tcl is a string, but we want pointers
|
||||
* to data structures
|
||||
*
|
||||
* 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*)
|
||||
*
|
||||
*
|
||||
* Copyright (c) 1994, Regents of the University of California
|
||||
*
|
||||
*
|
||||
* IDENTIFICATION
|
||||
* $Header: /cvsroot/pgsql/src/interfaces/libpgtcl/Attic/pgtclId.c,v 1.15 1998/09/03 02:10:44 momjian Exp $
|
||||
* $Header: /cvsroot/pgsql/src/interfaces/libpgtcl/Attic/pgtclId.c,v 1.16 1998/09/21 01:02:03 momjian Exp $
|
||||
*
|
||||
*-------------------------------------------------------------------------
|
||||
*/
|
||||
|
|
@ -20,7 +20,6 @@
|
|||
#include <stdlib.h>
|
||||
#include <string.h>
|
||||
#include <errno.h>
|
||||
#include <tcl.h>
|
||||
|
||||
#include "postgres.h"
|
||||
#include "pgtclCmds.h"
|
||||
|
|
@ -174,6 +173,7 @@ PgSetConnectionId(Tcl_Interp * interp, PGconn *conn)
|
|||
connid->results[i] = NULL;
|
||||
connid->notify_list = NULL;
|
||||
connid->notifier_running = 0;
|
||||
connid->notifier_socket = -1;
|
||||
|
||||
sprintf(connid->id, "pgsql%d", PQsocket(conn));
|
||||
|
||||
|
|
@ -433,7 +433,7 @@ error_out:
|
|||
|
||||
|
||||
|
||||
/********************************************
|
||||
/*-------------------------------------------
|
||||
Notify event source
|
||||
|
||||
These functions allow asynchronous notify messages arriving from
|
||||
|
|
@ -448,73 +448,37 @@ error_out:
|
|||
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 any pending events
|
||||
that reference it. 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
|
||||
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 info; /* Notify name from SQL server */
|
||||
Tcl_Event header; /* Standard Tcl event info */
|
||||
PGnotify info; /* Notify name from SQL server */
|
||||
Pg_ConnectionId *connid; /* Connection for server */
|
||||
} NotifyEvent;
|
||||
|
||||
/* Setup before waiting in event loop */
|
||||
|
||||
static void
|
||||
Pg_Notify_SetupProc(ClientData clientData, int flags)
|
||||
{
|
||||
Pg_ConnectionId *connid = (Pg_ConnectionId *) clientData;
|
||||
Tcl_File handle;
|
||||
int pqsock;
|
||||
|
||||
/* We classify SQL notifies as Tcl file events. */
|
||||
if (!(flags & TCL_FILE_EVENTS))
|
||||
return;
|
||||
|
||||
/* Set up to watch for asynchronous data arrival on backend channel */
|
||||
pqsock = PQsocket(connid->conn);
|
||||
if (pqsock < 0)
|
||||
return;
|
||||
|
||||
handle = Tcl_GetFile((ClientData) pqsock, TCL_UNIX_FD);
|
||||
Tcl_WatchFile(handle, TCL_READABLE);
|
||||
}
|
||||
|
||||
/* Check to see if events have arrived in event loop */
|
||||
|
||||
static void
|
||||
Pg_Notify_CheckProc(ClientData clientData, int flags)
|
||||
{
|
||||
Pg_ConnectionId *connid = (Pg_ConnectionId *) clientData;
|
||||
Tcl_File handle;
|
||||
int pqsock;
|
||||
|
||||
/* We classify SQL notifies as Tcl file events. */
|
||||
if (!(flags & TCL_FILE_EVENTS))
|
||||
return;
|
||||
|
||||
/*
|
||||
* Consume any data available from the SQL server (this just buffers
|
||||
* it internally to libpq). We use Tcl_FileReady to avoid a useless
|
||||
* kernel call when no data is available.
|
||||
*/
|
||||
pqsock = PQsocket(connid->conn);
|
||||
if (pqsock < 0)
|
||||
return;
|
||||
|
||||
handle = Tcl_GetFile((ClientData) pqsock, TCL_UNIX_FD);
|
||||
if (Tcl_FileReady(handle, TCL_READABLE) != 0)
|
||||
PQconsumeInput(connid->conn);
|
||||
|
||||
/* Transfer notify events from libpq to Tcl event queue. */
|
||||
PgNotifyTransferEvents(connid);
|
||||
}
|
||||
|
||||
/* Dispatch an event that has reached the front of the event queue */
|
||||
/* Dispatch a NotifyEvent that has reached the front of the event queue */
|
||||
|
||||
static int
|
||||
Pg_Notify_EventProc(Tcl_Event * evPtr, int flags)
|
||||
|
|
@ -529,6 +493,10 @@ Pg_Notify_EventProc(Tcl_Event * evPtr, int flags)
|
|||
if (!(flags & TCL_FILE_EVENTS))
|
||||
return 0;
|
||||
|
||||
/* If connection's been closed, just forget the whole thing. */
|
||||
if (event->connid == NULL)
|
||||
return 1;
|
||||
|
||||
/*
|
||||
* Preserve/Release to ensure the connection struct doesn't disappear
|
||||
* underneath us.
|
||||
|
|
@ -595,7 +563,7 @@ Pg_Notify_EventProc(Tcl_Event * evPtr, int flags)
|
|||
/*
|
||||
* 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_CheckProc
|
||||
* that arrive during command execution) as well as in Pg_Notify_FileHandler
|
||||
* (to capture notifies that arrive when we're idle).
|
||||
*/
|
||||
|
||||
|
|
@ -621,8 +589,8 @@ PgNotifyTransferEvents(Pg_ConnectionId * connid)
|
|||
*
|
||||
* PgNotifyInterpDelete is registered as an interpreter deletion callback
|
||||
* for each extant Pg_TclNotifies structure.
|
||||
* NotifyEventDeleteProc is used by PgStopNotifyEventSource to get
|
||||
* rid of pending Tcl events that reference a dying connection.
|
||||
* NotifyEventDeleteProc is used by PgStopNotifyEventSource to cancel
|
||||
* pending Tcl NotifyEvents that reference a dying connection.
|
||||
*/
|
||||
|
||||
void
|
||||
|
|
@ -634,26 +602,67 @@ PgNotifyInterpDelete(ClientData clientData, Tcl_Interp * interp)
|
|||
notifies->interp = NULL;
|
||||
}
|
||||
|
||||
/* Comparison routine for detecting events to be removed by DeleteEvent */
|
||||
/*
|
||||
* Comparison routine 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)
|
||||
{
|
||||
NotifyEvent *event;
|
||||
Pg_ConnectionId *connid = (Pg_ConnectionId *) clientData;
|
||||
|
||||
if (evPtr->proc != Pg_Notify_EventProc)
|
||||
return 0;
|
||||
event = (NotifyEvent *) evPtr;
|
||||
if (event->connid != connid)
|
||||
return 0;
|
||||
return 1;
|
||||
if (evPtr->proc == Pg_Notify_EventProc)
|
||||
{
|
||||
NotifyEvent *event = (NotifyEvent *) evPtr;
|
||||
if (event->connid == connid)
|
||||
event->connid = NULL;
|
||||
}
|
||||
return 0;
|
||||
}
|
||||
|
||||
/* Start and stop the notify event source for a connection.
|
||||
* We do not bother to run the notifier unless at least one
|
||||
* pg_listen has been executed on the connection. Currently,
|
||||
* once started the notifier is run until the connection is
|
||||
* closed.
|
||||
/*
|
||||
* 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).
|
||||
*/
|
||||
PQconsumeInput(connid->conn);
|
||||
|
||||
/* Transfer notify events from libpq to Tcl event queue. */
|
||||
PgNotifyTransferEvents(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
|
||||
* 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
|
||||
|
|
@ -662,9 +671,22 @@ PgStartNotifyEventSource(Pg_ConnectionId * connid)
|
|||
/* Start the notify event source if it isn't already running */
|
||||
if (!connid->notifier_running)
|
||||
{
|
||||
Tcl_CreateEventSource(Pg_Notify_SetupProc, Pg_Notify_CheckProc,
|
||||
(ClientData) connid);
|
||||
connid->notifier_running = 1;
|
||||
int pqsock = PQsocket(connid->conn);
|
||||
if (pqsock >= 0)
|
||||
{
|
||||
#if TCL_MAJOR_VERSION >= 8
|
||||
/* In Tcl 8, Tcl_CreateFileHandler takes a socket directly. */
|
||||
Tcl_CreateFileHandler(pqsock, 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);
|
||||
#endif
|
||||
connid->notifier_running = 1;
|
||||
connid->notifier_socket = pqsock;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
|
|
@ -674,10 +696,18 @@ PgStopNotifyEventSource(Pg_ConnectionId * connid)
|
|||
/* Remove the event source */
|
||||
if (connid->notifier_running)
|
||||
{
|
||||
Tcl_DeleteEventSource(Pg_Notify_SetupProc, Pg_Notify_CheckProc,
|
||||
(ClientData) connid);
|
||||
#if TCL_MAJOR_VERSION >= 8
|
||||
/* In Tcl 8, Tcl_DeleteFileHandler takes a socket directly. */
|
||||
Tcl_DeleteFileHandler(connid->notifier_socket);
|
||||
#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 any queued Tcl events that reference this channel */
|
||||
Tcl_DeleteEvents(NotifyEventDeleteProc, (ClientData) connid);
|
||||
}
|
||||
|
|
|
|||
|
|
@ -1,17 +1,18 @@
|
|||
/*-------------------------------------------------------------------------
|
||||
*
|
||||
* pgtclId.h--
|
||||
* useful routines to convert between strings and pointers
|
||||
* Needed because everything in tcl is a string, but often, pointers
|
||||
* to data structures are needed.
|
||||
*
|
||||
*
|
||||
* Copyright (c) 1994, Regents of the University of California
|
||||
*
|
||||
* $Id: pgtclId.h,v 1.8 1998/09/01 04:39:59 momjian Exp $
|
||||
*
|
||||
*-------------------------------------------------------------------------
|
||||
*/
|
||||
*
|
||||
* pgtclId.h--
|
||||
*
|
||||
* 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.
|
||||
*
|
||||
* Copyright (c) 1994, Regents of the University of California
|
||||
*
|
||||
* $Id: pgtclId.h,v 1.9 1998/09/21 01:02:04 momjian Exp $
|
||||
*
|
||||
*-------------------------------------------------------------------------
|
||||
*/
|
||||
|
||||
extern void PgSetConnectionId(Tcl_Interp * interp, PGconn *conn);
|
||||
|
||||
|
|
@ -32,8 +33,8 @@ extern void PgSetConnectionId(Tcl_Interp * interp, PGconn *conn);
|
|||
#define DRIVER_DEL_PROTO ClientData cData, Tcl_Interp *interp
|
||||
#endif
|
||||
|
||||
extern PGconn *PgGetConnectionId(Tcl_Interp * interp, char *id, \
|
||||
Pg_ConnectionId **);
|
||||
extern PGconn *PgGetConnectionId(Tcl_Interp * interp, char *id,
|
||||
Pg_ConnectionId **);
|
||||
extern PgDelConnectionId(DRIVER_DEL_PROTO);
|
||||
extern int PgOutputProc(DRIVER_OUTPUT_PROTO);
|
||||
extern PgInputProc(DRIVER_INPUT_PROTO);
|
||||
|
|
@ -46,8 +47,8 @@ extern void PgStopNotifyEventSource(Pg_ConnectionId * connid);
|
|||
extern void PgNotifyTransferEvents(Pg_ConnectionId * connid);
|
||||
extern void PgNotifyInterpDelete(ClientData clientData, Tcl_Interp * interp);
|
||||
|
||||
/* GetFileProc is needed in Tcl 7.6 and later */
|
||||
#if (TCL_MAJOR_VERSION * 100 + TCL_MINOR_VERSION) >= 706
|
||||
/* GetFileProc is needed in Tcl 7.6 *only* ... it went away again in 8.0 */
|
||||
#if TCL_MAJOR_VERSION == 7 && TCL_MINOR_VERSION >= 6
|
||||
#define HAVE_TCL_GETFILEPROC 1
|
||||
#else
|
||||
#define HAVE_TCL_GETFILEPROC 0
|
||||
|
|
@ -55,7 +56,6 @@ extern void PgNotifyInterpDelete(ClientData clientData, Tcl_Interp * interp);
|
|||
|
||||
#if HAVE_TCL_GETFILEPROC
|
||||
extern Tcl_File PgGetFileProc(ClientData cData, int direction);
|
||||
|
||||
#endif
|
||||
|
||||
extern Tcl_ChannelType Pg_ConnType;
|
||||
|
|
|
|||
Loading…
Reference in New Issue