*** a/doc/src/sgml/plperl.sgml
--- b/doc/src/sgml/plperl.sgml
***************
*** 1211,1216 **** CREATE TRIGGER test_valid_id_trig
--- 1211,1262 ----
+
+ PL/Perl Event Triggers
+
+
+ PL/Perl can be used to write event trigger functions. In an event trigger
+ function, the hash reference $_TD contains information
+ about the current trigger event. $_TD is a global variable,
+ which gets a separate local value for each invocation of the trigger. The
+ fields of the $_TD hash reference are:
+
+
+
+ $_TD->{event}
+
+
+ The name of the event the trigger is fired for.
+
+
+
+
+
+ $_TD->{tag}
+
+
+ The command tag for which the trigger is fired.
+
+
+
+
+
+
+
+ Here is an example of an event trigger function, illustrating some of the
+ above:
+
+ CREATE OR REPLACE FUNCTION perlsnitch() RETURNS event_trigger AS $$
+ elog(NOTICE, "perlsnitch: " . $_TD->{event} . " " . $_TD->{tag} . " ");
+ $$ LANGUAGE plperl;
+
+ CREATE EVENT TRIGGER perl_a_snitch
+ ON ddl_command_start
+ EXECUTE PROCEDURE perlsnitch();
+
+
+
+
PL/Perl Under the Hood
*** a/src/pl/plperl/expected/plperl_trigger.out
--- b/src/pl/plperl/expected/plperl_trigger.out
***************
*** 309,311 **** $$ LANGUAGE plperl;
--- 309,346 ----
SELECT direct_trigger();
ERROR: trigger functions can only be called as triggers
CONTEXT: compilation of PL/Perl function "direct_trigger"
+ -- test plperl command triggers
+ create or replace function perlsnitch() returns event_trigger language plperl as $$
+ elog(NOTICE, "perlsnitch: " . $_TD->{event} . " " . $_TD->{tag} . " ");
+ $$;
+ create event trigger perl_a_snitch on ddl_command_start
+ execute procedure perlsnitch();
+ create event trigger perl_b_snitch on ddl_command_end
+ execute procedure perlsnitch();
+ create or replace function foobar() returns int language sql as $$select 1;$$;
+ NOTICE: perlsnitch: ddl_command_start CREATE FUNCTION
+ CONTEXT: PL/Perl function "perlsnitch"
+ NOTICE: perlsnitch: ddl_command_end CREATE FUNCTION
+ CONTEXT: PL/Perl function "perlsnitch"
+ alter function foobar() cost 77;
+ NOTICE: perlsnitch: ddl_command_start ALTER FUNCTION
+ CONTEXT: PL/Perl function "perlsnitch"
+ NOTICE: perlsnitch: ddl_command_end ALTER FUNCTION
+ CONTEXT: PL/Perl function "perlsnitch"
+ drop function foobar();
+ NOTICE: perlsnitch: ddl_command_start DROP FUNCTION
+ CONTEXT: PL/Perl function "perlsnitch"
+ NOTICE: perlsnitch: ddl_command_end DROP FUNCTION
+ CONTEXT: PL/Perl function "perlsnitch"
+ create table foo();
+ NOTICE: perlsnitch: ddl_command_start CREATE TABLE
+ CONTEXT: PL/Perl function "perlsnitch"
+ NOTICE: perlsnitch: ddl_command_end CREATE TABLE
+ CONTEXT: PL/Perl function "perlsnitch"
+ drop table foo;
+ NOTICE: perlsnitch: ddl_command_start DROP TABLE
+ CONTEXT: PL/Perl function "perlsnitch"
+ NOTICE: perlsnitch: ddl_command_end DROP TABLE
+ CONTEXT: PL/Perl function "perlsnitch"
+ drop event trigger perl_a_snitch;
+ drop event trigger perl_b_snitch;
*** a/src/pl/plperl/plperl.c
--- b/src/pl/plperl/plperl.c
***************
*** 21,26 ****
--- 21,27 ----
#include "catalog/pg_language.h"
#include "catalog/pg_proc.h"
#include "catalog/pg_type.h"
+ #include "commands/event_trigger.h"
#include "commands/trigger.h"
#include "executor/spi.h"
#include "funcapi.h"
***************
*** 254,263 **** static void set_interp_require(bool trusted);
static Datum plperl_func_handler(PG_FUNCTION_ARGS);
static Datum plperl_trigger_handler(PG_FUNCTION_ARGS);
static void free_plperl_function(plperl_proc_desc *prodesc);
! static plperl_proc_desc *compile_plperl_function(Oid fn_oid, bool is_trigger);
static SV *plperl_hash_from_tuple(HeapTuple tuple, TupleDesc tupdesc);
static SV *plperl_hash_from_datum(Datum attr);
--- 255,267 ----
static Datum plperl_func_handler(PG_FUNCTION_ARGS);
static Datum plperl_trigger_handler(PG_FUNCTION_ARGS);
+ static void plperl_event_trigger_handler(PG_FUNCTION_ARGS);
static void free_plperl_function(plperl_proc_desc *prodesc);
! static plperl_proc_desc *compile_plperl_function(Oid fn_oid,
! bool is_trigger,
! bool is_event_trigger);
static SV *plperl_hash_from_tuple(HeapTuple tuple, TupleDesc tupdesc);
static SV *plperl_hash_from_datum(Datum attr);
***************
*** 1610,1615 **** plperl_trigger_build_args(FunctionCallInfo fcinfo)
--- 1614,1636 ----
}
+ /* Set up the arguments for an event trigger call. */
+ static SV *
+ plperl_event_trigger_build_args(FunctionCallInfo fcinfo)
+ {
+ EventTriggerData *tdata;
+ HV *hv;
+
+ hv = newHV();
+
+ tdata = (EventTriggerData *) fcinfo->context;
+
+ hv_store_string(hv, "event", cstr2sv(tdata->event));
+ hv_store_string(hv, "tag", cstr2sv(tdata->tag));
+
+ return newRV_noinc((SV *) hv);
+ }
+
/* Set up the new tuple returned from a trigger. */
static HeapTuple
***************
*** 1717,1722 **** plperl_call_handler(PG_FUNCTION_ARGS)
--- 1738,1748 ----
current_call_data = &this_call_data;
if (CALLED_AS_TRIGGER(fcinfo))
retval = PointerGetDatum(plperl_trigger_handler(fcinfo));
+ else if (CALLED_AS_EVENT_TRIGGER(fcinfo))
+ {
+ plperl_event_trigger_handler(fcinfo);
+ retval = (Datum) 0;
+ }
else
retval = plperl_func_handler(fcinfo);
}
***************
*** 1853,1859 **** plperl_validator(PG_FUNCTION_ARGS)
Oid *argtypes;
char **argnames;
char *argmodes;
! bool istrigger = false;
int i;
/* Get the new function's pg_proc entry */
--- 1879,1885 ----
Oid *argtypes;
char **argnames;
char *argmodes;
! bool is_trigger = false, is_event_trigger = false;
int i;
/* Get the new function's pg_proc entry */
***************
*** 1865,1877 **** plperl_validator(PG_FUNCTION_ARGS)
functyptype = get_typtype(proc->prorettype);
/* Disallow pseudotype result */
! /* except for TRIGGER, RECORD, or VOID */
if (functyptype == TYPTYPE_PSEUDO)
{
/* we assume OPAQUE with no arguments means a trigger */
if (proc->prorettype == TRIGGEROID ||
(proc->prorettype == OPAQUEOID && proc->pronargs == 0))
! istrigger = true;
else if (proc->prorettype != RECORDOID &&
proc->prorettype != VOIDOID)
ereport(ERROR,
--- 1891,1905 ----
functyptype = get_typtype(proc->prorettype);
/* Disallow pseudotype result */
! /* except for TRIGGER, EVTTRIGGER, RECORD, or VOID */
if (functyptype == TYPTYPE_PSEUDO)
{
/* we assume OPAQUE with no arguments means a trigger */
if (proc->prorettype == TRIGGEROID ||
(proc->prorettype == OPAQUEOID && proc->pronargs == 0))
! is_trigger = true;
! else if (proc->prorettype == EVTTRIGGEROID)
! is_event_trigger = true;
else if (proc->prorettype != RECORDOID &&
proc->prorettype != VOIDOID)
ereport(ERROR,
***************
*** 1898,1904 **** plperl_validator(PG_FUNCTION_ARGS)
/* Postpone body checks if !check_function_bodies */
if (check_function_bodies)
{
! (void) compile_plperl_function(funcoid, istrigger);
}
/* the result of a validator is ignored */
--- 1926,1932 ----
/* Postpone body checks if !check_function_bodies */
if (check_function_bodies)
{
! (void) compile_plperl_function(funcoid, is_trigger, is_event_trigger);
}
/* the result of a validator is ignored */
***************
*** 2169,2174 **** plperl_call_perl_trigger_func(plperl_proc_desc *desc, FunctionCallInfo fcinfo,
--- 2197,2258 ----
}
+ static void
+ plperl_call_perl_event_trigger_func(plperl_proc_desc *desc,
+ FunctionCallInfo fcinfo,
+ SV *td)
+ {
+ dSP;
+ SV *retval, *TDsv;
+ int count;
+
+ ENTER;
+ SAVETMPS;
+
+ TDsv = get_sv("main::_TD", 0);
+ if (!TDsv)
+ elog(ERROR, "couldn't fetch $_TD");
+
+ save_item(TDsv); /* local $_TD */
+ sv_setsv(TDsv, td);
+
+ PUSHMARK(sp);
+ PUTBACK;
+
+ /* Do NOT use G_KEEPERR here */
+ count = perl_call_sv(desc->reference, G_SCALAR | G_EVAL);
+
+ SPAGAIN;
+
+ if (count != 1)
+ {
+ PUTBACK;
+ FREETMPS;
+ LEAVE;
+ elog(ERROR, "didn't get a return item from trigger function");
+ }
+
+ if (SvTRUE(ERRSV))
+ {
+ (void) POPs;
+ PUTBACK;
+ FREETMPS;
+ LEAVE;
+ /* XXX need to find a way to assign an errcode here */
+ ereport(ERROR,
+ (errmsg("%s", strip_trailing_ws(sv2cstr(ERRSV)))));
+ }
+
+ retval = newSVsv(POPs);
+ (void) retval; /* silence compiler warning */
+
+ PUTBACK;
+ FREETMPS;
+ LEAVE;
+
+ return;
+ }
+
static Datum
plperl_func_handler(PG_FUNCTION_ARGS)
{
***************
*** 2181,2187 **** plperl_func_handler(PG_FUNCTION_ARGS)
if (SPI_connect() != SPI_OK_CONNECT)
elog(ERROR, "could not connect to SPI manager");
! prodesc = compile_plperl_function(fcinfo->flinfo->fn_oid, false);
current_call_data->prodesc = prodesc;
increment_prodesc_refcount(prodesc);
--- 2265,2271 ----
if (SPI_connect() != SPI_OK_CONNECT)
elog(ERROR, "could not connect to SPI manager");
! prodesc = compile_plperl_function(fcinfo->flinfo->fn_oid, false, false);
current_call_data->prodesc = prodesc;
increment_prodesc_refcount(prodesc);
***************
*** 2295,2301 **** plperl_trigger_handler(PG_FUNCTION_ARGS)
elog(ERROR, "could not connect to SPI manager");
/* Find or compile the function */
! prodesc = compile_plperl_function(fcinfo->flinfo->fn_oid, true);
current_call_data->prodesc = prodesc;
increment_prodesc_refcount(prodesc);
--- 2379,2385 ----
elog(ERROR, "could not connect to SPI manager");
/* Find or compile the function */
! prodesc = compile_plperl_function(fcinfo->flinfo->fn_oid, true, false);
current_call_data->prodesc = prodesc;
increment_prodesc_refcount(prodesc);
***************
*** 2386,2391 **** plperl_trigger_handler(PG_FUNCTION_ARGS)
--- 2470,2520 ----
}
+ static void
+ plperl_event_trigger_handler(PG_FUNCTION_ARGS)
+ {
+ plperl_proc_desc *prodesc;
+ SV *svTD;
+ ErrorContextCallback pl_error_context;
+
+ /*
+ * Create the call_data before connecting to SPI, so that it is not
+ * allocated in the SPI memory context
+ */
+ current_call_data = (plperl_call_data *) palloc0(sizeof(plperl_call_data));
+ current_call_data->fcinfo = fcinfo;
+
+ /* Connect to SPI manager */
+ if (SPI_connect() != SPI_OK_CONNECT)
+ elog(ERROR, "could not connect to SPI manager");
+
+ /* Find or compile the function */
+ prodesc = compile_plperl_function(fcinfo->flinfo->fn_oid, false, true);
+ current_call_data->prodesc = prodesc;
+
+ /* Set a callback for error reporting */
+ pl_error_context.callback = plperl_exec_callback;
+ pl_error_context.previous = error_context_stack;
+ pl_error_context.arg = prodesc->proname;
+ error_context_stack = &pl_error_context;
+
+ activate_interpreter(prodesc->interp);
+
+ svTD = plperl_event_trigger_build_args(fcinfo);
+ plperl_call_perl_event_trigger_func(prodesc, fcinfo, svTD);
+
+ if (SPI_finish() != SPI_OK_FINISH)
+ elog(ERROR, "SPI_finish() failed");
+
+ /* Restore the previous error callback */
+ error_context_stack = pl_error_context.previous;
+
+ SvREFCNT_dec(svTD);
+
+ return;
+ }
+
+
static bool
validate_plperl_function(plperl_proc_ptr *proc_ptr, HeapTuple procTup)
{
***************
*** 2437,2443 **** free_plperl_function(plperl_proc_desc *prodesc)
static plperl_proc_desc *
! compile_plperl_function(Oid fn_oid, bool is_trigger)
{
HeapTuple procTup;
Form_pg_proc procStruct;
--- 2566,2572 ----
static plperl_proc_desc *
! compile_plperl_function(Oid fn_oid, bool is_trigger, bool is_event_trigger)
{
HeapTuple procTup;
Form_pg_proc procStruct;
***************
*** 2543,2549 **** compile_plperl_function(Oid fn_oid, bool is_trigger)
* Get the required information for input conversion of the
* return value.
************************************************************/
! if (!is_trigger)
{
typeTup =
SearchSysCache1(TYPEOID,
--- 2672,2678 ----
* Get the required information for input conversion of the
* return value.
************************************************************/
! if (!is_trigger && !is_event_trigger)
{
typeTup =
SearchSysCache1(TYPEOID,
***************
*** 2562,2568 **** compile_plperl_function(Oid fn_oid, bool is_trigger)
if (procStruct->prorettype == VOIDOID ||
procStruct->prorettype == RECORDOID)
/* okay */ ;
! else if (procStruct->prorettype == TRIGGEROID)
{
free_plperl_function(prodesc);
ereport(ERROR,
--- 2691,2698 ----
if (procStruct->prorettype == VOIDOID ||
procStruct->prorettype == RECORDOID)
/* okay */ ;
! else if (procStruct->prorettype == TRIGGEROID ||
! procStruct->prorettype == EVTTRIGGEROID)
{
free_plperl_function(prodesc);
ereport(ERROR,
***************
*** 2598,2604 **** compile_plperl_function(Oid fn_oid, bool is_trigger)
* Get the required information for output conversion
* of all procedure arguments
************************************************************/
! if (!is_trigger)
{
prodesc->nargs = procStruct->pronargs;
for (i = 0; i < prodesc->nargs; i++)
--- 2728,2734 ----
* Get the required information for output conversion
* of all procedure arguments
************************************************************/
! if (!is_trigger && !is_event_trigger)
{
prodesc->nargs = procStruct->pronargs;
for (i = 0; i < prodesc->nargs; i++)
*** a/src/pl/plperl/sql/plperl_trigger.sql
--- b/src/pl/plperl/sql/plperl_trigger.sql
***************
*** 169,171 **** CREATE FUNCTION direct_trigger() RETURNS trigger AS $$
--- 169,191 ----
$$ LANGUAGE plperl;
SELECT direct_trigger();
+
+ -- test plperl command triggers
+ create or replace function perlsnitch() returns event_trigger language plperl as $$
+ elog(NOTICE, "perlsnitch: " . $_TD->{event} . " " . $_TD->{tag} . " ");
+ $$;
+
+ create event trigger perl_a_snitch on ddl_command_start
+ execute procedure perlsnitch();
+ create event trigger perl_b_snitch on ddl_command_end
+ execute procedure perlsnitch();
+
+ create or replace function foobar() returns int language sql as $$select 1;$$;
+ alter function foobar() cost 77;
+ drop function foobar();
+
+ create table foo();
+ drop table foo;
+
+ drop event trigger perl_a_snitch;
+ drop event trigger perl_b_snitch;