From a71a80b0f2ea0286495a95f4339b44966ba27fd4 Mon Sep 17 00:00:00 2001 From: "Marc G. Fournier" Date: Wed, 11 Feb 1998 14:08:01 +0000 Subject: [PATCH] From: Jan Wieck A few minutes ago I sent down the PL/Tcl directory to this list. Look at it and reuse anything that might help to build PL/perl. I really hope that PL/perl and PL/Tcl appear in the 6.3 distribution. I'll do whatever I can to make this happen. --- src/pl/tcl/INSTALL | 43 + src/pl/tcl/Makefile | 91 ++ src/pl/tcl/license.terms | 30 + src/pl/tcl/mkMakefile.tcldefs | 22 + src/pl/tcl/pltcl.c | 2159 +++++++++++++++++++++++++++++++++ src/pl/tcl/pltcl_guide.nr | 410 +++++++ 6 files changed, 2755 insertions(+) create mode 100644 src/pl/tcl/INSTALL create mode 100644 src/pl/tcl/Makefile create mode 100644 src/pl/tcl/license.terms create mode 100755 src/pl/tcl/mkMakefile.tcldefs create mode 100644 src/pl/tcl/pltcl.c create mode 100644 src/pl/tcl/pltcl_guide.nr diff --git a/src/pl/tcl/INSTALL b/src/pl/tcl/INSTALL new file mode 100644 index 0000000000..27d0df3325 --- /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 0000000000..df516350b9 --- /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 0000000000..2a201353eb --- /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 0000000000..ba1a9c63af --- /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 0000000000..9c5d6a85c7 --- /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 + +#include +#include +#include +#include +#include +#include +#include + +#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 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 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 0000000000..87fcc71f74 --- /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) -- 2.40.0