I know it's late in the day, but ...
Attached is a patch and 2 replacement files for plperl. The work has been done under the auspices of the plperlng project on pgfoundry. The code (which has been through several iterations) comes from CommandPrompt, and has had some minor editorializing by me (spelling, indentation, function heading comments). It has also been reviewed somewhat by Abhijit Menon-Sen, who supplied a small optimization. It has been tested by me and by David Fetter.
These changes should have low impact - they will not affect anyone who doesn't use plperl, nor anyone who does not use the new functionality (with one possible tiny exception, noted below).
This functionality does not by any means represent all we want to achieve with plperl, but it is what we have been able to achieve in a short space of time, and is a significant advance. If the patch is accepted we will provide a doc patch very shortly.
Summary of new functionality (for more details see below):
. 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.
Backwards compatibility: the move to a common name space for trusted functions will affect anyone who now relies on the fact that each function has its own namespace and has different functions store different data with the same name - I expect this to be at most some number of users countable on the fingers of one hand.
Known limitations - both of these will change in a future release:
. 'setof record' is not supported
. arrays and embedded composite types are represented as strings, and must be returned as strings.
Files changed: GNUmakefile SPI.xs plperl.c (this is where all the interesting stuff happens)
Files deleted: eloglvl.c eloglvl.h
Files added (incorporating eloglvl functionality): spi_internal.c spi_internal.h
More detailed description of new functionality, with some examples:
Database Access from PL/perl
PL/perl provides a function called spi_exec_query. Calling spi_exec_query with a query string and an optional limit argument causes that query to be run and the result to be returned in a result reference to hash.
The result has two values: rows which returns either the number of rows returned by the query, or in the case of a SELECT query, a reference to an array of the actual rows which can be accessed by row number and column name, and status which is the SPI_exec() return value.
The result hash can be modified.
For example:
$rv = spi_exec_query(''SELECT * FROM my_table'', 5);returns up to 5 rows from my_table. If my_table has a column my_column, it would be accessed as
$foo = $rv->{rows}[$i]->{my_column};
$nrows = @{$fv->{rows}};or
$query = "INSERT INTO my_table VALUES (1, ''test'')"; $rv = spi_exec_query($query);
result would be accessed as
$res = $rv->{status}; //SPI_OK_INSERT in our example
$nrows = $rv->{rows};
To return a row or composite-type value from a PL/perl-language function, you can use hash:
CREATE TYPE __testrowperl AS (f1 integer, f2 text, f3 text);
CREATE OR REPLACE FUNCTION perl_row() RETURNS __testrowperl AS $$
return {f2 => 'hello', f1 => 1, f3 => 'world'};$$ LANGUAGE plperl;
select * FROM perl_row();
Will return: f1 | f2 | f3 ----+-------+------- 1 | hello | world
You can also use SETOF functions (returning sets (multiple rows)):
CREATE TYPE __testsetperl AS (f1 integer, f2 text, f3 text);
CREATE OR REPLACE FUNCTION perl_set() RETURNS SETOF __testsetperl AS $$
return
[
{f1 => 1, f2 => 'hello', f3 => 'world'},
{f1 => 2, f2 => 'hello', f3 => 'postgres'},
{f1 => 3, f2 => 'hello', f3 => 'plperl'}
];
$$ LANGUAGE plperl;SELECT * FROM perl_set();
Will return: f1 | f2 | f3 ----+-------+---------- 1 | hello | world 2 | hello | postgres 3 | hello | plperl
CREATE OR REPLACE FUNCTION perl_set() RETURNS SETOF __testsetperl AS $$ return[]; $$ LANGUAGE plperl;
SELECT * FROM perl_set();
Will return: f1 | f2 | f3 ----+-------+----------
CREATE OR REPLACE FUNCTION perl_set() RETURNS SETOF __testsetperl AS $$
return[{f1=>undef, f2=>test, f3=>undef}];
$$ LANGUAGE plperl;SELECT * FROM perl_set();
Will return: f1 | f2 | f3 ----+-------+---------- | test | You can use hash %_SHARED to store data between function calls.
For exaple:
CREATE OR REPLACE FUNCTION set_var() RETURNS text AS $$
$_SHARED{first}='hello plperl';
return 'ok';
$$ LANGUAGE plperl;CREATE OR REPLACE FUNCTION get_var() RETURNS text AS $$
return $_SHARED{first};
$$ LANGUAGE plperl;SELECT set_var('hello plperl');
SELECT get_var(); //will return "hello plperl" in our exampleTrigger Procedures in PL/Perl
When a function is used in a trigger, the hash reference $_TD contains trigger-related values.
$_TD->{"new"}
A hash containing the values of the new table row for INSERT/UPDATE
actions, or empty for DELETE. Fields that are NULL will be undefined!$_TD->{"old"}
A hash containing the values of the old table row for UPDATE/DELETE
actions, or empty for INSERT. Fields that are NULL will be undefined!$_TD->{"name"}
contains the trigger name.$_TD->{"event"}
contains the event as a string (INSERT, UPDATE, DELETE or UNKNOWN).$_TD->{"when"}
contains one of BEFORE, AFTER or UNKNOWN.$_TD->{"level"}
contains one of ROW, STATEMENT or UNKNOWN.$_TD->{"relid"}
contains the relation ID of the table on which the trigger occurred.$_TD->{"relname"}
contains the relation name.$_TD->{"argc"}
contains the arguments count.If the trigger was called with arguments they are available as
$_TD->{"args"}[0], ... , $_TD->{"args"}[($_TD->{"argc"}-1)]Modification control
Structure of table for examples:
CREATE TABLE test (
i int,
v varchar
) WITH OIDS;Example of ON INSERT/UPDATE TRIGGER:
CREATE OR REPLACE FUNCTION valid_id() RETURNS trigger AS $$
if (($_TD->{new}{i}>=100) || ($_TD->{new}{i}<=0))
{
return "SKIP"; # Skip INSERT/UPDATE command
}
elsif ($_TD->{new}{v} ne "immortal")
{
$_TD->{new}{v} .= "(modified by trigger)";
return "MODIFY"; # Modify tuple and proceed INSERT/UPDATE command
}
else
{
return; # Proceed INSERT/UPDATE command
}
$$ LANGUAGE plperl;
CREATE TRIGGER test_valid_id_trig BEFORE INSERT OR UPDATE ON test FOR EACH ROW EXECUTE PROCEDURE valid_id();
INSERT INTO test (i, v) VALUES (1,'first line'); INSERT INTO test (i, v) VALUES (2,'second line'); INSERT INTO test (i, v) VALUES (3,'third line'); INSERT INTO test (i, v) VALUES (4,'immortal');
INSERT INTO test (i, v) VALUES (101,'bad id'); will output INSERT 0 0;
UPDATE test SET i = 5 where i=3; will output UPDATE 1, but
UPDATE test SET i = 100 where i=1; will output UPDATE 0
Example of ON DELETE TRIGGER:
CREATE OR REPLACE FUNCTION immortal() RETURNS trigger AS $$
if ($_TD->{old}{v} eq $_TD->{args}[0])
{
return "SKIP"; # Skip DELETE command
}
else
{
return; # Proceed DELETE command
};
$$ LANGUAGE plperl;CREATE TRIGGER immortal_trig BEFORE DELETE ON test
FOR EACH ROW EXECUTE PROCEDURE immortal('immortal');INSERT INTO test (i, v) VALUES (1,'first line'); INSERT INTO test (i, v) VALUES (2,'second line'); INSERT INTO test (i, v) VALUES (3,'third line'); INSERT INTO test (i, v) VALUES (4,'immortal');
DELETE FROM test; will output: DELETE 3, and line #4 has not been deleted
Tip: If the TD->{"when"} is BEFORE, you may return "SKIP" to abort the event,"MODIFY" to indicate you've modified the row, or "undef" to make the action.
Tip: To return "undef" just specify "return;" in plperl function source.
enjoy
andrew
Index: GNUmakefile
===================================================================
RCS file: /projects/cvsroot/pgsql-server/src/pl/plperl/GNUmakefile,v
retrieving revision 1.12
diff -c -w -r1.12 GNUmakefile
*** GNUmakefile 21 Jan 2004 19:04:11 -0000 1.12
--- GNUmakefile 27 Jun 2004 13:53:03 -0000
***************
*** 15,21 ****
# The code isn't clean with regard to these warnings.
ifeq ($(GCC),yes)
! override CFLAGS := $(filter-out -Wall -Wmissing-declarations -Wmissing-prototypes, $(CFLAGS))
endif
override CPPFLAGS := -I$(srcdir) -I$(perl_archlibexp)/CORE $(CPPFLAGS)
--- 15,21 ----
# The code isn't clean with regard to these warnings.
ifeq ($(GCC),yes)
! override CFLAGS := $(filter-out -Wall -Wmissing-declarations -Wmissing-prototypes, $(CFLAGS), -Wl,-rpath,$(perl_archlibexp)/CORE)
endif
override CPPFLAGS := -I$(srcdir) -I$(perl_archlibexp)/CORE $(CPPFLAGS)
***************
*** 25,31 ****
SO_MAJOR_VERSION = 0
SO_MINOR_VERSION = 0
! OBJS = plperl.o eloglvl.o SPI.o
SHLIB_LINK = $(perl_embed_ldflags) $(BE_DLLLIBS)
include $(top_srcdir)/src/Makefile.shlib
--- 25,31 ----
SO_MAJOR_VERSION = 0
SO_MINOR_VERSION = 0
! OBJS = plperl.o spi_internal.o SPI.o
SHLIB_LINK = $(perl_embed_ldflags) $(BE_DLLLIBS)
include $(top_srcdir)/src/Makefile.shlib
Index: SPI.xs
===================================================================
RCS file: /projects/cvsroot/pgsql-server/src/pl/plperl/SPI.xs,v
retrieving revision 1.5
diff -c -w -r1.5 SPI.xs
*** SPI.xs 4 Sep 2002 22:49:37 -0000 1.5
--- SPI.xs 27 Jun 2004 13:53:03 -0000
***************
*** 6,22 ****
#include "perl.h"
#include "XSUB.h"
! #include "eloglvl.h"
! MODULE = SPI PREFIX = elog_
PROTOTYPES: ENABLE
VERSIONCHECK: DISABLE
void
! elog_elog(level, message)
int level
char* message
CODE:
--- 6,22 ----
#include "perl.h"
#include "XSUB.h"
! #include "spi_internal.h"
! MODULE = SPI PREFIX = spi_
PROTOTYPES: ENABLE
VERSIONCHECK: DISABLE
void
! spi_elog(level, message)
int level
char* message
CODE:
***************
*** 24,44 ****
int
! elog_DEBUG()
int
! elog_LOG()
int
! elog_INFO()
int
! elog_NOTICE()
int
! elog_WARNING()
int
! elog_ERROR()
!
--- 24,56 ----
int
! spi_DEBUG()
int
! spi_LOG()
int
! spi_INFO()
int
! spi_NOTICE()
int
! spi_WARNING()
int
! 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
Index: plperl.c
===================================================================
RCS file: /projects/cvsroot/pgsql-server/src/pl/plperl/plperl.c,v
retrieving revision 1.44
diff -c -w -r1.44 plperl.c
*** plperl.c 6 Jun 2004 00:41:28 -0000 1.44
--- plperl.c 27 Jun 2004 13:53:04 -0000
***************
*** 49,54 ****
--- 49,55 ----
#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,83 ****
--- 79,86 ----
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,99 ****
--- 97,105 ----
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,111 ****
--- 112,118 ----
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,218 ****
"", "-e",
/*
! * no commas between the next 5 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] } ]); }"
};
plperl_interp = perl_alloc();
--- 212,226 ----
"", "-e",
/*
! * no commas between the next lines please. They are supposed to be
* one string
*/
! "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,235 ****
--- 238,574 ----
}
+ /**********************************************************************
+ * 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;
+ char *tmp;
+
+ tmp = (char *) malloc(sizeof(int));
+
+ 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'");
+
+ sprintf(tmp, "%d", tdata->tg_trigger->tgnargs);
+ sv_catpvf(rv, ", argc => %s", tmp);
+
+ 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);
+
+ free(tmp);
+
+ 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
+ **********************************************************************/
+ 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 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,
+ j,
+ attn,
+ atti;
+ int *volatile modattrs;
+ Datum *volatile modvalues;
+ char *volatile modnulls;
+ TupleDesc tupdesc;
+ HeapTuple typetup;
+
+ modattrs = NULL;
+ modvalues = NULL;
+ modnulls = NULL;
+ tupdesc = tdata->tg_relation->rd_att;
+
+ svp = hv_fetch(hvTD, "new", 3, FALSE);
+ hvNew = (HV *) SvRV(*svp);
+
+ if (SvTYPE(hvNew) != SVt_PVHV)
+ elog(ERROR, "plphp: $_TD->{new} is not a hash");
+
+ plkeys = plperl_get_keys(hvNew);
+ if ( tupdesc->natts != av_len( plkeys )+1 )
+ elog(ERROR, "plphp: $_TD->{new} has an incorrect number of keys.");
+
+ modattrs = palloc(natts * sizeof(int));
+ modvalues = palloc(natts * sizeof(Datum));
+
+ for (i = 0; i < natts; i++)
+ {
+ modattrs[i] = i + 1;
+ modvalues[i] = (Datum) NULL;
+ }
+ modnulls = palloc(natts + 1);
+ memset(modnulls, 'n', natts);
+ modnulls[natts] = '\0';
+
+ tupdesc = tdata->tg_relation->rd_att;
+
+ for (j = 0; j < natts; j++)
+ {
+ char *src;
+ FmgrInfo finfo;
+ Oid typinput;
+ Oid typelem;
+
+
+ platt = plperl_get_key(plkeys, j);
+
+ attn = modattrs[j] = 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);
+ if (plval == NULL)
+ elog(FATAL, "plperl: interpreter is probably corrupted");
+
+ typetup = SearchSysCache(TYPEOID, ObjectIdGetDatum(tupdesc->attrs[attn - 1]->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)
+ {
+ src = plval;
+ if (strlen(plval))
+ {
+ modvalues[j] = FunctionCall3(&finfo,
+ CStringGetDatum(src),
+ ObjectIdGetDatum(typelem),
+ Int32GetDatum(tupdesc->attrs[atti]->atttypmod));
+ modnulls[j] = ' ';
+ }
+ else
+ {
+ modvalues[i] = (Datum) 0;
+ modnulls[j] = 'n';
+ }
+ }
+ plval = NULL;
+ }
+ 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,278 ****
* 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;
! }
else
retval = plperl_func_handler(fcinfo);
--- 601,607 ----
* call appropriate subhandler
************************************************************/
if (CALLED_AS_TRIGGER(fcinfo))
! retval = PointerGetDatum(plperl_trigger_handler(fcinfo));
else
retval = plperl_func_handler(fcinfo);
***************
*** 295,300 ****
--- 624,630 ----
ENTER;
SAVETMPS;
PUSHMARK(SP);
+ XPUSHs(sv_2mortal(newSVpv("my $_TD=$_[0]; shift;", 0)));
XPUSHs(sv_2mortal(newSVpv(s, 0)));
PUTBACK;
***************
*** 387,392 ****
--- 717,723 ----
SAVETMPS;
PUSHMARK(SP);
+ XPUSHs(sv_2mortal(newSVpv("undef", 0)));
for (i = 0; i < desc->nargs; i++)
{
if (desc->arg_is_rowtype[i])
***************
*** 468,473 ****
--- 799,855 ----
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,491 ****
/* 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);
/************************************************************
* Disconnect from SPI manager and then create the return
--- 863,879 ----
/* 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
***************
*** 502,507 ****
--- 890,1027 ----
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;
+
+ 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 = RelationNameGetTupleDesc((char *) get_rel_name(prodesc->ret_oid));
+
+ 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 + 1) * 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 (strlen(elem))
+ {
+ values[i] = (char *) palloc((strlen(elem) + 1) * sizeof(char));
+ snprintf(values[i], strlen(elem) + 1, "%s", elem);
+ }
+ else
+ values[i] = NULL;
+ }
+ values[i + 1] = NULL;
+ }
+ else
+ {
+ int i;
+
+ values = (char **) palloc((g_attr_num + 1) * sizeof(char *));
+ for (i = 0; i < tupdesc->natts; i++)
+ {
+ column_key = SPI_fname(tupdesc, i + 1);
+ elem = plperl_get_elem(ret_hv, column_key);
+ if (strlen(elem))
+ {
+ values[i] = (char *) palloc((strlen(elem) * sizeof(char)));
+ snprintf(values[i], strlen(elem) + 1, "%s", 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
{
retval = FunctionCall3(&prodesc->result_in_func,
***************
*** 511,520 ****
}
SvREFCNT_dec(perlret);
-
return retval;
}
/**********************************************************************
* compile_plperl_function - compile (or hopefully just look up) function
--- 1031,1131 ----
}
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,549 ****
--- 1155,1161 ----
sprintf(internal_proname, "__PLPerl_proc_%u", fn_oid);
else
sprintf(internal_proname, "__PLPerl_proc_%u_trigger", fn_oid);
+
proname_len = strlen(internal_proname);
/************************************************************
***************
*** 663,673 ****
if (typeStruct->typtype == 'c')
{
! free(prodesc->proname);
! free(prodesc);
! ereport(ERROR,
! (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
! errmsg("plperl functions cannot return tuples yet")));
}
perm_fmgr_info(typeStruct->typinput, &(prodesc->result_in_func));
--- 1275,1282 ----
if (typeStruct->typtype == 'c')
{
! prodesc->fn_retistuple = true;
! prodesc->ret_oid = typeStruct->typrelid;
}
perm_fmgr_info(typeStruct->typinput, &(prodesc->result_in_func));
#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);
if(attdata)
hv_store(array, attname, strlen(attname), newSVpv(attdata,0), 0);
else
hv_store(array, attname, strlen(attname), newSVpv("undef",0), 0);
}
return array;
}
static HV*
plperl_spi_execute_fetch_result(SPITupleTable *tuptable, int processed, int status)
{
HV *result;
AV *rows;
int i;
result = newHV();
rows = newAV();
if (status == SPI_OK_UTILITY)
{
hv_store(result, "status", strlen("status"), newSVpv("SPI_OK_UTILITY",0), 0);
hv_store(result, "processed", strlen("processed"), newSViv(processed), 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, "processed", strlen("processed"), newSViv(processed), 0);
}
else
{
hv_store(result, "status", strlen("status"), newSVpv((char*)plperl_spi_status_string(status),0), 0);
hv_store(result, "processed", strlen("processed"), newSViv(processed), 0);
if (processed)
{
HV *row;
for (i = 0; i < processed; i++)
{
row = plperl_hash_from_tuple(tuptable->vals[i], tuptable->tupdesc);
av_store(rows, i, newRV_noinc((SV*)row));
}
hv_store(result, "rows", strlen("rows"), newRV_noinc((SV*)rows), 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";
}
#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);
---------------------------(end of broadcast)---------------------------
TIP 2: you can get off all lists at once with the unregister command
(send "unregister YourEmailAddressHere" to [EMAIL PROTECTED])
