diff --git a/src/pl/tcl/INSTALL b/src/pl/tcl/INSTALL
new file mode 100644
index 0000000000000000000000000000000000000000..27d0df33259fa3a1280474bcded813f8e07607f7
--- /dev/null
+++ b/src/pl/tcl/INSTALL
@@ -0,0 +1,43 @@
+Installation instructions for PL/Tcl
+
+1. Build the pltcl shared library
+
+ The Makefile for the pltcl shared library assumes the sources
+ for PostgreSQL are in /usr/local/src/postgresql-6.2.1/src. Edit
+ if not.
+
+ The Makefile depends on the tclConfig.sh file that get's installed
+ with Tcl. This should either be in /usr/lib or in /usr/local/lib.
+ If it is in a different place, edit mkMakefile.tcldefs or make a
+ symbolic link to it here.
+
+ Type make and the shared library should get built.
+
+2. Now create the PL/Tcl language in PostgreSQL
+
+ Since the pg_language system catalog is private to each database,
+ the new language can be created only for individual databases,
+ or in the template1 database. In the latter case, it is
+ automatically available in all newly created databases.
+
+ The commands to create the new language are:
+
+ create function pltcl_call_handler () returns opaque
+ as 'path-to-pltcl-shared-lib'
+ language 'C';
+
+ create trusted procedural language 'pltcl'
+ handler pltcl_call_handler
+ lancompiler 'PL/Tcl';
+
+ The trusted keyword on create procedural language tells PostgreSQL,
+ that all users (not only those with superuser privilege) are
+ permitted to create functions with LANGUAGE 'pltcl'. This is
+ absolutely safe, because there is nothing a normal user can do
+ with PL/Tcl, to get around access restrictions he/she has.
+
+3. Use PL/Tcl
+
+ Read pltcl_guide.txt to learn how to write functions and
+ trigger procedures in PL/Tcl.
+
diff --git a/src/pl/tcl/Makefile b/src/pl/tcl/Makefile
new file mode 100644
index 0000000000000000000000000000000000000000..df516350b9768f8b982821dbe1b4f50dc1b37110
--- /dev/null
+++ b/src/pl/tcl/Makefile
@@ -0,0 +1,91 @@
+#-------------------------------------------------------------------------
+#
+# Makefile
+# Makefile for the pltcl shared object
+#
+# IDENTIFICATION
+# $Header: /cvsroot/pgsql/src/pl/tcl/Makefile,v 1.1 1998/02/11 14:07:55 scrappy Exp $
+#
+#-------------------------------------------------------------------------
+
+#
+# Tell make where the postgresql sources live
+#
+SRCDIR= ../../../src
+include $(SRCDIR)/Makefile.global
+
+
+#
+# Include definitions from the tclConfig.sh file
+#
+include Makefile.tcldefs
+
+
+#
+# Uncomment the following to force a specific version of the
+# Tcl shared library to be used.
+#
+#TCL_LIB_SPEC=-L/usr/lib -ltcl8.0
+
+
+#
+# Change following to how shared library that contain
+# correct references to libtcl must get built on your system.
+# Since these definitions come from the tclConfig.sh script,
+# they should work if the shared build of tcl was successful
+# on this system.
+#
+%$(TCL_SHLIB_SUFFIX): %.o
+ $(TCL_SHLIB_LD) -o $@ $< $(TCL_SHLIB_LD_LIBS) $(TCL_LIB_SPEC) $(TCL_LIBS)
+
+
+#
+# Uncomment the following to enable the unknown command lookup
+# on the first of all calls to the call handler. See the doc
+# in the modules directory about details.
+#
+#CFLAGS+= -DPLTCL_UNKNOWN_SUPPORT
+
+
+CC = $(TCL_CC)
+CFLAGS+= -I$(LIBPQDIR) -I$(SRCDIR)/include $(TCL_SHLIB_CFLAGS)
+
+# For fmgr.h
+CFLAGS+= -I$(SRCDIR)/backend
+
+CFLAGS+= $(TCL_DEFS)
+
+LDADD+= -L$(LIBPQDIR) -lpq
+
+#
+# DLOBJS is the dynamically-loaded object file.
+#
+DLOBJS= pltcl$(DLSUFFIX)
+
+INFILES= $(DLOBJS)
+
+#
+# plus exports files
+#
+ifdef EXPSUFF
+INFILES+= $(DLOBJS:.o=$(EXPSUFF))
+endif
+
+#
+# Build the shared lib
+#
+all: $(INFILES)
+
+Makefile.tcldefs:
+ ./mkMakefile.tcldefs
+
+#
+# Clean
+#
+clean:
+ rm -f $(INFILES)
+ rm -f Makefile.tcldefs
+
+install: all
+ $(INSTALL) $(INSTL_LIB_OPTS) $(DLOBJS) $(DESTDIR)$(LIBDIR)/$(DLOBJS)
+
diff --git a/src/pl/tcl/license.terms b/src/pl/tcl/license.terms
new file mode 100644
index 0000000000000000000000000000000000000000..2a201353eb66a9f45ffab97546cbe41b4e6a0d3f
--- /dev/null
+++ b/src/pl/tcl/license.terms
@@ -0,0 +1,30 @@
+ This software is copyrighted by Jan Wieck - Hamburg.
+
+ The following terms apply to all files associated with the
+ software unless explicitly disclaimed in individual files.
+
+ The author hereby grants permission to use, copy, modify,
+ distribute, and license this software and its documentation
+ for any purpose, provided that existing copyright notices are
+ retained in all copies and that this notice is included
+ verbatim in any distributions. No written agreement, license,
+ or royalty fee is required for any of the authorized uses.
+ Modifications to this software may be copyrighted by their
+ author and need not follow the licensing terms described
+ here, provided that the new terms are clearly indicated on
+ the first page of each file where they apply.
+
+ IN NO EVENT SHALL THE AUTHOR OR DISTRIBUTORS BE LIABLE TO ANY
+ PARTY FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR
+ CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OF THIS
+ SOFTWARE, ITS DOCUMENTATION, OR ANY DERIVATIVES THEREOF, EVEN
+ IF THE AUTHOR HAVE BEEN ADVISED OF THE POSSIBILITY OF SUCH
+ DAMAGE.
+
+ THE AUTHOR AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY
+ WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+ WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR
+ PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE IS PROVIDED ON
+ AN "AS IS" BASIS, AND THE AUTHOR AND DISTRIBUTORS HAVE NO
+ OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES,
+ ENHANCEMENTS, OR MODIFICATIONS.
diff --git a/src/pl/tcl/mkMakefile.tcldefs b/src/pl/tcl/mkMakefile.tcldefs
new file mode 100755
index 0000000000000000000000000000000000000000..ba1a9c63af9efa222711bf68116f70e99a2bd02d
--- /dev/null
+++ b/src/pl/tcl/mkMakefile.tcldefs
@@ -0,0 +1,22 @@
+#!/bin/sh
+if [ -f ./tclConfig.sh ]; then
+ . ./tclConfig.sh
+else
+ if [ -f /usr/lib/tclConfig.sh ]; then
+ echo "using tclConfig.sh from /usr/lib"
+ . /usr/lib/tclConfig.sh
+ else
+ if [ -f /usr/local/lib/tclConfig.sh ]; then
+ echo "using tclConfig.sh from /usr/local/lib"
+ . /usr/local/lib/tclConfig.sh
+ else
+ echo "tclConfig.sh not found in /usr/lib or /usr/local/lib"
+ echo "I need this file! Please make a symbolic link to this file"
+ echo "and start make again."
+ exit 1
+ fi
+ fi
+fi
+
+set | grep '^TCL' >Makefile.tcldefs
+exit 0
diff --git a/src/pl/tcl/pltcl.c b/src/pl/tcl/pltcl.c
new file mode 100644
index 0000000000000000000000000000000000000000..9c5d6a85c7ee5741e5b40f89cf080a08d0344308
--- /dev/null
+++ b/src/pl/tcl/pltcl.c
@@ -0,0 +1,2159 @@
+/**********************************************************************
+ * pltcl.c - PostgreSQL support for Tcl as
+ * procedural language (PL)
+ *
+ * IDENTIFICATION
+ * $Header: /cvsroot/pgsql/src/pl/tcl/pltcl.c,v 1.1 1998/02/11 14:07:59 scrappy Exp $
+ *
+ * This software is copyrighted by Jan Wieck - Hamburg.
+ *
+ * The author hereby grants permission to use, copy, modify,
+ * distribute, and license this software and its documentation
+ * for any purpose, provided that existing copyright notices are
+ * retained in all copies and that this notice is included
+ * verbatim in any distributions. No written agreement, license,
+ * or royalty fee is required for any of the authorized uses.
+ * Modifications to this software may be copyrighted by their
+ * author and need not follow the licensing terms described
+ * here, provided that the new terms are clearly indicated on
+ * the first page of each file where they apply.
+ *
+ * IN NO EVENT SHALL THE AUTHOR OR DISTRIBUTORS BE LIABLE TO ANY
+ * PARTY FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR
+ * CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OF THIS
+ * SOFTWARE, ITS DOCUMENTATION, OR ANY DERIVATIVES THEREOF, EVEN
+ * IF THE AUTHOR HAVE BEEN ADVISED OF THE POSSIBILITY OF SUCH
+ * DAMAGE.
+ *
+ * THE AUTHOR AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY
+ * WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+ * WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR
+ * PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE IS PROVIDED ON
+ * AN "AS IS" BASIS, AND THE AUTHOR AND DISTRIBUTORS HAVE NO
+ * OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES,
+ * ENHANCEMENTS, OR MODIFICATIONS.
+ *
+ **********************************************************************/
+
+#include <tcl.h>
+
+#include <stdio.h>
+#include <stdlib.h>
+#include <stdarg.h>
+#include <unistd.h>
+#include <fcntl.h>
+#include <string.h>
+#include <setjmp.h>
+
+#include "executor/spi.h"
+#include "commands/trigger.h"
+#include "utils/elog.h"
+#include "utils/builtins.h"
+#include "fmgr.h"
+#include "access/heapam.h"
+
+#include "utils/syscache.h"
+#include "catalog/pg_proc.h"
+#include "catalog/pg_type.h"
+
+
+/**********************************************************************
+ * The information we cache about loaded procedures
+ **********************************************************************/
+typedef struct pltcl_proc_desc {
+ char *proname;
+ FmgrInfo result_in_func;
+ Oid result_in_elem;
+ int result_in_len;
+ int nargs;
+ FmgrInfo arg_out_func[MAXFMGRARGS];
+ Oid arg_out_elem[MAXFMGRARGS];
+ int arg_out_len[MAXFMGRARGS];
+ int arg_is_rel[MAXFMGRARGS];
+} pltcl_proc_desc;
+
+
+/**********************************************************************
+ * The information we cache about prepared and saved plans
+ **********************************************************************/
+typedef struct pltcl_query_desc {
+ char qname[20];
+ void *plan;
+ int nargs;
+ Oid *argtypes;
+ FmgrInfo *arginfuncs;
+ Oid *argtypelems;
+ Datum *argvalues;
+ int *arglen;
+} pltcl_query_desc;
+
+
+/************************************************************
+ * Make Warn_restart from tcop/postgres.c visible for us.
+ * The longjmp() mechanism of the elog(ERROR,...) restart let's
+ * interpreter levels lay around. So we must tidy up in that
+ * case and thus, we have to catch the longjmp's sometimes to
+ * return though all the interpreter levels back.
+ *
+ * It's ugly - Jan
+ ************************************************************/
+#if defined(nextstep)
+#define sigjmp_buf jmp_buf
+#define sigsetjmp(x,y) setjmp(x)
+#define siglongjmp longjmp
+#endif
+
+extern sigjmp_buf Warn_restart; /* in tcop/postgres.c */
+
+/**********************************************************************
+ * Global data
+ **********************************************************************/
+static int pltcl_firstcall = 1;
+static int pltcl_call_level = 0;
+static int pltcl_restart_in_progress = 0;
+static Tcl_Interp *pltcl_hold_interp = NULL;
+static Tcl_Interp *pltcl_safe_interp = NULL;
+static Tcl_HashTable *pltcl_proc_hash = NULL;
+static Tcl_HashTable *pltcl_query_hash = NULL;
+
+/**********************************************************************
+ * Forward declarations
+ **********************************************************************/
+static void pltcl_init_all(void);
+static void pltcl_init_safe_interp(void);
+
+#ifdef PLTCL_UNKNOWN_SUPPORT
+static void pltcl_init_load_unknown(void);
+#endif /* PLTCL_UNKNOWN_SUPPORT */
+
+Datum pltcl_call_handler(FmgrInfo *proinfo,
+ FmgrValues *proargs, bool *isNull);
+
+static Datum pltcl_func_handler(FmgrInfo *proinfo,
+ FmgrValues *proargs, bool *isNull);
+
+static HeapTuple pltcl_trigger_handler(FmgrInfo *proinfo);
+
+static int pltcl_elog(ClientData cdata, Tcl_Interp *interp,
+ int argc, char *argv[]);
+static int pltcl_quote(ClientData cdata, Tcl_Interp *interp,
+ int argc, char *argv[]);
+
+static int pltcl_SPI_exec(ClientData cdata, Tcl_Interp *interp,
+ int argc, char *argv[]);
+static int pltcl_SPI_prepare(ClientData cdata, Tcl_Interp *interp,
+ int argc, char *argv[]);
+static int pltcl_SPI_execp(ClientData cdata, Tcl_Interp *interp,
+ int argc, char *argv[]);
+
+static void pltcl_set_tuple_values(Tcl_Interp *interp, char *arrayname,
+ int tupno, HeapTuple tuple, TupleDesc tupdesc);
+static void pltcl_build_tuple_argument(HeapTuple tuple, TupleDesc tupdesc,
+ Tcl_DString *retval);
+
+/**********************************************************************
+ * pltcl_init_all() - Initialize all
+ **********************************************************************/
+static void
+pltcl_init_all(void)
+{
+ Tcl_HashEntry *hashent;
+ Tcl_HashSearch hashsearch;
+ pltcl_proc_desc *prodesc;
+ pltcl_query_desc *querydesc;
+
+ /************************************************************
+ * Do initialization only once
+ ************************************************************/
+ if (!pltcl_firstcall) return;
+
+ /************************************************************
+ * Create the dummy hold interpreter to prevent close of
+ * stdout and stderr on DeleteInterp
+ ************************************************************/
+ if (pltcl_hold_interp == NULL) {
+ if ((pltcl_hold_interp = Tcl_CreateInterp()) == NULL) {
+ elog(ERROR, "pltcl: internal error - cannot create 'hold' "
+ "interpreter");
+ }
+ }
+
+ /************************************************************
+ * Destroy the existing safe interpreter
+ ************************************************************/
+ if (pltcl_safe_interp != NULL) {
+ Tcl_DeleteInterp(pltcl_safe_interp);
+ pltcl_safe_interp = NULL;
+ }
+
+ /************************************************************
+ * Free the proc hash table
+ ************************************************************/
+ if (pltcl_proc_hash != NULL) {
+ hashent = Tcl_FirstHashEntry(pltcl_proc_hash, &hashsearch);
+ while (hashent != NULL) {
+ prodesc = (pltcl_proc_desc *)Tcl_GetHashValue(hashent);
+ free(prodesc->proname);
+ free(prodesc);
+ hashent = Tcl_NextHashEntry(&hashsearch);
+ }
+ Tcl_DeleteHashTable(pltcl_proc_hash);
+ free(pltcl_proc_hash);
+ pltcl_proc_hash = NULL;
+ }
+
+ /************************************************************
+ * Free the prepared query hash table
+ ************************************************************/
+ if (pltcl_query_hash != NULL) {
+ hashent = Tcl_FirstHashEntry(pltcl_query_hash, &hashsearch);
+ while (hashent != NULL) {
+ querydesc = (pltcl_query_desc *)Tcl_GetHashValue(hashent);
+ free(querydesc->argtypes);
+ free(querydesc);
+ hashent = Tcl_NextHashEntry(&hashsearch);
+ }
+ Tcl_DeleteHashTable(pltcl_query_hash);
+ free(pltcl_query_hash);
+ pltcl_query_hash = NULL;
+ }
+
+ /************************************************************
+ * Now recreate a new safe interpreter
+ ************************************************************/
+ pltcl_init_safe_interp();
+
+ pltcl_firstcall = 0;
+ return;
+}
+
+
+/**********************************************************************
+ * pltcl_init_safe_interp() - Create the safe Tcl interpreter
+ **********************************************************************/
+static void
+pltcl_init_safe_interp(void)
+{
+ /************************************************************
+ * Create the interpreter as a safe slave of the hold interp.
+ ************************************************************/
+ if ((pltcl_safe_interp =
+ Tcl_CreateSlave(pltcl_hold_interp, "safe", 1)) == NULL) {
+ elog(ERROR,
+ "pltcl: internal error - cannot create 'safe' interpreter");
+ }
+
+ /************************************************************
+ * Enable debugging output from the Tcl bytecode compiler
+ * To see the trace, the interpreter must be created unsafe
+ * USE ONLY FOR DEBUGGING!!!
+ ************************************************************/
+ /*
+ Tcl_SetVar(pltcl_safe_interp, "tcl_traceCompile", "1", 0);
+ */
+
+ /************************************************************
+ * Initialize the proc and query hash tables
+ ************************************************************/
+ pltcl_proc_hash = (Tcl_HashTable *)malloc(sizeof(Tcl_HashTable));
+ pltcl_query_hash = (Tcl_HashTable *)malloc(sizeof(Tcl_HashTable));
+ Tcl_InitHashTable(pltcl_proc_hash, TCL_STRING_KEYS);
+ Tcl_InitHashTable(pltcl_query_hash, TCL_STRING_KEYS);
+
+ /************************************************************
+ * Install the commands for SPI support in the safe interpreter
+ ************************************************************/
+ Tcl_CreateCommand(pltcl_safe_interp, "elog",
+ pltcl_elog, NULL, NULL);
+ Tcl_CreateCommand(pltcl_safe_interp, "quote",
+ pltcl_quote, NULL, NULL);
+
+ Tcl_CreateCommand(pltcl_safe_interp, "spi_exec",
+ pltcl_SPI_exec, NULL, NULL);
+ Tcl_CreateCommand(pltcl_safe_interp, "spi_prepare",
+ pltcl_SPI_prepare, NULL, NULL);
+ Tcl_CreateCommand(pltcl_safe_interp, "spi_execp",
+ pltcl_SPI_execp, NULL, NULL);
+
+#ifdef PLTCL_UNKNOWN_SUPPORT
+ /************************************************************
+ * Try to load the unknown procedure from pltcl_modules
+ ************************************************************/
+ if (SPI_connect() != SPI_OK_CONNECT) {
+ elog(ERROR, "pltcl_init_safe_interp(): SPI_connect failed");
+ }
+ pltcl_init_load_unknown();
+ if (SPI_finish() != SPI_OK_FINISH) {
+ elog(ERROR, "pltcl_init_safe_interp(): SPI_finish failed");
+ }
+#endif /* PLTCL_UNKNOWN_SUPPORT */
+}
+
+
+#ifdef PLTCL_UNKNOWN_SUPPORT
+
+/**********************************************************************
+ * pltcl_init_load_unknown() - Load the unknown procedure from
+ * table pltcl_modules (if it exists)
+ **********************************************************************/
+static void
+pltcl_init_load_unknown(void)
+{
+ int spi_rc;
+ int tcl_rc;
+ Tcl_DString unknown_src;
+ char *part;
+ int i;
+ int fno;
+
+ /************************************************************
+ * Check if table pltcl_modules exists
+ ************************************************************/
+ spi_rc = SPI_exec("select 1 from pg_class "
+ "where relname = 'pltcl_modules'", 1);
+ if (spi_rc != SPI_OK_SELECT) {
+ elog(ERROR, "pltcl_init_load_unknown(): select from pg_class failed");
+ }
+ if (SPI_processed == 0) {
+ return;
+ }
+
+ /************************************************************
+ * Read all the row's from it where modname = 'unknown' in
+ * the order of modseq
+ ************************************************************/
+ Tcl_DStringInit(&unknown_src);
+
+ spi_rc = SPI_exec("select modseq, modsrc from pltcl_modules "
+ "where modname = 'unknown' "
+ "order by modseq", 0);
+ if (spi_rc != SPI_OK_SELECT) {
+ elog(ERROR, "pltcl_init_load_unknown(): select from pltcl_modules "
+ "failed");
+ }
+
+ /************************************************************
+ * If there's nothing, module unknown doesn't exist
+ ************************************************************/
+ if (SPI_processed == 0) {
+ Tcl_DStringFree(&unknown_src);
+ elog(NOTICE, "pltcl: Module unknown not found in pltcl_modules");
+ return;
+ }
+
+ /************************************************************
+ * There is a module named unknown. Resemble the
+ * source from the modsrc attributes and evaluate
+ * it in the safe interpreter
+ ************************************************************/
+ fno = SPI_fnumber(SPI_tuptable->tupdesc, "modsrc");
+
+ for (i = 0; i < SPI_processed; i++) {
+ part = SPI_getvalue(SPI_tuptable->vals[i],
+ SPI_tuptable->tupdesc, fno);
+ if (part != NULL) {
+ Tcl_DStringAppend(&unknown_src, part, -1);
+ pfree(part);
+ }
+ }
+ tcl_rc = Tcl_GlobalEval(pltcl_safe_interp, Tcl_DStringValue(&unknown_src));
+ Tcl_DStringFree(&unknown_src);
+}
+
+#endif /* PLTCL_UNKNOWN_SUPPORT */
+
+
+/**********************************************************************
+ * pltcl_call_handler - This is the only visible function
+ * of the PL interpreter. The PostgreSQL
+ * function manager and trigger manager
+ * call this function for execution of
+ * PL/Tcl procedures.
+ **********************************************************************/
+Datum
+pltcl_call_handler(FmgrInfo *proinfo,
+ FmgrValues *proargs,
+ bool *isNull)
+{
+ Datum retval;
+
+ /************************************************************
+ * Initialize interpreters on first call
+ ************************************************************/
+ if (pltcl_firstcall) {
+ pltcl_init_all();
+ }
+
+ /************************************************************
+ * Connect to SPI manager
+ ************************************************************/
+ if (SPI_connect() != SPI_OK_CONNECT) {
+ elog(ERROR, "pltcl: cannot connect to SPI manager");
+ }
+ /************************************************************
+ * Keep track about the nesting of Tcl-SPI-Tcl-... calls
+ ************************************************************/
+ pltcl_call_level++;
+
+ /************************************************************
+ * Determine if called as function or trigger and
+ * call appropriate subhandler
+ ************************************************************/
+ if (CurrentTriggerData == NULL) {
+ retval = pltcl_func_handler(proinfo, proargs, isNull);
+ } else {
+ retval = (Datum)pltcl_trigger_handler(proinfo);
+ }
+
+ pltcl_call_level--;
+
+ /************************************************************
+ * Disconnect from SPI manager
+ ************************************************************/
+ if (SPI_finish() != SPI_OK_FINISH) {
+ elog(ERROR, "pltcl: SPI_finish() failed");
+ }
+
+ return retval;
+}
+
+
+/**********************************************************************
+ * pltcl_func_handler() - Handler for regular function calls
+ **********************************************************************/
+static Datum
+pltcl_func_handler(FmgrInfo *proinfo,
+ FmgrValues *proargs,
+ bool *isNull)
+{
+ int i;
+ char internal_proname[512];
+ char *stroid;
+ Tcl_HashEntry *hashent;
+ int hashnew;
+ pltcl_proc_desc *prodesc;
+ Tcl_DString tcl_cmd;
+ Tcl_DString list_tmp;
+ int tcl_rc;
+ Datum retval;
+ sigjmp_buf save_restart;
+
+ /************************************************************
+ * Build our internal proc name from the functions Oid
+ ************************************************************/
+ stroid = oidout(proinfo->fn_oid);
+ strcpy(internal_proname, "__PLTcl_proc_");
+ strcat(internal_proname, stroid);
+ pfree(stroid);
+
+ /************************************************************
+ * Lookup the internal proc name in the hashtable
+ ************************************************************/
+ hashent = Tcl_FindHashEntry(pltcl_proc_hash, internal_proname);
+ if (hashent == NULL) {
+ /************************************************************
+ * If we haven't found it in the hashtable, we analyze
+ * the functions arguments and returntype and store
+ * the in-/out-functions in the prodesc block and create
+ * a new hashtable entry for it.
+ *
+ * Then we load the procedure into the safe interpreter.
+ ************************************************************/
+ HeapTuple procTup;
+ HeapTuple typeTup;
+ Form_pg_proc procStruct;
+ TypeTupleForm typeStruct;
+ Tcl_DString proc_internal_def;
+ Tcl_DString proc_internal_body;
+ char proc_internal_args[4096];
+ char *proc_source;
+ char buf[512];
+
+ /************************************************************
+ * Allocate a new procedure description block
+ ************************************************************/
+ prodesc = (pltcl_proc_desc *)malloc(sizeof(pltcl_proc_desc));
+ prodesc->proname = malloc(strlen(internal_proname) + 1);
+ strcpy(prodesc->proname, internal_proname);
+
+ /************************************************************
+ * Lookup the pg_proc tuple by Oid
+ ************************************************************/
+ procTup = SearchSysCacheTuple(PROOID,
+ ObjectIdGetDatum(proinfo->fn_oid),
+ 0, 0, 0);
+ if (!HeapTupleIsValid(procTup)) {
+ free(prodesc->proname);
+ free(prodesc);
+ elog(ERROR, "pltcl: cache lookup from pg_proc failed");
+ }
+ procStruct = (Form_pg_proc) GETSTRUCT(procTup);
+
+ /************************************************************
+ * Get the required information for input conversion of the
+ * return value.
+ ************************************************************/
+ typeTup = SearchSysCacheTuple(TYPOID,
+ ObjectIdGetDatum(procStruct->prorettype),
+ 0, 0, 0);
+ if (!HeapTupleIsValid(typeTup)) {
+ free(prodesc->proname);
+ free(prodesc);
+ elog(ERROR, "pltcl: cache lookup for return type failed");
+ }
+ typeStruct = (TypeTupleForm) GETSTRUCT(typeTup);
+
+ if (typeStruct->typrelid != InvalidOid) {
+ free(prodesc->proname);
+ free(prodesc);
+ elog(ERROR, "pltcl: return types of tuples not supported yet");
+ }
+
+ fmgr_info(typeStruct->typinput, &(prodesc->result_in_func));
+ prodesc->result_in_elem = (Oid) (typeStruct->typelem);
+ prodesc->result_in_len = typeStruct->typlen;
+
+ /************************************************************
+ * Get the required information for output conversion
+ * of all procedure arguments
+ ************************************************************/
+ prodesc->nargs = proinfo->fn_nargs;
+ proc_internal_args[0] = '\0';
+ for (i = 0; i < proinfo->fn_nargs; i++) {
+ typeTup = SearchSysCacheTuple(TYPOID,
+ ObjectIdGetDatum(procStruct->proargtypes[i]),
+ 0, 0, 0);
+ if (!HeapTupleIsValid(typeTup)) {
+ free(prodesc->proname);
+ free(prodesc);
+ elog(ERROR, "pltcl: cache lookup for argument type failed");
+ }
+ typeStruct = (TypeTupleForm) GETSTRUCT(typeTup);
+
+ if (typeStruct->typrelid != InvalidOid) {
+ prodesc->arg_is_rel[i] = 1;
+ if (i > 0) {
+ strcat(proc_internal_args, " ");
+ }
+ sprintf(buf, "__PLTcl_Tup_%d", i + 1);
+ strcat(proc_internal_args, buf);
+ continue;
+ } else {
+ prodesc->arg_is_rel[i] = 0;
+ }
+
+ fmgr_info(typeStruct->typoutput, &(prodesc->arg_out_func[i]));
+ prodesc->arg_out_elem[i] = (Oid) (typeStruct->typelem);
+ prodesc->arg_out_len[i] = typeStruct->typlen;
+
+ if (i > 0) {
+ strcat(proc_internal_args, " ");
+ }
+ sprintf(buf, "%d", i + 1);
+ strcat(proc_internal_args, buf);
+ }
+
+ /************************************************************
+ * Create the tcl command to define the internal
+ * procedure
+ ************************************************************/
+ Tcl_DStringInit(&proc_internal_def);
+ Tcl_DStringInit(&proc_internal_body);
+ Tcl_DStringAppendElement(&proc_internal_def, "proc");
+ Tcl_DStringAppendElement(&proc_internal_def, internal_proname);
+ Tcl_DStringAppendElement(&proc_internal_def, proc_internal_args);
+
+ /************************************************************
+ * prefix procedure body with
+ * upvar #0 <internal_procname> GD
+ * and with appropriate upvars for tuple arguments
+ ************************************************************/
+ Tcl_DStringAppend(&proc_internal_body, "upvar #0 ", -1);
+ Tcl_DStringAppend(&proc_internal_body, internal_proname, -1);
+ Tcl_DStringAppend(&proc_internal_body, " GD\n", -1);
+ for (i = 0; i < proinfo->fn_nargs; i++) {
+ if (!prodesc->arg_is_rel[i]) continue;
+ sprintf(buf, "array set %d $__PLTcl_Tup_%d\n", i + 1, i + 1);
+ Tcl_DStringAppend(&proc_internal_body, buf, -1);
+ }
+ proc_source = textout(&(procStruct->prosrc));
+ Tcl_DStringAppend(&proc_internal_body, proc_source, -1);
+ pfree(proc_source);
+ Tcl_DStringAppendElement(&proc_internal_def,
+ Tcl_DStringValue(&proc_internal_body));
+ Tcl_DStringFree(&proc_internal_body);
+
+ /************************************************************
+ * Create the procedure in the safe interpreter
+ ************************************************************/
+ tcl_rc = Tcl_GlobalEval(pltcl_safe_interp,
+ Tcl_DStringValue(&proc_internal_def));
+ Tcl_DStringFree(&proc_internal_def);
+ if (tcl_rc != TCL_OK) {
+ free(prodesc->proname);
+ free(prodesc);
+ elog(ERROR, "pltcl: cannot create internal procedure %s - %s",
+ internal_proname, pltcl_safe_interp->result);
+ }
+
+ /************************************************************
+ * Add the proc description block to the hashtable
+ ************************************************************/
+ hashent = Tcl_CreateHashEntry(pltcl_proc_hash,
+ prodesc->proname, &hashnew);
+ Tcl_SetHashValue(hashent, (ClientData)prodesc);
+ } else {
+ /************************************************************
+ * Found the proc description block in the hashtable
+ ************************************************************/
+ prodesc = (pltcl_proc_desc *)Tcl_GetHashValue(hashent);
+ }
+
+ /************************************************************
+ * Create the tcl command to call the internal
+ * proc in the safe interpreter
+ ************************************************************/
+ Tcl_DStringInit(&tcl_cmd);
+ Tcl_DStringInit(&list_tmp);
+ Tcl_DStringAppendElement(&tcl_cmd, internal_proname);
+
+ /************************************************************
+ * Catch elog(ERROR) during build of the Tcl command
+ ************************************************************/
+ memcpy(&save_restart, &Warn_restart, sizeof(save_restart));
+ if (sigsetjmp(Warn_restart, 1) != 0) {
+ memcpy(&Warn_restart, &save_restart, sizeof(Warn_restart));
+ Tcl_DStringFree(&tcl_cmd);
+ Tcl_DStringFree(&list_tmp);
+ pltcl_restart_in_progress = 1;
+ if (--pltcl_call_level == 0) {
+ pltcl_restart_in_progress = 0;
+ }
+ siglongjmp(Warn_restart, 1);
+ }
+
+ /************************************************************
+ * Add all call arguments to the command
+ ************************************************************/
+ for (i = 0; i < prodesc->nargs; i++) {
+ if (prodesc->arg_is_rel[i]) {
+ /**************************************************
+ * For tuple values, add a list for 'array set ...'
+ **************************************************/
+ Tcl_DStringInit(&list_tmp);
+ pltcl_build_tuple_argument(
+ ((TupleTableSlot *)(proargs->data[i]))->val,
+ ((TupleTableSlot *)(proargs->data[i]))->ttc_tupleDescriptor,
+ &list_tmp);
+ Tcl_DStringAppendElement(&tcl_cmd, Tcl_DStringValue(&list_tmp));
+ Tcl_DStringFree(&list_tmp);
+ Tcl_DStringInit(&list_tmp);
+ } else {
+ /**************************************************
+ * Single values are added as string element
+ * of their external representation
+ **************************************************/
+ char *tmp;
+
+ tmp = (*fmgr_faddr(&(prodesc->arg_out_func[i])))
+ (proargs->data[i],
+ prodesc->arg_out_elem[i],
+ prodesc->arg_out_len[i]);
+ Tcl_DStringAppendElement(&tcl_cmd, tmp);
+ pfree(tmp);
+ }
+ }
+ Tcl_DStringFree(&list_tmp);
+ memcpy(&Warn_restart, &save_restart, sizeof(Warn_restart));
+
+ /************************************************************
+ * Call the Tcl function
+ ************************************************************/
+ tcl_rc = Tcl_GlobalEval(pltcl_safe_interp, Tcl_DStringValue(&tcl_cmd));
+ Tcl_DStringFree(&tcl_cmd);
+
+ /************************************************************
+ * Check the return code from Tcl and handle
+ * our special restart mechanism to get rid
+ * of all nested call levels on transaction
+ * abort.
+ ************************************************************/
+ if (tcl_rc != TCL_OK || pltcl_restart_in_progress) {
+ if (!pltcl_restart_in_progress) {
+ pltcl_restart_in_progress = 1;
+ if (--pltcl_call_level == 0) {
+ pltcl_restart_in_progress = 0;
+ }
+ elog(ERROR, "pltcl: %s", pltcl_safe_interp->result);
+ }
+ if (--pltcl_call_level == 0) {
+ pltcl_restart_in_progress = 0;
+ }
+ siglongjmp(Warn_restart, 1);
+ }
+
+ /************************************************************
+ * Convert the result value from the safe interpreter
+ * into it's PostgreSQL data format and return it.
+ * Again, the call to fmgr() could fire an elog and we
+ * have to count for the current interpreter level we are
+ * on. The save_restart from above is still good.
+ ************************************************************/
+ if (sigsetjmp(Warn_restart, 1) != 0) {
+ memcpy(&Warn_restart, &save_restart, sizeof(Warn_restart));
+ pltcl_restart_in_progress = 1;
+ if (--pltcl_call_level == 0) {
+ pltcl_restart_in_progress = 0;
+ }
+ siglongjmp(Warn_restart, 1);
+ }
+
+ retval = (Datum)(*fmgr_faddr(&prodesc->result_in_func))
+ (pltcl_safe_interp->result,
+ prodesc->result_in_elem,
+ prodesc->result_in_len);
+
+ memcpy(&Warn_restart, &save_restart, sizeof(Warn_restart));
+ return retval;
+}
+
+
+/**********************************************************************
+ * pltcl_trigger_handler() - Handler for trigger calls
+ **********************************************************************/
+static HeapTuple
+pltcl_trigger_handler(FmgrInfo *proinfo)
+{
+ TriggerData *trigdata;
+ char internal_proname[512];
+ char *stroid;
+ Tcl_HashEntry *hashent;
+ int hashnew;
+ pltcl_proc_desc *prodesc;
+ TupleDesc tupdesc;
+ HeapTuple rettup;
+ Tcl_DString tcl_cmd;
+ Tcl_DString tcl_trigtup;
+ Tcl_DString tcl_newtup;
+ int tcl_rc;
+ int i;
+
+ int *modattrs;
+ Datum *modvalues;
+ char *modnulls;
+
+ int ret_numvals;
+ char **ret_values;
+
+ sigjmp_buf save_restart;
+
+ /************************************************************
+ * Save the current trigger data local
+ ************************************************************/
+ trigdata = CurrentTriggerData;
+ CurrentTriggerData = NULL;
+
+ /************************************************************
+ * Build our internal proc name from the functions Oid
+ ************************************************************/
+ stroid = oidout(proinfo->fn_oid);
+ strcpy(internal_proname, "__PLTcl_proc_");
+ strcat(internal_proname, stroid);
+ pfree(stroid);
+
+ /************************************************************
+ * Lookup the internal proc name in the hashtable
+ ************************************************************/
+ hashent = Tcl_FindHashEntry(pltcl_proc_hash, internal_proname);
+ if (hashent == NULL) {
+ /************************************************************
+ * If we haven't found it in the hashtable,
+ * we load the procedure into the safe interpreter.
+ ************************************************************/
+ Tcl_DString proc_internal_def;
+ Tcl_DString proc_internal_body;
+ HeapTuple procTup;
+ Form_pg_proc procStruct;
+ char *proc_source;
+
+ /************************************************************
+ * Allocate a new procedure description block
+ ************************************************************/
+ prodesc = (pltcl_proc_desc *)malloc(sizeof(pltcl_proc_desc));
+ memset(prodesc, 0, sizeof(pltcl_proc_desc));
+ prodesc->proname = malloc(strlen(internal_proname) + 1);
+ strcpy(prodesc->proname, internal_proname);
+
+ /************************************************************
+ * Lookup the pg_proc tuple by Oid
+ ************************************************************/
+ procTup = SearchSysCacheTuple(PROOID,
+ ObjectIdGetDatum(proinfo->fn_oid),
+ 0, 0, 0);
+ if (!HeapTupleIsValid(procTup)) {
+ free(prodesc->proname);
+ free(prodesc);
+ elog(ERROR, "pltcl: cache lookup from pg_proc failed");
+ }
+ procStruct = (Form_pg_proc) GETSTRUCT(procTup);
+
+ /************************************************************
+ * Create the tcl command to define the internal
+ * procedure
+ ************************************************************/
+ Tcl_DStringInit(&proc_internal_def);
+ Tcl_DStringInit(&proc_internal_body);
+ Tcl_DStringAppendElement(&proc_internal_def, "proc");
+ Tcl_DStringAppendElement(&proc_internal_def, internal_proname);
+ Tcl_DStringAppendElement(&proc_internal_def,
+ "TG_name TG_relid TG_relatts TG_when TG_level TG_op __PLTcl_Tup_NEW __PLTcl_Tup_OLD args");
+
+ /************************************************************
+ * prefix procedure body with
+ * upvar #0 <internal_procname> GD
+ * and with appropriate setting of NEW, OLD,
+ * and the arguments as numerical variables.
+ ************************************************************/
+ Tcl_DStringAppend(&proc_internal_body, "upvar #0 ", -1);
+ Tcl_DStringAppend(&proc_internal_body, internal_proname, -1);
+ Tcl_DStringAppend(&proc_internal_body, " GD\n", -1);
+
+ Tcl_DStringAppend(&proc_internal_body,
+ "array set NEW $__PLTcl_Tup_NEW\n", -1);
+ Tcl_DStringAppend(&proc_internal_body,
+ "array set OLD $__PLTcl_Tup_OLD\n", -1);
+
+ Tcl_DStringAppend(&proc_internal_body,
+ "set i 0\n"
+ "set v 0\n"
+ "foreach v $args {\n"
+ " incr i\n"
+ " set $i $v\n"
+ "}\n"
+ "unset i v\n\n", -1);
+
+ proc_source = textout(&(procStruct->prosrc));
+ Tcl_DStringAppend(&proc_internal_body, proc_source, -1);
+ pfree(proc_source);
+ Tcl_DStringAppendElement(&proc_internal_def,
+ Tcl_DStringValue(&proc_internal_body));
+ Tcl_DStringFree(&proc_internal_body);
+
+ /************************************************************
+ * Create the procedure in the safe interpreter
+ ************************************************************/
+ tcl_rc = Tcl_GlobalEval(pltcl_safe_interp,
+ Tcl_DStringValue(&proc_internal_def));
+ Tcl_DStringFree(&proc_internal_def);
+ if (tcl_rc != TCL_OK) {
+ free(prodesc->proname);
+ free(prodesc);
+ elog(ERROR, "pltcl: cannot create internal procedure %s - %s",
+ internal_proname, pltcl_safe_interp->result);
+ }
+
+ /************************************************************
+ * Add the proc description block to the hashtable
+ ************************************************************/
+ hashent = Tcl_CreateHashEntry(pltcl_proc_hash,
+ prodesc->proname, &hashnew);
+ Tcl_SetHashValue(hashent, (ClientData)prodesc);
+ } else {
+ /************************************************************
+ * Found the proc description block in the hashtable
+ ************************************************************/
+ prodesc = (pltcl_proc_desc *)Tcl_GetHashValue(hashent);
+ }
+
+ tupdesc = trigdata->tg_relation->rd_att;
+
+ /************************************************************
+ * Create the tcl command to call the internal
+ * proc in the safe interpreter
+ ************************************************************/
+ Tcl_DStringInit(&tcl_cmd);
+ Tcl_DStringInit(&tcl_trigtup);
+ Tcl_DStringInit(&tcl_newtup);
+
+ /************************************************************
+ * We call external functions below - care for elog(ERROR)
+ ************************************************************/
+ memcpy(&save_restart, &Warn_restart, sizeof(save_restart));
+ if (sigsetjmp(Warn_restart, 1) != 0) {
+ memcpy(&Warn_restart, &save_restart, sizeof(Warn_restart));
+ Tcl_DStringFree(&tcl_cmd);
+ Tcl_DStringFree(&tcl_trigtup);
+ Tcl_DStringFree(&tcl_newtup);
+ pltcl_restart_in_progress = 1;
+ if (--pltcl_call_level == 0) {
+ pltcl_restart_in_progress = 0;
+ }
+ siglongjmp(Warn_restart, 1);
+ }
+
+ /* The procedure name */
+ Tcl_DStringAppendElement(&tcl_cmd, internal_proname);
+
+ /* The trigger name for argument TG_name */
+ Tcl_DStringAppendElement(&tcl_cmd, trigdata->tg_trigger->tgname);
+
+ /* The oid of the trigger relation for argument TG_relid */
+ stroid = oidout(trigdata->tg_relation->rd_id);
+ Tcl_DStringAppendElement(&tcl_cmd, stroid);
+ pfree(stroid);
+
+ /* A list of attribute names for argument TG_relatts */
+ Tcl_DStringAppendElement(&tcl_trigtup, "");
+ for (i = 0; i < tupdesc->natts; i++) {
+ Tcl_DStringAppendElement(&tcl_trigtup, tupdesc->attrs[i]->attname.data);
+ }
+ Tcl_DStringAppendElement(&tcl_cmd, Tcl_DStringValue(&tcl_trigtup));
+ Tcl_DStringFree(&tcl_trigtup);
+ Tcl_DStringInit(&tcl_trigtup);
+
+ /* The when part of the event for TG_when */
+ if (TRIGGER_FIRED_BEFORE(trigdata->tg_event)) {
+ Tcl_DStringAppendElement(&tcl_cmd, "BEFORE");
+ }
+ else if (TRIGGER_FIRED_AFTER(trigdata->tg_event)) {
+ Tcl_DStringAppendElement(&tcl_cmd, "AFTER");
+ }
+ else {
+ Tcl_DStringAppendElement(&tcl_cmd, "UNKNOWN");
+ }
+
+ /* The level part of the event for TG_level */
+ if (TRIGGER_FIRED_FOR_ROW(trigdata->tg_event)) {
+ Tcl_DStringAppendElement(&tcl_cmd, "ROW");
+ }
+ else if (TRIGGER_FIRED_FOR_STATEMENT(trigdata->tg_event)) {
+ Tcl_DStringAppendElement(&tcl_cmd, "STATEMENT");
+ }
+ else {
+ Tcl_DStringAppendElement(&tcl_cmd, "UNKNOWN");
+ }
+
+ /* Build the data list for the trigtuple */
+ pltcl_build_tuple_argument(trigdata->tg_trigtuple,
+ tupdesc, &tcl_trigtup);
+
+ /* Now the command part of the event for TG_op and data for NEW and OLD */
+ if (TRIGGER_FIRED_BY_INSERT(trigdata->tg_event)) {
+ Tcl_DStringAppendElement(&tcl_cmd, "INSERT");
+
+ Tcl_DStringAppendElement(&tcl_cmd, Tcl_DStringValue(&tcl_trigtup));
+ Tcl_DStringAppendElement(&tcl_cmd, "");
+
+ rettup = trigdata->tg_trigtuple;
+ }
+ else if (TRIGGER_FIRED_BY_DELETE(trigdata->tg_event)) {
+ Tcl_DStringAppendElement(&tcl_cmd, "DELETE");
+
+ Tcl_DStringAppendElement(&tcl_cmd, "");
+ Tcl_DStringAppendElement(&tcl_cmd, Tcl_DStringValue(&tcl_trigtup));
+
+ rettup = trigdata->tg_trigtuple;
+ }
+ else if (TRIGGER_FIRED_BY_UPDATE(trigdata->tg_event)) {
+ Tcl_DStringAppendElement(&tcl_cmd, "UPDATE");
+
+ pltcl_build_tuple_argument(trigdata->tg_newtuple,
+ tupdesc, &tcl_newtup);
+
+ Tcl_DStringAppendElement(&tcl_cmd, Tcl_DStringValue(&tcl_newtup));
+ Tcl_DStringAppendElement(&tcl_cmd, Tcl_DStringValue(&tcl_trigtup));
+
+ rettup = trigdata->tg_newtuple;
+ }
+ else {
+ Tcl_DStringAppendElement(&tcl_cmd, "UNKNOWN");
+
+ Tcl_DStringAppendElement(&tcl_cmd, Tcl_DStringValue(&tcl_trigtup));
+ Tcl_DStringAppendElement(&tcl_cmd, Tcl_DStringValue(&tcl_trigtup));
+
+ rettup = trigdata->tg_trigtuple;
+ }
+
+ memcpy(&Warn_restart, &save_restart, sizeof(Warn_restart));
+ Tcl_DStringFree(&tcl_trigtup);
+ Tcl_DStringFree(&tcl_newtup);
+
+ /************************************************************
+ * Finally append the arguments from CREATE TRIGGER
+ ************************************************************/
+ for (i = 0; i < trigdata->tg_trigger->tgnargs; i++) {
+ Tcl_DStringAppendElement(&tcl_cmd, trigdata->tg_trigger->tgargs[i]);
+ }
+
+ /************************************************************
+ * Call the Tcl function
+ ************************************************************/
+ tcl_rc = Tcl_GlobalEval(pltcl_safe_interp, Tcl_DStringValue(&tcl_cmd));
+ Tcl_DStringFree(&tcl_cmd);
+
+ /************************************************************
+ * Check the return code from Tcl and handle
+ * our special restart mechanism to get rid
+ * of all nested call levels on transaction
+ * abort.
+ ************************************************************/
+ if (tcl_rc == TCL_ERROR || pltcl_restart_in_progress) {
+ if (!pltcl_restart_in_progress) {
+ pltcl_restart_in_progress = 1;
+ if (--pltcl_call_level == 0) {
+ pltcl_restart_in_progress = 0;
+ }
+ elog(ERROR, "pltcl: %s", pltcl_safe_interp->result);
+ }
+ if (--pltcl_call_level == 0) {
+ pltcl_restart_in_progress = 0;
+ }
+ siglongjmp(Warn_restart, 1);
+ }
+
+ switch (tcl_rc) {
+ case TCL_OK:
+ break;
+
+ default:
+ elog(ERROR, "pltcl: unsupported TCL return code %d", tcl_rc);
+ }
+
+ /************************************************************
+ * The return value from the procedure might be one of
+ * the magic strings OK or SKIP or a list from array get
+ ************************************************************/
+ if (strcmp(pltcl_safe_interp->result, "OK") == 0) {
+ return rettup;
+ }
+ if (strcmp(pltcl_safe_interp->result, "SKIP") == 0) {
+ return (HeapTuple)NULL;;
+ }
+
+ /************************************************************
+ * Convert the result value from the safe interpreter
+ * and setup structures for SPI_modifytuple();
+ ************************************************************/
+ if (Tcl_SplitList(pltcl_safe_interp, pltcl_safe_interp->result,
+ &ret_numvals, &ret_values) != TCL_OK) {
+ elog(NOTICE, "pltcl: cannot split return value from trigger");
+ elog(ERROR, "pltcl: %s", pltcl_safe_interp->result);
+ }
+
+ if (ret_numvals % 2 != 0) {
+ ckfree(ret_values);
+ elog(ERROR, "pltcl: invalid return list from trigger - must have even # of elements");
+ }
+
+ modattrs = (int *)palloc(tupdesc->natts * sizeof(int));
+ modvalues = (Datum *)palloc(tupdesc->natts * sizeof(Datum));
+ for (i = 0; i < tupdesc->natts; i++) {
+ modattrs[i] = i + 1;
+ modvalues[i] = (Datum)NULL;
+ }
+
+ modnulls = palloc(tupdesc->natts + 1);
+ memset(modnulls, 'n', tupdesc->natts);
+ modnulls[tupdesc->natts] = '\0';
+
+ /************************************************************
+ * Care for possible elog(ERROR)'s below
+ ************************************************************/
+ if (sigsetjmp(Warn_restart, 1) != 0) {
+ memcpy(&Warn_restart, &save_restart, sizeof(Warn_restart));
+ ckfree(ret_values);
+ pltcl_restart_in_progress = 1;
+ if (--pltcl_call_level == 0) {
+ pltcl_restart_in_progress = 0;
+ }
+ siglongjmp(Warn_restart, 1);
+ }
+
+ i = 0;
+ while(i < ret_numvals) {
+ int attnum;
+ HeapTuple typeTup;
+ Oid typinput;
+ Oid typelem;
+ FmgrInfo finfo;
+
+ /************************************************************
+ * Ignore pseudo elements with a dot name
+ ************************************************************/
+ if (*(ret_values[i]) == '.') {
+ i += 2;
+ continue;
+ }
+
+ /************************************************************
+ * Get the attribute number
+ ************************************************************/
+ attnum = SPI_fnumber(tupdesc, ret_values[i++]);
+ if (attnum == SPI_ERROR_NOATTRIBUTE) {
+ elog(ERROR, "pltcl: invalid attribute '%s'", ret_values[--i]);
+ }
+
+ /************************************************************
+ * Lookup the attribute type in the syscache
+ * for the input function
+ ************************************************************/
+ typeTup = SearchSysCacheTuple(TYPOID,
+ ObjectIdGetDatum(tupdesc->attrs[attnum - 1]->atttypid),
+ 0, 0, 0);
+ if (!HeapTupleIsValid(typeTup)) {
+ elog(ERROR, "pltcl: Cache lookup for attribute '%s' type %ld failed",
+ ret_values[--i],
+ ObjectIdGetDatum(tupdesc->attrs[attnum - 1]->atttypid));
+ }
+ typinput = (Oid) (((TypeTupleForm)GETSTRUCT(typeTup))->typinput);
+ typelem = (Oid) (((TypeTupleForm)GETSTRUCT(typeTup))->typelem);
+
+ /************************************************************
+ * Set the attribute to NOT NULL and convert the contents
+ ************************************************************/
+ modnulls[attnum - 1] = ' ';
+ fmgr_info(typinput, &finfo);
+ modvalues[attnum - 1] = (Datum)(*fmgr_faddr(&finfo))
+ (ret_values[i++],
+ typelem,
+ (!VARLENA_FIXED_SIZE(tupdesc->attrs[attnum - 1]))
+ ? tupdesc->attrs[attnum - 1]->attlen
+ : tupdesc->attrs[attnum - 1]->atttypmod
+ );
+ }
+
+
+ rettup = SPI_modifytuple(trigdata->tg_relation, rettup, tupdesc->natts,
+ modattrs, modvalues, modnulls);
+
+ pfree(modattrs);
+ pfree(modvalues);
+ pfree(modnulls);
+
+ if (rettup == NULL) {
+ elog(ERROR, "pltcl: SPI_modifytuple() failed - RC = %d\n", SPI_result);
+ }
+
+ ckfree(ret_values);
+ memcpy(&Warn_restart, &save_restart, sizeof(Warn_restart));
+
+ return rettup;
+}
+
+
+/**********************************************************************
+ * pltcl_elog() - elog() support for PLTcl
+ **********************************************************************/
+static int pltcl_elog(ClientData cdata, Tcl_Interp *interp,
+ int argc, char *argv[])
+{
+ int level;
+ sigjmp_buf save_restart;
+
+ /************************************************************
+ * Suppress messages during the restart process
+ ************************************************************/
+ if (pltcl_restart_in_progress)
+ return TCL_ERROR;
+
+ /************************************************************
+ * Catch the restart longjmp and begin a controlled
+ * return though all interpreter levels if it happens
+ ************************************************************/
+ memcpy(&save_restart, &Warn_restart, sizeof(save_restart));
+ if (sigsetjmp(Warn_restart, 1) != 0) {
+ memcpy(&Warn_restart, &save_restart, sizeof(Warn_restart));
+ pltcl_restart_in_progress = 1;
+ return TCL_ERROR;
+ }
+
+ if (argc != 3) {
+ Tcl_SetResult(interp, "syntax error - 'elog level msg'",
+ TCL_VOLATILE);
+ return TCL_ERROR;
+ }
+
+ if (strcmp(argv[1], "NOTICE") == 0) {
+ level = NOTICE;
+ } else
+ if (strcmp(argv[1], "WARN") == 0) {
+ level = ERROR;
+ } else
+ if (strcmp(argv[1], "ERROR") == 0) {
+ level = ERROR;
+ } else
+ if (strcmp(argv[1], "FATAL") == 0) {
+ level = FATAL;
+ } else
+ if (strcmp(argv[1], "DEBUG") == 0) {
+ level = DEBUG;
+ } else
+ if (strcmp(argv[1], "NOIND") == 0) {
+ level = NOIND;
+ } else {
+ Tcl_AppendResult(interp, "Unknown elog level '", argv[1],
+ "'", NULL);
+ memcpy(&Warn_restart, &save_restart, sizeof(Warn_restart));
+ return TCL_ERROR;
+ }
+
+ /************************************************************
+ * Call elog(), restore the original restart address
+ * and return to the caller (if not catched)
+ ************************************************************/
+ elog(level, argv[2]);
+ memcpy(&Warn_restart, &save_restart, sizeof(Warn_restart));
+ return TCL_OK;
+}
+
+
+/**********************************************************************
+ * pltcl_quote() - quote literal strings that are to
+ * be used in SPI_exec query strings
+ **********************************************************************/
+static int pltcl_quote(ClientData cdata, Tcl_Interp *interp,
+ int argc, char *argv[])
+{
+ char *tmp;
+ char *cp1;
+ char *cp2;
+
+ /************************************************************
+ * Check call syntax
+ ************************************************************/
+ if (argc != 2) {
+ Tcl_SetResult(interp, "syntax error - 'quote string'", TCL_VOLATILE);
+ return TCL_ERROR;
+ }
+
+ /************************************************************
+ * Allocate space for the maximum the string can
+ * grow to and initialize pointers
+ ************************************************************/
+ tmp = palloc(strlen(argv[1]) * 2 + 1);
+ cp1 = argv[1];
+ cp2 = tmp;
+
+ /************************************************************
+ * Walk through string and double every quote and backslash
+ ************************************************************/
+ while (*cp1) {
+ if (*cp1 == '\'') {
+ *cp2++ = '\'';
+ } else {
+ if (*cp1 == '\\') {
+ *cp2++ = '\\';
+ }
+ }
+ *cp2++ = *cp1++;
+ }
+
+ /************************************************************
+ * Terminate the string and set it as result
+ ************************************************************/
+ *cp2 = '\0';
+ Tcl_SetResult(interp, tmp, TCL_VOLATILE);
+ pfree(tmp);
+ return TCL_OK;
+}
+
+
+/**********************************************************************
+ * pltcl_SPI_exec() - The builtin SPI_exec command
+ * for the safe interpreter
+ **********************************************************************/
+static int pltcl_SPI_exec(ClientData cdata, Tcl_Interp *interp,
+ int argc, char *argv[])
+{
+ int spi_rc;
+ char buf[64];
+ int count = 0;
+ char *arrayname = NULL;
+ int query_idx;
+ int i;
+ int loop_rc;
+ int ntuples;
+ HeapTuple *tuples;
+ TupleDesc tupdesc;
+ sigjmp_buf save_restart;
+
+ char *usage = "syntax error - 'SPI_exec "
+ "?-count n? "
+ "?-array name? query ?loop body?";
+
+ /************************************************************
+ * Don't do anything if we are already in restart mode
+ ************************************************************/
+ if (pltcl_restart_in_progress)
+ return TCL_ERROR;
+
+ /************************************************************
+ * Check the call syntax and get the count option
+ ************************************************************/
+ if (argc < 2) {
+ Tcl_SetResult(interp, usage, TCL_VOLATILE);
+ return TCL_ERROR;
+ }
+
+ i = 1;
+ while (i < argc) {
+ if (strcmp(argv[i], "-array") == 0) {
+ if (++i >= argc) {
+ Tcl_SetResult(interp, usage, TCL_VOLATILE);
+ return TCL_ERROR;
+ }
+ arrayname = argv[i++];
+ continue;
+ }
+
+ if (strcmp(argv[i], "-count") == 0) {
+ if (++i >= argc) {
+ Tcl_SetResult(interp, usage, TCL_VOLATILE);
+ return TCL_ERROR;
+ }
+ if (Tcl_GetInt(interp, argv[i++], &count) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ continue;
+ }
+
+ break;
+ }
+
+ query_idx = i;
+ if (query_idx >= argc) {
+ Tcl_SetResult(interp, usage, TCL_VOLATILE);
+ return TCL_ERROR;
+ }
+
+ /************************************************************
+ * Prepare to start a controlled return through all
+ * interpreter levels on transaction abort
+ ************************************************************/
+ memcpy(&save_restart, &Warn_restart, sizeof(save_restart));
+ if (sigsetjmp(Warn_restart, 1) != 0) {
+ memcpy(&Warn_restart, &save_restart, sizeof(Warn_restart));
+ pltcl_restart_in_progress = 1;
+ Tcl_SetResult(interp, "Transaction abort", TCL_VOLATILE);
+ return TCL_ERROR;
+ }
+
+ /************************************************************
+ * Execute the query and handle return codes
+ ************************************************************/
+ spi_rc = SPI_exec(argv[query_idx], count);
+ memcpy(&Warn_restart, &save_restart, sizeof(Warn_restart));
+
+ switch (spi_rc) {
+ case SPI_OK_UTILITY:
+ Tcl_SetResult(interp, "0", TCL_VOLATILE);
+ return TCL_OK;
+
+ case SPI_OK_SELINTO:
+ case SPI_OK_INSERT:
+ case SPI_OK_DELETE:
+ case SPI_OK_UPDATE:
+ sprintf(buf, "%d", SPI_processed);
+ Tcl_SetResult(interp, buf, TCL_VOLATILE);
+ return TCL_OK;
+
+ case SPI_OK_SELECT:
+ break;
+
+ case SPI_ERROR_ARGUMENT:
+ Tcl_SetResult(interp,
+ "pltcl: SPI_exec() failed - SPI_ERROR_ARGUMENT",
+ TCL_VOLATILE);
+ return TCL_ERROR;
+
+ case SPI_ERROR_UNCONNECTED:
+ Tcl_SetResult(interp,
+ "pltcl: SPI_exec() failed - SPI_ERROR_UNCONNECTED",
+ TCL_VOLATILE);
+ return TCL_ERROR;
+
+ case SPI_ERROR_COPY:
+ Tcl_SetResult(interp,
+ "pltcl: SPI_exec() failed - SPI_ERROR_COPY",
+ TCL_VOLATILE);
+ return TCL_ERROR;
+
+ case SPI_ERROR_CURSOR:
+ Tcl_SetResult(interp,
+ "pltcl: SPI_exec() failed - SPI_ERROR_CURSOR",
+ TCL_VOLATILE);
+ return TCL_ERROR;
+
+ case SPI_ERROR_TRANSACTION:
+ Tcl_SetResult(interp,
+ "pltcl: SPI_exec() failed - SPI_ERROR_TRANSACTION",
+ TCL_VOLATILE);
+ return TCL_ERROR;
+
+ case SPI_ERROR_OPUNKNOWN:
+ Tcl_SetResult(interp,
+ "pltcl: SPI_exec() failed - SPI_ERROR_OPUNKNOWN",
+ TCL_VOLATILE);
+ return TCL_ERROR;
+
+ default:
+ sprintf(buf, "%d", spi_rc);
+ Tcl_AppendResult(interp, "pltcl: SPI_exec() failed - ",
+ "unknown RC ", buf, NULL);
+ return TCL_ERROR;
+ }
+
+ /************************************************************
+ * Only SELECT queries fall through to here - remember the
+ * tuples we got
+ ************************************************************/
+
+ ntuples = SPI_processed;
+ if (ntuples > 0) {
+ tuples = SPI_tuptable->vals;
+ tupdesc = SPI_tuptable->tupdesc;
+ }
+
+ /************************************************************
+ * Again prepare for elog(ERROR)
+ ************************************************************/
+ if (sigsetjmp(Warn_restart, 1) != 0) {
+ memcpy(&Warn_restart, &save_restart, sizeof(Warn_restart));
+ pltcl_restart_in_progress = 1;
+ Tcl_SetResult(interp, "Transaction abort", TCL_VOLATILE);
+ return TCL_ERROR;
+ }
+
+ /************************************************************
+ * If there is no loop body given, just set the variables
+ * from the first tuple (if any) and return the number of
+ * tuples selected
+ ************************************************************/
+ if (argc == query_idx + 1) {
+ if (ntuples > 0) {
+ pltcl_set_tuple_values(interp, arrayname, 0, tuples[0], tupdesc);
+ }
+ sprintf(buf, "%d", ntuples);
+ Tcl_SetResult(interp, buf, TCL_VOLATILE);
+ memcpy(&Warn_restart, &save_restart, sizeof(Warn_restart));
+ return TCL_OK;
+ }
+
+ /************************************************************
+ * There is a loop body - process all tuples and evaluate
+ * the body on each
+ ************************************************************/
+ query_idx++;
+ for (i = 0; i < ntuples; i++) {
+ pltcl_set_tuple_values(interp, arrayname, i, tuples[i], tupdesc);
+
+ loop_rc = Tcl_Eval(interp, argv[query_idx]);
+
+ if (loop_rc == TCL_OK) continue;
+ if (loop_rc == TCL_CONTINUE) continue;
+ if (loop_rc == TCL_RETURN) {
+ memcpy(&Warn_restart, &save_restart, sizeof(Warn_restart));
+ return TCL_RETURN;
+ }
+ if (loop_rc == TCL_BREAK) break;
+ memcpy(&Warn_restart, &save_restart, sizeof(Warn_restart));
+ return TCL_ERROR;
+ }
+
+ /************************************************************
+ * Finally return the number of tuples
+ ************************************************************/
+ memcpy(&Warn_restart, &save_restart, sizeof(Warn_restart));
+ sprintf(buf, "%d", ntuples);
+ Tcl_SetResult(interp, buf, TCL_VOLATILE);
+ return TCL_OK;
+}
+
+
+/**********************************************************************
+ * pltcl_SPI_prepare() - Builtin support for prepared plans
+ * The Tcl command SPI_prepare
+ * allways saves the plan using
+ * SPI_saveplan and returns a key for
+ * access. There is no chance to prepare
+ * and not save the plan currently.
+ **********************************************************************/
+static int pltcl_SPI_prepare(ClientData cdata, Tcl_Interp *interp,
+ int argc, char *argv[])
+{
+ int nargs;
+ char **args;
+ pltcl_query_desc *qdesc;
+ void *plan;
+ int i;
+ HeapTuple typeTup;
+ Tcl_HashEntry *hashent;
+ int hashnew;
+ sigjmp_buf save_restart;
+
+ /************************************************************
+ * Don't do anything if we are already in restart mode
+ ************************************************************/
+ if (pltcl_restart_in_progress)
+ return TCL_ERROR;
+
+ /************************************************************
+ * Check the call syntax
+ ************************************************************/
+ if (argc != 3) {
+ Tcl_SetResult(interp, "syntax error - 'SPI_prepare query argtypes'",
+ TCL_VOLATILE);
+ return TCL_ERROR;
+ }
+
+ /************************************************************
+ * Split the argument type list
+ ************************************************************/
+ if (Tcl_SplitList(interp, argv[2], &nargs, &args) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ /************************************************************
+ * Allocate the new querydesc structure
+ ************************************************************/
+ qdesc = (pltcl_query_desc *)malloc(sizeof(pltcl_query_desc));
+ sprintf(qdesc->qname, "%lx", (long)qdesc);
+ qdesc->nargs = nargs;
+ qdesc->argtypes = (Oid *)malloc(nargs * sizeof(Oid));
+ qdesc->arginfuncs = (FmgrInfo *)malloc(nargs * sizeof(FmgrInfo));
+ qdesc->argtypelems = (Oid *)malloc(nargs * sizeof(Oid));
+ qdesc->argvalues = (Datum *)malloc(nargs * sizeof(Datum));
+ qdesc->arglen = (int *)malloc(nargs * sizeof(int));
+
+ /************************************************************
+ * Prepare to start a controlled return through all
+ * interpreter levels on transaction abort
+ ************************************************************/
+ memcpy(&save_restart, &Warn_restart, sizeof(save_restart));
+ if (sigsetjmp(Warn_restart, 1) != 0) {
+ memcpy(&Warn_restart, &save_restart, sizeof(Warn_restart));
+ pltcl_restart_in_progress = 1;
+ free(qdesc->argtypes);
+ free(qdesc->arginfuncs);
+ free(qdesc->argtypelems);
+ free(qdesc->argvalues);
+ free(qdesc->arglen);
+ free(qdesc);
+ ckfree(args);
+ return TCL_ERROR;
+ }
+
+ /************************************************************
+ * Lookup the argument types by name in the system cache
+ * and remember the required information for input conversion
+ ************************************************************/
+ for (i = 0; i < nargs; i++) {
+ typeTup = SearchSysCacheTuple(TYPNAME,
+ PointerGetDatum(args[i]),
+ 0, 0, 0);
+ if (!HeapTupleIsValid(typeTup)) {
+ elog(ERROR, "pltcl: Cache lookup of type %s failed", args[i]);
+ }
+ qdesc->argtypes[i] = typeTup->t_oid;
+ fmgr_info(((TypeTupleForm) GETSTRUCT(typeTup))->typinput,
+ &(qdesc->arginfuncs[i]));
+ qdesc->argtypelems[i] = ((TypeTupleForm) GETSTRUCT(typeTup))->typelem;
+ qdesc->argvalues[i] = (Datum)NULL;
+ qdesc->arglen[i] = (int)(((TypeTupleForm) GETSTRUCT(typeTup))->typlen);
+ }
+
+ /************************************************************
+ * Prepare the plan and check for errors
+ ************************************************************/
+ plan = SPI_prepare(argv[1], nargs, qdesc->argtypes);
+
+ if (plan == NULL) {
+ char buf[128];
+ char *reason;
+
+ memcpy(&Warn_restart, &save_restart, sizeof(Warn_restart));
+
+ switch(SPI_result) {
+ case SPI_ERROR_ARGUMENT:
+ reason = "SPI_ERROR_ARGUMENT";
+ break;
+
+ case SPI_ERROR_UNCONNECTED:
+ reason = "SPI_ERROR_UNCONNECTED";
+ break;
+
+ case SPI_ERROR_COPY:
+ reason = "SPI_ERROR_COPY";
+ break;
+
+ case SPI_ERROR_CURSOR:
+ reason = "SPI_ERROR_CURSOR";
+ break;
+
+ case SPI_ERROR_TRANSACTION:
+ reason = "SPI_ERROR_TRANSACTION";
+ break;
+
+ case SPI_ERROR_OPUNKNOWN:
+ reason = "SPI_ERROR_OPUNKNOWN";
+ break;
+
+ default:
+ sprintf(buf, "unknown RC %d", SPI_result);
+ reason = buf;
+ break;
+
+ }
+
+ elog(ERROR, "pltcl: SPI_prepare() failed - %s", reason);
+ }
+
+ /************************************************************
+ * Save the plan
+ ************************************************************/
+ qdesc->plan = SPI_saveplan(plan);
+ if (qdesc->plan == NULL) {
+ char buf[128];
+ char *reason;
+
+ memcpy(&Warn_restart, &save_restart, sizeof(Warn_restart));
+
+ switch(SPI_result) {
+ case SPI_ERROR_ARGUMENT:
+ reason = "SPI_ERROR_ARGUMENT";
+ break;
+
+ case SPI_ERROR_UNCONNECTED:
+ reason = "SPI_ERROR_UNCONNECTED";
+ break;
+
+ default:
+ sprintf(buf, "unknown RC %d", SPI_result);
+ reason = buf;
+ break;
+
+ }
+
+ elog(ERROR, "pltcl: SPI_saveplan() failed - %s", reason);
+ }
+
+ /************************************************************
+ * Insert a hashtable entry for the plan and return
+ * the key to the caller
+ ************************************************************/
+ memcpy(&Warn_restart, &save_restart, sizeof(Warn_restart));
+ hashent = Tcl_CreateHashEntry(pltcl_query_hash, qdesc->qname, &hashnew);
+ Tcl_SetHashValue(hashent, (ClientData)qdesc);
+
+ Tcl_SetResult(interp, qdesc->qname, TCL_VOLATILE);
+ return TCL_OK;
+}
+
+
+/**********************************************************************
+ * pltcl_SPI_execp() - Execute a prepared plan
+ **********************************************************************/
+static int pltcl_SPI_execp(ClientData cdata, Tcl_Interp *interp,
+ int argc, char *argv[])
+{
+ int spi_rc;
+ char buf[64];
+ int i, j;
+ int loop_body;
+ Tcl_HashEntry *hashent;
+ pltcl_query_desc *qdesc;
+ char *nulls = NULL;
+ char *arrayname = NULL;
+ int count = 0;
+ int callnargs;
+ static char **callargs = NULL;
+ int loop_rc;
+ int ntuples;
+ HeapTuple *tuples = NULL;
+ TupleDesc tupdesc = NULL;
+ sigjmp_buf save_restart;
+
+ char *usage = "syntax error - 'SPI_execp "
+ "?-nulls string? ?-count n? "
+ "?-array name? query ?args? ?loop body?";
+
+ /************************************************************
+ * Tidy up from an earlier abort
+ ************************************************************/
+ if (callargs != NULL) {
+ ckfree(callargs);
+ callargs = NULL;
+ }
+
+ /************************************************************
+ * Don't do anything if we are already in restart mode
+ ************************************************************/
+ if (pltcl_restart_in_progress)
+ return TCL_ERROR;
+
+ /************************************************************
+ * Get the options and check syntax
+ ************************************************************/
+ i = 1;
+ while (i < argc) {
+ if (strcmp(argv[i], "-array") == 0) {
+ if (++i >= argc) {
+ Tcl_SetResult(interp, usage, TCL_VOLATILE);
+ return TCL_ERROR;
+ }
+ arrayname = argv[i++];
+ continue;
+ }
+ if (strcmp(argv[i], "-nulls") == 0) {
+ if (++i >= argc) {
+ Tcl_SetResult(interp, usage, TCL_VOLATILE);
+ return TCL_ERROR;
+ }
+ nulls = argv[i++];
+ continue;
+ }
+ if (strcmp(argv[i], "-count") == 0) {
+ if (++i >= argc) {
+ Tcl_SetResult(interp, usage, TCL_VOLATILE);
+ return TCL_ERROR;
+ }
+ if (Tcl_GetInt(interp, argv[i++], &count) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ continue;
+ }
+
+ break;
+ }
+
+ /************************************************************
+ * Check minimum call arguments
+ ************************************************************/
+ if (i >= argc) {
+ Tcl_SetResult(interp, usage, TCL_VOLATILE);
+ return TCL_ERROR;
+ }
+
+ /************************************************************
+ * Get the prepared plan descriptor by it's key
+ ************************************************************/
+ hashent = Tcl_FindHashEntry(pltcl_query_hash, argv[i++]);
+ if (hashent == NULL) {
+ Tcl_AppendResult(interp, "invalid queryid '", argv[--i], "'", NULL);
+ return TCL_ERROR;
+ }
+ qdesc = (pltcl_query_desc *)Tcl_GetHashValue(hashent);
+
+ /************************************************************
+ * If a nulls string is given, check for correct length
+ ************************************************************/
+ if (nulls != NULL) {
+ if (strlen(nulls) != qdesc->nargs) {
+ Tcl_SetResult(interp,
+ "length of nulls string doesn't match # of arguments",
+ TCL_VOLATILE);
+ return TCL_ERROR;
+ }
+ }
+
+ /************************************************************
+ * If there was a argtype list on preparation, we need
+ * an argument value list now
+ ************************************************************/
+ if (qdesc->nargs > 0) {
+ if (i >= argc) {
+ Tcl_SetResult(interp, "missing argument list", TCL_VOLATILE);
+ return TCL_ERROR;
+ }
+
+ /************************************************************
+ * Split the argument values
+ ************************************************************/
+ if (Tcl_SplitList(interp, argv[i++], &callnargs, &callargs) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ /************************************************************
+ * Check that the # of arguments matches
+ ************************************************************/
+ if (callnargs != qdesc->nargs) {
+ Tcl_SetResult(interp,
+ "argument list length doesn't match # of arguments for query",
+ TCL_VOLATILE);
+ if (callargs != NULL) {
+ ckfree(callargs);
+ callargs = NULL;
+ }
+ return TCL_ERROR;
+ }
+
+ /************************************************************
+ * Prepare to start a controlled return through all
+ * interpreter levels on transaction abort during the
+ * parse of the arguments
+ ************************************************************/
+ memcpy(&save_restart, &Warn_restart, sizeof(save_restart));
+ if (sigsetjmp(Warn_restart, 1) != 0) {
+ memcpy(&Warn_restart, &save_restart, sizeof(Warn_restart));
+ for (j = 0; j < callnargs; j++) {
+ if (qdesc->arglen[j] < 0 &&
+ qdesc->argvalues[j] != (Datum)NULL) {
+ pfree((char *)(qdesc->argvalues[j]));
+ qdesc->argvalues[j] = (Datum)NULL;
+ }
+ }
+ ckfree(callargs);
+ callargs = NULL;
+ pltcl_restart_in_progress = 1;
+ Tcl_SetResult(interp, "Transaction abort", TCL_VOLATILE);
+ return TCL_ERROR;
+ }
+
+ /************************************************************
+ * Setup the value array for the SPI_execp() using
+ * the type specific input functions
+ ************************************************************/
+ for (j = 0; j < callnargs; j++) {
+ qdesc->argvalues[j] = (Datum)(*fmgr_faddr(&qdesc->arginfuncs[j]))
+ (callargs[j],
+ qdesc->argtypelems[j],
+ qdesc->arglen[j]);
+ }
+
+ /************************************************************
+ * Free the splitted argument value list
+ ************************************************************/
+ memcpy(&Warn_restart, &save_restart, sizeof(Warn_restart));
+ ckfree(callargs);
+ callargs = NULL;
+ } else {
+ callnargs = 0;
+ }
+
+ /************************************************************
+ * Remember the index of the last processed call
+ * argument - a loop body for SELECT might follow
+ ************************************************************/
+ loop_body = i;
+
+ /************************************************************
+ * Prepare to start a controlled return through all
+ * interpreter levels on transaction abort
+ ************************************************************/
+ memcpy(&save_restart, &Warn_restart, sizeof(save_restart));
+ if (sigsetjmp(Warn_restart, 1) != 0) {
+ memcpy(&Warn_restart, &save_restart, sizeof(Warn_restart));
+ for (j = 0; j < callnargs; j++) {
+ if (qdesc->arglen[j] < 0 && qdesc->argvalues[j] != (Datum)NULL) {
+ pfree((char *)(qdesc->argvalues[j]));
+ qdesc->argvalues[j] = (Datum)NULL;
+ }
+ }
+ pltcl_restart_in_progress = 1;
+ Tcl_SetResult(interp, "Transaction abort", TCL_VOLATILE);
+ return TCL_ERROR;
+ }
+
+ /************************************************************
+ * Execute the plan
+ ************************************************************/
+ spi_rc = SPI_execp(qdesc->plan, qdesc->argvalues, nulls, count);
+ memcpy(&Warn_restart, &save_restart, sizeof(Warn_restart));
+
+ /************************************************************
+ * For varlena data types, free the argument values
+ ************************************************************/
+ for (j = 0; j < callnargs; j++) {
+ if (qdesc->arglen[j] < 0 && qdesc->argvalues[j] != (Datum)NULL) {
+ pfree((char *)(qdesc->argvalues[j]));
+ qdesc->argvalues[j] = (Datum)NULL;
+ }
+ }
+
+ /************************************************************
+ * Check the return code from SPI_execp()
+ ************************************************************/
+ switch (spi_rc) {
+ case SPI_OK_UTILITY:
+ Tcl_SetResult(interp, "0", TCL_VOLATILE);
+ return TCL_OK;
+
+ case SPI_OK_SELINTO:
+ case SPI_OK_INSERT:
+ case SPI_OK_DELETE:
+ case SPI_OK_UPDATE:
+ sprintf(buf, "%d", SPI_processed);
+ Tcl_SetResult(interp, buf, TCL_VOLATILE);
+ return TCL_OK;
+
+ case SPI_OK_SELECT:
+ break;
+
+ case SPI_ERROR_ARGUMENT:
+ Tcl_SetResult(interp,
+ "pltcl: SPI_exec() failed - SPI_ERROR_ARGUMENT",
+ TCL_VOLATILE);
+ return TCL_ERROR;
+
+ case SPI_ERROR_UNCONNECTED:
+ Tcl_SetResult(interp,
+ "pltcl: SPI_exec() failed - SPI_ERROR_UNCONNECTED",
+ TCL_VOLATILE);
+ return TCL_ERROR;
+
+ case SPI_ERROR_COPY:
+ Tcl_SetResult(interp,
+ "pltcl: SPI_exec() failed - SPI_ERROR_COPY",
+ TCL_VOLATILE);
+ return TCL_ERROR;
+
+ case SPI_ERROR_CURSOR:
+ Tcl_SetResult(interp,
+ "pltcl: SPI_exec() failed - SPI_ERROR_CURSOR",
+ TCL_VOLATILE);
+ return TCL_ERROR;
+
+ case SPI_ERROR_TRANSACTION:
+ Tcl_SetResult(interp,
+ "pltcl: SPI_exec() failed - SPI_ERROR_TRANSACTION",
+ TCL_VOLATILE);
+ return TCL_ERROR;
+
+ case SPI_ERROR_OPUNKNOWN:
+ Tcl_SetResult(interp,
+ "pltcl: SPI_exec() failed - SPI_ERROR_OPUNKNOWN",
+ TCL_VOLATILE);
+ return TCL_ERROR;
+
+ default:
+ sprintf(buf, "%d", spi_rc);
+ Tcl_AppendResult(interp, "pltcl: SPI_exec() failed - ",
+ "unknown RC ", buf, NULL);
+ return TCL_ERROR;
+ }
+
+ /************************************************************
+ * Only SELECT queries fall through to here - remember the
+ * tuples we got
+ ************************************************************/
+
+ ntuples = SPI_processed;
+ if (ntuples > 0) {
+ tuples = SPI_tuptable->vals;
+ tupdesc = SPI_tuptable->tupdesc;
+ }
+
+ /************************************************************
+ * Prepare to start a controlled return through all
+ * interpreter levels on transaction abort during
+ * the ouput conversions of the results
+ ************************************************************/
+ memcpy(&save_restart, &Warn_restart, sizeof(save_restart));
+ if (sigsetjmp(Warn_restart, 1) != 0) {
+ memcpy(&Warn_restart, &save_restart, sizeof(Warn_restart));
+ pltcl_restart_in_progress = 1;
+ Tcl_SetResult(interp, "Transaction abort", TCL_VOLATILE);
+ return TCL_ERROR;
+ }
+
+ /************************************************************
+ * If there is no loop body given, just set the variables
+ * from the first tuple (if any) and return the number of
+ * tuples selected
+ ************************************************************/
+ if (loop_body >= argc) {
+ if (ntuples > 0) {
+ pltcl_set_tuple_values(interp, arrayname, 0, tuples[0], tupdesc);
+ }
+ memcpy(&Warn_restart, &save_restart, sizeof(Warn_restart));
+ sprintf(buf, "%d", ntuples);
+ Tcl_SetResult(interp, buf, TCL_VOLATILE);
+ return TCL_OK;
+ }
+
+ /************************************************************
+ * There is a loop body - process all tuples and evaluate
+ * the body on each
+ ************************************************************/
+ for (i = 0; i < ntuples; i++) {
+ pltcl_set_tuple_values(interp, arrayname, i, tuples[i], tupdesc);
+
+ loop_rc = Tcl_Eval(interp, argv[loop_body]);
+
+ if (loop_rc == TCL_OK) continue;
+ if (loop_rc == TCL_CONTINUE) continue;
+ if (loop_rc == TCL_RETURN) {
+ memcpy(&Warn_restart, &save_restart, sizeof(Warn_restart));
+ return TCL_RETURN;
+ }
+ if (loop_rc == TCL_BREAK) break;
+ memcpy(&Warn_restart, &save_restart, sizeof(Warn_restart));
+ return TCL_ERROR;
+ }
+
+ /************************************************************
+ * Finally return the number of tuples
+ ************************************************************/
+ memcpy(&Warn_restart, &save_restart, sizeof(Warn_restart));
+ sprintf(buf, "%d", ntuples);
+ Tcl_SetResult(interp, buf, TCL_VOLATILE);
+ return TCL_OK;
+}
+
+
+/**********************************************************************
+ * pltcl_set_tuple_values() - Set variables for all attributes
+ * of a given tuple
+ **********************************************************************/
+static void pltcl_set_tuple_values(Tcl_Interp *interp, char *arrayname,
+ int tupno, HeapTuple tuple, TupleDesc tupdesc)
+{
+ int i;
+ char *outputstr;
+ char buf[64];
+ Datum attr;
+ bool isnull;
+
+ char *attname;
+ HeapTuple typeTup;
+ Oid typoutput;
+ Oid typelem;
+
+ char **arrptr;
+ char **nameptr;
+ char *nullname = NULL;
+
+ /************************************************************
+ * Prepare pointers for Tcl_SetVar2() below and in array
+ * mode set the .tupno element
+ ************************************************************/
+ if (arrayname == NULL) {
+ arrptr = &attname;
+ nameptr = &nullname;
+ } else {
+ arrptr = &arrayname;
+ nameptr = &attname;
+ sprintf(buf, "%d", tupno);
+ Tcl_SetVar2(interp, arrayname, ".tupno", buf, 0);
+ }
+
+ for (i = 0; i < tupdesc->natts; i++) {
+ /************************************************************
+ * Get the attribute name
+ ************************************************************/
+ attname = tupdesc->attrs[i]->attname.data;
+
+ /************************************************************
+ * Get the attributes value
+ ************************************************************/
+ attr = heap_getattr(tuple, i + 1, tupdesc, &isnull);
+
+ /************************************************************
+ * Lookup the attribute type in the syscache
+ * for the output function
+ ************************************************************/
+ typeTup = SearchSysCacheTuple(TYPOID,
+ ObjectIdGetDatum(tupdesc->attrs[i]->atttypid),
+ 0, 0, 0);
+ if (!HeapTupleIsValid(typeTup)) {
+ elog(ERROR, "pltcl: Cache lookup for attribute '%s' type %ld failed",
+ attname, ObjectIdGetDatum(tupdesc->attrs[i]->atttypid));
+ }
+
+ typoutput = (Oid) (((TypeTupleForm)GETSTRUCT(typeTup))->typoutput);
+ typelem = (Oid) (((TypeTupleForm)GETSTRUCT(typeTup))->typelem);
+
+ /************************************************************
+ * If there is a value, set the variable
+ * If not, unset it
+ *
+ * Hmmm - Null attributes will cause functions to
+ * crash if they don't expect them - need something
+ * smarter here.
+ ************************************************************/
+ if (!isnull && OidIsValid(typoutput)) {
+ FmgrInfo finfo;
+
+ fmgr_info(typoutput, &finfo);
+
+ outputstr = (*fmgr_faddr(&finfo))
+ (attr, typelem,
+ tupdesc->attrs[i]->attlen);
+
+ Tcl_SetVar2(interp, *arrptr, *nameptr, outputstr, 0);
+ pfree(outputstr);
+ } else {
+ Tcl_UnsetVar2(interp, *arrptr, *nameptr, 0);
+ }
+ }
+}
+
+
+/**********************************************************************
+ * pltcl_build_tuple_argument() - Build a string usable for 'array set'
+ * from all attributes of a given tuple
+ **********************************************************************/
+static void pltcl_build_tuple_argument(HeapTuple tuple, TupleDesc tupdesc,
+ Tcl_DString *retval)
+{
+ int i;
+ char *outputstr;
+ Datum attr;
+ bool isnull;
+
+ char *attname;
+ HeapTuple typeTup;
+ Oid typoutput;
+ Oid typelem;
+
+ for (i = 0; i < tupdesc->natts; i++) {
+ /************************************************************
+ * Get the attribute name
+ ************************************************************/
+ attname = tupdesc->attrs[i]->attname.data;
+
+ /************************************************************
+ * Get the attributes value
+ ************************************************************/
+ attr = heap_getattr(tuple, i + 1, tupdesc, &isnull);
+
+ /************************************************************
+ * Lookup the attribute type in the syscache
+ * for the output function
+ ************************************************************/
+ typeTup = SearchSysCacheTuple(TYPOID,
+ ObjectIdGetDatum(tupdesc->attrs[i]->atttypid),
+ 0, 0, 0);
+ if (!HeapTupleIsValid(typeTup)) {
+ elog(ERROR, "pltcl: Cache lookup for attribute '%s' type %ld failed",
+ attname, ObjectIdGetDatum(tupdesc->attrs[i]->atttypid));
+ }
+
+ typoutput = (Oid) (((TypeTupleForm)GETSTRUCT(typeTup))->typoutput);
+ typelem = (Oid) (((TypeTupleForm)GETSTRUCT(typeTup))->typelem);
+
+ /************************************************************
+ * If there is a value, append the attribute name and the
+ * value to the list
+ *
+ * Hmmm - Null attributes will cause functions to
+ * crash if they don't expect them - need something
+ * smarter here.
+ ************************************************************/
+ if (!isnull && OidIsValid(typoutput)) {
+ FmgrInfo finfo;
+
+ fmgr_info(typoutput, &finfo);
+
+ outputstr = (*fmgr_faddr(&finfo))
+ (attr, typelem,
+ tupdesc->attrs[i]->attlen);
+
+ Tcl_DStringAppendElement(retval, attname);
+ Tcl_DStringAppendElement(retval, outputstr);
+ pfree(outputstr);
+ }
+ }
+}
+
+
diff --git a/src/pl/tcl/pltcl_guide.nr b/src/pl/tcl/pltcl_guide.nr
new file mode 100644
index 0000000000000000000000000000000000000000..87fcc71f747f5f3be793a63c15d7a3c147a94764
--- /dev/null
+++ b/src/pl/tcl/pltcl_guide.nr
@@ -0,0 +1,410 @@
+.pl 27.0c
+.ll 17.0c
+.po 2.0c
+.nf
+.nh
+.de HD
+.sp 2m
+..
+.de FT
+.sp 2m
+.tl _PL/Tcl_A PostgreSQL PL_Page %
+..
+.wh 0 HD
+.wh -3 FT
+.sp 5m
+.ce 1000
+PL/Tcl
+A procedural language for the
+
+PostgreSQL
+database system
+.ce 0
+.sp 5m
+.fi
+.in +4
+PL/Tcl is a dynamic loadable extension for the PostgreSQL database system
+that enables the Tcl language to be used to create functions and
+trigger-procedures. It offers most of the capabilities a function
+writer has in the C language, except for some restrictions.
+
+The good restriction is, that everything is executed in a safe
+Tcl-interpreter. In addition to the limited command set of safe Tcl, only
+a few commands are available to access the database over SPI and to raise
+messages via elog(). There is no way to access internals of the
+database backend or gaining OS-level access under the permissions of the
+PostgreSQL user ID like in C. Thus, any unprivileged user may be
+permitted to use this language.
+
+The other, internal given, restriction is, that Tcl procedures cannot
+be used to create input-/output-functions for new data types.
+.bp
+.ti -4
+Data type conversions
+
+PostgreSQL has a rich set of builtin data types. And new data types can
+be defined. The trick is, that PostgreSQL doesn't really know much about
+the internals of a data type. It just offers a container for storing the
+values and knows some functions to call to convert between the external
+string representation and the internal container format. In addition, it
+knows which functions to call to compare containers or to do some
+arithmetics on them for sorting, indexing and calculations.
+
+Tcl on the other hand stores all values as strings.
+
+These two different concepts meet perfectly for what we need. A PostgreSQL
+function has a return value and up to 9 arguments. The data types appear
+in the pg_type system catalog, where we find their type specific regproc's
+responsible for input-/output-conversion from/to strings.
+
+A special case are set values, which can appear as arguments to a
+function. A set value is like a structure containing all the fields
+of a table as it's elements.
+
+C functions cannot have sets as return values. So we cannot do this in
+Tcl either.
+
+
+.ti -4
+PostgreSQL functions and Tcl procedure names
+
+In PostgreSQL, one and the same function name can be used for
+different functions as long as the number of arguments or their types
+differ. This would collide with Tcl procedure names. To offer the same
+flexibility in PL/Tcl, the internal Tcl procedure names contain the object
+ID of the procedures pg_proc row as part of their name. Thus, different
+argtype versions of the same PostgreSQL function are different for Tcl too.
+.bp
+.ti -4
+Defining PostgreSQL functions in PL/Tcl
+
+The following assumes, that the PL/Tcl language is created by the
+administrator of the database with the language name 'pltcl'. See the
+installation instructions to do that.
+
+To create a function in the PL/Tcl language, use the known syntax:
+
+.nf
+ CREATE FUNCTION funcname ([typename [...]])
+.in +4
+ RETURNS typename AS '
+.in +4
+ PL/Tcl procedure body
+.in -4
+ ' LANGUAGE 'pltcl';
+.in -4
+.fi
+
+When calling this function in a query, the arguments are given as
+variables $1 ... $n to the procedure body. So a little max function
+returning the higher of two int4 values would be created as:
+
+.nf
+ create function max (int4, int4)
+.in +4
+ returns int4 as '
+.in +4
+ if {$1 > $2} {return $1}
+ return $2
+.in -4
+ ' language 'pltcl';
+.in -4
+.fi
+
+Set arguments are given to the procedure as Tcl arrays. The element names
+in the array are the field names of the set. If a field in the actual set
+has the NULL value, it will not appear in the array! The overpaid_2 sample
+from the CREATE FUNCTION section of the manual would be defined in Tcl as
+
+.nf
+ create function overpaid_2 (EMP)
+.in +4
+ returns bool as '
+.in +4
+ if {200000.0 < $EMP(salary)} {
+.in +4
+ return 't'
+.in -4
+ }
+ if {$EMP(age) < 30 && 100000.0 < $EMP(salary)} {
+.in +4
+ return 't'
+.in -4
+ }
+ return 'f'
+.in -4
+ ' language 'pltcl';
+.in -4
+.fi
+
+Sometimes (especially when using the SPI functions described later) it
+is useful to have some global status data that is held between two
+calls to a procedure. To protect PL/Tcl procedures from side effects,
+an array is made available to each procedure via the upvar
+command. The global name of this variable is the procedures internal
+name and the local name is GD.
+.bp
+.ti -4
+Defining trigger procedures in PL/Tcl
+
+Trigger procedures are defined in PostgreSQL as functions without
+arguments and a return type of opaque. And so are they in the PL/Tcl
+language.
+
+The informations from the trigger manager are given to the procedure body
+in the following variables:
+
+.in +4
+.ti -4
+$TG_name
+.br
+The name of the trigger from the CREATE TRIGGER statement
+
+.ti -4
+$TG_relid
+.br
+The Object ID of the table that caused the trigger procedure to be
+called.
+
+.ti -4
+$TG_relatts
+.br
+A Tcl list of the tables field names prefixed with an empty list element.
+So looking up an element name in the list with the lsearch Tcl command
+returns the same positive number starting from 1 as the fields are numbered
+in the pg_attribute system catalog.
+
+.ti -4
+$TG_when
+.br
+The string BEFORE or AFTER, depending on the event of the trigger call.
+
+.ti -4
+$TG_level
+.br
+The string ROW or STATEMENT, depending on the event of the trigger call.
+
+.ti -4
+$TG_op
+.br
+The string INSERT, UPDATE or DELETE, depending on the event of the trigger
+call.
+
+.ti -4
+$NEW
+.br
+An array containing the values of the new table row on INSERT/UPDATE
+actions, or empty on DELETE.
+
+.ti -4
+$OLD
+.br
+An array containing the values of the old table row on UPDATE/DELETE
+actions, or empty on INSERT.
+
+.ti -4
+$GD
+.br
+The global status data array as described in the functions section of this
+document.
+
+.ti -4
+$args
+.br
+A Tcl list of the arguments to the procedure as given in the
+CREATE TRIGGER statement. The arguments are also accessible as $1 ... $n
+in the procedure body.
+.bp
+.in -4
+The return value from a trigger procedure is one of the strings OK or SKIP,
+or a list as returned by the 'array get' Tcl command. If the return value
+is OK, the normal operation (INSERT/UPDATE/DELETE) that fired this trigger
+will take place. Obviously, SKIP tells the trigger manager to silently
+suppress the operation. The list from 'array get' tells PL/Tcl
+to return a modified row to the trigger manager that will be inserted instead
+of the one given in $NEW (INSERT/UPDATE only). Needless to say that all
+this is only meaningful when the trigger is BEFORE and FOR EACH ROW.
+
+Here's a little example trigger procedure that forces an integer value
+in a table to keep track of the # of updates that are performed on the
+row. For new row's inserted, the value is initialized to 0 and then
+incremented on every update operation:
+
+.nf
+.in +4
+create function trigfunc_modcount() returns opaque as '
+ switch $TG_op {
+ INSERT {
+ set NEW($1) 0
+ }
+ UPDATE {
+ set NEW($1) $OLD($1)
+ incr NEW($1)
+ }
+ default {
+ return OK
+ }
+ }
+ return [array get NEW]
+.ti -1
+ ' language 'pltcl';
+
+create table T1 (key int4, modcnt int4, desc text);
+
+create trigger trig_T1_modcount before insert or update
+ on T1 for each row execute procedure
+ trigfunc_modcount('modcnt');
+.in -4
+.fi
+.bp
+.ti -4
+PostgreSQL database access from PL/Tcl
+
+The following commands are available to access the database from
+the body of a PL/Tcl procedure:
+
+.in +4
+.ti -4
+elog level msg
+.br
+Fire a log message. Possible levels are NOTICE, WARN, ERROR,
+FATAL, DEBUG and NOIND
+like for the elog() C function.
+
+.ti -4
+quote string
+.br
+Duplicates all occurences of single quote and backslash characters.
+It should be used when variables are used in the query string given
+to spi_exec or spi_prepare (not for the value list on spi_execp).
+Think about a query string like
+
+.ti +4
+select '$val' as ret
+
+where the Tcl variable actually contains "doesn't". This would result
+in the final query string
+
+.ti +4
+select 'doesn't' as ret
+
+what's wrong. It should contain
+
+.ti +4
+select 'doesn''t'
+
+and should be written as
+
+.ti +4
+select '[quote $val]' as ret
+
+to work.
+
+.ti -4
+spi_exec ?-count n? ?-array name? query ?loop-body?
+.br
+Call parser/planner/optimizer/executor for query.
+The optional -count value tells spi_exec the maximum number of rows
+to be processed by the query.
+
+If the query is
+a SELECT statement and the optional loop-body (a body of Tcl commands
+like in a foreach statement) is given, it is evaluated for each
+row selected and behaves like expected on continue/break. The values
+of selected fields are put into variables named as the column names. So a
+
+.ti +2
+spi_exec "select count(*) as cnt from pg_proc"
+
+will set the variable $cnt to the number of rows in the pg_proc system
+catalog. If the option -array is given, the column values are stored
+in the associative array named 'name' indexed by the column name
+instead of individual variables.
+
+.in +2
+.nf
+spi_exec -array C "select * from pg_class" {
+ elog DEBUG "have table $C(relname)"
+}
+.fi
+.in -2
+
+will print a DEBUG log message for every row of pg_class. The return value
+of spi_exec is the number of rows affected by query as found in
+the global variable SPI_processed.
+
+.ti -4
+spi_prepare query typelist
+.br
+Prepares AND SAVES a query plan for later execution. It is a bit different
+from the C level SPI_prepare in that the plan is automatically copied to the
+toplevel memory context. Thus, there is currently no way of preparing a
+plan without saving it.
+
+If the query references arguments, the type names must be given as a Tcl
+list. The return value from spi_prepare is a query ID to be used in
+subsequent calls to spi_execp. See spi_execp for a sample.
+
+.ti -4
+spi_execp ?-count n? ?-array name? ?-nulls str? queryid ?values? ?loop-body?
+
+Execute a prepared plan from spi_prepare with variable substitution.
+The optional -count value tells spi_execp the maximum number of rows
+to be processed by the query.
+
+The optional value for -nulls is a string of spaces and 'n' characters
+telling spi_execp which of the values are NULL's. If given, it must
+have exactly the length of the number of values.
+
+The queryid is the ID returned by the spi_prepare call.
+
+If there was a typelist given to spi_prepare, a Tcl list of values of
+exactly the same length must be given to spi_execp after the query. If
+the type list on spi_prepare was empty, this argument must be omitted.
+
+If the query is a SELECT statement, the same as described for spi_exec
+happens for the loop-body and the variables for the fields selected.
+
+Here's an example for a PL/Tcl function using a prepared plan:
+
+.in +4
+.nf
+create table T1 (key int4, val text);
+
+create function T1_count(int4) returns int4 as '
+ if {![info exists GD]} {
+ # prepare the plan on the first call
+ set GD(plan) [spi_prepare \\\\
+ "select count(*) as cnt from T1 where key = \\\\$1" \\\\
+ int4]
+ }
+ spi_execp -count 1 $GD(plan) [list $1]
+ return $cnt
+.ti -1
+ ' language 'pltcl';
+.fi
+.in -4
+
+Note that each backslash that Tcl should see must be doubled in
+the query creating the function, since the PostgreSQL parser processes
+backslashes too.
+.bp
+.ti -4
+Modules and the unknown command
+
+PL/Tcl has a special support for things often used. It recognizes two
+magic tables, pltcl_modules and pltcl_modfuncs.
+If these exist, the module 'unknown' is loaded into the interpreter
+right after creation. Whenever an unknown Tcl procedure is called,
+the unknown proc is called to check if the procedure is defined in one
+of the modules. If this is true, the module is loaded on demand.
+
+See the documentation in the modules subdirectory for detailed
+information.
+
+
+
+.in -4
+Now enjoy PL/Tcl.
+
+jwieck@debis.com (Jan Wieck)