From c02f1ead482e3d6efdccaacb05a7955d4aead3d1 Mon Sep 17 00:00:00 2001 From: Bruce Momjian Date: Thu, 20 Jan 2000 05:08:58 +0000 Subject: [PATCH] Well, I finally solved the linking problem that kept me from making perl secure. Attached is uuencoded tarball to add PL/perl to postgresql. Things I know don't work. -- triggers -- SPI The README file has a _VERY_ short tutorial. Mark Hollomon --- src/pl/plperl/Makefile.pl | 113 ++ src/pl/plperl/README | 41 + src/pl/plperl/plperl.c | 2175 +++++++++++++++++++++++++++++++++++++ 3 files changed, 2329 insertions(+) create mode 100644 src/pl/plperl/Makefile.pl create mode 100644 src/pl/plperl/README create mode 100644 src/pl/plperl/plperl.c diff --git a/src/pl/plperl/Makefile.pl b/src/pl/plperl/Makefile.pl new file mode 100644 index 0000000000..6e1d569912 --- /dev/null +++ b/src/pl/plperl/Makefile.pl @@ -0,0 +1,113 @@ +use DynaLoader; +use Config; +use ExtUtils::Embed; + +# +# massage the ld options +# +my $ldopts = ldopts(); +chomp($ldopts); + +# +# get the location of the Opcode module +# +my $opcode = ''; +{ + + $modname = 'Opcode'; + + my $dir; + foreach (@INC) { + if (-d "$_/auto/$modname") { + $dir = "$_/auto/$modname"; + last; + } + } + + if (defined $dir) { + $opcode = DynaLoader::dl_findfile("-L$dir", $modname); + } + +} + +open(MAKEFILE, ">Makefile"); + +print MAKEFILE <<_STATIC_; +#------------------------------------------------------------------------- +# +# Makefile +# Makefile for the plperl shared object +# +# AUTOGENERATED Makefile.pl +# + +# +# Tell make where the postgresql sources live +# +SRCDIR= ../../../src +include \$(SRCDIR)/Makefile.global + + +# use the same compiler as perl did +CC= $Config{cc} + +# get the compiler options that perl wants. +CFLAGS+= @{[ccopts()]} +# including the ones for dynamic loading +CFLAGS+= $Config{cccdlflags} + +# add the includes for postgreSQL +CFLAGS+= -I\$(LIBPQDIR) -I\$(SRCDIR)/include + +# For fmgr.h +CFLAGS+= -I\$(SRCDIR)/backend + + +# add the postgreSQL libraries +LDADD+= -L\$(LIBPQDIR) -lpq + +LDFLAGS+= $Config{lddlflags} \\ + $ldopts \\ + -lperl + +# +# DLOBJS is the dynamically-loaded object file. +# +DLOBJS= plperl\$(DLSUFFIX) + +INFILES= \$(DLOBJS) + +SHLIB_EXTRA_LIBS+= $opcode + +# +# plus exports files +# +ifdef EXPSUFF +INFILES+= \$(DLOBJS:.o=\$(EXPSUFF)) +endif + +%.so: %.o + \$(CC) -o \$@ \$< \$(LDFLAGS) \$(SHLIB_EXTRA_LIBS) \$(LDADD) + + +# +# Build the shared lib +# +plperl : plperl.lo + libtool \$(CC) -o plperl.so plperl.lo \$(SHLIB_EXTRA_LIBS) \$(LDADD) \$(LDFLAGS) + +%.lo : %.c + libtool \$(CC) -c \$(CFLAGS) \$< + + +# +# Clean +# +clean: + rm -f \$(INFILES) *.o *.lo + rm -rf .libs + rm -f Makefile + +dep depend: + +_STATIC_ diff --git a/src/pl/plperl/README b/src/pl/plperl/README new file mode 100644 index 0000000000..20c025640a --- /dev/null +++ b/src/pl/plperl/README @@ -0,0 +1,41 @@ +>perl Makefile.pl +>make + +copy the resulting library somewhere that +the postgresql backend can see it. assume +that path is /usr/local/pgsql/modules/plperl.so + +CREATE FUNCTION plperl_call_handler() RETURNS opaque +AS '/usr/local/pgsql/modules/plperl.so' LANGUAGE 'C'; + +CREATE TRUSTED PROCEDURAL LANGUAGE 'plperl' +HANDLER plperl_call_handler +LANCOMPILER 'PL/Perl'; + +-- here is simple example +CREATE FUNCTION addints(int4, int4) RETURNS int4 AS ' +return $_[0] + $_[1] +' LANGUAGE 'plperl'; + +SELECT addints(3,4); + +-- of course, you can pass tuples; +CREATE TABLE twoints ( a integer, b integer); +CREATE FUNCTION addtwoints(twoints) RETURNS integer AS ' +$tup = shift; +return $tup->{"a"} + $tup->{"b"}; +' LANGUAGE 'plperl'; + +SELECT addtwoints(twoints) from twoints; + +-- here is one that will fail. Creating the function +-- will work, but using it will fail. +CREATE FUNCTION badfunc() RETURNS int4 AS ' +open(TEMP, ">/tmp/badfile"); +print TEMP "Gotcha!\n"; +return 1; +' LANGUAGE 'plperl'; + +SELECT badfunc(); + + diff --git a/src/pl/plperl/plperl.c b/src/pl/plperl/plperl.c new file mode 100644 index 0000000000..d820d6484d --- /dev/null +++ b/src/pl/plperl/plperl.c @@ -0,0 +1,2175 @@ +/********************************************************************** + * plperl.c - perl as a procedural language for PostgreSQL + * + * IDENTIFICATION + * + * This software is copyrighted by Mark Hollomon + * but is shameless cribbed from pltcl.c by Jan Weick. + * + * 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. + * + **********************************************************************/ + + +/* system stuff */ +#include +#include +#include +#include +#include +#include +#include + +/* postgreSQL stuff */ +#include "executor/spi.h" +#include "commands/trigger.h" +#include "utils/elog.h" +#include "utils/builtins.h" +#include "fmgr.h" +#include "access/heapam.h" + +#include "tcop/tcopprot.h" +#include "utils/syscache.h" +#include "catalog/pg_proc.h" +#include "catalog/pg_type.h" + +/* perl stuff */ +/* + * Evil Code Alert + * + * both posgreSQL and perl try to do 'the right thing' + * and provide union semun if the platform doesn't define + * it in a system header. + * psql uses HAVE_UNION_SEMUN + * perl uses HAS_UNION_SEMUN + * together, they cause compile errors. + * If we need it, the psql headers above will provide it. + * So we tell perl that we have it. + */ +#ifndef HAS_UNION_SEMUN +#define HAS_UNION_SEMUN +#endif +#include +#include + + +/********************************************************************** + * The information we cache about loaded procedures + **********************************************************************/ +typedef struct plperl_proc_desc +{ + char *proname; + FmgrInfo result_in_func; + Oid result_in_elem; + int result_in_len; + int nargs; + FmgrInfo arg_out_func[FUNC_MAX_ARGS]; + Oid arg_out_elem[FUNC_MAX_ARGS]; + int arg_out_len[FUNC_MAX_ARGS]; + int arg_is_rel[FUNC_MAX_ARGS]; + SV* reference; +} plperl_proc_desc; + + +/********************************************************************** + * The information we cache about prepared and saved plans + **********************************************************************/ +typedef struct plperl_query_desc +{ + char qname[20]; + void *plan; + int nargs; + Oid *argtypes; + FmgrInfo *arginfuncs; + Oid *argtypelems; + Datum *argvalues; + int *arglen; +} plperl_query_desc; + + +/********************************************************************** + * Global data + **********************************************************************/ +static int plperl_firstcall = 1; +static int plperl_call_level = 0; +static int plperl_restart_in_progress = 0; +static PerlInterpreter *plperl_safe_interp = NULL; +static HV *plperl_proc_hash = NULL; +#if REALLYHAVEITONTHEBALL +static Tcl_HashTable *plperl_query_hash = NULL; +#endif + +/********************************************************************** + * Forward declarations + **********************************************************************/ +static void plperl_init_all(void); +static void plperl_init_safe_interp(void); + +Datum plperl_call_handler(FmgrInfo *proinfo, + FmgrValues *proargs, bool *isNull); + +static Datum plperl_func_handler(FmgrInfo *proinfo, + FmgrValues *proargs, bool *isNull); + +static SV* plperl_build_tuple_argument(HeapTuple tuple, TupleDesc tupdesc); +static void plperl_init_shared_libs(void); + +#ifdef REALLYHAVEITONTHEBALL +static HeapTuple plperl_trigger_handler(FmgrInfo *proinfo); + +static int plperl_elog(ClientData cdata, Tcl_Interp *interp, + int argc, char *argv[]); +static int plperl_quote(ClientData cdata, Tcl_Interp *interp, + int argc, char *argv[]); + +static int plperl_SPI_exec(ClientData cdata, Tcl_Interp *interp, + int argc, char *argv[]); +static int plperl_SPI_prepare(ClientData cdata, Tcl_Interp *interp, + int argc, char *argv[]); +static int plperl_SPI_execp(ClientData cdata, Tcl_Interp *interp, + int argc, char *argv[]); + +static void plperl_set_tuple_values(Tcl_Interp *interp, char *arrayname, + int tupno, HeapTuple tuple, TupleDesc tupdesc); +#endif + + +/********************************************************************** + * plperl_init_all() - Initialize all + **********************************************************************/ +static void +plperl_init_all(void) +{ + + /************************************************************ + * Do initialization only once + ************************************************************/ + if (!plperl_firstcall) + return; + + + /************************************************************ + * Destroy the existing safe interpreter + ************************************************************/ + if (plperl_safe_interp != NULL) + { + perl_destruct(plperl_safe_interp); + perl_free(plperl_safe_interp); + plperl_safe_interp = NULL; + } + + /************************************************************ + * Free the proc hash table + ************************************************************/ + if (plperl_proc_hash != NULL) + { + hv_undef(plperl_proc_hash); + SvREFCNT_dec((SV*) plperl_proc_hash); + plperl_proc_hash = NULL; + } + + /************************************************************ + * Free the prepared query hash table + ************************************************************/ + /* + if (plperl_query_hash != NULL) + { + } + */ + + /************************************************************ + * Now recreate a new safe interpreter + ************************************************************/ + plperl_init_safe_interp(); + + plperl_firstcall = 0; + return; +} + + +/********************************************************************** + * plperl_init_safe_interp() - Create the safe Perl interpreter + **********************************************************************/ +static void +plperl_init_safe_interp(void) +{ + + char *embedding[] = { "", "-e", "BEGIN { use DynaLoader; require Safe;}", "0" }; + + plperl_safe_interp = perl_alloc(); + if (!plperl_safe_interp) + elog(ERROR, "plperl_init_safe_interp(): could not allocate perl interpreter"); + + perl_construct(plperl_safe_interp); + perl_parse(plperl_safe_interp, plperl_init_shared_libs, 3, embedding, NULL); + perl_run(plperl_safe_interp); + + + + /************************************************************ + * Initialize the proc and query hash tables + ************************* ***********************************/ + plperl_proc_hash = newHV(); + + /************************************************************ + * Install the commands for SPI support in the safe interpreter + * Someday. + ************************************************************/ +} + + + +/********************************************************************** + * plperl_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 + * perl procedures. + **********************************************************************/ + +/* keep non-static */ +Datum +plperl_call_handler(FmgrInfo *proinfo, + FmgrValues *proargs, + bool *isNull) +{ + Datum retval; + + /************************************************************ + * Initialize interpreters on first call + ************************************************************/ + if (plperl_firstcall) + plperl_init_all(); + + /************************************************************ + * Connect to SPI manager + ************************************************************/ + if (SPI_connect() != SPI_OK_CONNECT) + elog(ERROR, "plperl: cannot connect to SPI manager"); + /************************************************************ + * Keep track about the nesting of Tcl-SPI-Tcl-... calls + ************************************************************/ + plperl_call_level++; + + /************************************************************ + * Determine if called as function or trigger and + * call appropriate subhandler + ************************************************************/ + if (CurrentTriggerData == NULL) + retval = plperl_func_handler(proinfo, proargs, isNull); + else { + elog(ERROR, "plperl: can't use perl in triggers yet."); + /* + retval = (Datum) plperl_trigger_handler(proinfo); + */ + /* make the compiler happy */ + retval = (Datum) 0; + } + + plperl_call_level--; + + return retval; +} + + +/********************************************************************** + * plperl_create_sub() - calls the perl interpreter to + * create the anonymous subroutine whose text is in the SV. + * Returns the SV containing the RV to the closure. + **********************************************************************/ +static +SV * +plperl_create_sub(SV *s) { + dSP; + + SV* subref = NULL; + + ENTER; + SAVETMPS; + PUSHMARK(SP); + perl_eval_sv(s, G_SCALAR | G_EVAL | G_KEEPERR); + SPAGAIN; + + if (SvTRUE(GvSV(errgv))) { + POPs; + PUTBACK; + FREETMPS; + LEAVE; + elog(ERROR, "creation of function failed : %s", SvPV(GvSV(errgv), na)); + } + + /* + * need to make a deep copy of the return. + * it comes off the stack as a temporary. + */ + subref = newSVsv(POPs); + + if (!SvROK(subref)) { + PUTBACK; + FREETMPS; + LEAVE; + /* + * subref is our responsibility because it is not mortal + */ + SvREFCNT_dec(subref); + elog(ERROR, "plperl_create_sub: didn't get a code ref"); + } + + PUTBACK; + FREETMPS; + LEAVE; + return subref; +} + +/********************************************************************** + * plperl_init_shared_libs() - + * + * We cannot use the DynaLoader directly to get at the Opcode + * module (used by Safe.pm). So, we link Opcode into ourselves + * and do the initialization behind perl's back. + * + **********************************************************************/ + +extern void boot_DynaLoader _((CV* cv)); +extern void boot_Opcode _((CV* cv)); + +extern void +plperl_init_shared_libs(void) +{ + char *file = __FILE__; + newXS("DynaLoader::bootstrap", boot_DynaLoader, file); + newXS("Opcode::bootstrap", boot_Opcode, file); +} + +/********************************************************************** + * plperl_call_perl_func() - calls a perl function through the RV + * stored in the prodesc structure. massages the input parms properly + **********************************************************************/ +static +SV* +plperl_call_perl_func (plperl_proc_desc * desc, FmgrValues *pargs) +{ + dSP; + + SV* retval; + int i; + int count; + + + ENTER; + SAVETMPS; + + PUSHMARK(sp); + for (i = 0; i < desc->nargs; i++) { + if (desc->arg_is_rel[i]) { + /* + * plperl_build_tuple_argument better return a + * mortal SV. + */ + SV* hashref = plperl_build_tuple_argument( + ((TupleTableSlot *) (pargs->data[i]))->val, + ((TupleTableSlot *) (pargs->data[i]))->ttc_tupleDescriptor); + XPUSHs(hashref); + } else { + char *tmp = (*fmgr_faddr(&(desc->arg_out_func[i]))) + (pargs->data[i], + desc->arg_out_elem[i], + desc->arg_out_len[i]); + + XPUSHs(sv_2mortal(newSVpv(tmp, 0))); + pfree(tmp); + } + } + PUTBACK; + count = perl_call_sv(desc->reference, G_SCALAR | G_EVAL | G_KEEPERR); + + SPAGAIN; + + if (count !=1) { + PUTBACK ; + FREETMPS ; + LEAVE; + elog(ERROR, "plperl : didn't get a return item from function"); + } + + if (SvTRUE(GvSV(errgv))) { + POPs; + PUTBACK ; + FREETMPS ; + LEAVE; + elog(ERROR, "plperl : error from function : %s", SvPV(GvSV(errgv), na)); + } + + retval = newSVsv(POPs); + + + PUTBACK ; + FREETMPS ; + LEAVE ; + + return retval; + + +} + +/********************************************************************** + * plperl_func_handler() - Handler for regular function calls + **********************************************************************/ +static Datum +plperl_func_handler(FmgrInfo *proinfo, + FmgrValues *proargs, + bool *isNull) +{ + int i; + char internal_proname[512]; + int proname_len; + char *stroid; + plperl_proc_desc *prodesc; + SV* perlret; + Datum retval; + sigjmp_buf save_restart; + + /************************************************************ + * Build our internal proc name from the functions Oid + ************************************************************/ + stroid = oidout(proinfo->fn_oid); + strcpy(internal_proname, "__PLperl_proc_"); + strcat(internal_proname, stroid); + pfree(stroid); + proname_len = strlen(internal_proname); + + /************************************************************ + * Lookup the internal proc name in the hashtable + ************************************************************/ + if (! hv_exists(plperl_proc_hash, internal_proname, proname_len)) + { + /************************************************************ + * 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; + Form_pg_type typeStruct; + SV * proc_internal_def; + char proc_internal_args[4096]; + char *proc_source; + + /************************************************************ + * Allocate a new procedure description block + ************************************************************/ + prodesc = (plperl_proc_desc *) malloc(sizeof(plperl_proc_desc)); + prodesc->proname = malloc(strlen(internal_proname) + 1); + strcpy(prodesc->proname, internal_proname); + + /************************************************************ + * Lookup the pg_proc tuple by Oid + ************************************************************/ + procTup = SearchSysCacheTuple(PROCOID, + ObjectIdGetDatum(proinfo->fn_oid), + 0, 0, 0); + if (!HeapTupleIsValid(procTup)) + { + free(prodesc->proname); + free(prodesc); + elog(ERROR, "plperl: 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(TYPEOID, + ObjectIdGetDatum(procStruct->prorettype), + 0, 0, 0); + if (!HeapTupleIsValid(typeTup)) + { + free(prodesc->proname); + free(prodesc); + elog(ERROR, "plperl: cache lookup for return type failed"); + } + typeStruct = (Form_pg_type) GETSTRUCT(typeTup); + + if (typeStruct->typrelid != InvalidOid) + { + free(prodesc->proname); + free(prodesc); + elog(ERROR, "plperl: 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(TYPEOID, + ObjectIdGetDatum(procStruct->proargtypes[i]), + 0, 0, 0); + if (!HeapTupleIsValid(typeTup)) + { + free(prodesc->proname); + free(prodesc); + elog(ERROR, "plperl: cache lookup for argument type failed"); + } + typeStruct = (Form_pg_type) GETSTRUCT(typeTup); + + if (typeStruct->typrelid != InvalidOid) + prodesc->arg_is_rel[i] = 1; + 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; + + } + + /************************************************************ + * create the text of the anonymous subroutine. + * we do not use a named subroutine so that we can call directly + * through the reference. + * + ************************************************************/ + proc_source = textout(&(procStruct->prosrc)); + /* + * the string has been split for readbility. + * please don't put commas between them. Hope everyone is ANSI + */ + proc_internal_def = newSVpvf( + "$::x = new Safe;" + "$::x->permit_only(':default');" + "use strict;" + "return $::x->reval( q[ sub { %s } ]);", proc_source); + + pfree(proc_source); + + /************************************************************ + * Create the procedure in the interpreter + ************************************************************/ + prodesc->reference = plperl_create_sub(proc_internal_def); + if (!prodesc->reference) + { + free(prodesc->proname); + free(prodesc); + elog(ERROR, "plperl: cannot create internal procedure %s", + internal_proname); + } + + /************************************************************ + * Add the proc description block to the hashtable + ************************************************************/ + hv_store(plperl_proc_hash, internal_proname, proname_len, + newSViv((IV)prodesc), 0); + } + else + { + /************************************************************ + * Found the proc description block in the hashtable + ************************************************************/ + prodesc = (plperl_proc_desc *) SvIV(*hv_fetch(plperl_proc_hash, + internal_proname, proname_len, 0)); + } + + + memcpy(&save_restart, &Warn_restart, sizeof(save_restart)); + + if (sigsetjmp(Warn_restart, 1) != 0) + { + memcpy(&Warn_restart, &save_restart, sizeof(Warn_restart)); + plperl_restart_in_progress = 1; + if (--plperl_call_level == 0) + plperl_restart_in_progress = 0; + siglongjmp(Warn_restart, 1); + } + + + /************************************************************ + * Call the Perl function + ************************************************************/ + perlret = plperl_call_perl_func(prodesc, proargs); + + /************************************************************ + * Disconnect from SPI manager and then create the return + * values datum (if the input function does a palloc for it + * this must not be allocated in the SPI memory context + * because SPI_finish would free it). + ************************************************************/ + if (SPI_finish() != SPI_OK_FINISH) + elog(ERROR, "plperl: SPI_finish() failed"); + + retval = (Datum) (*fmgr_faddr(&prodesc->result_in_func)) + (SvPV(perlret, na), + prodesc->result_in_elem, + prodesc->result_in_len); + + SvREFCNT_dec(perlret); + + memcpy(&Warn_restart, &save_restart, sizeof(Warn_restart)); + if (plperl_restart_in_progress) { + if (--plperl_call_level == 0 ) + plperl_restart_in_progress = 0; + siglongjmp(Warn_restart,1); + } + + return retval; +} + + +#ifdef REALLYHAVEITONTHEBALL +/********************************************************************** + * plperl_trigger_handler() - Handler for trigger calls + **********************************************************************/ +static HeapTuple +plperl_trigger_handler(FmgrInfo *proinfo) +{ + TriggerData *trigdata; + char internal_proname[512]; + char *stroid; + Tcl_HashEntry *hashent; + int hashnew; + plperl_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(plperl_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 = (plperl_proc_desc *) malloc(sizeof(plperl_proc_desc)); + memset(prodesc, 0, sizeof(plperl_proc_desc)); + prodesc->proname = malloc(strlen(internal_proname) + 1); + strcpy(prodesc->proname, internal_proname); + + /************************************************************ + * Lookup the pg_proc tuple by Oid + ************************************************************/ + procTup = SearchSysCacheTuple(PROCOID, + ObjectIdGetDatum(proinfo->fn_oid), + 0, 0, 0); + if (!HeapTupleIsValid(procTup)) + { + free(prodesc->proname); + free(prodesc); + elog(ERROR, "plperl: 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(plperl_safe_interp, + Tcl_DStringValue(&proc_internal_def)); + Tcl_DStringFree(&proc_internal_def); + if (tcl_rc != TCL_OK) + { + free(prodesc->proname); + free(prodesc); + elog(ERROR, "plperl: cannot create internal procedure %s - %s", + internal_proname, plperl_safe_interp->result); + } + + /************************************************************ + * Add the proc description block to the hashtable + ************************************************************/ + hashent = Tcl_CreateHashEntry(plperl_proc_hash, + prodesc->proname, &hashnew); + Tcl_SetHashValue(hashent, (ClientData) prodesc); + } + else + { + /************************************************************ + * Found the proc description block in the hashtable + ************************************************************/ + prodesc = (plperl_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); + plperl_restart_in_progress = 1; + if (--plperl_call_level == 0) + plperl_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 */ + plperl_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"); + + plperl_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(plperl_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 || plperl_restart_in_progress) + { + if (!plperl_restart_in_progress) + { + plperl_restart_in_progress = 1; + if (--plperl_call_level == 0) + plperl_restart_in_progress = 0; + elog(ERROR, "plperl: %s", plperl_safe_interp->result); + } + if (--plperl_call_level == 0) + plperl_restart_in_progress = 0; + siglongjmp(Warn_restart, 1); + } + + switch (tcl_rc) + { + case TCL_OK: + break; + + default: + elog(ERROR, "plperl: 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 (SPI_finish() != SPI_OK_FINISH) + elog(ERROR, "plperl: SPI_finish() failed"); + + if (strcmp(plperl_safe_interp->result, "OK") == 0) + return rettup; + if (strcmp(plperl_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(plperl_safe_interp, plperl_safe_interp->result, + &ret_numvals, &ret_values) != TCL_OK) + { + elog(NOTICE, "plperl: cannot split return value from trigger"); + elog(ERROR, "plperl: %s", plperl_safe_interp->result); + } + + if (ret_numvals % 2 != 0) + { + ckfree(ret_values); + elog(ERROR, "plperl: 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); + plperl_restart_in_progress = 1; + if (--plperl_call_level == 0) + plperl_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, "plperl: invalid attribute '%s'", ret_values[--i]); + + /************************************************************ + * Lookup the attribute type in the syscache + * for the input function + ************************************************************/ + typeTup = SearchSysCacheTuple(TYPEOID, + ObjectIdGetDatum(tupdesc->attrs[attnum - 1]->atttypid), + 0, 0, 0); + if (!HeapTupleIsValid(typeTup)) + { + elog(ERROR, "plperl: Cache lookup for attribute '%s' type %ld failed", + ret_values[--i], + ObjectIdGetDatum(tupdesc->attrs[attnum - 1]->atttypid)); + } + typinput = (Oid) (((Form_pg_type) GETSTRUCT(typeTup))->typinput); + typelem = (Oid) (((Form_pg_type) 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, "plperl: SPI_modifytuple() failed - RC = %d\n", SPI_result); + + ckfree(ret_values); + memcpy(&Warn_restart, &save_restart, sizeof(Warn_restart)); + + return rettup; +} + + +/********************************************************************** + * plperl_elog() - elog() support for PLTcl + **********************************************************************/ +static int +plperl_elog(ClientData cdata, Tcl_Interp *interp, + int argc, char *argv[]) +{ + int level; + sigjmp_buf save_restart; + + /************************************************************ + * Suppress messages during the restart process + ************************************************************/ + if (plperl_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)); + plperl_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; +} + + +/********************************************************************** + * plperl_quote() - quote literal strings that are to + * be used in SPI_exec query strings + **********************************************************************/ +static int +plperl_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; +} + + +/********************************************************************** + * plperl_SPI_exec() - The builtin SPI_exec command + * for the safe interpreter + **********************************************************************/ +static int +plperl_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 = NULL; + 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 (plperl_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)); + plperl_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, + "plperl: SPI_exec() failed - SPI_ERROR_ARGUMENT", + TCL_VOLATILE); + return TCL_ERROR; + + case SPI_ERROR_UNCONNECTED: + Tcl_SetResult(interp, + "plperl: SPI_exec() failed - SPI_ERROR_UNCONNECTED", + TCL_VOLATILE); + return TCL_ERROR; + + case SPI_ERROR_COPY: + Tcl_SetResult(interp, + "plperl: SPI_exec() failed - SPI_ERROR_COPY", + TCL_VOLATILE); + return TCL_ERROR; + + case SPI_ERROR_CURSOR: + Tcl_SetResult(interp, + "plperl: SPI_exec() failed - SPI_ERROR_CURSOR", + TCL_VOLATILE); + return TCL_ERROR; + + case SPI_ERROR_TRANSACTION: + Tcl_SetResult(interp, + "plperl: SPI_exec() failed - SPI_ERROR_TRANSACTION", + TCL_VOLATILE); + return TCL_ERROR; + + case SPI_ERROR_OPUNKNOWN: + Tcl_SetResult(interp, + "plperl: SPI_exec() failed - SPI_ERROR_OPUNKNOWN", + TCL_VOLATILE); + return TCL_ERROR; + + default: + sprintf(buf, "%d", spi_rc); + Tcl_AppendResult(interp, "plperl: 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)); + plperl_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) + plperl_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++) + { + plperl_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; +} + + +/********************************************************************** + * plperl_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 +plperl_SPI_prepare(ClientData cdata, Tcl_Interp *interp, + int argc, char *argv[]) +{ + int nargs; + char **args; + plperl_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 (plperl_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 = (plperl_query_desc *) malloc(sizeof(plperl_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)); + plperl_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, "plperl: Cache lookup of type %s failed", args[i]); + qdesc->argtypes[i] = typeTup->t_data->t_oid; + fmgr_info(((Form_pg_type) GETSTRUCT(typeTup))->typinput, + &(qdesc->arginfuncs[i])); + qdesc->argtypelems[i] = ((Form_pg_type) GETSTRUCT(typeTup))->typelem; + qdesc->argvalues[i] = (Datum) NULL; + qdesc->arglen[i] = (int) (((Form_pg_type) 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, "plperl: 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, "plperl: 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(plperl_query_hash, qdesc->qname, &hashnew); + Tcl_SetHashValue(hashent, (ClientData) qdesc); + + Tcl_SetResult(interp, qdesc->qname, TCL_VOLATILE); + return TCL_OK; +} + + +/********************************************************************** + * plperl_SPI_execp() - Execute a prepared plan + **********************************************************************/ +static int +plperl_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; + plperl_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 (plperl_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(plperl_query_hash, argv[i++]); + if (hashent == NULL) + { + Tcl_AppendResult(interp, "invalid queryid '", argv[--i], "'", NULL); + return TCL_ERROR; + } + qdesc = (plperl_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; + plperl_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; + } + } + plperl_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, + "plperl: SPI_exec() failed - SPI_ERROR_ARGUMENT", + TCL_VOLATILE); + return TCL_ERROR; + + case SPI_ERROR_UNCONNECTED: + Tcl_SetResult(interp, + "plperl: SPI_exec() failed - SPI_ERROR_UNCONNECTED", + TCL_VOLATILE); + return TCL_ERROR; + + case SPI_ERROR_COPY: + Tcl_SetResult(interp, + "plperl: SPI_exec() failed - SPI_ERROR_COPY", + TCL_VOLATILE); + return TCL_ERROR; + + case SPI_ERROR_CURSOR: + Tcl_SetResult(interp, + "plperl: SPI_exec() failed - SPI_ERROR_CURSOR", + TCL_VOLATILE); + return TCL_ERROR; + + case SPI_ERROR_TRANSACTION: + Tcl_SetResult(interp, + "plperl: SPI_exec() failed - SPI_ERROR_TRANSACTION", + TCL_VOLATILE); + return TCL_ERROR; + + case SPI_ERROR_OPUNKNOWN: + Tcl_SetResult(interp, + "plperl: SPI_exec() failed - SPI_ERROR_OPUNKNOWN", + TCL_VOLATILE); + return TCL_ERROR; + + default: + sprintf(buf, "%d", spi_rc); + Tcl_AppendResult(interp, "plperl: 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)); + plperl_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) + plperl_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++) + { + plperl_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; +} + + +/********************************************************************** + * plperl_set_tuple_values() - Set variables for all attributes + * of a given tuple + **********************************************************************/ +static void +plperl_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(TYPEOID, + ObjectIdGetDatum(tupdesc->attrs[i]->atttypid), + 0, 0, 0); + if (!HeapTupleIsValid(typeTup)) + { + elog(ERROR, "plperl: Cache lookup for attribute '%s' type %ld failed", + attname, ObjectIdGetDatum(tupdesc->attrs[i]->atttypid)); + } + + typoutput = (Oid) (((Form_pg_type) GETSTRUCT(typeTup))->typoutput); + typelem = (Oid) (((Form_pg_type) 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); + } +} + + +#endif +/********************************************************************** + * plperl_build_tuple_argument() - Build a string for a ref to a hash + * from all attributes of a given tuple + **********************************************************************/ +static SV* +plperl_build_tuple_argument(HeapTuple tuple, TupleDesc tupdesc) +{ + int i; + SV* output; + Datum attr; + bool isnull; + + char *attname; + char* outputstr; + HeapTuple typeTup; + Oid typoutput; + Oid typelem; + + output = sv_2mortal(newSVpv("{", 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(TYPEOID, + ObjectIdGetDatum(tupdesc->attrs[i]->atttypid), + 0, 0, 0); + if (!HeapTupleIsValid(typeTup)) + { + elog(ERROR, "plperl: Cache lookup for attribute '%s' type %ld failed", + attname, ObjectIdGetDatum(tupdesc->attrs[i]->atttypid)); + } + + typoutput = (Oid) (((Form_pg_type) GETSTRUCT(typeTup))->typoutput); + typelem = (Oid) (((Form_pg_type) GETSTRUCT(typeTup))->typelem); + + /************************************************************ + * If there is a value, append the attribute name and the + * value to the list. + * If it is null it will be set to undef. + ************************************************************/ + if (!isnull && OidIsValid(typoutput)) + { + FmgrInfo finfo; + + fmgr_info(typoutput, &finfo); + + outputstr = (*fmgr_faddr(&finfo)) + (attr, typelem, + tupdesc->attrs[i]->attlen); + + sv_catpvf(output, "'%s' => '%s',", attname, outputstr); + pfree(outputstr); + } else { + sv_catpvf(output, "'%s' => undef,", attname); + } + } + sv_catpv(output, "}"); + output = perl_eval_pv(SvPV(output, na), TRUE); + return output; +}