diff --git a/src/pl/plperl/expected/plperl.out b/src/pl/plperl/expected/plperl.out index e1b0c75..c8a8fdb 100644 *** a/src/pl/plperl/expected/plperl.out --- b/src/pl/plperl/expected/plperl.out *************** CREATE OR REPLACE FUNCTION perl_set() RE *** 122,129 **** --- 122,131 ---- $$ LANGUAGE plperl; SELECT perl_set(); ERROR: SETOF-composite-returning PL/Perl function must call return_next with reference to hash + CONTEXT: PL/Perl function "perl_set" SELECT * FROM perl_set(); ERROR: SETOF-composite-returning PL/Perl function must call return_next with reference to hash + CONTEXT: PL/Perl function "perl_set" CREATE OR REPLACE FUNCTION perl_set() RETURNS SETOF testrowperl AS $$ return [ { f1 => 1, f2 => 'Hello', f3 => 'World' }, *************** CREATE OR REPLACE FUNCTION perl_record() *** 171,176 **** --- 173,179 ---- $$ LANGUAGE plperl; SELECT perl_record(); ERROR: function returning record called in context that cannot accept type record + CONTEXT: PL/Perl function "perl_record" SELECT * FROM perl_record(); ERROR: a column definition list is required for functions returning "record" LINE 1: SELECT * FROM perl_record(); *************** CREATE OR REPLACE FUNCTION perl_record_s *** 186,191 **** --- 189,195 ---- $$ LANGUAGE plperl; SELECT perl_record_set(); ERROR: set-valued function called in context that cannot accept a set + CONTEXT: PL/Perl function "perl_record_set" SELECT * FROM perl_record_set(); ERROR: a column definition list is required for functions returning "record" LINE 1: SELECT * FROM perl_record_set(); *************** CREATE OR REPLACE FUNCTION perl_record_s *** 204,215 **** --- 208,221 ---- $$ LANGUAGE plperl; SELECT perl_record_set(); ERROR: set-valued function called in context that cannot accept a set + CONTEXT: PL/Perl function "perl_record_set" SELECT * FROM perl_record_set(); ERROR: a column definition list is required for functions returning "record" LINE 1: SELECT * FROM perl_record_set(); ^ SELECT * FROM perl_record_set() AS (f1 integer, f2 text, f3 text); ERROR: SETOF-composite-returning PL/Perl function must call return_next with reference to hash + CONTEXT: PL/Perl function "perl_record_set" CREATE OR REPLACE FUNCTION perl_record_set() RETURNS SETOF record AS $$ return [ { f1 => 1, f2 => 'Hello', f3 => 'World' }, *************** CREATE OR REPLACE FUNCTION perl_record_s *** 219,224 **** --- 225,231 ---- $$ LANGUAGE plperl; SELECT perl_record_set(); ERROR: set-valued function called in context that cannot accept a set + CONTEXT: PL/Perl function "perl_record_set" SELECT * FROM perl_record_set(); ERROR: a column definition list is required for functions returning "record" LINE 1: SELECT * FROM perl_record_set(); *************** CREATE OR REPLACE FUNCTION foo_bad() RET *** 308,318 **** --- 315,327 ---- $$ LANGUAGE plperl; SELECT * FROM foo_bad(); ERROR: Perl hash contains nonexistent column "z" + CONTEXT: PL/Perl function "foo_bad" CREATE OR REPLACE FUNCTION foo_bad() RETURNS footype AS $$ return 42; $$ LANGUAGE plperl; SELECT * FROM foo_bad(); ERROR: composite-returning PL/Perl function must return reference to hash + CONTEXT: PL/Perl function "foo_bad" CREATE OR REPLACE FUNCTION foo_bad() RETURNS footype AS $$ return [ [1, 2], *************** return [ *** 321,336 **** --- 330,348 ---- $$ LANGUAGE plperl; SELECT * FROM foo_bad(); ERROR: composite-returning PL/Perl function must return reference to hash + CONTEXT: PL/Perl function "foo_bad" CREATE OR REPLACE FUNCTION foo_set_bad() RETURNS SETOF footype AS $$ return 42; $$ LANGUAGE plperl; SELECT * FROM foo_set_bad(); ERROR: set-returning PL/Perl function must return reference to array or use return_next + CONTEXT: PL/Perl function "foo_set_bad" CREATE OR REPLACE FUNCTION foo_set_bad() RETURNS SETOF footype AS $$ return {y => 3, z => 4}; $$ LANGUAGE plperl; SELECT * FROM foo_set_bad(); ERROR: set-returning PL/Perl function must return reference to array or use return_next + CONTEXT: PL/Perl function "foo_set_bad" CREATE OR REPLACE FUNCTION foo_set_bad() RETURNS SETOF footype AS $$ return [ [1, 2], *************** return [ *** 339,344 **** --- 351,357 ---- $$ LANGUAGE plperl; SELECT * FROM foo_set_bad(); ERROR: SETOF-composite-returning PL/Perl function must call return_next with reference to hash + CONTEXT: PL/Perl function "foo_set_bad" CREATE OR REPLACE FUNCTION foo_set_bad() RETURNS SETOF footype AS $$ return [ {y => 3, z => 4} *************** return [ *** 346,351 **** --- 359,365 ---- $$ LANGUAGE plperl; SELECT * FROM foo_set_bad(); ERROR: Perl hash contains nonexistent column "z" + CONTEXT: PL/Perl function "foo_set_bad" -- -- Check passing a tuple argument -- *************** CREATE OR REPLACE FUNCTION perl_spi_prep *** 539,542 **** return $result; $$ LANGUAGE plperl; SELECT perl_spi_prepared_bad(4.35) as "double precision"; ! ERROR: error from Perl function "perl_spi_prepared_bad": type "does_not_exist" does not exist at line 2. --- 553,557 ---- return $result; $$ LANGUAGE plperl; SELECT perl_spi_prepared_bad(4.35) as "double precision"; ! ERROR: type "does_not_exist" does not exist at line 2. ! CONTEXT: PL/Perl function "perl_spi_prepared_bad" diff --git a/src/pl/plperl/expected/plperl_elog.out b/src/pl/plperl/expected/plperl_elog.out index fcb6e8d..1791d3c 100644 *** a/src/pl/plperl/expected/plperl_elog.out --- b/src/pl/plperl/expected/plperl_elog.out *************** create or replace function perl_elog(tex *** 7,12 **** --- 7,13 ---- $$; select perl_elog('explicit elog'); NOTICE: explicit elog + CONTEXT: PL/Perl function "perl_elog" perl_elog ----------- *************** $$; *** 21,26 **** --- 22,28 ---- select perl_warn('implicit elog via warn'); NOTICE: implicit elog via warn at line 4. + CONTEXT: PL/Perl function "perl_warn" perl_warn ----------- *************** create or replace function uses_global() *** 35,42 **** return 'uses_global worked'; $$; ! ERROR: creation of Perl function "uses_global" failed: Global symbol "$global" requires explicit package name at line 3. Global symbol "$other_global" requires explicit package name at line 4. select uses_global(); ERROR: function uses_global() does not exist LINE 1: select uses_global(); --- 37,45 ---- return 'uses_global worked'; $$; ! ERROR: Global symbol "$global" requires explicit package name at line 3. Global symbol "$other_global" requires explicit package name at line 4. + CONTEXT: compilation of PL/Perl function "uses_global" select uses_global(); ERROR: function uses_global() does not exist LINE 1: select uses_global(); diff --git a/src/pl/plperl/expected/plperl_trigger.out b/src/pl/plperl/expected/plperl_trigger.out index 48a4853..b5af566 100644 *** a/src/pl/plperl/expected/plperl_trigger.out --- b/src/pl/plperl/expected/plperl_trigger.out *************** BEFORE INSERT OR UPDATE OR DELETE ON tri *** 53,93 **** --- 53,127 ---- FOR EACH ROW EXECUTE PROCEDURE trigger_data(23,'skidoo'); insert into trigger_test values(1,'insert'); NOTICE: $_TD->{argc} = '2' + CONTEXT: PL/Perl function "trigger_data" NOTICE: $_TD->{args} = ['23', 'skidoo'] + CONTEXT: PL/Perl function "trigger_data" NOTICE: $_TD->{event} = 'INSERT' + CONTEXT: PL/Perl function "trigger_data" NOTICE: $_TD->{level} = 'ROW' + CONTEXT: PL/Perl function "trigger_data" NOTICE: $_TD->{name} = 'show_trigger_data_trig' + CONTEXT: PL/Perl function "trigger_data" NOTICE: $_TD->{new} = {'i' => '1', 'v' => 'insert'} + CONTEXT: PL/Perl function "trigger_data" NOTICE: $_TD->{relid} = 'bogus:12345' + CONTEXT: PL/Perl function "trigger_data" NOTICE: $_TD->{relname} = 'trigger_test' + CONTEXT: PL/Perl function "trigger_data" NOTICE: $_TD->{table_name} = 'trigger_test' + CONTEXT: PL/Perl function "trigger_data" NOTICE: $_TD->{table_schema} = 'public' + CONTEXT: PL/Perl function "trigger_data" NOTICE: $_TD->{when} = 'BEFORE' + CONTEXT: PL/Perl function "trigger_data" update trigger_test set v = 'update' where i = 1; NOTICE: $_TD->{argc} = '2' + CONTEXT: PL/Perl function "trigger_data" NOTICE: $_TD->{args} = ['23', 'skidoo'] + CONTEXT: PL/Perl function "trigger_data" NOTICE: $_TD->{event} = 'UPDATE' + CONTEXT: PL/Perl function "trigger_data" NOTICE: $_TD->{level} = 'ROW' + CONTEXT: PL/Perl function "trigger_data" NOTICE: $_TD->{name} = 'show_trigger_data_trig' + CONTEXT: PL/Perl function "trigger_data" NOTICE: $_TD->{new} = {'i' => '1', 'v' => 'update'} + CONTEXT: PL/Perl function "trigger_data" NOTICE: $_TD->{old} = {'i' => '1', 'v' => 'insert'} + CONTEXT: PL/Perl function "trigger_data" NOTICE: $_TD->{relid} = 'bogus:12345' + CONTEXT: PL/Perl function "trigger_data" NOTICE: $_TD->{relname} = 'trigger_test' + CONTEXT: PL/Perl function "trigger_data" NOTICE: $_TD->{table_name} = 'trigger_test' + CONTEXT: PL/Perl function "trigger_data" NOTICE: $_TD->{table_schema} = 'public' + CONTEXT: PL/Perl function "trigger_data" NOTICE: $_TD->{when} = 'BEFORE' + CONTEXT: PL/Perl function "trigger_data" delete from trigger_test; NOTICE: $_TD->{argc} = '2' + CONTEXT: PL/Perl function "trigger_data" NOTICE: $_TD->{args} = ['23', 'skidoo'] + CONTEXT: PL/Perl function "trigger_data" NOTICE: $_TD->{event} = 'DELETE' + CONTEXT: PL/Perl function "trigger_data" NOTICE: $_TD->{level} = 'ROW' + CONTEXT: PL/Perl function "trigger_data" NOTICE: $_TD->{name} = 'show_trigger_data_trig' + CONTEXT: PL/Perl function "trigger_data" NOTICE: $_TD->{old} = {'i' => '1', 'v' => 'update'} + CONTEXT: PL/Perl function "trigger_data" NOTICE: $_TD->{relid} = 'bogus:12345' + CONTEXT: PL/Perl function "trigger_data" NOTICE: $_TD->{relname} = 'trigger_test' + CONTEXT: PL/Perl function "trigger_data" NOTICE: $_TD->{table_name} = 'trigger_test' + CONTEXT: PL/Perl function "trigger_data" NOTICE: $_TD->{table_schema} = 'public' + CONTEXT: PL/Perl function "trigger_data" NOTICE: $_TD->{when} = 'BEFORE' + CONTEXT: PL/Perl function "trigger_data" DROP TRIGGER show_trigger_data_trig on trigger_test; diff --git a/src/pl/plperl/plperl.c b/src/pl/plperl/plperl.c index 82e2f4b..0a4bb8c 100644 *** a/src/pl/plperl/plperl.c --- b/src/pl/plperl/plperl.c *************** static SV **hv_store_string(HV *hv, cons *** 162,167 **** --- 162,169 ---- static SV **hv_fetch_string(HV *hv, const char *key); static SV *plperl_create_sub(char *proname, char *s, bool trusted); static SV *plperl_call_perl_func(plperl_proc_desc *desc, FunctionCallInfo fcinfo); + static void plperl_compile_callback(void *arg); + static void plperl_exec_callback(void *arg); /* * This routine is a crock, and so is everyplace that calls it. The problem *************** plperl_call_handler(PG_FUNCTION_ARGS) *** 869,875 **** { Datum retval; plperl_call_data *save_call_data; ! save_call_data = current_call_data; PG_TRY(); { --- 871,877 ---- { Datum retval; plperl_call_data *save_call_data; ! save_call_data = current_call_data; PG_TRY(); { *************** plperl_create_sub(char *proname, char *s *** 1019,1027 **** LEAVE; ereport(ERROR, (errcode(ERRCODE_SYNTAX_ERROR), ! errmsg("creation of Perl function \"%s\" failed: %s", ! proname, ! strip_trailing_ws(SvPV(ERRSV, PL_na))))); } /* --- 1021,1027 ---- LEAVE; ereport(ERROR, (errcode(ERRCODE_SYNTAX_ERROR), ! errmsg("%s", strip_trailing_ws(SvPV(ERRSV, PL_na))))); } /* *************** plperl_call_perl_func(plperl_proc_desc * *** 1149,1157 **** LEAVE; /* XXX need to find a way to assign an errcode here */ ereport(ERROR, ! (errmsg("error from Perl function \"%s\": %s", ! desc->proname, ! strip_trailing_ws(SvPV(ERRSV, PL_na))))); } retval = newSVsv(POPs); --- 1149,1155 ---- LEAVE; /* XXX need to find a way to assign an errcode here */ ereport(ERROR, ! (errmsg("%s", strip_trailing_ws(SvPV(ERRSV, PL_na))))); } retval = newSVsv(POPs); *************** plperl_call_perl_trigger_func(plperl_pro *** 1207,1215 **** LEAVE; /* XXX need to find a way to assign an errcode here */ ereport(ERROR, ! (errmsg("error from Perl function \"%s\": %s", ! desc->proname, ! strip_trailing_ws(SvPV(ERRSV, PL_na))))); } retval = newSVsv(POPs); --- 1205,1211 ---- LEAVE; /* XXX need to find a way to assign an errcode here */ ereport(ERROR, ! (errmsg("%s", strip_trailing_ws(SvPV(ERRSV, PL_na))))); } retval = newSVsv(POPs); *************** plperl_func_handler(PG_FUNCTION_ARGS) *** 1231,1236 **** --- 1227,1233 ---- ReturnSetInfo *rsi; SV *array_ret = NULL; bool oldcontext = trusted_context; + ErrorContextCallback pl_error_context; /* * Create the call_data beforing connecting to SPI, so that it is not *************** plperl_func_handler(PG_FUNCTION_ARGS) *** 1244,1249 **** --- 1241,1252 ---- prodesc = compile_plperl_function(fcinfo->flinfo->fn_oid, false); 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; rsi = (ReturnSetInfo *) fcinfo->resultinfo; *************** plperl_func_handler(PG_FUNCTION_ARGS) *** 1366,1372 **** retval = InputFunctionCall(&prodesc->result_in_func, val, prodesc->result_typioparam, -1); } ! if (array_ret == NULL) SvREFCNT_dec(perlret); --- 1369,1378 ---- retval = InputFunctionCall(&prodesc->result_in_func, val, prodesc->result_typioparam, -1); } ! ! /* Restore the previous error callback */ ! error_context_stack = pl_error_context.previous; ! if (array_ret == NULL) SvREFCNT_dec(perlret); *************** plperl_trigger_handler(PG_FUNCTION_ARGS) *** 1386,1391 **** --- 1392,1398 ---- SV *svTD; HV *hvTD; bool oldcontext = trusted_context; + ErrorContextCallback pl_error_context; /* * Create the call_data beforing connecting to SPI, so that it is not *************** plperl_trigger_handler(PG_FUNCTION_ARGS) *** 1401,1406 **** --- 1408,1419 ---- /* Find or compile the function */ prodesc = compile_plperl_function(fcinfo->flinfo->fn_oid, 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; check_interp(prodesc->lanpltrusted); *************** plperl_trigger_handler(PG_FUNCTION_ARGS) *** 1470,1475 **** --- 1483,1491 ---- } retval = PointerGetDatum(trv); } + + /* Restore the previous error callback */ + error_context_stack = pl_error_context.previous; SvREFCNT_dec(svTD); if (perlret) *************** compile_plperl_function(Oid fn_oid, bool *** 1492,1497 **** --- 1508,1514 ---- plperl_proc_entry *hash_entry; bool found; bool oldcontext = trusted_context; + ErrorContextCallback plperl_error_context; /* We'll need the pg_proc tuple in any case... */ procTup = SearchSysCache(PROCOID, *************** compile_plperl_function(Oid fn_oid, bool *** 1500,1505 **** --- 1517,1528 ---- if (!HeapTupleIsValid(procTup)) elog(ERROR, "cache lookup failed for function %u", fn_oid); procStruct = (Form_pg_proc) GETSTRUCT(procTup); + + /* Set a callback for reporting compilation errors */ + plperl_error_context.callback = plperl_compile_callback; + plperl_error_context.previous = error_context_stack; + plperl_error_context.arg = NameStr(procStruct->proname); + error_context_stack = &plperl_error_context; /************************************************************ * Build our internal proc name from the function's Oid *************** compile_plperl_function(Oid fn_oid, bool *** 1731,1736 **** --- 1754,1762 ---- hash_entry->proc_data = prodesc; } + /* restore previous error callback */ + error_context_stack = plperl_error_context.previous; + ReleaseSysCache(procTup); return prodesc; *************** hv_fetch_string(HV *hv, const char *key) *** 2683,2685 **** --- 2709,2733 ---- #endif return hv_fetch(hv, key, klen, 0); } + + /* + * Provide function name for PL/Perl execution errors + */ + static void + plperl_exec_callback(void *arg) + { + char *procname = (char *) arg; + if (procname) + errcontext("PL/Perl function \"%s\"", procname); + } + + /* + * Provide function name for PL/Perl compilation errors + */ + static void + plperl_compile_callback(void *arg) + { + char *procname = (char *) arg; + if (procname) + errcontext("compilation of PL/Perl function \"%s\"", procname); + }