*** 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_dml_trigger, ! bool is_evt_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,1637 ---- } + /* Set up the arguments for an event trigger call. */ + static SV * + plperl_event_trigger_build_args(FunctionCallInfo fcinfo) + { + EventTriggerData *tdata; + HV *hv; + + hv = newHV(); + hv_ksplit(hv, 12); /* pre-grow the hash */ + + 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) --- 1739,1746 ---- 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); 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 */ --- 1877,1883 ---- Oid *argtypes; char **argnames; char *argmodes; ! bool is_dml_trigger = false, is_evt_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, --- 1889,1903 ---- 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_dml_trigger = true; ! else if (proc->prorettype == EVTTRIGGEROID) ! is_evt_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 */ --- 1924,1930 ---- /* Postpone body checks if !check_function_bodies */ if (check_function_bodies) { ! (void) compile_plperl_function(funcoid, is_dml_trigger, is_evt_trigger); } /* the result of a validator is ignored */ *************** *** 2169,2174 **** plperl_call_perl_trigger_func(plperl_proc_desc *desc, FunctionCallInfo fcinfo, --- 2195,2255 ---- } + 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); + + 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); --- 2262,2268 ---- 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); --- 2376,2382 ---- 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) --- 2467,2517 ---- } + 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; --- 2563,2569 ---- static plperl_proc_desc * ! compile_plperl_function(Oid fn_oid, bool is_dml_trigger, bool is_evt_trigger) { HeapTuple procTup; Form_pg_proc procStruct; *************** *** 2462,2468 **** compile_plperl_function(Oid fn_oid, bool is_trigger) /* Try to find function in plperl_proc_hash */ proc_key.proc_id = fn_oid; ! proc_key.is_trigger = is_trigger; proc_key.user_id = GetUserId(); proc_ptr = hash_search(plperl_proc_hash, &proc_key, --- 2588,2594 ---- /* Try to find function in plperl_proc_hash */ proc_key.proc_id = fn_oid; ! proc_key.is_trigger = is_dml_trigger; proc_key.user_id = GetUserId(); proc_ptr = hash_search(plperl_proc_hash, &proc_key, *************** *** 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, --- 2669,2675 ---- * Get the required information for input conversion of the * return value. ************************************************************/ ! if (!is_dml_trigger && !is_evt_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, --- 2688,2695 ---- 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++) --- 2725,2731 ---- * Get the required information for output conversion * of all procedure arguments ************************************************************/ ! if (!is_dml_trigger && !is_evt_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;