mirrors/postgres
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

plperl update from Andrew Dunstan, deriving (I believe) from Command Prompt's

Browse Source 
plperlNG. Review and minor cleanup/improvements by Joe Conway.

Summary of new functionality:
- Shared data space and namespace. There is a new global variable %_SHARED
  that functions can use to store and save data between invocations of a
  function, or between different functions. Also, all trusted plperl function
  now share a common Safe container (this is an optimization, also), which
  they can use for storing non-lexical variables, functions, etc.
- Triggers are now supported
- Records can now be returned (as a hash reference)
- Sets of records can now be returned (as a reference to an array of hash
  references).
- New function spi_exec_query() provided for performing db functions or
  getting data from db.
- Optimization for counting hash keys (Abhijit Menon-Sen)
- Allow return of 'record' and 'setof record'
This commit is contained in:
Joe Conway 2004-07-01 20:50:22 +00:00
parent b6197fe069
commit 1732cb0dbe
7 changed files with 841 additions and 98 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
src/pl/plperl/GNUmakefile
View File

@ -1,5 +1,5 @@
# Makefile for PL/Perl
# $PostgreSQL: pgsql/src/pl/plperl/GNUmakefile,v 1.12 2004/01/21 19:04:11 tgl Exp $
# $PostgreSQL: pgsql/src/pl/plperl/GNUmakefile,v 1.13 2004/07/01 20:50:22 joe Exp $
subdir = src/pl/plperl
top_builddir = ../../..
@ -25,8 +25,13 @@ NAME = plperl
SO_MAJOR_VERSION = 0
SO_MINOR_VERSION = 0
OBJS = plperl.o eloglvl.o SPI.o
OBJS = plperl.o spi_internal.o SPI.o
ifeq ($(enable_rpath), yes)
SHLIB_LINK = $(perl_embed_ldflags) $(BE_DLLLIBS) -Wl,-rpath,$(perl_archlibexp)/CORE
else
SHLIB_LINK = $(perl_embed_ldflags) $(BE_DLLLIBS)
endif
include $(top_srcdir)/src/Makefile.shlib

32
src/pl/plperl/SPI.xs
View File

@ -6,17 +6,17 @@
#include "perl.h"
#include "XSUB.h"
#include "eloglvl.h"
#include "spi_internal.h"
MODULE = SPI PREFIX = elog_
MODULE = SPI PREFIX = spi_
PROTOTYPES: ENABLE
VERSIONCHECK: DISABLE
void
elog_elog(level, message)
spi_elog(level, message)
int level
char* message
CODE:
@ -24,21 +24,33 @@ elog_elog(level, message)
int
elog_DEBUG()
spi_DEBUG()
int
elog_LOG()
spi_LOG()
int
elog_INFO()
spi_INFO()
int
elog_NOTICE()
spi_NOTICE()
int
elog_WARNING()
spi_WARNING()
int
elog_ERROR()
spi_ERROR()
SV*
spi_spi_exec_query(query, ...)
char* query;
PREINIT:
HV *ret_hash;
int limit=0;
CODE:
if (items>2) Perl_croak(aTHX_ "Usage: spi_exec_query(query, limit) or spi_exec_query(query)");
if (items == 2) limit = SvIV(ST(1));
ret_hash=plperl_spi_exec(query, limit);
RETVAL = newRV_noinc((SV*)ret_hash);
OUTPUT:
RETVAL

45
src/pl/plperl/eloglvl.c
View File

@ -1,45 +0,0 @@
#include "postgres.h"
/*
* This kludge is necessary because of the conflicting
* definitions of 'DEBUG' between postgres and perl.
* we'll live.
*/
#include "eloglvl.h"
int
elog_DEBUG(void)
{
return DEBUG2;
}
int
elog_LOG(void)
{
return LOG;
}
int
elog_INFO(void)
{
return INFO;
}
int
elog_NOTICE(void)
{
return NOTICE;
}
int
elog_WARNING(void)
{
return WARNING;
}
int
elog_ERROR(void)
{
return ERROR;
}

12
src/pl/plperl/eloglvl.h
View File

@ -1,12 +0,0 @@
int elog_DEBUG(void);
int elog_LOG(void);
int elog_INFO(void);
int elog_NOTICE(void);
int elog_WARNING(void);
int elog_ERROR(void);

643
src/pl/plperl/plperl.c
View File

@ -33,7 +33,7 @@
* ENHANCEMENTS, OR MODIFICATIONS.
*
* IDENTIFICATION
* $PostgreSQL: pgsql/src/pl/plperl/plperl.c,v 1.44 2004/06/06 00:41:28 tgl Exp $
* $PostgreSQL: pgsql/src/pl/plperl/plperl.c,v 1.45 2004/07/01 20:50:22 joe Exp $
*
**********************************************************************/
@ -49,6 +49,7 @@
#include "catalog/pg_language.h"
#include "catalog/pg_proc.h"
#include "catalog/pg_type.h"
#include "funcapi.h" /* need for SRF support */
#include "commands/trigger.h"
#include "executor/spi.h"
#include "fmgr.h"
@ -78,6 +79,8 @@ typedef struct plperl_proc_desc
TransactionId fn_xmin;
CommandId fn_cmin;
bool lanpltrusted;
bool fn_retistuple; /* true, if function returns tuple */
Oid ret_oid; /* Oid of returning type */
FmgrInfo result_in_func;
Oid result_typioparam;
int nargs;
@ -94,6 +97,9 @@ typedef struct plperl_proc_desc
static int plperl_firstcall = 1;
static PerlInterpreter *plperl_interp = NULL;
static HV *plperl_proc_hash = NULL;
AV *g_row_keys = NULL;
AV *g_column_keys = NULL;
int g_attr_num = 0;
/**********************************************************************
* Forward declarations
@ -106,6 +112,7 @@ void plperl_init(void);
static Datum plperl_func_handler(PG_FUNCTION_ARGS);
static Datum plperl_trigger_handler(PG_FUNCTION_ARGS);
static plperl_proc_desc *compile_plperl_function(Oid fn_oid, bool is_trigger);
static SV *plperl_build_tuple_argument(HeapTuple tuple, TupleDesc tupdesc);
@ -205,14 +212,15 @@ plperl_init_interp(void)
"", "-e",
/*
* no commas between the next 5 please. They are supposed to be
* no commas between the next lines please. They are supposed to be
* one string
*/
"require Safe; SPI::bootstrap();"
"sub ::mksafefunc { my $x = new Safe; $x->permit_only(':default');$x->permit(':base_math');"
"$x->share(qw[&elog &DEBUG &LOG &INFO &NOTICE &WARNING &ERROR]);"
" return $x->reval(qq[sub { $_[0] }]); }"
"sub ::mkunsafefunc {return eval(qq[ sub { $_[0] } ]); }"
"require Safe; SPI::bootstrap(); use vars qw(%_SHARED);"
"use vars qw($PLContainer); $PLContainer = new Safe('PLPerl');"
"$PLContainer->permit_only(':default');$PLContainer->permit(':base_math');"
"$PLContainer->share(qw[&elog &spi_exec_query &DEBUG &LOG &INFO &NOTICE &WARNING &ERROR %SHARED ]);"
"sub ::mksafefunc { return $PLContainer->reval(qq[sub { $_[0] $_[1]}]); }"
"sub ::mkunsafefunc {return eval(qq[ sub { $_[0] $_[1] } ]); }"
};
plperl_interp = perl_alloc();
@ -230,6 +238,312 @@ plperl_init_interp(void)
}
/**********************************************************************
* turn a tuple into a hash expression and add it to a list
**********************************************************************/
static void
plperl_sv_add_tuple_value(SV * rv, HeapTuple tuple, TupleDesc tupdesc)
{
int i;
char *value;
char *key;
sv_catpvf(rv, "{ ");
for (i = 0; i < tupdesc->natts; i++)
{
key = SPI_fname(tupdesc, i + 1);
value = SPI_getvalue(tuple, tupdesc, i + 1);
if (value)
sv_catpvf(rv, "%s => '%s'", key, value);
else
sv_catpvf(rv, "%s => undef", key);
if (i != tupdesc->natts - 1)
sv_catpvf(rv, ", ");
}
sv_catpvf(rv, " }");
}
/**********************************************************************
* set up arguments for a trigger call
**********************************************************************/
static SV *
plperl_trigger_build_args(FunctionCallInfo fcinfo)
{
TriggerData *tdata;
TupleDesc tupdesc;
int i = 0;
SV *rv;
rv = newSVpv("{ ", 0);
tdata = (TriggerData *) fcinfo->context;
tupdesc = tdata->tg_relation->rd_att;
sv_catpvf(rv, "name => '%s'", tdata->tg_trigger->tgname);
sv_catpvf(rv, ", relid => '%s'", DatumGetCString(DirectFunctionCall1(oidout, ObjectIdGetDatum(tdata->tg_relation->rd_id))));
if (TRIGGER_FIRED_BY_INSERT(tdata->tg_event))
{
sv_catpvf(rv, ", event => 'INSERT'");
sv_catpvf(rv, ", new =>");
plperl_sv_add_tuple_value(rv, tdata->tg_trigtuple, tupdesc);
}
else if (TRIGGER_FIRED_BY_DELETE(tdata->tg_event))
{
sv_catpvf(rv, ", event => 'DELETE'");
sv_catpvf(rv, ", old => ");
plperl_sv_add_tuple_value(rv, tdata->tg_trigtuple, tupdesc);
}
else if (TRIGGER_FIRED_BY_UPDATE(tdata->tg_event))
{
sv_catpvf(rv, ", event => 'UPDATE'");
sv_catpvf(rv, ", new =>");
plperl_sv_add_tuple_value(rv, tdata->tg_newtuple, tupdesc);
sv_catpvf(rv, ", old => ");
plperl_sv_add_tuple_value(rv, tdata->tg_trigtuple, tupdesc);
}
else
sv_catpvf(rv, ", event => 'UNKNOWN'");
sv_catpvf(rv, ", argc => %d", tdata->tg_trigger->tgnargs);
if (tdata->tg_trigger->tgnargs != 0)
{
sv_catpvf(rv, ", args => [ ");
for (i = 0; i < tdata->tg_trigger->tgnargs; i++)
{
sv_catpvf(rv, "%s", tdata->tg_trigger->tgargs[i]);
if (i != tdata->tg_trigger->tgnargs - 1)
sv_catpvf(rv, ", ");
}
sv_catpvf(rv, " ]");
}
sv_catpvf(rv, ", relname => '%s'", SPI_getrelname(tdata->tg_relation));
if (TRIGGER_FIRED_BEFORE(tdata->tg_event))
sv_catpvf(rv, ", when => 'BEFORE'");
else if (TRIGGER_FIRED_AFTER(tdata->tg_event))
sv_catpvf(rv, ", when => 'AFTER'");
else
sv_catpvf(rv, ", when => 'UNKNOWN'");
if (TRIGGER_FIRED_FOR_ROW(tdata->tg_event))
sv_catpvf(rv, ", level => 'ROW'");
else if (TRIGGER_FIRED_FOR_STATEMENT(tdata->tg_event))
sv_catpvf(rv, ", level => 'STATEMENT'");
else
sv_catpvf(rv, ", level => 'UNKNOWN'");
sv_catpvf(rv, " }");
rv = perl_eval_pv(SvPV(rv, PL_na), TRUE);
return rv;
}
/**********************************************************************
* check return value from plperl function
**********************************************************************/
static int
plperl_is_set(SV * sv)
{
int i = 0;
int len = 0;
int set = 0;
int other = 0;
AV *input_av;
SV **val;
if (SvTYPE(sv) != SVt_RV)
return 0;
if (SvTYPE(SvRV(sv)) == SVt_PVHV)
return 0;
if (SvTYPE(SvRV(sv)) == SVt_PVAV)
{
input_av = (AV *) SvRV(sv);
len = av_len(input_av) + 1;
for (i = 0; i < len; i++)
{
val = av_fetch(input_av, i, FALSE);
if (SvTYPE(*val) == SVt_RV)
set = 1;
else
other = 1;
}
}
if (len == 0)
return 1;
if (set && !other)
return 1;
if (!set && other)
return 0;
if (set && other)
elog(ERROR, "plperl: check your return value structure");
if (!set && !other)
elog(ERROR, "plperl: check your return value structure");
return 0; /* for compiler */
}
/**********************************************************************
* extract a list of keys from a hash
**********************************************************************/
static AV *
plperl_get_keys(HV * hv)
{
AV *ret;
SV **svp;
int key_count;
SV *val;
char *key;
I32 klen;
key_count = 0;
ret = newAV();
hv_iterinit(hv);
while (val = hv_iternextsv(hv, (char **) &key, &klen))
{
av_store(ret, key_count, eval_pv(key, TRUE));
key_count++;
}
hv_iterinit(hv);
return ret;
}
/**********************************************************************
* extract a given key (by index) from a list of keys
**********************************************************************/
static char *
plperl_get_key(AV * keys, int index)
{
SV **svp;
int len;
len = av_len(keys) + 1;
if (index < len)
svp = av_fetch(keys, index, FALSE);
else
return NULL;
return SvPV(*svp, PL_na);
}
/**********************************************************************
* extract a value for a given key from a hash
*
* return NULL on error or if we got an undef
*
**********************************************************************/
static char *
plperl_get_elem(HV * hash, char *key)
{
SV **svp;
if (hv_exists_ent(hash, eval_pv(key, TRUE), FALSE))
svp = hv_fetch(hash, key, strlen(key), FALSE);
else
{
elog(ERROR, "plperl: key '%s' not found", key);
return NULL;
}
return SvTYPE(*svp) == SVt_NULL ? NULL : SvPV(*svp, PL_na);
}
/**********************************************************************
* set up the new tuple returned from a trigger
**********************************************************************/
static HeapTuple
plperl_modify_tuple(HV * hvTD, TriggerData *tdata, HeapTuple otup, Oid fn_oid)
{
SV **svp;
HV *hvNew;
AV *plkeys;
char *platt;
char *plval;
HeapTuple rtup;
int natts,
i,
attn,
atti;
int *volatile modattrs = NULL;
Datum *volatile modvalues = NULL;
char *volatile modnulls = NULL;
TupleDesc tupdesc;
HeapTuple typetup;
tupdesc = tdata->tg_relation->rd_att;
svp = hv_fetch(hvTD, "new", 3, FALSE);
hvNew = (HV *) SvRV(*svp);
if (SvTYPE(hvNew) != SVt_PVHV)
elog(ERROR, "plperl: $_TD->{new} is not a hash");
plkeys = plperl_get_keys(hvNew);
natts = av_len(plkeys)+1;
if (natts != tupdesc->natts)
elog(ERROR, "plperl: $_TD->{new} has an incorrect number of keys.");
modattrs = palloc0(natts * sizeof(int));
modvalues = palloc0(natts * sizeof(Datum));
modnulls = palloc0(natts * sizeof(char));
for (i = 0; i < natts; i++)
{
FmgrInfo finfo;
Oid typinput;
Oid typelem;
platt = plperl_get_key(plkeys, i);
attn = modattrs[i] = SPI_fnumber(tupdesc, platt);
if (attn == SPI_ERROR_NOATTRIBUTE)
elog(ERROR, "plperl: invalid attribute `%s' in tuple.", platt);
atti = attn - 1;
plval = plperl_get_elem(hvNew, platt);
typetup = SearchSysCache(TYPEOID, ObjectIdGetDatum(tupdesc->attrs[atti]->atttypid), 0, 0, 0);
typinput = ((Form_pg_type) GETSTRUCT(typetup))->typinput;
typelem = ((Form_pg_type) GETSTRUCT(typetup))->typelem;
ReleaseSysCache(typetup);
fmgr_info(typinput, &finfo);
if (plval)
{
modvalues[i] = FunctionCall3(&finfo,
CStringGetDatum(plval),
ObjectIdGetDatum(typelem),
Int32GetDatum(tupdesc->attrs[atti]->atttypmod));
modnulls[i] = ' ';
}
else
{
modvalues[i] = (Datum) 0;
modnulls[i] = 'n';
}
}
rtup = SPI_modifytuple(tdata->tg_relation, otup, natts, modattrs, modvalues, modnulls);
pfree(modattrs);
pfree(modvalues);
pfree(modnulls);
if (rtup == NULL)
elog(ERROR, "plperl: SPI_modifytuple failed -- error: %d", SPI_result);
return rtup;
}
/**********************************************************************
* plperl_call_handler - This is the only visible function
@ -262,17 +576,7 @@ plperl_call_handler(PG_FUNCTION_ARGS)
* call appropriate subhandler
************************************************************/
if (CALLED_AS_TRIGGER(fcinfo))
{
ereport(ERROR,
(errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
errmsg("cannot use perl in triggers yet")));
/*
* retval = PointerGetDatum(plperl_trigger_handler(fcinfo));
*/
/* make the compiler happy */
retval = (Datum) 0;
}
retval = PointerGetDatum(plperl_trigger_handler(fcinfo));
else
retval = plperl_func_handler(fcinfo);
@ -295,6 +599,7 @@ plperl_create_sub(char *s, bool trusted)
ENTER;
SAVETMPS;
PUSHMARK(SP);
XPUSHs(sv_2mortal(newSVpv("my $_TD=$_[0]; shift;", 0)));
XPUSHs(sv_2mortal(newSVpv(s, 0)));
PUTBACK;
@ -387,6 +692,7 @@ plperl_call_perl_func(plperl_proc_desc * desc, FunctionCallInfo fcinfo)
SAVETMPS;
PUSHMARK(SP);
XPUSHs(sv_2mortal(newSVpv("undef", 0)));
for (i = 0; i < desc->nargs; i++)
{
if (desc->arg_is_rowtype[i])
@ -468,6 +774,57 @@ plperl_call_perl_func(plperl_proc_desc * desc, FunctionCallInfo fcinfo)
return retval;
}
/**********************************************************************
* plperl_call_perl_trigger_func() - calls a perl function affected by trigger
* through the RV stored in the prodesc structure. massages the input parms properly
**********************************************************************/
static SV *
plperl_call_perl_trigger_func(plperl_proc_desc * desc, FunctionCallInfo fcinfo, SV * td)
{
dSP;
SV *retval;
int i;
int count;
char *ret_test;
ENTER;
SAVETMPS;
PUSHMARK(sp);
XPUSHs(td);
for (i = 0; i < ((TriggerData *) fcinfo->context)->tg_trigger->tgnargs; i++)
XPUSHs(sv_2mortal(newSVpv(((TriggerData *) fcinfo->context)->tg_trigger->tgargs[i], 0)));
PUTBACK;
count = perl_call_sv(desc->reference, G_SCALAR | G_EVAL | G_KEEPERR);
SPAGAIN;
if (count != 1)
{
PUTBACK;
FREETMPS;
LEAVE;
elog(ERROR, "plperl: didn't get a return item from function");
}
if (SvTRUE(ERRSV))
{
POPs;
PUTBACK;
FREETMPS;
LEAVE;
elog(ERROR, "plperl: error from function: %s", SvPV(ERRSV, PL_na));
}
retval = newSVsv(POPs);
PUTBACK;
FREETMPS;
LEAVE;
return retval;
}
/**********************************************************************
* plperl_func_handler() - Handler for regular function calls
@ -481,11 +838,17 @@ plperl_func_handler(PG_FUNCTION_ARGS)
/* Find or compile the function */
prodesc = compile_plperl_function(fcinfo->flinfo->fn_oid, false);
/************************************************************
* Call the Perl function
************************************************************/
perlret = plperl_call_perl_func(prodesc, fcinfo);
if (prodesc->fn_retistuple && SRF_IS_FIRSTCALL())
{
if (SvTYPE(perlret) != SVt_RV)
elog(ERROR, "plperl: this function must return a reference");
g_column_keys = newAV();
}
/************************************************************
* Disconnect from SPI manager and then create the return
@ -496,13 +859,145 @@ plperl_func_handler(PG_FUNCTION_ARGS)
if (SPI_finish() != SPI_OK_FINISH)
elog(ERROR, "SPI_finish() failed");
if (!(perlret && SvOK(perlret)))
if (!(perlret && SvOK(perlret) && SvTYPE(perlret)!=SVt_NULL ))
{
/* return NULL if Perl code returned undef */
retval = (Datum) 0;
fcinfo->isnull = true;
}
if (prodesc->fn_retistuple)
{
/* SRF support */
HV *ret_hv;
AV *ret_av;
FuncCallContext *funcctx;
int call_cntr;
int max_calls;
TupleDesc tupdesc;
TupleTableSlot *slot;
AttInMetadata *attinmeta;
bool isset = 0;
char **values = NULL;
ReturnSetInfo *rsinfo = (ReturnSetInfo *) fcinfo->resultinfo;
if (!rsinfo)
ereport(ERROR,
(errcode(ERRCODE_SYNTAX_ERROR),
errmsg("returning a composite type is not allowed in this context"),
errhint("This function is intended for use in the FROM clause.")));
if (SvTYPE(perlret) != SVt_RV)
elog(ERROR, "plperl: this function must return a reference");
isset = plperl_is_set(perlret);
if (SvTYPE(SvRV(perlret)) == SVt_PVHV)
ret_hv = (HV *) SvRV(perlret);
else
ret_av = (AV *) SvRV(perlret);
if (SRF_IS_FIRSTCALL())
{
MemoryContext oldcontext;
int i;
funcctx = SRF_FIRSTCALL_INIT();
oldcontext = MemoryContextSwitchTo(funcctx->multi_call_memory_ctx);
if (SvTYPE(SvRV(perlret)) == SVt_PVHV)
{
if (isset)
funcctx->max_calls = hv_iterinit(ret_hv);
else
funcctx->max_calls = 1;
}
else
{
if (isset)
funcctx->max_calls = av_len(ret_av) + 1;
else
funcctx->max_calls = 1;
}
tupdesc = CreateTupleDescCopy(rsinfo->expectedDesc);
g_attr_num = tupdesc->natts;
for (i = 0; i < tupdesc->natts; i++)
av_store(g_column_keys, i + 1, eval_pv(SPI_fname(tupdesc, i + 1), TRUE));
slot = TupleDescGetSlot(tupdesc);
funcctx->slot = slot;
attinmeta = TupleDescGetAttInMetadata(tupdesc);
funcctx->attinmeta = attinmeta;
MemoryContextSwitchTo(oldcontext);
}
funcctx = SRF_PERCALL_SETUP();
call_cntr = funcctx->call_cntr;
max_calls = funcctx->max_calls;
slot = funcctx->slot;
attinmeta = funcctx->attinmeta;
if (call_cntr < max_calls)
{
HeapTuple tuple;
Datum result;
int i;
char *column_key;
char *elem;
if (isset)
{
HV *row_hv;
SV **svp;
char *row_key;
svp = av_fetch(ret_av, call_cntr, FALSE);
row_hv = (HV *) SvRV(*svp);
values = (char **) palloc(g_attr_num * sizeof(char *));
for (i = 0; i < g_attr_num; i++)
{
column_key = plperl_get_key(g_column_keys, i + 1);
elem = plperl_get_elem(row_hv, column_key);
if (elem)
values[i] = elem;
else
values[i] = NULL;
}
}
else
{
int i;
values = (char **) palloc(g_attr_num * sizeof(char *));
for (i = 0; i < g_attr_num; i++)
{
column_key = SPI_fname(tupdesc, i + 1);
elem = plperl_get_elem(ret_hv, column_key);
if (elem)
values[i] = elem;
else
values[i] = NULL;
}
}
tuple = BuildTupleFromCStrings(attinmeta, values);
result = TupleGetDatum(slot, tuple);
SRF_RETURN_NEXT(funcctx, result);
}
else
{
SvREFCNT_dec(perlret);
SRF_RETURN_DONE(funcctx);
}
}
else if (! fcinfo->isnull)
{
retval = FunctionCall3(&prodesc->result_in_func,
PointerGetDatum(SvPV(perlret, PL_na)),
@ -511,10 +1006,101 @@ plperl_func_handler(PG_FUNCTION_ARGS)
}
SvREFCNT_dec(perlret);
return retval;
}
/**********************************************************************
* plperl_trigger_handler() - Handler for trigger function calls
**********************************************************************/
static Datum
plperl_trigger_handler(PG_FUNCTION_ARGS)
{
plperl_proc_desc *prodesc;
SV *perlret;
Datum retval;
char *tmp;
SV *svTD;
HV *hvTD;
/* Find or compile the function */
prodesc = compile_plperl_function(fcinfo->flinfo->fn_oid, true);
/************************************************************
* Call the Perl function
************************************************************/
/*
* call perl trigger function and build TD hash
*/
svTD = plperl_trigger_build_args(fcinfo);
perlret = plperl_call_perl_trigger_func(prodesc, fcinfo, svTD);
hvTD = (HV *) SvRV(svTD); /* convert SV TD structure to Perl Hash
* structure */
tmp = SvPV(perlret, PL_na);
/************************************************************
* Disconnect from SPI manager and then create the return
* values datum (if the input function does a palloc for it
* this must not be allocated in the SPI memory context
* because SPI_finish would free it).
************************************************************/
if (SPI_finish() != SPI_OK_FINISH)
elog(ERROR, "plperl: SPI_finish() failed");
if (!(perlret && SvOK(perlret)))
{
TriggerData *trigdata = ((TriggerData *) fcinfo->context);
if (TRIGGER_FIRED_BY_INSERT(trigdata->tg_event))
retval = (Datum) trigdata->tg_trigtuple;
else if (TRIGGER_FIRED_BY_UPDATE(trigdata->tg_event))
retval = (Datum) trigdata->tg_newtuple;
else if (TRIGGER_FIRED_BY_DELETE(trigdata->tg_event))
retval = (Datum) trigdata->tg_trigtuple;
}
else
{
if (!fcinfo->isnull)
{
HeapTuple trv;
if (strcasecmp(tmp, "SKIP") == 0)
trv = NULL;
else if (strcasecmp(tmp, "MODIFY") == 0)
{
TriggerData *trigdata = (TriggerData *) fcinfo->context;
if (TRIGGER_FIRED_BY_INSERT(trigdata->tg_event))
trv = plperl_modify_tuple(hvTD, trigdata, trigdata->tg_trigtuple, fcinfo->flinfo->fn_oid);
else if (TRIGGER_FIRED_BY_UPDATE(trigdata->tg_event))
trv = plperl_modify_tuple(hvTD, trigdata, trigdata->tg_newtuple, fcinfo->flinfo->fn_oid);
else
{
trv = NULL;
elog(WARNING, "plperl: Ignoring modified tuple in DELETE trigger");
}
}
else if (strcasecmp(tmp, "OK"))
{
trv = NULL;
elog(ERROR, "plperl: Expected return to be undef, 'SKIP' or 'MODIFY'");
}
else
{
trv = NULL;
elog(ERROR, "plperl: Expected return to be undef, 'SKIP' or 'MODIFY'");
}
retval = PointerGetDatum(trv);
}
}
SvREFCNT_dec(perlret);
fcinfo->isnull = false;
return retval;
}
/**********************************************************************
* compile_plperl_function - compile (or hopefully just look up) function
@ -544,6 +1130,7 @@ compile_plperl_function(Oid fn_oid, bool is_trigger)
sprintf(internal_proname, "__PLPerl_proc_%u", fn_oid);
else
sprintf(internal_proname, "__PLPerl_proc_%u_trigger", fn_oid);
proname_len = strlen(internal_proname);
/************************************************************
@ -637,10 +1224,11 @@ compile_plperl_function(Oid fn_oid, bool is_trigger)
}
typeStruct = (Form_pg_type) GETSTRUCT(typeTup);
/* Disallow pseudotype result, except VOID */
/* Disallow pseudotype result, except VOID or RECORD */
if (typeStruct->typtype == 'p')
{
if (procStruct->prorettype == VOIDOID)
if (procStruct->prorettype == VOIDOID ||
procStruct->prorettype == RECORDOID)
/* okay */ ;
else if (procStruct->prorettype == TRIGGEROID)
{
@ -661,13 +1249,10 @@ compile_plperl_function(Oid fn_oid, bool is_trigger)
}
}
if (typeStruct->typtype == 'c')
if (typeStruct->typtype == 'c' || procStruct->prorettype == RECORDOID)
{
free(prodesc->proname);
free(prodesc);
ereport(ERROR,
(errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
errmsg("plperl functions cannot return tuples yet")));
prodesc->fn_retistuple = true;
prodesc->ret_oid = typeStruct->typrelid;
}
perm_fmgr_info(typeStruct->typinput, &(prodesc->result_in_func));

179
src/pl/plperl/spi_internal.c Normal file
View File

@ -0,0 +1,179 @@
#include "postgres.h"
#include "executor/spi.h"
#include "utils/syscache.h"
/*
* This kludge is necessary because of the conflicting
* definitions of 'DEBUG' between postgres and perl.
* we'll live.
*/
#include "spi_internal.h"
static char* plperl_spi_status_string(int);
static HV* plperl_spi_execute_fetch_result(SPITupleTable*, int, int );
int
spi_DEBUG(void)
{
return DEBUG2;
}
int
spi_LOG(void)
{
return LOG;
}
int
spi_INFO(void)
{
return INFO;
}
int
spi_NOTICE(void)
{
return NOTICE;
}
int
spi_WARNING(void)
{
return WARNING;
}
int
spi_ERROR(void)
{
return ERROR;
}
HV*
plperl_spi_exec(char* query, int limit)
{
HV *ret_hv;
int spi_rv;
spi_rv = SPI_exec(query, limit);
ret_hv=plperl_spi_execute_fetch_result(SPI_tuptable, SPI_processed, spi_rv);
return ret_hv;
}
static HV*
plperl_hash_from_tuple(HeapTuple tuple, TupleDesc tupdesc)
{
int i;
char *attname;
char *attdata;
HV *array;
array = newHV();
for (i = 0; i < tupdesc->natts; i++) {
/************************************************************
* Get the attribute name
************************************************************/
attname = tupdesc->attrs[i]->attname.data;
/************************************************************
* Get the attributes value
************************************************************/
attdata = SPI_getvalue(tuple, tupdesc, i+1);
hv_store(array, attname, strlen(attname), newSVpv(attdata,0), 0);
}
return array;
}
static HV*
plperl_spi_execute_fetch_result(SPITupleTable *tuptable, int rows, int status)
{
HV *result;
int i;
result = newHV();
if (status == SPI_OK_UTILITY)
{
hv_store(result, "status", strlen("status"), newSVpv("SPI_OK_UTILITY",0), 0);
hv_store(result, "rows", strlen("rows"), newSViv(rows), 0);
}
else if (status != SPI_OK_SELECT)
{
hv_store(result, "status", strlen("status"), newSVpv((char*)plperl_spi_status_string(status),0), 0);
hv_store(result, "rows", strlen("rows"), newSViv(rows), 0);
}
else
{
if (rows)
{
char* key=palloc(sizeof(int));
HV *row;
for (i = 0; i < rows; i++)
{
row = plperl_hash_from_tuple(tuptable->vals[i], tuptable->tupdesc);
sprintf(key, "%i", i);
hv_store(result, key, strlen(key), newRV_noinc((SV*)row), 0);
}
SPI_freetuptable(tuptable);
}
}
return result;
}
static char*
plperl_spi_status_string(int status)
{
switch(status){
/*errors*/
case SPI_ERROR_TYPUNKNOWN:
return "SPI_ERROR_TYPUNKNOWN";
case SPI_ERROR_NOOUTFUNC:
return "SPI_ERROR_NOOUTFUNC";
case SPI_ERROR_NOATTRIBUTE:
return "SPI_ERROR_NOATTRIBUTE";
case SPI_ERROR_TRANSACTION:
return "SPI_ERROR_TRANSACTION";
case SPI_ERROR_PARAM:
return "SPI_ERROR_PARAM";
case SPI_ERROR_ARGUMENT:
return "SPI_ERROR_ARGUMENT";
case SPI_ERROR_CURSOR:
return "SPI_ERROR_CURSOR";
case SPI_ERROR_UNCONNECTED:
return "SPI_ERROR_UNCONNECTED";
case SPI_ERROR_OPUNKNOWN:
return "SPI_ERROR_OPUNKNOWN";
case SPI_ERROR_COPY:
return "SPI_ERROR_COPY";
case SPI_ERROR_CONNECT:
return "SPI_ERROR_CONNECT";
/*ok*/
case SPI_OK_CONNECT:
return "SPI_OK_CONNECT";
case SPI_OK_FINISH:
return "SPI_OK_FINISH";
case SPI_OK_FETCH:
return "SPI_OK_FETCH";
case SPI_OK_UTILITY:
return "SPI_OK_UTILITY";
case SPI_OK_SELECT:
return "SPI_OK_SELECT";
case SPI_OK_SELINTO:
return "SPI_OK_SELINTO";
case SPI_OK_INSERT:
return "SPI_OK_INSERT";
case SPI_OK_DELETE:
return "SPI_OK_DELETE";
case SPI_OK_UPDATE:
return "SPI_OK_UPDATE";
case SPI_OK_CURSOR:
return "SPI_OK_CURSOR";
}
return "Unknown or Invalid code";
}

19
src/pl/plperl/spi_internal.h Normal file
View File

@ -0,0 +1,19 @@
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
int spi_DEBUG(void);
int spi_LOG(void);
int spi_INFO(void);
int spi_NOTICE(void);
int spi_WARNING(void);
int spi_ERROR(void);
HV* plperl_spi_exec(char*, int);