Skip to content

P
Postgres FD Implementation
Commit a71a80b0 authored by Marc G. Fournier's avatar Marc G. Fournier
Browse files
Options

From: Jan Wieck <jwieck@debis.com> 

    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.
parent 243a9137
Show whitespace changes
Inline Side-by-side
Showing with 2755 additions and 0 deletions
src/pl/tcl/INSTALL 0 → 100644
View file @ a71a80b0
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.
src/pl/tcl/Makefile 0 → 100644
View file @ a71a80b0
#-------------------------------------------------------------------------
#
# 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)
src/pl/tcl/license.terms 0 → 100644
View file @ a71a80b0
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.
src/pl/tcl/mkMakefile.tcldefs 0 → 100755
View file @ a71a80b0
#!/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
src/pl/tcl/pltcl.c 0 → 100644
View file @ a71a80b0
/**********************************************************************
* 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);
}
}
}
src/pl/tcl/pltcl_guide.nr 0 → 100644
View file @ a71a80b0
.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)
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment