mirrors/postgres
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
postgres/src/pl/tcl/pltcl.c

2435 lines
70 KiB
C
Raw Blame History

/**********************************************************************
* pltcl.c - PostgreSQL support for Tcl as
* procedural language (PL)
*
* $PostgreSQL: pgsql/src/pl/tcl/pltcl.c,v 1.127 2009/01/21 11:13:14 heikki Exp $
*
**********************************************************************/
#include "postgres.h"
#include <tcl.h>
#include <unistd.h>
#include <fcntl.h>
/* Hack to deal with Tcl 8.4 const-ification without losing compatibility */
#ifndef CONST84
#define CONST84
#endif
#include "access/xact.h"
#include "catalog/pg_language.h"
#include "catalog/pg_proc.h"
#include "catalog/pg_type.h"
#include "commands/trigger.h"
#include "executor/spi.h"
#include "fmgr.h"
#include "miscadmin.h"
#include "nodes/makefuncs.h"
#include "parser/parse_type.h"
#include "tcop/tcopprot.h"
#include "utils/builtins.h"
#include "utils/lsyscache.h"
#include "utils/memutils.h"
#include "utils/syscache.h"
#include "utils/typcache.h"
#define HAVE_TCL_VERSION(maj,min) \
((TCL_MAJOR_VERSION > maj) || \
(TCL_MAJOR_VERSION == maj && TCL_MINOR_VERSION >= min))
/* In Tcl >= 8.0, really not supposed to touch interp->result directly */
#if !HAVE_TCL_VERSION(8,0)
#define Tcl_GetStringResult(interp) ((interp)->result)
#endif
/* define our text domain for translations */
#undef TEXTDOMAIN
#define TEXTDOMAIN PG_TEXTDOMAIN("pltcl")
#if defined(UNICODE_CONVERSION) && HAVE_TCL_VERSION(8,1)
#include "mb/pg_wchar.h"
static unsigned char *
utf_u2e(unsigned char *src)
{
return pg_do_encoding_conversion(src, strlen(src), PG_UTF8, GetDatabaseEncoding());
}
static unsigned char *
utf_e2u(unsigned char *src)
{
return pg_do_encoding_conversion(src, strlen(src), GetDatabaseEncoding(), PG_UTF8);
}
#define PLTCL_UTF
#define UTF_BEGIN do { \
unsigned char *_pltcl_utf_src; \
unsigned char *_pltcl_utf_dst
#define UTF_END if (_pltcl_utf_src!=_pltcl_utf_dst) \
pfree(_pltcl_utf_dst); } while (0)
#define UTF_U2E(x) (_pltcl_utf_dst=utf_u2e(_pltcl_utf_src=(x)))
#define UTF_E2U(x) (_pltcl_utf_dst=utf_e2u(_pltcl_utf_src=(x)))
#else /* !PLTCL_UTF */
#define UTF_BEGIN
#define UTF_END
#define UTF_U2E(x) (x)
#define UTF_E2U(x) (x)
#endif /* PLTCL_UTF */
PG_MODULE_MAGIC;
/**********************************************************************
* The information we cache about loaded procedures
**********************************************************************/
typedef struct pltcl_proc_desc
{
char *user_proname;
char *internal_proname;
TransactionId fn_xmin;
ItemPointerData fn_tid;
bool fn_readonly;
bool lanpltrusted;
FmgrInfo result_in_func;
Oid result_typioparam;
int nargs;
FmgrInfo arg_out_func[FUNC_MAX_ARGS];
bool arg_is_rowtype[FUNC_MAX_ARGS];
} 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 *argtypioparams;
} pltcl_query_desc;
/**********************************************************************
* Global data
**********************************************************************/
static bool pltcl_pm_init_done = false;
static bool pltcl_be_init_done = false;
static Tcl_Interp *pltcl_hold_interp = NULL;
static Tcl_Interp *pltcl_norm_interp = NULL;
static Tcl_Interp *pltcl_safe_interp = NULL;
static Tcl_HashTable *pltcl_proc_hash = NULL;
static Tcl_HashTable *pltcl_norm_query_hash = NULL;
static Tcl_HashTable *pltcl_safe_query_hash = NULL;
/* these are saved and restored by pltcl_call_handler */
static FunctionCallInfo pltcl_current_fcinfo = NULL;
static pltcl_proc_desc *pltcl_current_prodesc = NULL;
/**********************************************************************
* Forward declarations
**********************************************************************/
Datum pltcl_call_handler(PG_FUNCTION_ARGS);
Datum pltclu_call_handler(PG_FUNCTION_ARGS);
void _PG_init(void);
static void pltcl_init_all(void);
static void pltcl_init_interp(Tcl_Interp *interp);
static void pltcl_init_load_unknown(Tcl_Interp *interp);
static Datum pltcl_func_handler(PG_FUNCTION_ARGS);
static HeapTuple pltcl_trigger_handler(PG_FUNCTION_ARGS);
static void throw_tcl_error(Tcl_Interp *interp, const char *proname);
static pltcl_proc_desc *compile_pltcl_function(Oid fn_oid, Oid tgreloid);
static int pltcl_elog(ClientData cdata, Tcl_Interp *interp,
int argc, CONST84 char *argv[]);
static int pltcl_quote(ClientData cdata, Tcl_Interp *interp,
int argc, CONST84 char *argv[]);
static int pltcl_argisnull(ClientData cdata, Tcl_Interp *interp,
int argc, CONST84 char *argv[]);
static int pltcl_returnnull(ClientData cdata, Tcl_Interp *interp,
int argc, CONST84 char *argv[]);
static int pltcl_SPI_execute(ClientData cdata, Tcl_Interp *interp,
int argc, CONST84 char *argv[]);
static int pltcl_process_SPI_result(Tcl_Interp *interp,
CONST84 char *arrayname,
CONST84 char *loop_body,
int spi_rc,
SPITupleTable *tuptable,
int ntuples);
static int pltcl_SPI_prepare(ClientData cdata, Tcl_Interp *interp,
int argc, CONST84 char *argv[]);
static int pltcl_SPI_execute_plan(ClientData cdata, Tcl_Interp *interp,
int argc, CONST84 char *argv[]);
static int pltcl_SPI_lastoid(ClientData cdata, Tcl_Interp *interp,
int argc, CONST84 char *argv[]);
static void pltcl_set_tuple_values(Tcl_Interp *interp, CONST84 char *arrayname,
int tupno, HeapTuple tuple, TupleDesc tupdesc);
static void pltcl_build_tuple_argument(HeapTuple tuple, TupleDesc tupdesc,
Tcl_DString *retval);
/*
* Hack to override Tcl's builtin Notifier subsystem. This prevents the
* backend from becoming multithreaded, which breaks all sorts of things.
* That happens in the default version of Tcl_InitNotifier if the TCL library
* has been compiled with multithreading support (i.e. when TCL_THREADS is
* defined under Unix, and in all cases under Windows).
* It's okay to disable the notifier because we never enter the Tcl event loop
* from Postgres, so the notifier capabilities are initialized, but never
* used. Only InitNotifier and DeleteFileHandler ever seem to get called
* within Postgres, but we implement all the functions for completeness.
* We can only fix this with Tcl >= 8.4, when Tcl_SetNotifier() appeared.
*/
#if HAVE_TCL_VERSION(8,4)
static ClientData
pltcl_InitNotifier(void)
{
static int fakeThreadKey; /* To give valid address for ClientData */
return (ClientData) &(fakeThreadKey);
}
static void
pltcl_FinalizeNotifier(ClientData clientData)
{
}
static void
pltcl_SetTimer(Tcl_Time *timePtr)
{
}
static void
pltcl_AlertNotifier(ClientData clientData)
{
}
static void
pltcl_CreateFileHandler(int fd, int mask,
Tcl_FileProc *proc, ClientData clientData)
{
}
static void
pltcl_DeleteFileHandler(int fd)
{
}
static void
pltcl_ServiceModeHook(int mode)
{
}
static int
pltcl_WaitForEvent(Tcl_Time *timePtr)
{
return 0;
}
#endif /* HAVE_TCL_VERSION(8,4) */
/*
* This routine is a crock, and so is everyplace that calls it. The problem
* is that the cached form of pltcl functions/queries is allocated permanently
* (mostly via malloc()) and never released until backend exit. Subsidiary
* data structures such as fmgr info records therefore must live forever
* as well. A better implementation would store all this stuff in a per-
* function memory context that could be reclaimed at need. In the meantime,
* fmgr_info_cxt must be called specifying TopMemoryContext so that whatever
* it might allocate, and whatever the eventual function might allocate using
* fn_mcxt, will live forever too.
*/
static void
perm_fmgr_info(Oid functionId, FmgrInfo *finfo)
{
fmgr_info_cxt(functionId, finfo, TopMemoryContext);
}
/*
* _PG_init() - library load-time initialization
*
* DO NOT make this static nor change its name!
*/
void
_PG_init(void)
{
/* Be sure we do initialization only once (should be redundant now) */
if (pltcl_pm_init_done)
return;
pg_bindtextdomain(TEXTDOMAIN);
#ifdef WIN32
/* Required on win32 to prevent error loading init.tcl */
Tcl_FindExecutable("");
#endif
#if HAVE_TCL_VERSION(8,4)
/*
* Override the functions in the Notifier subsystem. See comments above.
*/
{
Tcl_NotifierProcs notifier;
notifier.setTimerProc = pltcl_SetTimer;
notifier.waitForEventProc = pltcl_WaitForEvent;
notifier.createFileHandlerProc = pltcl_CreateFileHandler;
notifier.deleteFileHandlerProc = pltcl_DeleteFileHandler;
notifier.initNotifierProc = pltcl_InitNotifier;
notifier.finalizeNotifierProc = pltcl_FinalizeNotifier;
notifier.alertNotifierProc = pltcl_AlertNotifier;
notifier.serviceModeHookProc = pltcl_ServiceModeHook;
Tcl_SetNotifier(&notifier);
}
#endif
/************************************************************
* Create the dummy hold interpreter to prevent close of
* stdout and stderr on DeleteInterp
************************************************************/
if ((pltcl_hold_interp = Tcl_CreateInterp()) == NULL)
elog(ERROR, "could not create \"hold\" interpreter");
/************************************************************
* Create the two interpreters
************************************************************/
if ((pltcl_norm_interp =
Tcl_CreateSlave(pltcl_hold_interp, "norm", 0)) == NULL)
elog(ERROR, "could not create \"normal\" interpreter");
pltcl_init_interp(pltcl_norm_interp);
if ((pltcl_safe_interp =
Tcl_CreateSlave(pltcl_hold_interp, "safe", 1)) == NULL)
elog(ERROR, "could not create \"safe\" interpreter");
pltcl_init_interp(pltcl_safe_interp);
/************************************************************
* Initialize the proc and query hash tables
************************************************************/
pltcl_proc_hash = (Tcl_HashTable *) malloc(sizeof(Tcl_HashTable));
pltcl_norm_query_hash = (Tcl_HashTable *) malloc(sizeof(Tcl_HashTable));
pltcl_safe_query_hash = (Tcl_HashTable *) malloc(sizeof(Tcl_HashTable));
Tcl_InitHashTable(pltcl_proc_hash, TCL_STRING_KEYS);
Tcl_InitHashTable(pltcl_norm_query_hash, TCL_STRING_KEYS);
Tcl_InitHashTable(pltcl_safe_query_hash, TCL_STRING_KEYS);
pltcl_pm_init_done = true;
}
/**********************************************************************
* pltcl_init_all() - Initialize all
*
* This does initialization that can't be done in the postmaster, and
* hence is not safe to do at library load time.
**********************************************************************/
static void
pltcl_init_all(void)
{
/************************************************************
* Try to load the unknown procedure from pltcl_modules
************************************************************/
if (!pltcl_be_init_done)
{
if (SPI_connect() != SPI_OK_CONNECT)
elog(ERROR, "SPI_connect failed");
pltcl_init_load_unknown(pltcl_norm_interp);
pltcl_init_load_unknown(pltcl_safe_interp);
if (SPI_finish() != SPI_OK_FINISH)
elog(ERROR, "SPI_finish failed");
pltcl_be_init_done = true;
}
}
/**********************************************************************
* pltcl_init_interp() - initialize a Tcl interpreter
**********************************************************************/
static void
pltcl_init_interp(Tcl_Interp *interp)
{
/************************************************************
* Install the commands for SPI support in the interpreter
************************************************************/
Tcl_CreateCommand(interp, "elog",
pltcl_elog, NULL, NULL);
Tcl_CreateCommand(interp, "quote",
pltcl_quote, NULL, NULL);
Tcl_CreateCommand(interp, "argisnull",
pltcl_argisnull, NULL, NULL);
Tcl_CreateCommand(interp, "return_null",
pltcl_returnnull, NULL, NULL);
Tcl_CreateCommand(interp, "spi_exec",
pltcl_SPI_execute, NULL, NULL);
Tcl_CreateCommand(interp, "spi_prepare",
pltcl_SPI_prepare, NULL, NULL);
Tcl_CreateCommand(interp, "spi_execp",
pltcl_SPI_execute_plan, NULL, NULL);
Tcl_CreateCommand(interp, "spi_lastoid",
pltcl_SPI_lastoid, NULL, NULL);
}
/**********************************************************************
* pltcl_init_load_unknown() - Load the unknown procedure from
* table pltcl_modules (if it exists)
**********************************************************************/
static void
pltcl_init_load_unknown(Tcl_Interp *interp)
{
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_execute("select 1 from pg_catalog.pg_class "
"where relname = 'pltcl_modules'",
false, 1);
SPI_freetuptable(SPI_tuptable);
if (spi_rc != SPI_OK_SELECT)
elog(ERROR, "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_execute("select modseq, modsrc from pltcl_modules "
"where modname = 'unknown' "
"order by modseq",
false, 0);
if (spi_rc != SPI_OK_SELECT)
elog(ERROR, "select from pltcl_modules failed");
/************************************************************
* If there's nothing, module unknown doesn't exist
************************************************************/
if (SPI_processed == 0)
{
Tcl_DStringFree(&unknown_src);
SPI_freetuptable(SPI_tuptable);
elog(WARNING, "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 Tcl 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)
{
UTF_BEGIN;
Tcl_DStringAppend(&unknown_src, UTF_E2U(part), -1);
UTF_END;
pfree(part);
}
}
tcl_rc = Tcl_GlobalEval(interp, Tcl_DStringValue(&unknown_src));
Tcl_DStringFree(&unknown_src);
SPI_freetuptable(SPI_tuptable);
}
/**********************************************************************
* 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.
**********************************************************************/
PG_FUNCTION_INFO_V1(pltcl_call_handler);
/* keep non-static */
Datum
pltcl_call_handler(PG_FUNCTION_ARGS)
{
Datum retval;
FunctionCallInfo save_fcinfo;
pltcl_proc_desc *save_prodesc;
/*
* Initialize interpreters if first time through
*/
pltcl_init_all();
/*
* Ensure that static pointers are saved/restored properly
*/
save_fcinfo = pltcl_current_fcinfo;
save_prodesc = pltcl_current_prodesc;
PG_TRY();
{
/*
* Determine if called as function or trigger and call appropriate
* subhandler
*/
if (CALLED_AS_TRIGGER(fcinfo))
{
pltcl_current_fcinfo = NULL;
retval = PointerGetDatum(pltcl_trigger_handler(fcinfo));
}
else
{
pltcl_current_fcinfo = fcinfo;
retval = pltcl_func_handler(fcinfo);
}
}
PG_CATCH();
{
pltcl_current_fcinfo = save_fcinfo;
pltcl_current_prodesc = save_prodesc;
PG_RE_THROW();
}
PG_END_TRY();
pltcl_current_fcinfo = save_fcinfo;
pltcl_current_prodesc = save_prodesc;
return retval;
}
/*
* Alternative handler for unsafe functions
*/
PG_FUNCTION_INFO_V1(pltclu_call_handler);
/* keep non-static */
Datum
pltclu_call_handler(PG_FUNCTION_ARGS)
{
return pltcl_call_handler(fcinfo);
}
/**********************************************************************
* pltcl_func_handler() - Handler for regular function calls
**********************************************************************/
static Datum
pltcl_func_handler(PG_FUNCTION_ARGS)
{
pltcl_proc_desc *prodesc;
Tcl_Interp *volatile interp;
Tcl_DString tcl_cmd;
Tcl_DString list_tmp;
int i;
int tcl_rc;
Datum retval;
/* Connect to SPI manager */
if (SPI_connect() != SPI_OK_CONNECT)
elog(ERROR, "could not connect to SPI manager");
/* Find or compile the function */
prodesc = compile_pltcl_function(fcinfo->flinfo->fn_oid, InvalidOid);
pltcl_current_prodesc = prodesc;
if (prodesc->lanpltrusted)
interp = pltcl_safe_interp;
else
interp = pltcl_norm_interp;
/************************************************************
* Create the tcl command to call the internal
* proc in the Tcl interpreter
************************************************************/
Tcl_DStringInit(&tcl_cmd);
Tcl_DStringInit(&list_tmp);
Tcl_DStringAppendElement(&tcl_cmd, prodesc->internal_proname);
/************************************************************
* Add all call arguments to the command
************************************************************/
PG_TRY();
{
for (i = 0; i < prodesc->nargs; i++)
{
if (prodesc->arg_is_rowtype[i])
{
/**************************************************
* For tuple values, add a list for 'array set ...'
**************************************************/
if (fcinfo->argnull[i])
Tcl_DStringAppendElement(&tcl_cmd, "");
else
{
HeapTupleHeader td;
Oid tupType;
int32 tupTypmod;
TupleDesc tupdesc;
HeapTupleData tmptup;
td = DatumGetHeapTupleHeader(fcinfo->arg[i]);
/* Extract rowtype info and find a tupdesc */
tupType = HeapTupleHeaderGetTypeId(td);
tupTypmod = HeapTupleHeaderGetTypMod(td);
tupdesc = lookup_rowtype_tupdesc(tupType, tupTypmod);
/* Build a temporary HeapTuple control structure */
tmptup.t_len = HeapTupleHeaderGetDatumLength(td);
tmptup.t_data = td;
Tcl_DStringSetLength(&list_tmp, 0);
pltcl_build_tuple_argument(&tmptup, tupdesc, &list_tmp);
Tcl_DStringAppendElement(&tcl_cmd,
Tcl_DStringValue(&list_tmp));
ReleaseTupleDesc(tupdesc);
}
}
else
{
/**************************************************
* Single values are added as string element
* of their external representation
**************************************************/
if (fcinfo->argnull[i])
Tcl_DStringAppendElement(&tcl_cmd, "");
else
{
char *tmp;
tmp = OutputFunctionCall(&prodesc->arg_out_func[i],
fcinfo->arg[i]);
UTF_BEGIN;
Tcl_DStringAppendElement(&tcl_cmd, UTF_E2U(tmp));
UTF_END;
pfree(tmp);
}
}
}
}
PG_CATCH();
{
Tcl_DStringFree(&tcl_cmd);
Tcl_DStringFree(&list_tmp);
PG_RE_THROW();
}
PG_END_TRY();
Tcl_DStringFree(&list_tmp);
/************************************************************
* Call the Tcl function
*
* We assume no PG error can be thrown directly from this call.
************************************************************/
tcl_rc = Tcl_GlobalEval(interp, Tcl_DStringValue(&tcl_cmd));
Tcl_DStringFree(&tcl_cmd);
/************************************************************
* Check for errors reported by Tcl.
************************************************************/
if (tcl_rc != TCL_OK)
throw_tcl_error(interp, prodesc->user_proname);
/************************************************************
* Disconnect from SPI manager and then create the return
* value 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). But don't try to call
* the result_in_func if we've been told to return a NULL;
* the Tcl result may not be a valid value of the result type
* in that case.
************************************************************/
if (SPI_finish() != SPI_OK_FINISH)
elog(ERROR, "SPI_finish() failed");
if (fcinfo->isnull)
retval = InputFunctionCall(&prodesc->result_in_func,
NULL,
prodesc->result_typioparam,
-1);
else
{
UTF_BEGIN;
retval = InputFunctionCall(&prodesc->result_in_func,
UTF_U2E((char *) Tcl_GetStringResult(interp)),
prodesc->result_typioparam,
-1);
UTF_END;
}
return retval;
}
/**********************************************************************
* pltcl_trigger_handler() - Handler for trigger calls
**********************************************************************/
static HeapTuple
pltcl_trigger_handler(PG_FUNCTION_ARGS)
{
pltcl_proc_desc *prodesc;
Tcl_Interp *volatile interp;
TriggerData *trigdata = (TriggerData *) fcinfo->context;
char *stroid;
TupleDesc tupdesc;
volatile 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;
CONST84 char *result;
CONST84 char **ret_values;
/* Connect to SPI manager */
if (SPI_connect() != SPI_OK_CONNECT)
elog(ERROR, "could not connect to SPI manager");
/* Find or compile the function */
prodesc = compile_pltcl_function(fcinfo->flinfo->fn_oid,
RelationGetRelid(trigdata->tg_relation));
pltcl_current_prodesc = prodesc;
if (prodesc->lanpltrusted)
interp = pltcl_safe_interp;
else
interp = pltcl_norm_interp;
tupdesc = trigdata->tg_relation->rd_att;
/************************************************************
* Create the tcl command to call the internal
* proc in the interpreter
************************************************************/
Tcl_DStringInit(&tcl_cmd);
Tcl_DStringInit(&tcl_trigtup);
Tcl_DStringInit(&tcl_newtup);
PG_TRY();
{
/* The procedure name */
Tcl_DStringAppendElement(&tcl_cmd, prodesc->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 = DatumGetCString(DirectFunctionCall1(oidout,
ObjectIdGetDatum(trigdata->tg_relation->rd_id)));
Tcl_DStringAppendElement(&tcl_cmd, stroid);
pfree(stroid);
/* The name of the table the trigger is acting on: TG_table_name */
stroid = SPI_getrelname(trigdata->tg_relation);
Tcl_DStringAppendElement(&tcl_cmd, stroid);
pfree(stroid);
/* The schema of the table the trigger is acting on: TG_table_schema */
stroid = SPI_getnspname(trigdata->tg_relation);
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++)
{
if (tupdesc->attrs[i]->attisdropped)
Tcl_DStringAppendElement(&tcl_trigtup, "");
else
Tcl_DStringAppendElement(&tcl_trigtup,
NameStr(tupdesc->attrs[i]->attname));
}
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
elog(ERROR, "unrecognized WHEN tg_event: %u", trigdata->tg_event);
/* The level part of the event for TG_level */
if (TRIGGER_FIRED_FOR_ROW(trigdata->tg_event))
{
Tcl_DStringAppendElement(&tcl_cmd, "ROW");
/* 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
elog(ERROR, "unrecognized OP tg_event: %u", trigdata->tg_event);
}
else if (TRIGGER_FIRED_FOR_STATEMENT(trigdata->tg_event))
{
Tcl_DStringAppendElement(&tcl_cmd, "STATEMENT");
if (TRIGGER_FIRED_BY_INSERT(trigdata->tg_event))
Tcl_DStringAppendElement(&tcl_cmd, "INSERT");
else if (TRIGGER_FIRED_BY_DELETE(trigdata->tg_event))
Tcl_DStringAppendElement(&tcl_cmd, "DELETE");
else if (TRIGGER_FIRED_BY_UPDATE(trigdata->tg_event))
Tcl_DStringAppendElement(&tcl_cmd, "UPDATE");
else if (TRIGGER_FIRED_BY_TRUNCATE(trigdata->tg_event))
Tcl_DStringAppendElement(&tcl_cmd, "TRUNCATE");
else
elog(ERROR, "unrecognized OP tg_event: %u", trigdata->tg_event);
Tcl_DStringAppendElement(&tcl_cmd, "");
Tcl_DStringAppendElement(&tcl_cmd, "");
rettup = (HeapTuple) NULL;
}
else
elog(ERROR, "unrecognized LEVEL tg_event: %u", trigdata->tg_event);
/* 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]);
}
PG_CATCH();
{
Tcl_DStringFree(&tcl_cmd);
Tcl_DStringFree(&tcl_trigtup);
Tcl_DStringFree(&tcl_newtup);
PG_RE_THROW();
}
PG_END_TRY();
Tcl_DStringFree(&tcl_trigtup);
Tcl_DStringFree(&tcl_newtup);
/************************************************************
* Call the Tcl function
*
* We assume no PG error can be thrown directly from this call.
************************************************************/
tcl_rc = Tcl_GlobalEval(interp, Tcl_DStringValue(&tcl_cmd));
Tcl_DStringFree(&tcl_cmd);
/************************************************************
* Check for errors reported by Tcl.
************************************************************/
if (tcl_rc != TCL_OK)
throw_tcl_error(interp, prodesc->user_proname);
/************************************************************
* The return value from the procedure might be one of
* the magic strings OK or SKIP or a list from array get.
* We can check for OK or SKIP without worrying about encoding.
************************************************************/
if (SPI_finish() != SPI_OK_FINISH)
elog(ERROR, "SPI_finish() failed");
result = Tcl_GetStringResult(interp);
if (strcmp(result, "OK") == 0)
return rettup;
if (strcmp(result, "SKIP") == 0)
return (HeapTuple) NULL;
/************************************************************
* Convert the result value from the Tcl interpreter
* and setup structures for SPI_modifytuple();
************************************************************/
if (Tcl_SplitList(interp, result,
&ret_numvals, &ret_values) != TCL_OK)
{
UTF_BEGIN;
elog(ERROR, "could not split return value from trigger: %s",
UTF_U2E(Tcl_GetStringResult(interp)));
UTF_END;
}
/* Use a TRY to ensure ret_values will get freed */
PG_TRY();
{
if (ret_numvals % 2 != 0)
elog(ERROR, "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);
memset(modnulls, 'n', tupdesc->natts);
for (i = 0; i < ret_numvals; i += 2)
{
CONST84 char *ret_name = ret_values[i];
CONST84 char *ret_value = ret_values[i + 1];
int attnum;
HeapTuple typeTup;
Oid typinput;
Oid typioparam;
FmgrInfo finfo;
/************************************************************
* Ignore ".tupno" pseudo elements (see pltcl_set_tuple_values)
************************************************************/
if (strcmp(ret_name, ".tupno") == 0)
continue;
/************************************************************
* Get the attribute number
************************************************************/
attnum = SPI_fnumber(tupdesc, ret_name);
if (attnum == SPI_ERROR_NOATTRIBUTE)
elog(ERROR, "invalid attribute \"%s\"", ret_name);
if (attnum <= 0)
elog(ERROR, "cannot set system attribute \"%s\"", ret_name);
/************************************************************
* Ignore dropped columns
************************************************************/
if (tupdesc->attrs[attnum - 1]->attisdropped)
continue;
/************************************************************
* Lookup the attribute type in the syscache
* for the input function
************************************************************/
typeTup = SearchSysCache(TYPEOID,
ObjectIdGetDatum(tupdesc->attrs[attnum - 1]->atttypid),
0, 0, 0);
if (!HeapTupleIsValid(typeTup))
elog(ERROR, "cache lookup failed for type %u",
tupdesc->attrs[attnum - 1]->atttypid);
typinput = ((Form_pg_type) GETSTRUCT(typeTup))->typinput;
typioparam = getTypeIOParam(typeTup);
ReleaseSysCache(typeTup);
/************************************************************
* Set the attribute to NOT NULL and convert the contents
************************************************************/
modnulls[attnum - 1] = ' ';
fmgr_info(typinput, &finfo);
UTF_BEGIN;
modvalues[attnum - 1] = InputFunctionCall(&finfo,
(char *) UTF_U2E(ret_value),
typioparam,
tupdesc->attrs[attnum - 1]->atttypmod);
UTF_END;
}
rettup = SPI_modifytuple(trigdata->tg_relation, rettup, tupdesc->natts,
modattrs, modvalues, modnulls);
pfree(modattrs);
pfree(modvalues);
pfree(modnulls);
if (rettup == NULL)
elog(ERROR, "SPI_modifytuple() failed - RC = %d", SPI_result);
}
PG_CATCH();
{
ckfree((char *) ret_values);
PG_RE_THROW();
}
PG_END_TRY();
ckfree((char *) ret_values);
return rettup;
}
/**********************************************************************
* throw_tcl_error - ereport an error returned from the Tcl interpreter
**********************************************************************/
static void
throw_tcl_error(Tcl_Interp *interp, const char *proname)
{
/*
* Caution is needed here because Tcl_GetVar could overwrite the
* interpreter result (even though it's not really supposed to),
* and we can't control the order of evaluation of ereport arguments.
* Hence, make real sure we have our own copy of the result string
* before invoking Tcl_GetVar.
*/
char *emsg;
char *econtext;
UTF_BEGIN;
emsg = pstrdup(UTF_U2E(Tcl_GetStringResult(interp)));
UTF_END;
UTF_BEGIN;
econtext = UTF_U2E((char *) Tcl_GetVar(interp, "errorInfo",
TCL_GLOBAL_ONLY));
ereport(ERROR,
(errmsg("%s", emsg),
errcontext("%s\nin PL/Tcl function \"%s\"",
econtext, proname)));
UTF_END;
}
/**********************************************************************
* compile_pltcl_function - compile (or hopefully just look up) function
*
* tgreloid is the OID of the relation when compiling a trigger, or zero
* (InvalidOid) when compiling a plain function.
**********************************************************************/
static pltcl_proc_desc *
compile_pltcl_function(Oid fn_oid, Oid tgreloid)
{
bool is_trigger = OidIsValid(tgreloid);
HeapTuple procTup;
Form_pg_proc procStruct;
char internal_proname[128];
Tcl_HashEntry *hashent;
pltcl_proc_desc *prodesc = NULL;
Tcl_Interp *interp;
int i;
int hashnew;
int tcl_rc;
/* We'll need the pg_proc tuple in any case... */
procTup = SearchSysCache(PROCOID,
ObjectIdGetDatum(fn_oid),
0, 0, 0);
if (!HeapTupleIsValid(procTup))
elog(ERROR, "cache lookup failed for function %u", fn_oid);
procStruct = (Form_pg_proc) GETSTRUCT(procTup);
/************************************************************
* Build our internal proc name from the functions Oid
************************************************************/
if (!is_trigger)
snprintf(internal_proname, sizeof(internal_proname),
"__PLTcl_proc_%u", fn_oid);
else
snprintf(internal_proname, sizeof(internal_proname),
"__PLTcl_proc_%u_trigger_%u", fn_oid, tgreloid);
/************************************************************
* Lookup the internal proc name in the hashtable
************************************************************/
hashent = Tcl_FindHashEntry(pltcl_proc_hash, internal_proname);
/************************************************************
* If it's present, must check whether it's still up to date.
* This is needed because CREATE OR REPLACE FUNCTION can modify the
* function's pg_proc entry without changing its OID.
************************************************************/
if (hashent != NULL)
{
bool uptodate;
prodesc = (pltcl_proc_desc *) Tcl_GetHashValue(hashent);
uptodate = (prodesc->fn_xmin == HeapTupleHeaderGetXmin(procTup->t_data) &&
ItemPointerEquals(&prodesc->fn_tid, &procTup->t_self));
if (!uptodate)
{
Tcl_DeleteHashEntry(hashent);
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 Tcl interpreter.
************************************************************/
if (hashent == NULL)
{
HeapTuple langTup;
HeapTuple typeTup;
Form_pg_language langStruct;
Form_pg_type typeStruct;
Tcl_DString proc_internal_def;
Tcl_DString proc_internal_body;
char proc_internal_args[33 * FUNC_MAX_ARGS];
Datum prosrcdatum;
bool isnull;
char *proc_source;
char buf[32];
/************************************************************
* Allocate a new procedure description block
************************************************************/
prodesc = (pltcl_proc_desc *) malloc(sizeof(pltcl_proc_desc));
if (prodesc == NULL)
ereport(ERROR,
(errcode(ERRCODE_OUT_OF_MEMORY),
errmsg("out of memory")));
MemSet(prodesc, 0, sizeof(pltcl_proc_desc));
prodesc->user_proname = strdup(NameStr(procStruct->proname));
prodesc->internal_proname = strdup(internal_proname);
prodesc->fn_xmin = HeapTupleHeaderGetXmin(procTup->t_data);
prodesc->fn_tid = procTup->t_self;
/* Remember if function is STABLE/IMMUTABLE */
prodesc->fn_readonly =
(procStruct->provolatile != PROVOLATILE_VOLATILE);
/************************************************************
* Lookup the pg_language tuple by Oid
************************************************************/
langTup = SearchSysCache(LANGOID,
ObjectIdGetDatum(procStruct->prolang),
0, 0, 0);
if (!HeapTupleIsValid(langTup))
{
free(prodesc->user_proname);
free(prodesc->internal_proname);
free(prodesc);
elog(ERROR, "cache lookup failed for language %u",
procStruct->prolang);
}
langStruct = (Form_pg_language) GETSTRUCT(langTup);
prodesc->lanpltrusted = langStruct->lanpltrusted;
ReleaseSysCache(langTup);
if (prodesc->lanpltrusted)
interp = pltcl_safe_interp;
else
interp = pltcl_norm_interp;
/************************************************************
* Get the required information for input conversion of the
* return value.
************************************************************/
if (!is_trigger)
{
typeTup = SearchSysCache(TYPEOID,
ObjectIdGetDatum(procStruct->prorettype),
0, 0, 0);
if (!HeapTupleIsValid(typeTup))
{
free(prodesc->user_proname);
free(prodesc->internal_proname);
free(prodesc);
elog(ERROR, "cache lookup failed for type %u",
procStruct->prorettype);
}
typeStruct = (Form_pg_type) GETSTRUCT(typeTup);
/* Disallow pseudotype result, except VOID */
if (typeStruct->typtype == TYPTYPE_PSEUDO)
{
if (procStruct->prorettype == VOIDOID)
/* okay */ ;
else if (procStruct->prorettype == TRIGGEROID)
{
free(prodesc->user_proname);
free(prodesc->internal_proname);
free(prodesc);
ereport(ERROR,
(errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
errmsg("trigger functions can only be called as triggers")));
}
else
{
free(prodesc->user_proname);
free(prodesc->internal_proname);
free(prodesc);
ereport(ERROR,
(errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
errmsg("PL/Tcl functions cannot return type %s",
format_type_be(procStruct->prorettype))));
}
}
if (typeStruct->typtype == TYPTYPE_COMPOSITE)
{
free(prodesc->user_proname);
free(prodesc->internal_proname);
free(prodesc);
ereport(ERROR,
(errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
errmsg("PL/Tcl functions cannot return composite types")));
}
perm_fmgr_info(typeStruct->typinput, &(prodesc->result_in_func));
prodesc->result_typioparam = getTypeIOParam(typeTup);
ReleaseSysCache(typeTup);
}
/************************************************************
* Get the required information for output conversion
* of all procedure arguments
************************************************************/
if (!is_trigger)
{
prodesc->nargs = procStruct->pronargs;
proc_internal_args[0] = '\0';
for (i = 0; i < prodesc->nargs; i++)
{
typeTup = SearchSysCache(TYPEOID,
ObjectIdGetDatum(procStruct->proargtypes.values[i]),
0, 0, 0);
if (!HeapTupleIsValid(typeTup))
{
free(prodesc->user_proname);
free(prodesc->internal_proname);
free(prodesc);
elog(ERROR, "cache lookup failed for type %u",
procStruct->proargtypes.values[i]);
}
typeStruct = (Form_pg_type) GETSTRUCT(typeTup);
/* Disallow pseudotype argument */
if (typeStruct->typtype == TYPTYPE_PSEUDO)
{
free(prodesc->user_proname);
free(prodesc->internal_proname);
free(prodesc);
ereport(ERROR,
(errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
errmsg("PL/Tcl functions cannot accept type %s",
format_type_be(procStruct->proargtypes.values[i]))));
}
if (typeStruct->typtype == TYPTYPE_COMPOSITE)
{
prodesc->arg_is_rowtype[i] = true;
snprintf(buf, sizeof(buf), "__PLTcl_Tup_%d", i + 1);
}
else
{
prodesc->arg_is_rowtype[i] = false;
perm_fmgr_info(typeStruct->typoutput,
&(prodesc->arg_out_func[i]));
snprintf(buf, sizeof(buf), "%d", i + 1);
}
if (i > 0)
strcat(proc_internal_args, " ");
strcat(proc_internal_args, buf);
ReleaseSysCache(typeTup);
}
}
else
{
/* trigger procedure has fixed args */
strcpy(proc_internal_args,
"TG_name TG_relid TG_table_name TG_table_schema TG_relatts TG_when TG_level TG_op __PLTcl_Tup_NEW __PLTcl_Tup_OLD args");
}
/************************************************************
* 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 setting of 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);
if (!is_trigger)
{
for (i = 0; i < prodesc->nargs; i++)
{
if (prodesc->arg_is_rowtype[i])
{
snprintf(buf, sizeof(buf),
"array set %d $__PLTcl_Tup_%d\n",
i + 1, i + 1);
Tcl_DStringAppend(&proc_internal_body, buf, -1);
}
}
}
else
{
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);
}
/************************************************************
* Add user's function definition to proc body
************************************************************/
prosrcdatum = SysCacheGetAttr(PROCOID, procTup,
Anum_pg_proc_prosrc, &isnull);
if (isnull)
elog(ERROR, "null prosrc");
proc_source = TextDatumGetCString(prosrcdatum);
UTF_BEGIN;
Tcl_DStringAppend(&proc_internal_body, UTF_E2U(proc_source), -1);
UTF_END;
pfree(proc_source);
Tcl_DStringAppendElement(&proc_internal_def,
Tcl_DStringValue(&proc_internal_body));
Tcl_DStringFree(&proc_internal_body);
/************************************************************
* Create the procedure in the interpreter
************************************************************/
tcl_rc = Tcl_GlobalEval(interp,
Tcl_DStringValue(&proc_internal_def));
Tcl_DStringFree(&proc_internal_def);
if (tcl_rc != TCL_OK)
{
free(prodesc->user_proname);
free(prodesc->internal_proname);
free(prodesc);
UTF_BEGIN;
elog(ERROR, "could not create internal procedure \"%s\": %s",
internal_proname, UTF_U2E(Tcl_GetStringResult(interp)));
UTF_END;
}
/************************************************************
* Add the proc description block to the hashtable
************************************************************/
hashent = Tcl_CreateHashEntry(pltcl_proc_hash,
prodesc->internal_proname, &hashnew);
Tcl_SetHashValue(hashent, (ClientData) prodesc);
}
ReleaseSysCache(procTup);
return prodesc;
}
/**********************************************************************
* pltcl_elog() - elog() support for PLTcl
**********************************************************************/
static int
pltcl_elog(ClientData cdata, Tcl_Interp *interp,
int argc, CONST84 char *argv[])
{
volatile int level;
MemoryContext oldcontext;
if (argc != 3)
{
Tcl_SetResult(interp, "syntax error - 'elog level msg'", TCL_STATIC);
return TCL_ERROR;
}
if (strcmp(argv[1], "DEBUG") == 0)
level = DEBUG2;
else if (strcmp(argv[1], "LOG") == 0)
level = LOG;
else if (strcmp(argv[1], "INFO") == 0)
level = INFO;
else if (strcmp(argv[1], "NOTICE") == 0)
level = NOTICE;
else if (strcmp(argv[1], "WARNING") == 0)
level = WARNING;
else if (strcmp(argv[1], "ERROR") == 0)
level = ERROR;
else if (strcmp(argv[1], "FATAL") == 0)
level = FATAL;
else
{
Tcl_AppendResult(interp, "Unknown elog level '", argv[1],
"'", NULL);
return TCL_ERROR;
}
if (level == ERROR)
{
/*
* We just pass the error back to Tcl. If it's not caught,
* it'll eventually get converted to a PG error when we reach
* the call handler.
*/
Tcl_SetResult(interp, (char *) argv[2], TCL_VOLATILE);
return TCL_ERROR;
}
/*
* For non-error messages, just pass 'em to elog(). We do not expect
* that this will fail, but just on the off chance it does, report the
* error back to Tcl. Note we are assuming that elog() can't have any
* internal failures that are so bad as to require a transaction abort.
*
* This path is also used for FATAL errors, which aren't going to come
* back to us at all.
*/
oldcontext = CurrentMemoryContext;
PG_TRY();
{
UTF_BEGIN;
elog(level, "%s", UTF_U2E(argv[2]));
UTF_END;
}
PG_CATCH();
{
ErrorData *edata;
/* Must reset elog.c's state */
MemoryContextSwitchTo(oldcontext);
edata = CopyErrorData();
FlushErrorState();
/* Pass the error message to Tcl */
UTF_BEGIN;
Tcl_SetResult(interp, UTF_E2U(edata->message), TCL_VOLATILE);
UTF_END;
FreeErrorData(edata);
return TCL_ERROR;
}
PG_END_TRY();
return TCL_OK;
}
/**********************************************************************
* pltcl_quote() - quote literal strings that are to
* be used in SPI_execute query strings
**********************************************************************/
static int
pltcl_quote(ClientData cdata, Tcl_Interp *interp,
int argc, CONST84 char *argv[])
{
char *tmp;
const char *cp1;
char *cp2;
/************************************************************
* Check call syntax
************************************************************/
if (argc != 2)
{
Tcl_SetResult(interp, "syntax error - 'quote string'", TCL_STATIC);
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_argisnull() - determine if a specific argument is NULL
**********************************************************************/
static int
pltcl_argisnull(ClientData cdata, Tcl_Interp *interp,
int argc, CONST84 char *argv[])
{
int argno;
FunctionCallInfo fcinfo = pltcl_current_fcinfo;
/************************************************************
* Check call syntax
************************************************************/
if (argc != 2)
{
Tcl_SetResult(interp, "syntax error - 'argisnull argno'",
TCL_STATIC);
return TCL_ERROR;
}
/************************************************************
* Check that we're called as a normal function
************************************************************/
if (fcinfo == NULL)
{
Tcl_SetResult(interp, "argisnull cannot be used in triggers",
TCL_STATIC);
return TCL_ERROR;
}
/************************************************************
* Get the argument number
************************************************************/
if (Tcl_GetInt(interp, argv[1], &argno) != TCL_OK)
return TCL_ERROR;
/************************************************************
* Check that the argno is valid
************************************************************/
argno--;
if (argno < 0 || argno >= fcinfo->nargs)
{
Tcl_SetResult(interp, "argno out of range", TCL_STATIC);
return TCL_ERROR;
}
/************************************************************
* Get the requested NULL state
************************************************************/
if (PG_ARGISNULL(argno))
Tcl_SetResult(interp, "1", TCL_STATIC);
else
Tcl_SetResult(interp, "0", TCL_STATIC);
return TCL_OK;
}
/**********************************************************************
* pltcl_returnnull() - Cause a NULL return from a function
**********************************************************************/
static int
pltcl_returnnull(ClientData cdata, Tcl_Interp *interp,
int argc, CONST84 char *argv[])
{
FunctionCallInfo fcinfo = pltcl_current_fcinfo;
/************************************************************
* Check call syntax
************************************************************/
if (argc != 1)
{
Tcl_SetResult(interp, "syntax error - 'return_null'", TCL_STATIC);
return TCL_ERROR;
}
/************************************************************
* Check that we're called as a normal function
************************************************************/
if (fcinfo == NULL)
{
Tcl_SetResult(interp, "return_null cannot be used in triggers",
TCL_STATIC);
return TCL_ERROR;
}
/************************************************************
* Set the NULL return flag and cause Tcl to return from the
* procedure.
************************************************************/
fcinfo->isnull = true;
return TCL_RETURN;
}
/*----------
* Support for running SPI operations inside subtransactions
*
* Intended usage pattern is:
*
* MemoryContext oldcontext = CurrentMemoryContext;
* ResourceOwner oldowner = CurrentResourceOwner;
*
* ...
* pltcl_subtrans_begin(oldcontext, oldowner);
* PG_TRY();
* {
* do something risky;
* pltcl_subtrans_commit(oldcontext, oldowner);
* }
* PG_CATCH();
* {
* pltcl_subtrans_abort(interp, oldcontext, oldowner);
* return TCL_ERROR;
* }
* PG_END_TRY();
* return TCL_OK;
*----------
*/
static void
pltcl_subtrans_begin(MemoryContext oldcontext, ResourceOwner oldowner)
{
BeginInternalSubTransaction(NULL);
/* Want to run inside function's memory context */
MemoryContextSwitchTo(oldcontext);
}
static void
pltcl_subtrans_commit(MemoryContext oldcontext, ResourceOwner oldowner)
{
/* Commit the inner transaction, return to outer xact context */
ReleaseCurrentSubTransaction();
MemoryContextSwitchTo(oldcontext);
CurrentResourceOwner = oldowner;
/*
* AtEOSubXact_SPI() should not have popped any SPI context, but just in
* case it did, make sure we remain connected.
*/
SPI_restore_connection();
}
static void
pltcl_subtrans_abort(Tcl_Interp *interp,
MemoryContext oldcontext, ResourceOwner oldowner)
{
ErrorData *edata;
/* Save error info */
MemoryContextSwitchTo(oldcontext);
edata = CopyErrorData();
FlushErrorState();
/* Abort the inner transaction */
RollbackAndReleaseCurrentSubTransaction();
MemoryContextSwitchTo(oldcontext);
CurrentResourceOwner = oldowner;
/*
* If AtEOSubXact_SPI() popped any SPI context of the subxact, it will
* have left us in a disconnected state. We need this hack to return to
* connected state.
*/
SPI_restore_connection();
/* Pass the error message to Tcl */
UTF_BEGIN;
Tcl_SetResult(interp, UTF_E2U(edata->message), TCL_VOLATILE);
UTF_END;
FreeErrorData(edata);
}
/**********************************************************************
* pltcl_SPI_execute() - The builtin SPI_execute command
* for the Tcl interpreter
**********************************************************************/
static int
pltcl_SPI_execute(ClientData cdata, Tcl_Interp *interp,
int argc, CONST84 char *argv[])
{
int my_rc;
int spi_rc;
int query_idx;
int i;
int count = 0;
CONST84 char *volatile arrayname = NULL;
CONST84 char *volatile loop_body = NULL;
MemoryContext oldcontext = CurrentMemoryContext;
ResourceOwner oldowner = CurrentResourceOwner;
char *usage = "syntax error - 'SPI_exec "
"?-count n? "
"?-array name? query ?loop body?";
/************************************************************
* Check the call syntax and get the options
************************************************************/
if (argc < 2)
{
Tcl_SetResult(interp, usage, TCL_STATIC);
return TCL_ERROR;
}
i = 1;
while (i < argc)
{
if (strcmp(argv[i], "-array") == 0)
{
if (++i >= argc)
{
Tcl_SetResult(interp, usage, TCL_STATIC);
return TCL_ERROR;
}
arrayname = argv[i++];
continue;
}
if (strcmp(argv[i], "-count") == 0)
{
if (++i >= argc)
{
Tcl_SetResult(interp, usage, TCL_STATIC);
return TCL_ERROR;
}
if (Tcl_GetInt(interp, argv[i++], &count) != TCL_OK)
return TCL_ERROR;
continue;
}
break;
}
query_idx = i;
if (query_idx >= argc || query_idx + 2 < argc)
{
Tcl_SetResult(interp, usage, TCL_STATIC);
return TCL_ERROR;
}
if (query_idx + 1 < argc)
loop_body = argv[query_idx + 1];
/************************************************************
* Execute the query inside a sub-transaction, so we can cope with
* errors sanely
************************************************************/
pltcl_subtrans_begin(oldcontext, oldowner);
PG_TRY();
{
UTF_BEGIN;
spi_rc = SPI_execute(UTF_U2E(argv[query_idx]),
pltcl_current_prodesc->fn_readonly, count);
UTF_END;
my_rc = pltcl_process_SPI_result(interp,
arrayname,
loop_body,
spi_rc,
SPI_tuptable,
SPI_processed);
pltcl_subtrans_commit(oldcontext, oldowner);
}
PG_CATCH();
{
pltcl_subtrans_abort(interp, oldcontext, oldowner);
return TCL_ERROR;
}
PG_END_TRY();
return my_rc;
}
/*
* Process the result from SPI_execute or SPI_execute_plan
*
* Shared code between pltcl_SPI_execute and pltcl_SPI_execute_plan
*/
static int
pltcl_process_SPI_result(Tcl_Interp *interp,
CONST84 char *arrayname,
CONST84 char *loop_body,
int spi_rc,
SPITupleTable *tuptable,
int ntuples)
{
int my_rc = TCL_OK;
char buf[64];
int i;
int loop_rc;
HeapTuple *tuples;
TupleDesc tupdesc;
switch (spi_rc)
{
case SPI_OK_SELINTO:
case SPI_OK_INSERT:
case SPI_OK_DELETE:
case SPI_OK_UPDATE:
snprintf(buf, sizeof(buf), "%d", ntuples);
Tcl_SetResult(interp, buf, TCL_VOLATILE);
break;
case SPI_OK_UTILITY:
case SPI_OK_REWRITTEN:
if (tuptable == NULL)
{
Tcl_SetResult(interp, "0", TCL_STATIC);
break;
}
/* FALL THRU for utility returning tuples */
case SPI_OK_SELECT:
case SPI_OK_INSERT_RETURNING:
case SPI_OK_DELETE_RETURNING:
case SPI_OK_UPDATE_RETURNING:
/*
* Process the tuples we got
*/
tuples = tuptable->vals;
tupdesc = tuptable->tupdesc;
if (loop_body == NULL)
{
/*
* If there is no loop body given, just set the variables from
* the first tuple (if any)
*/
if (ntuples > 0)
pltcl_set_tuple_values(interp, arrayname, 0,
tuples[0], tupdesc);
}
else
{
/*
* 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, loop_body);
if (loop_rc == TCL_OK)
continue;
if (loop_rc == TCL_CONTINUE)
continue;
if (loop_rc == TCL_RETURN)
{
my_rc = TCL_RETURN;
break;
}
if (loop_rc == TCL_BREAK)
break;
my_rc = TCL_ERROR;
break;
}
}
if (my_rc == TCL_OK)
{
snprintf(buf, sizeof(buf), "%d", ntuples);
Tcl_SetResult(interp, buf, TCL_VOLATILE);
}
break;
default:
Tcl_AppendResult(interp, "pltcl: SPI_execute failed: ",
SPI_result_code_string(spi_rc), NULL);
my_rc = TCL_ERROR;
break;
}
SPI_freetuptable(tuptable);
return my_rc;
}
/**********************************************************************
* pltcl_SPI_prepare() - Builtin support for prepared plans
* The Tcl command SPI_prepare
* always 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, CONST84 char *argv[])
{
int nargs;
CONST84 char **args;
pltcl_query_desc *qdesc;
void *plan;
int i;
Tcl_HashEntry *hashent;
int hashnew;
Tcl_HashTable *query_hash;
MemoryContext oldcontext = CurrentMemoryContext;
ResourceOwner oldowner = CurrentResourceOwner;
/************************************************************
* Check the call syntax
************************************************************/
if (argc != 3)
{
Tcl_SetResult(interp, "syntax error - 'SPI_prepare query argtypes'",
TCL_STATIC);
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));
snprintf(qdesc->qname, sizeof(qdesc->qname), "%lx", (long) qdesc);
qdesc->nargs = nargs;
qdesc->argtypes = (Oid *) malloc(nargs * sizeof(Oid));
qdesc->arginfuncs = (FmgrInfo *) malloc(nargs * sizeof(FmgrInfo));
qdesc->argtypioparams = (Oid *) malloc(nargs * sizeof(Oid));
/************************************************************
* Execute the prepare inside a sub-transaction, so we can cope with
* errors sanely
************************************************************/
pltcl_subtrans_begin(oldcontext, oldowner);
PG_TRY();
{
/************************************************************
* Resolve argument type names and then look them up by oid
* in the system cache, and remember the required information
* for input conversion.
************************************************************/
for (i = 0; i < nargs; i++)
{
Oid typId,
typInput,
typIOParam;
int32 typmod;
parseTypeString(args[i], &typId, &typmod);
getTypeInputInfo(typId, &typInput, &typIOParam);
qdesc->argtypes[i] = typId;
perm_fmgr_info(typInput, &(qdesc->arginfuncs[i]));
qdesc->argtypioparams[i] = typIOParam;
}
/************************************************************
* Prepare the plan and check for errors
************************************************************/
UTF_BEGIN;
plan = SPI_prepare(UTF_U2E(argv[1]), nargs, qdesc->argtypes);
UTF_END;
if (plan == NULL)
elog(ERROR, "SPI_prepare() failed");
/************************************************************
* Save the plan into permanent memory (right now it's in the
* SPI procCxt, which will go away at function end).
************************************************************/
qdesc->plan = SPI_saveplan(plan);
if (qdesc->plan == NULL)
elog(ERROR, "SPI_saveplan() failed");
/* Release the procCxt copy to avoid within-function memory leak */
SPI_freeplan(plan);
pltcl_subtrans_commit(oldcontext, oldowner);
}
PG_CATCH();
{
pltcl_subtrans_abort(interp, oldcontext, oldowner);
free(qdesc->argtypes);
free(qdesc->arginfuncs);
free(qdesc->argtypioparams);
free(qdesc);
ckfree((char *) args);
return TCL_ERROR;
}
PG_END_TRY();
/************************************************************
* Insert a hashtable entry for the plan and return
* the key to the caller
************************************************************/
if (interp == pltcl_norm_interp)
query_hash = pltcl_norm_query_hash;
else
query_hash = pltcl_safe_query_hash;
hashent = Tcl_CreateHashEntry(query_hash, qdesc->qname, &hashnew);
Tcl_SetHashValue(hashent, (ClientData) qdesc);
ckfree((char *) args);
/* qname is ASCII, so no need for encoding conversion */
Tcl_SetResult(interp, qdesc->qname, TCL_VOLATILE);
return TCL_OK;
}
/**********************************************************************
* pltcl_SPI_execute_plan() - Execute a prepared plan
**********************************************************************/
static int
pltcl_SPI_execute_plan(ClientData cdata, Tcl_Interp *interp,
int argc, CONST84 char *argv[])
{
int my_rc;
int spi_rc;
int i;
int j;
Tcl_HashEntry *hashent;
pltcl_query_desc *qdesc;
const char *volatile nulls = NULL;
CONST84 char *volatile arrayname = NULL;
CONST84 char *volatile loop_body = NULL;
int count = 0;
int callnargs;
CONST84 char **callargs = NULL;
Datum *argvalues;
MemoryContext oldcontext = CurrentMemoryContext;
ResourceOwner oldowner = CurrentResourceOwner;
Tcl_HashTable *query_hash;
char *usage = "syntax error - 'SPI_execp "
"?-nulls string? ?-count n? "
"?-array name? query ?args? ?loop body?";
/************************************************************
* 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_STATIC);
return TCL_ERROR;
}
arrayname = argv[i++];
continue;
}
if (strcmp(argv[i], "-nulls") == 0)
{
if (++i >= argc)
{
Tcl_SetResult(interp, usage, TCL_STATIC);
return TCL_ERROR;
}
nulls = argv[i++];
continue;
}
if (strcmp(argv[i], "-count") == 0)
{
if (++i >= argc)
{
Tcl_SetResult(interp, usage, TCL_STATIC);
return TCL_ERROR;
}
if (Tcl_GetInt(interp, argv[i++], &count) != TCL_OK)
return TCL_ERROR;
continue;
}
break;
}
/************************************************************
* Get the prepared plan descriptor by its key
************************************************************/
if (i >= argc)
{
Tcl_SetResult(interp, usage, TCL_STATIC);
return TCL_ERROR;
}
if (interp == pltcl_norm_interp)
query_hash = pltcl_norm_query_hash;
else
query_hash = pltcl_safe_query_hash;
hashent = Tcl_FindHashEntry(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);
i++;
/************************************************************
* 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_STATIC);
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_STATIC);
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_STATIC);
ckfree((char *) callargs);
return TCL_ERROR;
}
}
else
callnargs = 0;
/************************************************************
* Get loop body if present
************************************************************/
if (i < argc)
loop_body = argv[i++];
if (i != argc)
{
Tcl_SetResult(interp, usage, TCL_STATIC);
return TCL_ERROR;
}
/************************************************************
* Execute the plan inside a sub-transaction, so we can cope with
* errors sanely
************************************************************/
pltcl_subtrans_begin(oldcontext, oldowner);
PG_TRY();
{
/************************************************************
* Setup the value array for SPI_execute_plan() using
* the type specific input functions
************************************************************/
argvalues = (Datum *) palloc(callnargs * sizeof(Datum));
for (j = 0; j < callnargs; j++)
{
if (nulls && nulls[j] == 'n')
{
argvalues[j] = InputFunctionCall(&qdesc->arginfuncs[j],
NULL,
qdesc->argtypioparams[j],
-1);
}
else
{
UTF_BEGIN;
argvalues[j] = InputFunctionCall(&qdesc->arginfuncs[j],
(char *) UTF_U2E(callargs[j]),
qdesc->argtypioparams[j],
-1);
UTF_END;
}
}
if (callargs)
ckfree((char *) callargs);
callargs = NULL;
/************************************************************
* Execute the plan
************************************************************/
spi_rc = SPI_execute_plan(qdesc->plan, argvalues, nulls,
pltcl_current_prodesc->fn_readonly, count);
my_rc = pltcl_process_SPI_result(interp,
arrayname,
loop_body,
spi_rc,
SPI_tuptable,
SPI_processed);
pltcl_subtrans_commit(oldcontext, oldowner);
}
PG_CATCH();
{
pltcl_subtrans_abort(interp, oldcontext, oldowner);
if (callargs)
ckfree((char *) callargs);
return TCL_ERROR;
}
PG_END_TRY();
return my_rc;
}
/**********************************************************************
* pltcl_SPI_lastoid() - return the last oid. To
* be used after insert queries
**********************************************************************/
static int
pltcl_SPI_lastoid(ClientData cdata, Tcl_Interp *interp,
int argc, CONST84 char *argv[])
{
char buf[64];
snprintf(buf, sizeof(buf), "%u", SPI_lastoid);
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, CONST84 char *arrayname,
int tupno, HeapTuple tuple, TupleDesc tupdesc)
{
int i;
char *outputstr;
char buf[64];
Datum attr;
bool isnull;
CONST84 char *attname;
HeapTuple typeTup;
Oid typoutput;
CONST84 char **arrptr;
CONST84 char **nameptr;
CONST84 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;
snprintf(buf, sizeof(buf), "%d", tupno);
Tcl_SetVar2(interp, arrayname, ".tupno", buf, 0);
}
for (i = 0; i < tupdesc->natts; i++)
{
/* ignore dropped attributes */
if (tupdesc->attrs[i]->attisdropped)
continue;
/************************************************************
* Get the attribute name
************************************************************/
attname = NameStr(tupdesc->attrs[i]->attname);
/************************************************************
* Get the attributes value
************************************************************/
attr = heap_getattr(tuple, i + 1, tupdesc, &isnull);
/************************************************************
* Lookup the attribute type in the syscache
* for the output function
************************************************************/
typeTup = SearchSysCache(TYPEOID,
ObjectIdGetDatum(tupdesc->attrs[i]->atttypid),
0, 0, 0);
if (!HeapTupleIsValid(typeTup))
elog(ERROR, "cache lookup failed for type %u",
tupdesc->attrs[i]->atttypid);
typoutput = ((Form_pg_type) GETSTRUCT(typeTup))->typoutput;
ReleaseSysCache(typeTup);
/************************************************************
* 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))
{
outputstr = OidOutputFunctionCall(typoutput, attr);
UTF_BEGIN;
Tcl_SetVar2(interp, *arrptr, *nameptr, UTF_E2U(outputstr), 0);
UTF_END;
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;
for (i = 0; i < tupdesc->natts; i++)
{
/* ignore dropped attributes */
if (tupdesc->attrs[i]->attisdropped)
continue;
/************************************************************
* Get the attribute name
************************************************************/
attname = NameStr(tupdesc->attrs[i]->attname);
/************************************************************
* Get the attributes value
************************************************************/
attr = heap_getattr(tuple, i + 1, tupdesc, &isnull);
/************************************************************
* Lookup the attribute type in the syscache
* for the output function
************************************************************/
typeTup = SearchSysCache(TYPEOID,
ObjectIdGetDatum(tupdesc->attrs[i]->atttypid),
0, 0, 0);
if (!HeapTupleIsValid(typeTup))
elog(ERROR, "cache lookup failed for type %u",
tupdesc->attrs[i]->atttypid);
typoutput = ((Form_pg_type) GETSTRUCT(typeTup))->typoutput;
ReleaseSysCache(typeTup);
/************************************************************
* 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))
{
outputstr = OidOutputFunctionCall(typoutput, attr);
Tcl_DStringAppendElement(retval, attname);
UTF_BEGIN;
Tcl_DStringAppendElement(retval, UTF_E2U(outputstr));
UTF_END;
pfree(outputstr);
}
}
}
Reference in New Issue View Git Blame Copy Permalink