From 26abb50c490dee191df21282bc940b94118550aa Mon Sep 17 00:00:00 2001
From: Tom Lane <tgl@sss.pgh.pa.us>
Date: Sun, 6 Nov 2016 17:56:05 -0500
Subject: [PATCH] Support PL/Tcl functions that return composite types and/or
sets.
Jim Nasby, rather heavily editorialized by me
Patch: <f2134651-14b3-efeb-f274-c69f3c084031@BlueTreble.com>
---
doc/src/sgml/pltcl.sgml | 73 ++++-
src/pl/tcl/expected/pltcl_queries.out | 61 ++++
src/pl/tcl/expected/pltcl_setup.out | 13 +
src/pl/tcl/pltcl.c | 430 ++++++++++++++++++++++----
src/pl/tcl/sql/pltcl_queries.sql | 33 ++
src/pl/tcl/sql/pltcl_setup.sql | 16 +
6 files changed, 545 insertions(+), 81 deletions(-)
diff --git a/doc/src/sgml/pltcl.sgml b/doc/src/sgml/pltcl.sgml
index 52fc44940c2..8afaf4ad36e 100644
--- a/doc/src/sgml/pltcl.sgml
+++ b/doc/src/sgml/pltcl.sgml
@@ -94,11 +94,11 @@ $$ LANGUAGE pltcl;
<para>
The body of the function is simply a piece of Tcl script.
- When the function is called, the argument values are passed as
- variables <literal>$1</literal> ... <literal>$<replaceable>n</replaceable></literal> to the
- Tcl script. The result is returned
- from the Tcl code in the usual way, with a <literal>return</literal>
- statement.
+ When the function is called, the argument values are passed to the
+ Tcl script as variables named <literal>1</literal>
+ ... <literal><replaceable>n</replaceable></literal>. The result is
+ returned from the Tcl code in the usual way, with
+ a <literal>return</literal> statement.
</para>
<para>
@@ -173,17 +173,57 @@ $$ LANGUAGE pltcl;
</para>
<para>
- There is currently no support for returning a composite-type
- result value, nor for returning sets.
+ PL/Tcl functions can return composite-type results, too. To do this,
+ the Tcl code must return a list of column name/value pairs matching
+ the expected result type. Any column names omitted from the list
+ are returned as nulls, and an error is raised if there are unexpected
+ column names. Here is an example:
+
+<programlisting>
+CREATE FUNCTION square_cube(in int, out squared int, out cubed int) AS $$
+ return [list squared [expr {$1 * $1}] cubed [expr {$1 * $1 * $1}]]
+$$ LANGUAGE pltcl;
+</programlisting>
</para>
+ <tip>
+ <para>
+ The result list can be made from an array representation of the
+ desired tuple with the <literal>array get</> Tcl command. For example:
+
+<programlisting>
+CREATE FUNCTION raise_pay(employee, delta int) RETURNS employee AS $$
+ set 1(salary) [expr {$1(salary) + $2}]
+ return [array get 1]
+$$ LANGUAGE pltcl;
+</programlisting>
+ </para>
+ </tip>
+
<para>
- <application>PL/Tcl</> does not currently have full support for
- domain types: it treats a domain the same as the underlying scalar
- type. This means that constraints associated with the domain will
- not be enforced. This is not an issue for function arguments, but
- it is a hazard if you declare a <application>PL/Tcl</> function
- as returning a domain type.
+ PL/Tcl functions can return sets. To do this, the Tcl code should
+ call <function>return_next</function> once per row to be returned,
+ passing either the appropriate value when returning a scalar type,
+ or a list of column name/value pairs when returning a composite type.
+ Here is an example returning a scalar type:
+
+<programlisting>
+CREATE FUNCTION sequence(int, int) RETURNS SETOF int AS $$
+ for {set i $1} {$i < $2} {incr i} {
+ return_next $i
+ }
+$$ LANGUAGE pltcl;
+</programlisting>
+
+ and here is one returning a composite type:
+
+<programlisting>
+CREATE FUNCTION table_of_squares(int, int) RETURNS TABLE (x int, x2 int) AS $$
+ for {set i $1} {$i < $2} {incr i} {
+ return_next [list x $i x2 [expr {$i * $i}]]
+ }
+$$ LANGUAGE pltcl;
+</programlisting>
</para>
</sect1>
@@ -195,10 +235,9 @@ $$ LANGUAGE pltcl;
The argument values supplied to a PL/Tcl function's code are simply
the input arguments converted to text form (just as if they had been
displayed by a <command>SELECT</> statement). Conversely, the
- <literal>return</>
- command will accept any string that is acceptable input format for
- the function's declared return type. So, within the PL/Tcl function,
- all values are just text strings.
+ <literal>return</> and <literal>return_next</> commands will accept
+ any string that is acceptable input format for the function's declared
+ result type, or for the specified column of a composite result type.
</para>
</sect1>
diff --git a/src/pl/tcl/expected/pltcl_queries.out b/src/pl/tcl/expected/pltcl_queries.out
index 6cb1fdbb611..3a9fef34477 100644
--- a/src/pl/tcl/expected/pltcl_queries.out
+++ b/src/pl/tcl/expected/pltcl_queries.out
@@ -303,3 +303,64 @@ select tcl_lastoid('t2') > 0;
t
(1 row)
+-- test some error cases
+CREATE FUNCTION tcl_error(OUT a int, OUT b int) AS $$return {$$ LANGUAGE pltcl;
+SELECT tcl_error();
+ERROR: missing close-brace
+CREATE FUNCTION bad_record(OUT a text, OUT b text) AS $$return [list a]$$ LANGUAGE pltcl;
+SELECT bad_record();
+ERROR: column name/value list must have even number of elements
+CREATE FUNCTION bad_field(OUT a text, OUT b text) AS $$return [list a 1 b 2 cow 3]$$ LANGUAGE pltcl;
+SELECT bad_field();
+ERROR: column name/value list contains nonexistent column name "cow"
+-- test compound return
+select * from tcl_test_cube_squared(5);
+ squared | cubed
+---------+-------
+ 25 | 125
+(1 row)
+
+-- test SRF
+select * from tcl_test_squared_rows(0,5);
+ x | y
+---+----
+ 0 | 0
+ 1 | 1
+ 2 | 4
+ 3 | 9
+ 4 | 16
+(5 rows)
+
+select * from tcl_test_sequence(0,5) as a;
+ a
+---
+ 0
+ 1
+ 2
+ 3
+ 4
+(5 rows)
+
+select 1, tcl_test_sequence(0,5);
+ ?column? | tcl_test_sequence
+----------+-------------------
+ 1 | 0
+ 1 | 1
+ 1 | 2
+ 1 | 3
+ 1 | 4
+(5 rows)
+
+CREATE FUNCTION non_srf() RETURNS int AS $$return_next 1$$ LANGUAGE pltcl;
+select non_srf();
+ERROR: return_next cannot be used in non-set-returning functions
+CREATE FUNCTION bad_record_srf(OUT a text, OUT b text) RETURNS SETOF record AS $$
+return_next [list a]
+$$ LANGUAGE pltcl;
+SELECT bad_record_srf();
+ERROR: column name/value list must have even number of elements
+CREATE FUNCTION bad_field_srf(OUT a text, OUT b text) RETURNS SETOF record AS $$
+return_next [list a 1 b 2 cow 3]
+$$ LANGUAGE pltcl;
+SELECT bad_field_srf();
+ERROR: column name/value list contains nonexistent column name "cow"
diff --git a/src/pl/tcl/expected/pltcl_setup.out b/src/pl/tcl/expected/pltcl_setup.out
index e65e9e3ff71..ed99d9b4922 100644
--- a/src/pl/tcl/expected/pltcl_setup.out
+++ b/src/pl/tcl/expected/pltcl_setup.out
@@ -555,6 +555,19 @@ NOTICE: tclsnitch: ddl_command_start DROP TABLE
NOTICE: tclsnitch: ddl_command_end DROP TABLE
drop event trigger tcl_a_snitch;
drop event trigger tcl_b_snitch;
+CREATE FUNCTION tcl_test_cube_squared(in int, out squared int, out cubed int) AS $$
+ return [list squared [expr {$1 * $1}] cubed [expr {$1 * $1 * $1}]]
+$$ language pltcl;
+CREATE FUNCTION tcl_test_squared_rows(int,int) RETURNS TABLE (x int, y int) AS $$
+ for {set i $1} {$i < $2} {incr i} {
+ return_next [list y [expr {$i * $i}] x $i]
+ }
+$$ language pltcl;
+CREATE FUNCTION tcl_test_sequence(int,int) RETURNS SETOF int AS $$
+ for {set i $1} {$i < $2} {incr i} {
+ return_next $i
+ }
+$$ language pltcl;
-- test use of errorCode in error handling
create function tcl_error_handling_test() returns text as $$
global errorCode
diff --git a/src/pl/tcl/pltcl.c b/src/pl/tcl/pltcl.c
index 97d1f7ef7d3..3d529c2e7df 100644
--- a/src/pl/tcl/pltcl.c
+++ b/src/pl/tcl/pltcl.c
@@ -21,6 +21,7 @@
#include "commands/trigger.h"
#include "executor/spi.h"
#include "fmgr.h"
+#include "funcapi.h"
#include "mb/pg_wchar.h"
#include "miscadmin.h"
#include "nodes/makefuncs.h"
@@ -123,6 +124,9 @@ typedef struct pltcl_interp_desc
* problem to manage its memory when we replace a proc definition. We do
* not clean up pltcl_proc_descs when a pg_proc row is deleted, only when
* it is updated, and the same policy applies to Tcl's copy as well.)
+ *
+ * Note that the data in this struct is shared across all active calls;
+ * nothing except the fn_refcount should be changed by a call instance.
**********************************************************************/
typedef struct pltcl_proc_desc
{
@@ -137,6 +141,8 @@ typedef struct pltcl_proc_desc
pltcl_interp_desc *interp_desc; /* interpreter to use */
FmgrInfo result_in_func; /* input function for fn's result type */
Oid result_typioparam; /* param to pass to same */
+ bool fn_retisset; /* true if function returns a set */
+ bool fn_retistuple; /* true if function returns composite */
int nargs; /* number of arguments */
/* these arrays have nargs entries: */
FmgrInfo *arg_out_func; /* output fns for arg types */
@@ -188,6 +194,32 @@ typedef struct pltcl_proc_ptr
} pltcl_proc_ptr;
+/**********************************************************************
+ * Per-call state
+ **********************************************************************/
+typedef struct pltcl_call_state
+{
+ /* Call info struct, or NULL in a trigger */
+ FunctionCallInfo fcinfo;
+
+ /* Function we're executing (NULL if not yet identified) */
+ pltcl_proc_desc *prodesc;
+
+ /*
+ * Information for SRFs and functions returning composite types.
+ * ret_tupdesc and attinmeta are set up if either fn_retistuple or
+ * fn_retisset, since even a scalar-returning SRF needs a tuplestore.
+ */
+ TupleDesc ret_tupdesc; /* return rowtype, if retistuple or retisset */
+ AttInMetadata *attinmeta; /* metadata for building tuples of that type */
+
+ ReturnSetInfo *rsi; /* passed-in ReturnSetInfo, if any */
+ Tuplestorestate *tuple_store; /* SRFs accumulate result here */
+ MemoryContext tuple_store_cxt; /* context and resowner for tuplestore */
+ ResourceOwner tuple_store_owner;
+} pltcl_call_state;
+
+
/**********************************************************************
* Global data
**********************************************************************/
@@ -196,9 +228,8 @@ static Tcl_Interp *pltcl_hold_interp = NULL;
static HTAB *pltcl_interp_htab = NULL;
static HTAB *pltcl_proc_htab = NULL;
-/* these are saved and restored by pltcl_handler */
-static FunctionCallInfo pltcl_current_fcinfo = NULL;
-static pltcl_proc_desc *pltcl_current_prodesc = NULL;
+/* this is saved and restored by pltcl_handler */
+static pltcl_call_state *pltcl_current_call_state = NULL;
/**********************************************************************
* Lookup table for SQLSTATE condition names
@@ -225,10 +256,12 @@ static void pltcl_init_load_unknown(Tcl_Interp *interp);
static Datum pltcl_handler(PG_FUNCTION_ARGS, bool pltrusted);
-static Datum pltcl_func_handler(PG_FUNCTION_ARGS, bool pltrusted);
-
-static HeapTuple pltcl_trigger_handler(PG_FUNCTION_ARGS, bool pltrusted);
-static void pltcl_event_trigger_handler(PG_FUNCTION_ARGS, bool pltrusted);
+static Datum pltcl_func_handler(PG_FUNCTION_ARGS, pltcl_call_state *call_state,
+ bool pltrusted);
+static HeapTuple pltcl_trigger_handler(PG_FUNCTION_ARGS, pltcl_call_state *call_state,
+ bool pltrusted);
+static void pltcl_event_trigger_handler(PG_FUNCTION_ARGS, pltcl_call_state *call_state,
+ bool pltrusted);
static void throw_tcl_error(Tcl_Interp *interp, const char *proname);
@@ -246,7 +279,8 @@ static int pltcl_argisnull(ClientData cdata, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[]);
static int pltcl_returnnull(ClientData cdata, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[]);
-
+static int pltcl_returnnext(ClientData cdata, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const objv[]);
static int pltcl_SPI_execute(ClientData cdata, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[]);
static int pltcl_process_SPI_result(Tcl_Interp *interp,
@@ -265,6 +299,10 @@ static int pltcl_SPI_lastoid(ClientData cdata, Tcl_Interp *interp,
static void pltcl_set_tuple_values(Tcl_Interp *interp, const char *arrayname,
uint64 tupno, HeapTuple tuple, TupleDesc tupdesc);
static Tcl_Obj *pltcl_build_tuple_argument(HeapTuple tuple, TupleDesc tupdesc);
+static HeapTuple pltcl_build_tuple_result(Tcl_Interp *interp,
+ Tcl_Obj **kvObjv, int kvObjc,
+ pltcl_call_state *call_state);
+static void pltcl_init_tuple_store(pltcl_call_state *call_state);
/*
@@ -432,7 +470,8 @@ pltcl_init_interp(pltcl_interp_desc *interp_desc, bool pltrusted)
pltcl_argisnull, NULL, NULL);
Tcl_CreateObjCommand(interp, "return_null",
pltcl_returnnull, NULL, NULL);
-
+ Tcl_CreateObjCommand(interp, "return_next",
+ pltcl_returnnext, NULL, NULL);
Tcl_CreateObjCommand(interp, "spi_exec",
pltcl_SPI_execute, NULL, NULL);
Tcl_CreateObjCommand(interp, "spi_prepare",
@@ -625,29 +664,33 @@ pltclu_call_handler(PG_FUNCTION_ARGS)
}
+/**********************************************************************
+ * pltcl_handler() - Handler for function and trigger calls, for
+ * both trusted and untrusted interpreters.
+ **********************************************************************/
static Datum
pltcl_handler(PG_FUNCTION_ARGS, bool pltrusted)
{
Datum retval;
- FunctionCallInfo save_fcinfo;
- pltcl_proc_desc *save_prodesc;
- pltcl_proc_desc *this_prodesc;
+ pltcl_call_state current_call_state;
+ pltcl_call_state *save_call_state;
/*
- * Ensure that static pointers are saved/restored properly
+ * Initialize current_call_state to nulls/zeroes; in particular, set its
+ * prodesc pointer to null. Anything that sets it non-null should
+ * increase the prodesc's fn_refcount at the same time. We'll decrease
+ * the refcount, and then delete the prodesc if it's no longer referenced,
+ * on the way out of this function. This ensures that prodescs live as
+ * long as needed even if somebody replaces the originating pg_proc row
+ * while they're executing.
*/
- save_fcinfo = pltcl_current_fcinfo;
- save_prodesc = pltcl_current_prodesc;
+ memset(¤t_call_state, 0, sizeof(current_call_state));
/*
- * Reset pltcl_current_prodesc to null. Anything that sets it non-null
- * should increase the prodesc's fn_refcount at the same time. We'll
- * decrease the refcount, and then delete the prodesc if it's no longer
- * referenced, on the way out of this function. This ensures that
- * prodescs live as long as needed even if somebody replaces the
- * originating pg_proc row while they're executing.
+ * Ensure that static pointer is saved/restored properly
*/
- pltcl_current_prodesc = NULL;
+ save_call_state = pltcl_current_call_state;
+ pltcl_current_call_state = ¤t_call_state;
PG_TRY();
{
@@ -657,47 +700,46 @@ pltcl_handler(PG_FUNCTION_ARGS, bool pltrusted)
*/
if (CALLED_AS_TRIGGER(fcinfo))
{
- pltcl_current_fcinfo = NULL;
- retval = PointerGetDatum(pltcl_trigger_handler(fcinfo, pltrusted));
+ /* invoke the trigger handler */
+ retval = PointerGetDatum(pltcl_trigger_handler(fcinfo,
+ ¤t_call_state,
+ pltrusted));
}
else if (CALLED_AS_EVENT_TRIGGER(fcinfo))
{
- pltcl_current_fcinfo = NULL;
- pltcl_event_trigger_handler(fcinfo, pltrusted);
+ /* invoke the event trigger handler */
+ pltcl_event_trigger_handler(fcinfo, ¤t_call_state, pltrusted);
retval = (Datum) 0;
}
else
{
- pltcl_current_fcinfo = fcinfo;
- retval = pltcl_func_handler(fcinfo, pltrusted);
+ /* invoke the regular function handler */
+ current_call_state.fcinfo = fcinfo;
+ retval = pltcl_func_handler(fcinfo, ¤t_call_state, pltrusted);
}
}
PG_CATCH();
{
- /* Restore globals, then clean up the prodesc refcount if any */
- this_prodesc = pltcl_current_prodesc;
- pltcl_current_fcinfo = save_fcinfo;
- pltcl_current_prodesc = save_prodesc;
- if (this_prodesc != NULL)
+ /* Restore static pointer, then clean up the prodesc refcount if any */
+ pltcl_current_call_state = save_call_state;
+ if (current_call_state.prodesc != NULL)
{
- Assert(this_prodesc->fn_refcount > 0);
- if (--this_prodesc->fn_refcount == 0)
- MemoryContextDelete(this_prodesc->fn_cxt);
+ Assert(current_call_state.prodesc->fn_refcount > 0);
+ if (--current_call_state.prodesc->fn_refcount == 0)
+ MemoryContextDelete(current_call_state.prodesc->fn_cxt);
}
PG_RE_THROW();
}
PG_END_TRY();
- /* Restore globals, then clean up the prodesc refcount if any */
+ /* Restore static pointer, then clean up the prodesc refcount if any */
/* (We're being paranoid in case an error is thrown in context deletion) */
- this_prodesc = pltcl_current_prodesc;
- pltcl_current_fcinfo = save_fcinfo;
- pltcl_current_prodesc = save_prodesc;
- if (this_prodesc != NULL)
+ pltcl_current_call_state = save_call_state;
+ if (current_call_state.prodesc != NULL)
{
- Assert(this_prodesc->fn_refcount > 0);
- if (--this_prodesc->fn_refcount == 0)
- MemoryContextDelete(this_prodesc->fn_cxt);
+ Assert(current_call_state.prodesc->fn_refcount > 0);
+ if (--current_call_state.prodesc->fn_refcount == 0)
+ MemoryContextDelete(current_call_state.prodesc->fn_cxt);
}
return retval;
@@ -708,7 +750,8 @@ pltcl_handler(PG_FUNCTION_ARGS, bool pltrusted)
* pltcl_func_handler() - Handler for regular function calls
**********************************************************************/
static Datum
-pltcl_func_handler(PG_FUNCTION_ARGS, bool pltrusted)
+pltcl_func_handler(PG_FUNCTION_ARGS, pltcl_call_state *call_state,
+ bool pltrusted)
{
pltcl_proc_desc *prodesc;
Tcl_Interp *volatile interp;
@@ -725,11 +768,32 @@ pltcl_func_handler(PG_FUNCTION_ARGS, bool pltrusted)
prodesc = compile_pltcl_function(fcinfo->flinfo->fn_oid, InvalidOid,
false, pltrusted);
- pltcl_current_prodesc = prodesc;
+ call_state->prodesc = prodesc;
prodesc->fn_refcount++;
interp = prodesc->interp_desc->interp;
+ /*
+ * If we're a SRF, check caller can handle materialize mode, and save
+ * relevant info into call_state. We must ensure that the returned
+ * tuplestore is owned by the caller's context, even if we first create it
+ * inside a subtransaction.
+ */
+ if (prodesc->fn_retisset)
+ {
+ ReturnSetInfo *rsi = (ReturnSetInfo *) fcinfo->resultinfo;
+
+ if (!rsi || !IsA(rsi, ReturnSetInfo) ||
+ (rsi->allowedModes & SFRM_Materialize) == 0)
+ ereport(ERROR,
+ (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
+ errmsg("set-valued function called in context that cannot accept a set")));
+
+ call_state->rsi = rsi;
+ call_state->tuple_store_cxt = rsi->econtext->ecxt_per_query_memory;
+ call_state->tuple_store_owner = CurrentResourceOwner;
+ }
+
/************************************************************
* Create the tcl command to call the internal
* proc in the Tcl interpreter
@@ -838,11 +902,72 @@ pltcl_func_handler(PG_FUNCTION_ARGS, bool pltrusted)
if (SPI_finish() != SPI_OK_FINISH)
elog(ERROR, "SPI_finish() failed");
- if (fcinfo->isnull)
+ if (prodesc->fn_retisset)
+ {
+ ReturnSetInfo *rsi = call_state->rsi;
+
+ /* We already checked this is OK */
+ rsi->returnMode = SFRM_Materialize;
+
+ /* If we produced any tuples, send back the result */
+ if (call_state->tuple_store)
+ {
+ rsi->setResult = call_state->tuple_store;
+ if (call_state->ret_tupdesc)
+ {
+ MemoryContext oldcxt;
+
+ oldcxt = MemoryContextSwitchTo(call_state->tuple_store_cxt);
+ rsi->setDesc = CreateTupleDescCopy(call_state->ret_tupdesc);
+ MemoryContextSwitchTo(oldcxt);
+ }
+ }
+ retval = (Datum) 0;
+ fcinfo->isnull = true;
+ }
+ else if (fcinfo->isnull)
+ {
retval = InputFunctionCall(&prodesc->result_in_func,
NULL,
prodesc->result_typioparam,
-1);
+ }
+ else if (prodesc->fn_retistuple)
+ {
+ TupleDesc td;
+ HeapTuple tup;
+ Tcl_Obj *resultObj;
+ Tcl_Obj **resultObjv;
+ int resultObjc;
+
+ /*
+ * Set up data about result type. XXX it's tempting to consider
+ * caching this in the prodesc, in the common case where the rowtype
+ * is determined by the function not the calling query. But we'd have
+ * to be able to deal with ADD/DROP/ALTER COLUMN events when the
+ * result type is a named composite type, so it's not exactly trivial.
+ * Maybe worth improving someday.
+ */
+ if (get_call_result_type(fcinfo, NULL, &td) != TYPEFUNC_COMPOSITE)
+ ereport(ERROR,
+ (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
+ errmsg("function returning record called in context "
+ "that cannot accept type record")));
+
+ Assert(!call_state->ret_tupdesc);
+ Assert(!call_state->attinmeta);
+ call_state->ret_tupdesc = td;
+ call_state->attinmeta = TupleDescGetAttInMetadata(td);
+
+ /* Convert function result to tuple */
+ resultObj = Tcl_GetObjResult(interp);
+ if (Tcl_ListObjGetElements(interp, resultObj, &resultObjc, &resultObjv) == TCL_ERROR)
+ throw_tcl_error(interp, prodesc->user_proname);
+
+ tup = pltcl_build_tuple_result(interp, resultObjv, resultObjc,
+ call_state);
+ retval = HeapTupleGetDatum(tup);
+ }
else
retval = InputFunctionCall(&prodesc->result_in_func,
utf_u2e(Tcl_GetStringResult(interp)),
@@ -857,7 +982,8 @@ pltcl_func_handler(PG_FUNCTION_ARGS, bool pltrusted)
* pltcl_trigger_handler() - Handler for trigger calls
**********************************************************************/
static HeapTuple
-pltcl_trigger_handler(PG_FUNCTION_ARGS, bool pltrusted)
+pltcl_trigger_handler(PG_FUNCTION_ARGS, pltcl_call_state *call_state,
+ bool pltrusted)
{
pltcl_proc_desc *prodesc;
Tcl_Interp *volatile interp;
@@ -886,7 +1012,7 @@ pltcl_trigger_handler(PG_FUNCTION_ARGS, bool pltrusted)
false, /* not an event trigger */
pltrusted);
- pltcl_current_prodesc = prodesc;
+ call_state->prodesc = prodesc;
prodesc->fn_refcount++;
interp = prodesc->interp_desc->interp;
@@ -1169,7 +1295,8 @@ pltcl_trigger_handler(PG_FUNCTION_ARGS, bool pltrusted)
* pltcl_event_trigger_handler() - Handler for event trigger calls
**********************************************************************/
static void
-pltcl_event_trigger_handler(PG_FUNCTION_ARGS, bool pltrusted)
+pltcl_event_trigger_handler(PG_FUNCTION_ARGS, pltcl_call_state *call_state,
+ bool pltrusted)
{
pltcl_proc_desc *prodesc;
Tcl_Interp *volatile interp;
@@ -1185,7 +1312,7 @@ pltcl_event_trigger_handler(PG_FUNCTION_ARGS, bool pltrusted)
prodesc = compile_pltcl_function(fcinfo->flinfo->fn_oid,
InvalidOid, true, pltrusted);
- pltcl_current_prodesc = prodesc;
+ call_state->prodesc = prodesc;
prodesc->fn_refcount++;
interp = prodesc->interp_desc->interp;
@@ -1389,10 +1516,11 @@ compile_pltcl_function(Oid fn_oid, Oid tgreloid,
procStruct->prorettype);
typeStruct = (Form_pg_type) GETSTRUCT(typeTup);
- /* Disallow pseudotype result, except VOID */
+ /* Disallow pseudotype result, except VOID and RECORD */
if (typeStruct->typtype == TYPTYPE_PSEUDO)
{
- if (procStruct->prorettype == VOIDOID)
+ if (procStruct->prorettype == VOIDOID ||
+ procStruct->prorettype == RECORDOID)
/* okay */ ;
else if (procStruct->prorettype == TRIGGEROID ||
procStruct->prorettype == EVTTRIGGEROID)
@@ -1406,16 +1534,15 @@ compile_pltcl_function(Oid fn_oid, Oid tgreloid,
format_type_be(procStruct->prorettype))));
}
- if (typeStruct->typtype == TYPTYPE_COMPOSITE)
- ereport(ERROR,
- (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
- errmsg("PL/Tcl functions cannot return composite types")));
-
fmgr_info_cxt(typeStruct->typinput,
&(prodesc->result_in_func),
proc_cxt);
prodesc->result_typioparam = getTypeIOParam(typeTup);
+ prodesc->fn_retisset = procStruct->proretset;
+ prodesc->fn_retistuple = (procStruct->prorettype == RECORDOID ||
+ typeStruct->typtype == TYPTYPE_COMPOSITE);
+
ReleaseSysCache(typeTup);
}
@@ -1914,7 +2041,7 @@ pltcl_argisnull(ClientData cdata, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[])
{
int argno;
- FunctionCallInfo fcinfo = pltcl_current_fcinfo;
+ FunctionCallInfo fcinfo = pltcl_current_call_state->fcinfo;
/************************************************************
* Check call syntax
@@ -1967,7 +2094,7 @@ static int
pltcl_returnnull(ClientData cdata, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[])
{
- FunctionCallInfo fcinfo = pltcl_current_fcinfo;
+ FunctionCallInfo fcinfo = pltcl_current_call_state->fcinfo;
/************************************************************
* Check call syntax
@@ -1998,6 +2125,95 @@ pltcl_returnnull(ClientData cdata, Tcl_Interp *interp,
}
+/**********************************************************************
+ * pltcl_returnnext() - Add a row to the result tuplestore in a SRF.
+ **********************************************************************/
+static int
+pltcl_returnnext(ClientData cdata, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const objv[])
+{
+ pltcl_call_state *call_state = pltcl_current_call_state;
+ FunctionCallInfo fcinfo = call_state->fcinfo;
+ pltcl_proc_desc *prodesc = call_state->prodesc;
+ int result = TCL_OK;
+ MemoryContext tmpcxt;
+ MemoryContext oldcxt;
+
+ /*
+ * Check that we're called as a set-returning function
+ */
+ if (fcinfo == NULL)
+ {
+ Tcl_SetObjResult(interp,
+ Tcl_NewStringObj("return_next cannot be used in triggers", -1));
+ return TCL_ERROR;
+ }
+
+ if (!prodesc->fn_retisset)
+ {
+ Tcl_SetObjResult(interp,
+ Tcl_NewStringObj("return_next cannot be used in non-set-returning functions", -1));
+ return TCL_ERROR;
+ }
+
+ /*
+ * Check call syntax
+ */
+ if (objc != 2)
+ {
+ Tcl_WrongNumArgs(interp, 1, objv, "result");
+ return TCL_ERROR;
+ }
+
+ /* Set up tuple store if first output row */
+ if (call_state->tuple_store == NULL)
+ pltcl_init_tuple_store(call_state);
+
+ /* Make short-lived context to run input functions in */
+ tmpcxt = AllocSetContextCreate(CurrentMemoryContext,
+ "pltcl_returnnext",
+ ALLOCSET_SMALL_SIZES);
+ oldcxt = MemoryContextSwitchTo(tmpcxt);
+
+ if (prodesc->fn_retistuple)
+ {
+ Tcl_Obj **rowObjv;
+ int rowObjc;
+
+ /* result should be a list, so break it down */
+ if (Tcl_ListObjGetElements(interp, objv[1], &rowObjc, &rowObjv) == TCL_ERROR)
+ result = TCL_ERROR;
+ else
+ {
+ HeapTuple tuple;
+
+ SPI_push();
+ tuple = pltcl_build_tuple_result(interp, rowObjv, rowObjc,
+ call_state);
+ tuplestore_puttuple(call_state->tuple_store, tuple);
+ SPI_pop();
+ }
+ }
+ else
+ {
+ Datum retval;
+ bool isNull = false;
+
+ retval = InputFunctionCall(&prodesc->result_in_func,
+ utf_u2e((char *) Tcl_GetString(objv[1])),
+ prodesc->result_typioparam,
+ -1);
+ tuplestore_putvalues(call_state->tuple_store, call_state->ret_tupdesc,
+ &retval, &isNull);
+ }
+
+ MemoryContextSwitchTo(oldcxt);
+ MemoryContextDelete(tmpcxt);
+
+ return result;
+}
+
+
/*----------
* Support for running SPI operations inside subtransactions
*
@@ -2164,7 +2380,7 @@ pltcl_SPI_execute(ClientData cdata, Tcl_Interp *interp,
{
UTF_BEGIN;
spi_rc = SPI_execute(UTF_U2E(Tcl_GetString(objv[query_idx])),
- pltcl_current_prodesc->fn_readonly, count);
+ pltcl_current_call_state->prodesc->fn_readonly, count);
UTF_END;
my_rc = pltcl_process_SPI_result(interp,
@@ -2414,7 +2630,7 @@ pltcl_SPI_prepare(ClientData cdata, Tcl_Interp *interp,
* Insert a hashtable entry for the plan and return
* the key to the caller
************************************************************/
- query_hash = &pltcl_current_prodesc->interp_desc->query_hash;
+ query_hash = &pltcl_current_call_state->prodesc->interp_desc->query_hash;
hashent = Tcl_CreateHashEntry(query_hash, qdesc->qname, &hashnew);
Tcl_SetHashValue(hashent, (ClientData) qdesc);
@@ -2503,7 +2719,7 @@ pltcl_SPI_execute_plan(ClientData cdata, Tcl_Interp *interp,
return TCL_ERROR;
}
- query_hash = &pltcl_current_prodesc->interp_desc->query_hash;
+ query_hash = &pltcl_current_call_state->prodesc->interp_desc->query_hash;
hashent = Tcl_FindHashEntry(query_hash, Tcl_GetString(objv[i]));
if (hashent == NULL)
@@ -2618,7 +2834,8 @@ pltcl_SPI_execute_plan(ClientData cdata, Tcl_Interp *interp,
* Execute the plan
************************************************************/
spi_rc = SPI_execute_plan(qdesc->plan, argvalues, nulls,
- pltcl_current_prodesc->fn_readonly, count);
+ pltcl_current_call_state->prodesc->fn_readonly,
+ count);
my_rc = pltcl_process_SPI_result(interp,
arrayname,
@@ -2808,3 +3025,88 @@ pltcl_build_tuple_argument(HeapTuple tuple, TupleDesc tupdesc)
return retobj;
}
+
+/**********************************************************************
+ * pltcl_build_tuple_result() - Build a tuple of function's result rowtype
+ * from a Tcl list of column names and values
+ *
+ * Note: this function leaks memory. Even if we made it clean up its own
+ * mess, there's no way to prevent the datatype input functions it calls
+ * from leaking. Run it in a short-lived context, unless we're about to
+ * exit the procedure anyway.
+ *
+ * Also, caller is responsible for doing SPI_push/SPI_pop if calling from
+ * inside SPI environment.
+ **********************************************************************/
+static HeapTuple
+pltcl_build_tuple_result(Tcl_Interp *interp, Tcl_Obj **kvObjv, int kvObjc,
+ pltcl_call_state *call_state)
+{
+ char **values;
+ int i;
+
+ if (kvObjc % 2 != 0)
+ ereport(ERROR,
+ (errcode(ERRCODE_INVALID_PARAMETER_VALUE),
+ errmsg("column name/value list must have even number of elements")));
+
+ values = (char **) palloc0(call_state->ret_tupdesc->natts * sizeof(char *));
+
+ for (i = 0; i < kvObjc; i += 2)
+ {
+ char *fieldName = utf_e2u(Tcl_GetString(kvObjv[i]));
+ int attn = SPI_fnumber(call_state->ret_tupdesc, fieldName);
+
+ if (attn <= 0 || call_state->ret_tupdesc->attrs[attn - 1]->attisdropped)
+ ereport(ERROR,
+ (errcode(ERRCODE_UNDEFINED_COLUMN),
+ errmsg("column name/value list contains nonexistent column name \"%s\"",
+ fieldName)));
+
+ values[attn - 1] = utf_e2u(Tcl_GetString(kvObjv[i + 1]));
+ }
+
+ return BuildTupleFromCStrings(call_state->attinmeta, values);
+}
+
+/**********************************************************************
+ * pltcl_init_tuple_store() - Initialize the result tuplestore for a SRF
+ **********************************************************************/
+static void
+pltcl_init_tuple_store(pltcl_call_state *call_state)
+{
+ ReturnSetInfo *rsi = call_state->rsi;
+ MemoryContext oldcxt;
+ ResourceOwner oldowner;
+
+ /* Should be in a SRF */
+ Assert(rsi);
+ /* Should be first time through */
+ Assert(!call_state->tuple_store);
+ Assert(!call_state->attinmeta);
+
+ /* We expect caller to provide an appropriate result tupdesc */
+ Assert(rsi->expectedDesc);
+ call_state->ret_tupdesc = rsi->expectedDesc;
+
+ /*
+ * Switch to the right memory context and resource owner for storing the
+ * tuplestore. If we're within a subtransaction opened for an exception
+ * block, for example, we must still create the tuplestore in the resource
+ * owner that was active when this function was entered, and not in the
+ * subtransaction's resource owner.
+ */
+ oldcxt = MemoryContextSwitchTo(call_state->tuple_store_cxt);
+ oldowner = CurrentResourceOwner;
+ CurrentResourceOwner = call_state->tuple_store_owner;
+
+ call_state->tuple_store =
+ tuplestore_begin_heap(rsi->allowedModes & SFRM_Materialize_Random,
+ false, work_mem);
+
+ /* Build attinmeta in this context, too */
+ call_state->attinmeta = TupleDescGetAttInMetadata(call_state->ret_tupdesc);
+
+ CurrentResourceOwner = oldowner;
+ MemoryContextSwitchTo(oldcxt);
+}
diff --git a/src/pl/tcl/sql/pltcl_queries.sql b/src/pl/tcl/sql/pltcl_queries.sql
index a0a9619a9bb..0ebfe653406 100644
--- a/src/pl/tcl/sql/pltcl_queries.sql
+++ b/src/pl/tcl/sql/pltcl_queries.sql
@@ -97,3 +97,36 @@ create temp table t1 (f1 int);
select tcl_lastoid('t1');
create temp table t2 (f1 int) with oids;
select tcl_lastoid('t2') > 0;
+
+-- test some error cases
+CREATE FUNCTION tcl_error(OUT a int, OUT b int) AS $$return {$$ LANGUAGE pltcl;
+SELECT tcl_error();
+
+CREATE FUNCTION bad_record(OUT a text, OUT b text) AS $$return [list a]$$ LANGUAGE pltcl;
+SELECT bad_record();
+
+CREATE FUNCTION bad_field(OUT a text, OUT b text) AS $$return [list a 1 b 2 cow 3]$$ LANGUAGE pltcl;
+SELECT bad_field();
+
+-- test compound return
+select * from tcl_test_cube_squared(5);
+
+-- test SRF
+select * from tcl_test_squared_rows(0,5);
+
+select * from tcl_test_sequence(0,5) as a;
+
+select 1, tcl_test_sequence(0,5);
+
+CREATE FUNCTION non_srf() RETURNS int AS $$return_next 1$$ LANGUAGE pltcl;
+select non_srf();
+
+CREATE FUNCTION bad_record_srf(OUT a text, OUT b text) RETURNS SETOF record AS $$
+return_next [list a]
+$$ LANGUAGE pltcl;
+SELECT bad_record_srf();
+
+CREATE FUNCTION bad_field_srf(OUT a text, OUT b text) RETURNS SETOF record AS $$
+return_next [list a 1 b 2 cow 3]
+$$ LANGUAGE pltcl;
+SELECT bad_field_srf();
diff --git a/src/pl/tcl/sql/pltcl_setup.sql b/src/pl/tcl/sql/pltcl_setup.sql
index 8df65a58165..58f38d53aa4 100644
--- a/src/pl/tcl/sql/pltcl_setup.sql
+++ b/src/pl/tcl/sql/pltcl_setup.sql
@@ -596,6 +596,22 @@ drop table foo;
drop event trigger tcl_a_snitch;
drop event trigger tcl_b_snitch;
+CREATE FUNCTION tcl_test_cube_squared(in int, out squared int, out cubed int) AS $$
+ return [list squared [expr {$1 * $1}] cubed [expr {$1 * $1 * $1}]]
+$$ language pltcl;
+
+CREATE FUNCTION tcl_test_squared_rows(int,int) RETURNS TABLE (x int, y int) AS $$
+ for {set i $1} {$i < $2} {incr i} {
+ return_next [list y [expr {$i * $i}] x $i]
+ }
+$$ language pltcl;
+
+CREATE FUNCTION tcl_test_sequence(int,int) RETURNS SETOF int AS $$
+ for {set i $1} {$i < $2} {incr i} {
+ return_next $i
+ }
+$$ language pltcl;
+
-- test use of errorCode in error handling
create function tcl_error_handling_test() returns text as $$
--
GitLab