PL/Perl: Add event trigger support

From: Dimitri Fontaine <dimitri@2ndQuadrant.fr>

diff --git a/doc/src/sgml/plperl.sgml b/doc/src/sgml/plperl.sgml
index 10eac0e243cecc3cd0cd29c5608460e19e44fbbe..34663e475fe01edfc96ab2fd12f43b00b3006cd6 100644 (file)
--- a/doc/src/sgml/plperl.sgml
+++ b/doc/src/sgml/plperl.sgml
@@ -1211,6 +1211,56 @@ CREATE TRIGGER test_valid_id_trig
   </para>
  </sect1>
 
+ <sect1 id="plperl-event-triggers">
+  <title>PL/Perl Event Triggers</title>
+
+  <para>
+   PL/Perl can be used to write event trigger functions.  In an event trigger
+   function, the hash reference <varname>$_TD</varname> contains information
+   about the current trigger event.  <varname>$_TD</> is a global variable,
+   which gets a separate local value for each invocation of the trigger.  The
+   fields of the <varname>$_TD</varname> hash reference are:
+
+   <variablelist>
+    <varlistentry>
+     <term><literal>$_TD-&gt;{event}</literal></term>
+     <listitem>
+      <para>
+       The name of the event the trigger is fired for.
+      </para>
+     </listitem>
+    </varlistentry>
+
+    <varlistentry>
+     <term><literal>$_TD-&gt;{tag}</literal></term>
+     <listitem>
+      <para>
+       The command tag for which the trigger is fired.
+      </para>
+     </listitem>
+    </varlistentry>
+   </variablelist>
+  </para>
+
+  <para>
+   The return value of the trigger procedure is ignored.
+  </para>
+
+  <para>
+   Here is an example of an event trigger function, illustrating some of the
+   above:
+<programlisting>
+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();
+</programlisting>
+  </para>
+ </sect1>
+
  <sect1 id="plperl-under-the-hood">
   <title>PL/Perl Under the Hood</title>
 

diff --git a/src/pl/plperl/expected/plperl_trigger.out b/src/pl/plperl/expected/plperl_trigger.out
index 181dcfa7aeb723a04d4b261c156af7fd138984c6..36ecb920958b9288d87d1a43541defbcf2d05c61 100644 (file)
--- a/src/pl/plperl/expected/plperl_trigger.out
+++ b/src/pl/plperl/expected/plperl_trigger.out
@@ -309,3 +309,38 @@ $$ LANGUAGE plperl;
 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;

diff --git a/src/pl/plperl/plperl.c b/src/pl/plperl/plperl.c
index de8cb0e04761558460c770aa57c745dd93c21ab6..4f5b92fa3affbf77b7308dc8ea88cfbb1ca84631 100644 (file)
--- a/src/pl/plperl/plperl.c
+++ b/src/pl/plperl/plperl.c
@@ -21,6 +21,7 @@
 #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,10 +255,13 @@ 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 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);
+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,6 +1614,23 @@ plperl_trigger_build_args(FunctionCallInfo fcinfo)
 }
 
 
+/* 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,6 +1738,11 @@ plperl_call_handler(PG_FUNCTION_ARGS)
                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,7 +1879,8 @@ plperl_validator(PG_FUNCTION_ARGS)
        Oid                *argtypes;
        char      **argnames;
        char       *argmodes;
-       bool            istrigger = false;
+       bool            is_trigger = false;
+       bool            is_event_trigger = false;
        int                     i;
 
        /* Get the new function's pg_proc entry */
@@ -1865,13 +1892,15 @@ plperl_validator(PG_FUNCTION_ARGS)
        functyptype = get_typtype(proc->prorettype);
 
        /* Disallow pseudotype result */
-       /* except for TRIGGER, RECORD, or VOID */
+       /* 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))
-                       istrigger = true;
+                       is_trigger = true;
+               else if (proc->prorettype == EVTTRIGGEROID)
+                       is_event_trigger = true;
                else if (proc->prorettype != RECORDOID &&
                                 proc->prorettype != VOIDOID)
                        ereport(ERROR,
@@ -1898,7 +1927,7 @@ plperl_validator(PG_FUNCTION_ARGS)
        /* Postpone body checks if !check_function_bodies */
        if (check_function_bodies)
        {
-               (void) compile_plperl_function(funcoid, istrigger);
+               (void) compile_plperl_function(funcoid, is_trigger, is_event_trigger);
        }
 
        /* the result of a validator is ignored */
@@ -2169,6 +2198,63 @@ plperl_call_perl_trigger_func(plperl_proc_desc *desc, FunctionCallInfo fcinfo,
 }
 
 
+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,7 +2267,7 @@ 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);
+       prodesc = compile_plperl_function(fcinfo->flinfo->fn_oid, false, false);
        current_call_data->prodesc = prodesc;
        increment_prodesc_refcount(prodesc);
 
@@ -2295,7 +2381,7 @@ 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);
+       prodesc = compile_plperl_function(fcinfo->flinfo->fn_oid, true, false);
        current_call_data->prodesc = prodesc;
        increment_prodesc_refcount(prodesc);
 
@@ -2386,6 +2472,45 @@ plperl_trigger_handler(PG_FUNCTION_ARGS)
 }
 
 
+static void
+plperl_event_trigger_handler(PG_FUNCTION_ARGS)
+{
+       plperl_proc_desc *prodesc;
+       SV                 *svTD;
+       ErrorContextCallback pl_error_context;
+
+       /* 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;
+       increment_prodesc_refcount(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,7 +2562,7 @@ free_plperl_function(plperl_proc_desc *prodesc)
 
 
 static plperl_proc_desc *
-compile_plperl_function(Oid fn_oid, bool is_trigger)
+compile_plperl_function(Oid fn_oid, bool is_trigger, bool is_event_trigger)
 {
        HeapTuple       procTup;
        Form_pg_proc procStruct;
@@ -2543,7 +2668,7 @@ compile_plperl_function(Oid fn_oid, bool is_trigger)
                 * Get the required information for input conversion of the
                 * return value.
                 ************************************************************/
-               if (!is_trigger)
+               if (!is_trigger && !is_event_trigger)
                {
                        typeTup =
                                SearchSysCache1(TYPEOID,
@@ -2562,7 +2687,8 @@ compile_plperl_function(Oid fn_oid, bool is_trigger)
                                if (procStruct->prorettype == VOIDOID ||
                                        procStruct->prorettype == RECORDOID)
                                         /* okay */ ;
-                               else if (procStruct->prorettype == TRIGGEROID)
+                               else if (procStruct->prorettype == TRIGGEROID ||
+                                                procStruct->prorettype == EVTTRIGGEROID)
                                {
                                        free_plperl_function(prodesc);
                                        ereport(ERROR,
@@ -2598,7 +2724,7 @@ compile_plperl_function(Oid fn_oid, bool is_trigger)
                 * Get the required information for output conversion
                 * of all procedure arguments
                 ************************************************************/
-               if (!is_trigger)
+               if (!is_trigger && !is_event_trigger)
                {
                        prodesc->nargs = procStruct->pronargs;
                        for (i = 0; i < prodesc->nargs; i++)

diff --git a/src/pl/plperl/sql/plperl_trigger.sql b/src/pl/plperl/sql/plperl_trigger.sql
index c43b31ede0a91bded905daa25cb87995fd9d9fb0..a375b401ea2705344678b5e8b495bade7f3c2897 100644 (file)
--- a/src/pl/plperl/sql/plperl_trigger.sql
+++ b/src/pl/plperl/sql/plperl_trigger.sql
@@ -169,3 +169,23 @@ CREATE FUNCTION direct_trigger() RETURNS trigger AS $$
 $$ 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;