This patch covers several to-do items that I had for libpgtcl:

src/interfaces/libpgtcl/libpgtcl.h

@@ -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 $
  *
  *-------------------------------------------------------------------------
  */

src/interfaces/libpgtcl/pgtcl.c

@@ -2,14 +2,14 @@
  *
  * pgtcl.c--
  *
- *	  libpgtcl is a tcl package for front-ends to interface with pglite
+ *	libpgtcl is a tcl package for front-ends to interface with PostgreSQL.
- *	 It's the tcl equivalent of the old libpq C interface.
+ *	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;
 }

src/interfaces/libpgtcl/pgtclCmds.c

@@ -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);
+		Tcl_AppendResult(interp, "Invalid option\n", 0);
-		goto Pg_result_errReturn;
+		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-oid\n",
-					 "\t-assignbyidx arrayVarName ?appendstr?\n",
 					 "\t-numTuples\n",
 					 "\t-numAttrs\n"
-					 "\t-attributes\n"
+					 "\t-assign arrayVarName\n",
-					 "\t-lAttributes\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(&notifies->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)
 	{
+		/*
+		 * Create or update a callback for a relation
+		 */
+		int alreadyHadListener = Pg_have_listener(connid, caserelname);
+
 		entry = Tcl_CreateHashEntry(&notifies->notify_hash, caserelname, &new);
-		if (new)
+		/* If update, free the old callback string */
-		{
+		if (! new)
-			/* New callback, execute a listen command on the relation */
+			ckfree((char *) Tcl_GetHashValue(entry));
-			char	   *cmd = (char *) ckalloc((unsigned) (strlen(origrelname) + 8));
+		/* 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);
 	}
-
+	else
-	/*
-	 * 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)
 	{
+		/*
+		 * Remove a callback for a relation
+		 */
 		entry = Tcl_FindHashEntry(&notifies->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);

src/interfaces/libpgtcl/pgtclCmds.h

@@ -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

src/interfaces/libpgtcl/pgtclId.c

@@ -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
  *
- *	ASSUMPTION:  sizeof(long) >= sizeof(void*)
+ *	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
+  Upon closure of the channel, we immediately delete the file event handler
-  that reference it.  But for interpreter deletion, we just set any
+  for it, which has the effect of disabling any file-ready events that might
-  matching interp pointers in the Pg_TclNotifies list to NULL.	The
+  be hanging about in the Tcl event queue.  But for interpreter deletion,
-  list item stays around until the connection is deleted.  (This avoids
+  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 */
+	Tcl_Event		header;		/* Standard Tcl event info */
-	PGnotify	info;			/* Notify name from SQL server */
+	PGnotify		info;		/* Notify name from SQL server */
 	Pg_ConnectionId *connid;	/* Connection for server */
 }			NotifyEvent;
 
-/* Setup before waiting in event loop */
+/* Dispatch a NotifyEvent that has reached the front of the event queue */
-
-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 */
 
 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
+ * NotifyEventDeleteProc is used by PgStopNotifyEventSource to cancel
- * rid of pending Tcl events that reference a dying connection.
+ * 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)
+	if (evPtr->proc == Pg_Notify_EventProc)
-		return 0;
+	{
-	event = (NotifyEvent *) evPtr;
+		NotifyEvent *event = (NotifyEvent *) evPtr;
-	if (event->connid != connid)
+		if (event->connid == connid)
-		return 0;
+			event->connid = NULL;
-	return 1;
+	}
+	return 0;
 }
 
-/* Start and stop the notify event source for a connection.
+/*
- * We do not bother to run the notifier unless at least one
+ * File handler callback: called when Tcl has detected read-ready on socket.
- * pg_listen has been executed on the connection.  Currently,
+ * The clientData is a pointer to the associated connection.
- * once started the notifier is run until the connection is
+ * We can ignore the condition mask since we only ever ask about read-ready.
- * closed.
+ */
+
+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,
+		int pqsock = PQsocket(connid->conn);
-							  (ClientData) connid);
+		if (pqsock >= 0)
-		connid->notifier_running = 1;
+		{
+#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,
+#if TCL_MAJOR_VERSION >= 8
-							  (ClientData) connid);
+		/* 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);
 }

src/interfaces/libpgtcl/pgtclId.h

@@ -1,17 +1,18 @@
 /*-------------------------------------------------------------------------
-*
+ *
-* pgtclId.h--
+ * pgtclId.h--
-*	 useful routines to convert between strings and pointers
+ *
-*  Needed because everything in tcl is a string, but often, pointers
+ *	Contains Tcl "channel" interface routines, plus useful routines
-*  to data structures are needed.
+ *	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
+ *
-*
+ * Copyright (c) 1994, Regents of the University of California
-* $Id: pgtclId.h,v 1.8 1998/09/01 04:39:59 momjian Exp $
+ *
-*
+ * $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, \
+extern PGconn *PgGetConnectionId(Tcl_Interp * interp, char *id,
-				  Pg_ConnectionId **);
+								 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 */
+/* GetFileProc is needed in Tcl 7.6 *only* ... it went away again in 8.0 */
-#if (TCL_MAJOR_VERSION * 100 + TCL_MINOR_VERSION) >= 706
+#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;