Skip to content

P
Postgres FD Implementation
Commit d995014f authored by Bruce Momjian's avatar Bruce Momjian
Browse files
Options

At 2005-05-21 20:18:50 +0530, ams@oryx.com wrote: 

>
> > The second issue is where plperl returns a large result set.

I have attached the following seven patches to address this problem:

1. Trivial. Replaces some errant spaces with tabs.

2. Trivial. Fixes the spelling of Jan's name, and gets rid of many
   inane, useless, annoying, and often misleading comments. Here's
   a sample: "plperl_init_all() - Initialize all".

   (I have tried to add some useful comments here and there, and will
   continue to do so now and again.)

3. Trivial. Splits up some long lines.

4. Converts SRFs in PL/Perl to use a Tuplestore and SFRM_Materialize
   to return the result set, based on the PL/PgSQL model.

   There are two major consequences: result sets will spill to disk when
   they can no longer fit in work_mem; and "select foo_srf()" no longer
   works. (I didn't lose sleep over the latter, since that form is not
   valid in PL/PgSQL, and it's not documented in PL/Perl.)

5. Trivial, but important. Fixes use of "undef" instead of undef. This
   would cause empty functions to fail in bizarre ways. I suspect that
   there's still another (old) bug here. I'll investigate further.

6. Moves the majority of (4) out into a new plperl_return_next()
   function, to make it possible to expose the functionality to
   Perl; cleans up some of the code besides.

7. Add an spi_return_next function for use in Perl code.

If you want to apply the patches and try them out, 8-composite.diff is
what you should use. (Note: my patches depend upon Andrew's use-strict
and %_SHARED patches being applied.)

Here's something to try:

    create or replace function foo() returns setof record as $$
    $i = 0;
    for ("World", "PostgreSQL", "PL/Perl") {
        spi_return_next({f1=>++$i, f2=>'Hello', f3=>$_});
    }
    return;
    $$ language plperl;
    select * from foo() as (f1 integer, f2 text, f3 text);

(Many thanks to Andrews Dunstan and Supernews for their help.)

Abhijit Menon-Sen
parent 3cf1fd32
Hide whitespace changes
Inline Side-by-side
Showing with 241 additions and 284 deletions
src/pl/plperl/SPI.xs
View file @ d995014f
...@@ -97,6 +97,11 @@ spi_spi_exec_query(query, ...) ...@@ -97,6 +97,11 @@ spi_spi_exec_query(query, ...)
OUTPUT: OUTPUT:
RETVAL RETVAL
void
spi_spi_return_next(rv)
SV *rv;
CODE:
plperl_return_next(rv);
BOOT: BOOT:
items = 0; /* avoid 'unused variable' warning */ items = 0; /* avoid 'unused variable' warning */
src/pl/plperl/plperl.c
View file @ d995014f
...@@ -4,7 +4,7 @@ ...@@ -4,7 +4,7 @@
* IDENTIFICATION * IDENTIFICATION
* *
* This software is copyrighted by Mark Hollomon * This software is copyrighted by Mark Hollomon
* but is shameless cribbed from pltcl.c by Jan Weick. * but is shameless cribbed from pltcl.c by Jan Wieck.
* *
* The author hereby grants permission to use, copy, modify, * The author hereby grants permission to use, copy, modify,
* distribute, and license this software and its documentation * distribute, and license this software and its documentation
...@@ -33,7 +33,7 @@ ...@@ -33,7 +33,7 @@
* ENHANCEMENTS, OR MODIFICATIONS. * ENHANCEMENTS, OR MODIFICATIONS.
* *
* IDENTIFICATION * IDENTIFICATION
* $PostgreSQL: pgsql/src/pl/plperl/plperl.c,v 1.74 2005/05/23 01:57:51 neilc Exp $ * $PostgreSQL: pgsql/src/pl/plperl/plperl.c,v 1.75 2005/06/04 20:33:06 momjian Exp $
* *
**********************************************************************/ **********************************************************************/
...@@ -53,6 +53,7 @@ ...@@ -53,6 +53,7 @@
#include "utils/lsyscache.h" #include "utils/lsyscache.h"
#include "utils/memutils.h" #include "utils/memutils.h"
#include "utils/typcache.h" #include "utils/typcache.h"
#include "miscadmin.h"
/* perl stuff */ /* perl stuff */
#include "EXTERN.h" #include "EXTERN.h"
...@@ -86,6 +87,9 @@ typedef struct plperl_proc_desc ...@@ -86,6 +87,9 @@ typedef struct plperl_proc_desc
FmgrInfo arg_out_func[FUNC_MAX_ARGS]; FmgrInfo arg_out_func[FUNC_MAX_ARGS];
bool arg_is_rowtype[FUNC_MAX_ARGS]; bool arg_is_rowtype[FUNC_MAX_ARGS];
SV *reference; SV *reference;
FunctionCallInfo caller_info;
Tuplestorestate *tuple_store;
TupleDesc tuple_desc;
} plperl_proc_desc; } plperl_proc_desc;
...@@ -97,6 +101,8 @@ static bool plperl_safe_init_done = false; ...@@ -97,6 +101,8 @@ static bool plperl_safe_init_done = false;
static PerlInterpreter *plperl_interp = NULL; static PerlInterpreter *plperl_interp = NULL;
static HV *plperl_proc_hash = NULL; static HV *plperl_proc_hash = NULL;
static bool plperl_use_strict = false;
/* this is saved and restored by plperl_call_handler */ /* this is saved and restored by plperl_call_handler */
static plperl_proc_desc *plperl_current_prodesc = NULL; static plperl_proc_desc *plperl_current_prodesc = NULL;
...@@ -120,6 +126,7 @@ static SV *plperl_hash_from_tuple(HeapTuple tuple, TupleDesc tupdesc); ...@@ -120,6 +126,7 @@ static SV *plperl_hash_from_tuple(HeapTuple tuple, TupleDesc tupdesc);
static void plperl_init_shared_libs(pTHX); static void plperl_init_shared_libs(pTHX);
static HV *plperl_spi_execute_fetch_result(SPITupleTable *, int, int); static HV *plperl_spi_execute_fetch_result(SPITupleTable *, int, int);
void plperl_return_next(SV *);
/* /*
* This routine is a crock, and so is everyplace that calls it. The problem * This routine is a crock, and so is everyplace that calls it. The problem
...@@ -138,79 +145,69 @@ perm_fmgr_info(Oid functionId, FmgrInfo *finfo) ...@@ -138,79 +145,69 @@ perm_fmgr_info(Oid functionId, FmgrInfo *finfo)
fmgr_info_cxt(functionId, finfo, TopMemoryContext); fmgr_info_cxt(functionId, finfo, TopMemoryContext);
} }
/**********************************************************************
* plperl_init() - Initialize everything that can be /* Perform initialization during postmaster startup. */
* safely initialized during postmaster
* startup.
*
* DO NOT make this static --- it has to be callable by preload
**********************************************************************/
void void
plperl_init(void) plperl_init(void)
{ {
/************************************************************
* Do initialization only once
************************************************************/
if (!plperl_firstcall) if (!plperl_firstcall)
return; return;
/************************************************************ DefineCustomBoolVariable(
* Create the Perl interpreter "plperl.use_strict",
************************************************************/ "If true, will compile trusted and untrusted perl code in strict mode",
plperl_init_interp(); NULL,
&plperl_use_strict,
PGC_USERSET,
NULL, NULL);
EmitWarningsOnPlaceholders("plperl");
plperl_init_interp();
plperl_firstcall = 0; plperl_firstcall = 0;
} }
/**********************************************************************
* plperl_init_all() - Initialize all /* Perform initialization during backend startup. */
**********************************************************************/
static void static void
plperl_init_all(void) plperl_init_all(void)
{ {
/************************************************************
* Execute postmaster-startup safe initialization
************************************************************/
if (plperl_firstcall) if (plperl_firstcall)
plperl_init(); plperl_init();
/************************************************************ /* We don't need to do anything yet when a new backend starts. */
* Any other initialization that must be done each time a new
* backend starts -- currently none
************************************************************/
} }
/**********************************************************************
* plperl_init_interp() - Create the Perl interpreter
**********************************************************************/
static void static void
plperl_init_interp(void) plperl_init_interp(void)
{ {
static char *embedding[3] = { static char *loose_embedding[3] = {
"", "-e", "", "-e",
/* all one string follows (no commas please) */
/*
* no commas between the next lines please. They are supposed to
* be one string
*/
"SPI::bootstrap(); use vars qw(%_SHARED);" "SPI::bootstrap(); use vars qw(%_SHARED);"
"sub ::mkunsafefunc {return eval(qq[ sub { $_[0] $_[1] } ]); }" "sub ::mkunsafefunc {return eval(qq[ sub { $_[0] $_[1] } ]); }"
}; };
static char *strict_embedding[3] = {
"", "-e",
/* all one string follows (no commas please) */
"SPI::bootstrap(); use vars qw(%_SHARED);"
"sub ::mkunsafefunc {return eval("
"qq[ sub { use strict; $_[0] $_[1] } ]); }"
};
plperl_interp = perl_alloc(); plperl_interp = perl_alloc();
if (!plperl_interp) if (!plperl_interp)
elog(ERROR, "could not allocate Perl interpreter"); elog(ERROR, "could not allocate Perl interpreter");
perl_construct(plperl_interp); perl_construct(plperl_interp);
perl_parse(plperl_interp, plperl_init_shared_libs, 3, embedding, NULL); perl_parse(plperl_interp, plperl_init_shared_libs, 3 ,
(plperl_use_strict ? strict_embedding : loose_embedding), NULL);
perl_run(plperl_interp); perl_run(plperl_interp);
/************************************************************
* Initialize the procedure hash table
************************************************************/
plperl_proc_hash = newHV(); plperl_proc_hash = newHV();
} }
...@@ -221,22 +218,33 @@ plperl_safe_init(void) ...@@ -221,22 +218,33 @@ plperl_safe_init(void)
static char *safe_module = static char *safe_module =
"require Safe; $Safe::VERSION"; "require Safe; $Safe::VERSION";
static char *safe_ok = static char *common_safe_ok =
"use vars qw($PLContainer); $PLContainer = new Safe('PLPerl');" "use vars qw($PLContainer); $PLContainer = new Safe('PLPerl');"
"$PLContainer->permit_only(':default');" "$PLContainer->permit_only(':default');"
"$PLContainer->permit(qw[:base_math !:base_io sort time]);" "$PLContainer->permit(qw[:base_math !:base_io sort time]);"
"$PLContainer->share(qw[&elog &spi_exec_query &DEBUG &LOG " "$PLContainer->share(qw[&elog &spi_exec_query &spi_return_next "
"&INFO &NOTICE &WARNING &ERROR %_SHARED ]);" "&DEBUG &LOG &INFO &NOTICE &WARNING &ERROR %_SHARED ]);"
"sub ::mksafefunc { return $PLContainer->reval(qq[sub { $_[0] $_[1]}]); }"
; ;
static char * strict_safe_ok =
"$PLContainer->permit('require');$PLContainer->reval('use strict;');"
"$PLContainer->deny('require');"
"sub ::mksafefunc { return $PLContainer->reval(qq[ "
" sub { BEGIN { strict->import(); } $_[0] $_[1]}]); }"
;
static char * loose_safe_ok =
"sub ::mksafefunc { return $PLContainer->reval(qq[ "
" sub { $_[0] $_[1]}]); }"
;
static char *safe_bad = static char *safe_bad =
"use vars qw($PLContainer); $PLContainer = new Safe('PLPerl');" "use vars qw($PLContainer); $PLContainer = new Safe('PLPerl');"
"$PLContainer->permit_only(':default');" "$PLContainer->permit_only(':default');"
"$PLContainer->share(qw[&elog &ERROR ]);" "$PLContainer->share(qw[&elog &ERROR ]);"
"sub ::mksafefunc { return $PLContainer->reval(qq[sub { " "sub ::mksafefunc { return $PLContainer->reval(qq[sub { "
"elog(ERROR,'trusted Perl functions disabled - " "elog(ERROR,'trusted Perl functions disabled - "
"please upgrade Perl Safe module to version 2.09 or later');}]); }" "please upgrade Perl Safe module to version 2.09 or later');}]); }"
; ;
SV *res; SV *res;
...@@ -251,7 +259,16 @@ plperl_safe_init(void) ...@@ -251,7 +259,16 @@ plperl_safe_init(void)
* assume that floating-point comparisons are exact, so use a slightly * assume that floating-point comparisons are exact, so use a slightly
* smaller comparison value. * smaller comparison value.
*/ */
eval_pv((safe_version < 2.0899 ? safe_bad : safe_ok), FALSE); if (safe_version < 2.0899 )
{
/* not safe, so disallow all trusted funcs */
eval_pv(safe_bad, FALSE);
}
else
{
eval_pv(common_safe_ok, FALSE);
eval_pv((plperl_use_strict ? strict_safe_ok : loose_safe_ok), FALSE);
}
plperl_safe_init_done = true; plperl_safe_init_done = true;
} }
...@@ -272,9 +289,8 @@ strip_trailing_ws(const char *msg) ...@@ -272,9 +289,8 @@ strip_trailing_ws(const char *msg)
} }
/* /* Build a tuple from a hash. */
* Build a tuple from a hash
*/
static HeapTuple static HeapTuple
plperl_build_tuple_result(HV *perlhash, AttInMetadata *attinmeta) plperl_build_tuple_result(HV *perlhash, AttInMetadata *attinmeta)
{ {
...@@ -290,7 +306,7 @@ plperl_build_tuple_result(HV *perlhash, AttInMetadata *attinmeta) ...@@ -290,7 +306,7 @@ plperl_build_tuple_result(HV *perlhash, AttInMetadata *attinmeta)
hv_iterinit(perlhash); hv_iterinit(perlhash);
while ((val = hv_iternextsv(perlhash, &key, &klen))) while ((val = hv_iternextsv(perlhash, &key, &klen)))
{ {
int attn = SPI_fnumber(td, key); int attn = SPI_fnumber(td, key);
if (attn <= 0 || td->attrs[attn - 1]->attisdropped) if (attn <= 0 || td->attrs[attn - 1]->attisdropped)
ereport(ERROR, ereport(ERROR,
...@@ -308,9 +324,8 @@ plperl_build_tuple_result(HV *perlhash, AttInMetadata *attinmeta) ...@@ -308,9 +324,8 @@ plperl_build_tuple_result(HV *perlhash, AttInMetadata *attinmeta)
} }
/********************************************************************** /* Set up the arguments for a trigger call. */
* set up arguments for a trigger call
**********************************************************************/
static SV * static SV *
plperl_trigger_build_args(FunctionCallInfo fcinfo) plperl_trigger_build_args(FunctionCallInfo fcinfo)
{ {
...@@ -403,27 +418,8 @@ plperl_trigger_build_args(FunctionCallInfo fcinfo) ...@@ -403,27 +418,8 @@ plperl_trigger_build_args(FunctionCallInfo fcinfo)
} }
/* /* Set up the new tuple returned from a trigger. */
* Obtain tuple descriptor for a function returning tuple
*
* NB: copy the result if needed for any great length of time
*/
static TupleDesc
get_function_tupdesc(FunctionCallInfo fcinfo)
{
TupleDesc result;
if (get_call_result_type(fcinfo, NULL, &result) != TYPEFUNC_COMPOSITE)
ereport(ERROR,
(errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
errmsg("function returning record called in context "
"that cannot accept type record")));
return result;
}
/**********************************************************************
* set up the new tuple returned from a trigger
**********************************************************************/
static HeapTuple static HeapTuple
plperl_modify_tuple(HV *hvTD, TriggerData *tdata, HeapTuple otup) plperl_modify_tuple(HV *hvTD, TriggerData *tdata, HeapTuple otup)
{ {
...@@ -508,38 +504,25 @@ plperl_modify_tuple(HV *hvTD, TriggerData *tdata, HeapTuple otup) ...@@ -508,38 +504,25 @@ plperl_modify_tuple(HV *hvTD, TriggerData *tdata, HeapTuple otup)
return rtup; return rtup;
} }
/**********************************************************************
* plperl_call_handler - This is the only visible function /* This is the only externally-visible part of the plperl interface.
* of the PL interpreter. The PostgreSQL * The Postgres function and trigger managers call it to execute a
* function manager and trigger manager * perl function. */
* call this function for execution of
* perl procedures.
**********************************************************************/
PG_FUNCTION_INFO_V1(plperl_call_handler); PG_FUNCTION_INFO_V1(plperl_call_handler);
/* keep non-static */
Datum Datum
plperl_call_handler(PG_FUNCTION_ARGS) plperl_call_handler(PG_FUNCTION_ARGS)
{ {
Datum retval; Datum retval;
plperl_proc_desc *save_prodesc; plperl_proc_desc *save_prodesc;
/*
* Initialize interpreter if first time through
*/
plperl_init_all(); plperl_init_all();
/*
* Ensure that static pointers are saved/restored properly
*/
save_prodesc = plperl_current_prodesc; save_prodesc = plperl_current_prodesc;
PG_TRY(); PG_TRY();
{ {
/*
* Determine if called as function or trigger and
* call appropriate subhandler
*/
if (CALLED_AS_TRIGGER(fcinfo)) if (CALLED_AS_TRIGGER(fcinfo))
retval = PointerGetDatum(plperl_trigger_handler(fcinfo)); retval = PointerGetDatum(plperl_trigger_handler(fcinfo));
else else
...@@ -558,11 +541,9 @@ plperl_call_handler(PG_FUNCTION_ARGS) ...@@ -558,11 +541,9 @@ plperl_call_handler(PG_FUNCTION_ARGS)
} }
/********************************************************************** /* Uses mksafefunc/mkunsafefunc to create an anonymous sub whose text is
* plperl_create_sub() - calls the perl interpreter to * supplied in s, and returns a reference to the closure. */
* create the anonymous subroutine whose text is in the SV.
* Returns the SV containing the RV to the closure.
**********************************************************************/
static SV * static SV *
plperl_create_sub(char *s, bool trusted) plperl_create_sub(char *s, bool trusted)
{ {
...@@ -638,6 +619,7 @@ plperl_create_sub(char *s, bool trusted) ...@@ -638,6 +619,7 @@ plperl_create_sub(char *s, bool trusted)
return subref; return subref;
} }
/********************************************************************** /**********************************************************************
* plperl_init_shared_libs() - * plperl_init_shared_libs() -
* *
...@@ -659,10 +641,7 @@ plperl_init_shared_libs(pTHX) ...@@ -659,10 +641,7 @@ plperl_init_shared_libs(pTHX)
newXS("SPI::bootstrap", boot_SPI, file); newXS("SPI::bootstrap", boot_SPI, file);
} }
/**********************************************************************
* plperl_call_perl_func() - calls a perl function through the RV
* stored in the prodesc structure. massages the input parms properly
**********************************************************************/
static SV * static SV *
plperl_call_perl_func(plperl_proc_desc *desc, FunctionCallInfo fcinfo) plperl_call_perl_func(plperl_proc_desc *desc, FunctionCallInfo fcinfo)
{ {
...@@ -676,7 +655,7 @@ plperl_call_perl_func(plperl_proc_desc *desc, FunctionCallInfo fcinfo) ...@@ -676,7 +655,7 @@ plperl_call_perl_func(plperl_proc_desc *desc, FunctionCallInfo fcinfo)
PUSHMARK(SP); PUSHMARK(SP);
XPUSHs(sv_2mortal(newSVpv("undef", 0))); /* no trigger data */ XPUSHs(&PL_sv_undef); /* no trigger data */
for (i = 0; i < desc->nargs; i++) for (i = 0; i < desc->nargs; i++)
{ {
...@@ -749,10 +728,7 @@ plperl_call_perl_func(plperl_proc_desc *desc, FunctionCallInfo fcinfo) ...@@ -749,10 +728,7 @@ plperl_call_perl_func(plperl_proc_desc *desc, FunctionCallInfo fcinfo)
return retval; return retval;
} }
/**********************************************************************
* plperl_call_perl_trigger_func() - calls a perl trigger function
* through the RV stored in the prodesc structure.
**********************************************************************/
static SV * static SV *
plperl_call_perl_trigger_func(plperl_proc_desc *desc, FunctionCallInfo fcinfo, plperl_call_perl_trigger_func(plperl_proc_desc *desc, FunctionCallInfo fcinfo,
SV *td) SV *td)
...@@ -809,39 +785,26 @@ plperl_call_perl_trigger_func(plperl_proc_desc *desc, FunctionCallInfo fcinfo, ...@@ -809,39 +785,26 @@ plperl_call_perl_trigger_func(plperl_proc_desc *desc, FunctionCallInfo fcinfo,
return retval; return retval;
} }
/**********************************************************************
* plperl_func_handler() - Handler for regular function calls
**********************************************************************/
static Datum static Datum
plperl_func_handler(PG_FUNCTION_ARGS) plperl_func_handler(PG_FUNCTION_ARGS)
{ {
plperl_proc_desc *prodesc; plperl_proc_desc *prodesc;
SV *perlret; SV *perlret;
Datum retval; Datum retval;
ReturnSetInfo *rsi;
/* Connect to SPI manager */
if (SPI_connect() != SPI_OK_CONNECT) if (SPI_connect() != SPI_OK_CONNECT)
elog(ERROR, "could not connect to SPI manager"); elog(ERROR, "could not connect to SPI manager");
/* Find or compile the function */
prodesc = compile_plperl_function(fcinfo->flinfo->fn_oid, false); prodesc = compile_plperl_function(fcinfo->flinfo->fn_oid, false);
plperl_current_prodesc = prodesc; plperl_current_prodesc = prodesc;
prodesc->caller_info = fcinfo;
prodesc->tuple_store = 0;
prodesc->tuple_desc = 0;
/************************************************************ perlret = plperl_call_perl_func(prodesc, fcinfo);
* Call the Perl function if not returning set
************************************************************/
if (!prodesc->fn_retisset)
perlret = plperl_call_perl_func(prodesc, fcinfo);
else if (SRF_IS_FIRSTCALL())
perlret = plperl_call_perl_func(prodesc, fcinfo);
else
{
/* Get back the SV stashed on initial call */
FuncCallContext *funcctx = (FuncCallContext *) fcinfo->flinfo->fn_extra;
perlret = (SV *) funcctx->user_fctx;
}
/************************************************************ /************************************************************
* Disconnect from SPI manager and then create the return * Disconnect from SPI manager and then create the return
...@@ -852,161 +815,90 @@ plperl_func_handler(PG_FUNCTION_ARGS) ...@@ -852,161 +815,90 @@ plperl_func_handler(PG_FUNCTION_ARGS)
if (SPI_finish() != SPI_OK_FINISH) if (SPI_finish() != SPI_OK_FINISH)
elog(ERROR, "SPI_finish() failed"); elog(ERROR, "SPI_finish() failed");
if (!(perlret && SvOK(perlret) && SvTYPE(perlret) != SVt_NULL)) rsi = (ReturnSetInfo *)fcinfo->resultinfo;
{
/* return NULL if Perl code returned undef */
ReturnSetInfo *rsi = (ReturnSetInfo *) fcinfo->resultinfo;
if (perlret)
SvREFCNT_dec(perlret);
if (rsi && IsA(rsi, ReturnSetInfo))
rsi->isDone = ExprEndResult;
PG_RETURN_NULL();
}
if (prodesc->fn_retisset && prodesc->fn_retistuple)
{
/* set of tuples */
AV *ret_av;
FuncCallContext *funcctx;
TupleDesc tupdesc;
AttInMetadata *attinmeta;
if (!SvOK(perlret) || SvTYPE(perlret) != SVt_RV || SvTYPE(SvRV(perlret)) != SVt_PVAV)
ereport(ERROR,
(errcode(ERRCODE_DATATYPE_MISMATCH),
errmsg("set-returning Perl function must return reference to array")));
ret_av = (AV *) SvRV(perlret);
if (SRF_IS_FIRSTCALL()) if (prodesc->fn_retisset) {
if (!rsi || !IsA(rsi, ReturnSetInfo) ||
(rsi->allowedModes & SFRM_Materialize) == 0 ||
rsi->expectedDesc == NULL)
{ {
MemoryContext oldcontext; ereport(ERROR,
(errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
funcctx = SRF_FIRSTCALL_INIT(); errmsg("set-valued function called in context that "
"cannot accept a set")));
funcctx->user_fctx = (void *) perlret;
funcctx->max_calls = av_len(ret_av) + 1;
/* Cache a copy of the result's tupdesc and attinmeta */
oldcontext = MemoryContextSwitchTo(funcctx->multi_call_memory_ctx);
tupdesc = get_function_tupdesc(fcinfo);
tupdesc = CreateTupleDescCopy(tupdesc);
funcctx->attinmeta = TupleDescGetAttInMetadata(tupdesc);
MemoryContextSwitchTo(oldcontext);
} }
funcctx = SRF_PERCALL_SETUP(); /* If the Perl function returned an arrayref, we pretend that it
attinmeta = funcctx->attinmeta; * called return_next() for each element of the array, to handle
tupdesc = attinmeta->tupdesc; * old SRFs that didn't know about return_next(). Any other sort
* of return value is an error. */
if (funcctx->call_cntr < funcctx->max_calls) if (SvTYPE(perlret) == SVt_RV &&
SvTYPE(SvRV(perlret)) == SVt_PVAV)
{ {
SV **svp; int i = 0;
HV *row_hv; SV **svp = 0;
HeapTuple tuple; AV *rav = (AV *)SvRV(perlret);
while ((svp = av_fetch(rav, i, FALSE)) != NULL) {
svp = av_fetch(ret_av, funcctx->call_cntr, FALSE); plperl_return_next(*svp);
Assert(svp != NULL); i++;
}
if (!SvOK(*svp) || SvTYPE(*svp) != SVt_RV || SvTYPE(SvRV(*svp)) != SVt_PVHV)
ereport(ERROR,
(errcode(ERRCODE_DATATYPE_MISMATCH),
errmsg("elements of Perl result array must be reference to hash")));
row_hv = (HV *) SvRV(*svp);
tuple = plperl_build_tuple_result(row_hv, attinmeta);
retval = HeapTupleGetDatum(tuple);
SRF_RETURN_NEXT(funcctx, retval);
} }
else else if (SvTYPE(perlret) != SVt_NULL)
{ {
SvREFCNT_dec(perlret);
SRF_RETURN_DONE(funcctx);
}
}
else if (prodesc->fn_retisset)
{
/* set of non-tuples */
AV *ret_av;
FuncCallContext *funcctx;
if (!SvOK(perlret) || SvTYPE(perlret) != SVt_RV || SvTYPE(SvRV(perlret)) != SVt_PVAV)
ereport(ERROR, ereport(ERROR,
(errcode(ERRCODE_DATATYPE_MISMATCH), (errcode(ERRCODE_DATATYPE_MISMATCH),
errmsg("set-returning Perl function must return reference to array"))); errmsg("set-returning Perl function must return "
ret_av = (AV *) SvRV(perlret); "reference to array or use return_next")));
if (SRF_IS_FIRSTCALL())
{
funcctx = SRF_FIRSTCALL_INIT();
funcctx->user_fctx = (void *) perlret;
funcctx->max_calls = av_len(ret_av) + 1;
} }
funcctx = SRF_PERCALL_SETUP(); rsi->returnMode = SFRM_Materialize;
if (prodesc->tuple_store) {
if (funcctx->call_cntr < funcctx->max_calls) rsi->setResult = prodesc->tuple_store;
{ rsi->setDesc = prodesc->tuple_desc;
SV **svp;
svp = av_fetch(ret_av, funcctx->call_cntr, FALSE);
Assert(svp != NULL);
if (SvOK(*svp) && SvTYPE(*svp) != SVt_NULL)
{
char *val = SvPV(*svp, PL_na);
fcinfo->isnull = false;
retval = FunctionCall3(&prodesc->result_in_func,
PointerGetDatum(val),
ObjectIdGetDatum(prodesc->result_typioparam),
Int32GetDatum(-1));
}
else
{
fcinfo->isnull = true;
retval = (Datum) 0;
}
SRF_RETURN_NEXT(funcctx, retval);
}
else
{
SvREFCNT_dec(perlret);
SRF_RETURN_DONE(funcctx);
} }
retval = (Datum)0;
}
else if (SvTYPE(perlret) == SVt_NULL)
{
/* Return NULL if Perl code returned undef */
if (rsi && IsA(rsi, ReturnSetInfo))
rsi->isDone = ExprEndResult;
fcinfo->isnull = true;
retval = (Datum)0;
} }
else if (prodesc->fn_retistuple) else if (prodesc->fn_retistuple)
{ {
/* singleton perl hash to Datum */ /* Return a perl hash converted to a Datum */
HV *perlhash; TupleDesc td;
TupleDesc td;
AttInMetadata *attinmeta; AttInMetadata *attinmeta;
HeapTuple tup; HeapTuple tup;
if (!SvOK(perlret) || SvTYPE(perlret) != SVt_RV || SvTYPE(SvRV(perlret)) != SVt_PVHV) if (!SvOK(perlret) || SvTYPE(perlret) != SVt_RV ||
SvTYPE(SvRV(perlret)) != SVt_PVHV)
{
ereport(ERROR, ereport(ERROR,
(errcode(ERRCODE_DATATYPE_MISMATCH), (errcode(ERRCODE_DATATYPE_MISMATCH),
errmsg("composite-returning Perl function must return reference to hash"))); errmsg("composite-returning Perl function "
perlhash = (HV *) SvRV(perlret); "must return reference to hash")));
}
/* /* XXX should cache the attinmeta data instead of recomputing */
* XXX should cache the attinmeta data instead of recomputing if (get_call_result_type(fcinfo, NULL, &td) != TYPEFUNC_COMPOSITE)
*/ {
td = get_function_tupdesc(fcinfo); ereport(ERROR,
/* td = CreateTupleDescCopy(td); */ (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
attinmeta = TupleDescGetAttInMetadata(td); errmsg("function returning record called in context "
"that cannot accept type record")));
}
tup = plperl_build_tuple_result(perlhash, attinmeta); attinmeta = TupleDescGetAttInMetadata(td);
tup = plperl_build_tuple_result((HV *)SvRV(perlret), attinmeta);
retval = HeapTupleGetDatum(tup); retval = HeapTupleGetDatum(tup);
} }
else else
{ {
/* perl string to Datum */ /* Return a perl string converted to a Datum */
char *val = SvPV(perlret, PL_na); char *val = SvPV(perlret, PL_na);
retval = FunctionCall3(&prodesc->result_in_func, retval = FunctionCall3(&prodesc->result_in_func,
CStringGetDatum(val), CStringGetDatum(val),
ObjectIdGetDatum(prodesc->result_typioparam), ObjectIdGetDatum(prodesc->result_typioparam),
...@@ -1017,9 +909,7 @@ plperl_func_handler(PG_FUNCTION_ARGS) ...@@ -1017,9 +909,7 @@ plperl_func_handler(PG_FUNCTION_ARGS)
return retval; return retval;
} }
/**********************************************************************
* plperl_trigger_handler() - Handler for trigger function calls
**********************************************************************/
static Datum static Datum
plperl_trigger_handler(PG_FUNCTION_ARGS) plperl_trigger_handler(PG_FUNCTION_ARGS)
{ {
...@@ -1038,18 +928,9 @@ plperl_trigger_handler(PG_FUNCTION_ARGS) ...@@ -1038,18 +928,9 @@ plperl_trigger_handler(PG_FUNCTION_ARGS)
plperl_current_prodesc = prodesc; plperl_current_prodesc = prodesc;
/************************************************************
* Call the Perl function
************************************************************/
/*
* call perl trigger function and build TD hash
*/
svTD = plperl_trigger_build_args(fcinfo); svTD = plperl_trigger_build_args(fcinfo);
perlret = plperl_call_perl_trigger_func(prodesc, fcinfo, svTD); perlret = plperl_call_perl_trigger_func(prodesc, fcinfo, svTD);
hvTD = (HV *) SvRV(svTD);
hvTD = (HV *) SvRV(svTD); /* convert SV TD structure to Perl Hash
* structure */
/************************************************************ /************************************************************
* Disconnect from SPI manager and then create the return * Disconnect from SPI manager and then create the return
...@@ -1105,7 +986,8 @@ plperl_trigger_handler(PG_FUNCTION_ARGS) ...@@ -1105,7 +986,8 @@ plperl_trigger_handler(PG_FUNCTION_ARGS)
{ {
ereport(ERROR, ereport(ERROR,
(errcode(ERRCODE_E_R_I_E_TRIGGER_PROTOCOL_VIOLATED), (errcode(ERRCODE_E_R_I_E_TRIGGER_PROTOCOL_VIOLATED),
errmsg("result of Perl trigger function must be undef, \"SKIP\" or \"MODIFY\""))); errmsg("result of Perl trigger function must be undef, "
"\"SKIP\" or \"MODIFY\"")));
trv = NULL; trv = NULL;
} }
retval = PointerGetDatum(trv); retval = PointerGetDatum(trv);
...@@ -1118,9 +1000,7 @@ plperl_trigger_handler(PG_FUNCTION_ARGS) ...@@ -1118,9 +1000,7 @@ plperl_trigger_handler(PG_FUNCTION_ARGS)
return retval; return retval;
} }
/**********************************************************************
* compile_plperl_function - compile (or hopefully just look up) function
**********************************************************************/
static plperl_proc_desc * static plperl_proc_desc *
compile_plperl_function(Oid fn_oid, bool is_trigger) compile_plperl_function(Oid fn_oid, bool is_trigger)
{ {
...@@ -1257,7 +1137,8 @@ compile_plperl_function(Oid fn_oid, bool is_trigger) ...@@ -1257,7 +1137,8 @@ compile_plperl_function(Oid fn_oid, bool is_trigger)
free(prodesc); free(prodesc);
ereport(ERROR, ereport(ERROR,
(errcode(ERRCODE_FEATURE_NOT_SUPPORTED), (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
errmsg("trigger functions may only be called as triggers"))); errmsg("trigger functions may only be called "
"as triggers")));
} }
else else
{ {
...@@ -1351,9 +1232,6 @@ compile_plperl_function(Oid fn_oid, bool is_trigger) ...@@ -1351,9 +1232,6 @@ compile_plperl_function(Oid fn_oid, bool is_trigger)
internal_proname); internal_proname);
} }
/************************************************************
* Add the proc description block to the hashtable
************************************************************/
hv_store(plperl_proc_hash, internal_proname, proname_len, hv_store(plperl_proc_hash, internal_proname, proname_len,
newSViv((IV) prodesc), 0); newSViv((IV) prodesc), 0);
} }
...@@ -1364,10 +1242,8 @@ compile_plperl_function(Oid fn_oid, bool is_trigger) ...@@ -1364,10 +1242,8 @@ compile_plperl_function(Oid fn_oid, bool is_trigger)
} }
/********************************************************************** /* Build a hash from all attributes of a given tuple. */
* plperl_hash_from_tuple() - Build a ref to a hash
* from all attributes of a given tuple
**********************************************************************/
static SV * static SV *
plperl_hash_from_tuple(HeapTuple tuple, TupleDesc tupdesc) plperl_hash_from_tuple(HeapTuple tuple, TupleDesc tupdesc)
{ {
...@@ -1414,9 +1290,6 @@ plperl_hash_from_tuple(HeapTuple tuple, TupleDesc tupdesc) ...@@ -1414,9 +1290,6 @@ plperl_hash_from_tuple(HeapTuple tuple, TupleDesc tupdesc)
} }
/*
* Implementation of spi_exec_query() Perl function
*/
HV * HV *
plperl_spi_exec(char *query, int limit) plperl_spi_exec(char *query, int limit)
{ {
...@@ -1484,6 +1357,7 @@ plperl_spi_exec(char *query, int limit) ...@@ -1484,6 +1357,7 @@ plperl_spi_exec(char *query, int limit)
return ret_hv; return ret_hv;
} }
static HV * static HV *
plperl_spi_execute_fetch_result(SPITupleTable *tuptable, int processed, plperl_spi_execute_fetch_result(SPITupleTable *tuptable, int processed,
int status) int status)
...@@ -1517,3 +1391,80 @@ plperl_spi_execute_fetch_result(SPITupleTable *tuptable, int processed, ...@@ -1517,3 +1391,80 @@ plperl_spi_execute_fetch_result(SPITupleTable *tuptable, int processed,
return result; return result;
} }
void
plperl_return_next(SV *sv)
{
plperl_proc_desc *prodesc = plperl_current_prodesc;
FunctionCallInfo fcinfo = prodesc->caller_info;
ReturnSetInfo *rsi = (ReturnSetInfo *)fcinfo->resultinfo;
MemoryContext cxt;
HeapTuple tuple;
TupleDesc tupdesc;
if (!sv)
return;
if (!prodesc->fn_retisset)
{
ereport(ERROR,
(errcode(ERRCODE_SYNTAX_ERROR),
errmsg("cannot use return_next in a non-SETOF function")));
}
if (prodesc->fn_retistuple &&
!(SvOK(sv) && SvTYPE(sv) == SVt_RV && SvTYPE(SvRV(sv)) == SVt_PVHV))
{
ereport(ERROR,
(errcode(ERRCODE_DATATYPE_MISMATCH),
errmsg("setof-composite-returning Perl function "
"must call return_next with reference to hash")));
}
cxt = MemoryContextSwitchTo(rsi->econtext->ecxt_per_query_memory);
if (!prodesc->tuple_store)
prodesc->tuple_store = tuplestore_begin_heap(true, false, work_mem);
if (prodesc->fn_retistuple)
{
TypeFuncClass rettype;
AttInMetadata *attinmeta;
rettype = get_call_result_type(fcinfo, NULL, &tupdesc);
tupdesc = CreateTupleDescCopy(tupdesc);
attinmeta = TupleDescGetAttInMetadata(tupdesc);
tuple = plperl_build_tuple_result((HV *)SvRV(sv), attinmeta);
}
else
{
Datum ret;
bool isNull;
tupdesc = CreateTupleDescCopy(rsi->expectedDesc);
if (SvOK(sv) && SvTYPE(sv) != SVt_NULL)
{
char *val = SvPV(sv, PL_na);
ret = FunctionCall3(&prodesc->result_in_func,
PointerGetDatum(val),
ObjectIdGetDatum(prodesc->result_typioparam),
Int32GetDatum(-1));
isNull = false;
}
else {
ret = (Datum)0;
isNull = true;
}
tuple = heap_form_tuple(tupdesc, &ret, &isNull);
}
if (!prodesc->tuple_desc)
prodesc->tuple_desc = tupdesc;
tuplestore_puttuple(prodesc->tuple_store, tuple);
heap_freetuple(tuple);
MemoryContextSwitchTo(cxt);
}
src/pl/plperl/spi_internal.h
View file @ d995014f
...@@ -17,3 +17,4 @@ int spi_ERROR(void); ...@@ -17,3 +17,4 @@ int spi_ERROR(void);
/* this is actually in plperl.c */ /* this is actually in plperl.c */
HV *plperl_spi_exec(char *, int); HV *plperl_spi_exec(char *, int);
void plperl_return_next(SV *);
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment