Thread: plperl patch
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 example
Trigger 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);
I wrote: > > 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. > > My apologies. I should have tested more. It appears that the optimization Abhijit sent us causes a memory error, at least onn my machine. I have therefore reverted it. Please ignore the patch file previously sent and use this one instead. The other files in my previous post are still relevant - to save space I have not reattached them. cheers andrew
Andrew Dunstan wrote:
>
>
> I wrote:
>
>>
>> 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.
>>
>>
>
> My apologies. I should have tested more. It appears that the
> optimization Abhijit sent us causes a memory error, at least onn my
> machine. I have therefore reverted it. Please ignore the patch file
> previously sent and use this one instead. The other files in my
> previous post are still relevant - to save space I have not reattached
> them.
>
>
This time it's attached ...
cheers
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 20:51:24 -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 20:51:24 -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 20:51:24 -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,596 ----
}
+ /**********************************************************************
+ * 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;
+ }
+
+
+ /**********************************************************************
+ * count keys in a hash
+ **********************************************************************/
+ static int
+ plperl_count_hv(HV * hv)
+ {
+ char *key;
+ I32 klen;
+ SV *val;
+ int key_count;
+
+ key_count = 0;
+
+ while (val = hv_iternextsv(hv, (char **) &key, &klen))
+ key_count++;
+
+ return key_count;
+ }
+
+
+ /**********************************************************************
+ * 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);
+ natts = plperl_count_hv(hvNew);
+ if (natts != tupdesc->natts)
+ 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);
--- 623,629 ----
* call appropriate subhandler
************************************************************/
if (CALLED_AS_TRIGGER(fcinfo))
! retval = PointerGetDatum(plperl_trigger_handler(fcinfo));
else
retval = plperl_func_handler(fcinfo);
***************
*** 295,300 ****
--- 646,652 ----
ENTER;
SAVETMPS;
PUSHMARK(SP);
+ XPUSHs(sv_2mortal(newSVpv("my $_TD=$_[0]; shift;", 0)));
XPUSHs(sv_2mortal(newSVpv(s, 0)));
PUTBACK;
***************
*** 387,392 ****
--- 739,745 ----
SAVETMPS;
PUSHMARK(SP);
+ XPUSHs(sv_2mortal(newSVpv("undef", 0)));
for (i = 0; i < desc->nargs; i++)
{
if (desc->arg_is_rowtype[i])
***************
*** 468,473 ****
--- 821,877 ----
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
--- 885,901 ----
/* 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 ****
--- 912,1050 ----
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
--- 1054,1154 ----
}
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 ****
--- 1178,1184 ----
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));
--- 1298,1305 ----
if (typeStruct->typtype == 'c')
{
! prodesc->fn_retistuple = true;
! prodesc->ret_oid = typeStruct->typrelid;
}
perm_fmgr_info(typeStruct->typinput, &(prodesc->result_in_func));
Quick head up - I have a fix for the count hash keys 'fix' I reverted yesterday, and also a patch from Joe Coway to allow returning record and setof record. Revised patch will be forthcoming after some testing. cheers andrew
Andrew Dunstan wrote:
>
> Quick head up - I have a fix for the count hash keys 'fix' I reverted
> yesterday, and also a patch from Joe Coway to allow returning record
> and setof record.
>
> Revised patch will be forthcoming after some testing.
The attached patch (and 2 new files incorporating previous eloglvl.[ch]
as before) has the following changes in plperl.c over previously sent patch:
- fixed optimization for counting hash keys (Abhijit Menon-Sen)
- allow return of 'record' and 'setof record' - removed previously
advisied limitation (Joe Conway)
- fix off by 1 errors in SRF code that caused memory errors (Joe Conway)
- minor cleanup (me)
There is a new known issue which will be addressed quickly:
- empty string is interpreted as NULL - only undef should translate as NULL
enjoy
andrew
#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";
}
#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);
Index: src/pl/plperl/GNUmakefile
===================================================================
RCS file: /projects/cvsroot/pgsql-server/src/pl/plperl/GNUmakefile,v
retrieving revision 1.12
diff -c -w -r1.12 GNUmakefile
*** src/pl/plperl/GNUmakefile 21 Jan 2004 19:04:11 -0000 1.12
--- src/pl/plperl/GNUmakefile 29 Jun 2004 16:35:55 -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: src/pl/plperl/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
*** src/pl/plperl/SPI.xs 4 Sep 2002 22:49:37 -0000 1.5
--- src/pl/plperl/SPI.xs 29 Jun 2004 16:35:55 -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: src/pl/plperl/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
*** src/pl/plperl/plperl.c 6 Jun 2004 00:41:28 -0000 1.44
--- src/pl/plperl/plperl.c 29 Jun 2004 16:35:55 -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,576 ----
}
+ /**********************************************************************
+ * 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, "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 = 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);
--- 603,609 ----
* call appropriate subhandler
************************************************************/
if (CALLED_AS_TRIGGER(fcinfo))
! retval = PointerGetDatum(plperl_trigger_handler(fcinfo));
else
retval = plperl_func_handler(fcinfo);
***************
*** 295,300 ****
--- 626,632 ----
ENTER;
SAVETMPS;
PUSHMARK(SP);
+ XPUSHs(sv_2mortal(newSVpv("my $_TD=$_[0]; shift;", 0)));
XPUSHs(sv_2mortal(newSVpv(s, 0)));
PUTBACK;
***************
*** 387,392 ****
--- 719,725 ----
SAVETMPS;
PUSHMARK(SP);
+ XPUSHs(sv_2mortal(newSVpv("undef", 0)));
for (i = 0; i < desc->nargs; i++)
{
if (desc->arg_is_rowtype[i])
***************
*** 468,473 ****
--- 801,857 ----
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
--- 865,881 ----
/* 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 ****
--- 892,1030 ----
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 (strlen(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 (strlen(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
{
retval = FunctionCall3(&prodesc->result_in_func,
***************
*** 511,520 ****
}
SvREFCNT_dec(perlret);
-
return retval;
}
/**********************************************************************
* compile_plperl_function - compile (or hopefully just look up) function
--- 1034,1134 ----
}
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 ****
--- 1158,1164 ----
sprintf(internal_proname, "__PLPerl_proc_%u", fn_oid);
else
sprintf(internal_proname, "__PLPerl_proc_%u_trigger", fn_oid);
+
proname_len = strlen(internal_proname);
/************************************************************
***************
*** 640,646 ****
/* Disallow pseudotype result, except VOID */
if (typeStruct->typtype == 'p')
{
! if (procStruct->prorettype == VOIDOID)
/* okay */ ;
else if (procStruct->prorettype == TRIGGEROID)
{
--- 1255,1262 ----
/* Disallow pseudotype result, except VOID */
if (typeStruct->typtype == 'p')
{
! if (procStruct->prorettype == VOIDOID ||
! procStruct->prorettype == RECORDOID)
/* okay */ ;
else if (procStruct->prorettype == TRIGGEROID)
{
***************
*** 661,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));
--- 1277,1286 ----
}
}
! if (typeStruct->typtype == 'c' || procStruct->prorettype == RECORDOID)
{
! prodesc->fn_retistuple = true;
! prodesc->ret_oid = typeStruct->typrelid;
}
perm_fmgr_info(typeStruct->typinput, &(prodesc->result_in_func));
Andrew Dunstan said: > > There is a new known issue which will be addressed quickly: > - empty string is interpreted as NULL - only undef should translate as > NULL > I have fixes for this, which will appear soon. Details available at http://lists.pgfoundry.org/pipermail/plperlng-devel/2004-June/000030.html and http://lists.pgfoundry.org/pipermail/plperlng-devel/2004-June/000033.html cheers andrew