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..ef09245 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,876 **** --- 871,885 ---- { Datum retval; plperl_call_data *save_call_data; + ErrorContextCallback pl_error_context; save_call_data = current_call_data; + + /* Set a callback for error reporting */ + pl_error_context.callback = plperl_exec_callback; + pl_error_context.previous = error_context_stack; + error_context_stack = &pl_error_context; + PG_TRY(); { if (CALLED_AS_TRIGGER(fcinfo)) *************** plperl_call_handler(PG_FUNCTION_ARGS) *** 885,890 **** --- 894,902 ---- } PG_END_TRY(); + /* Restore the previous error callback */ + error_context_stack = pl_error_context.previous; + current_call_data = save_call_data; return retval; } *************** 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))))); } /* --- 1031,1037 ---- 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); --- 1159,1165 ---- 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); --- 1215,1221 ---- 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); *************** compile_plperl_function(Oid fn_oid, bool *** 1492,1497 **** --- 1498,1504 ---- 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 **** --- 1507,1518 ---- 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 **** --- 1744,1752 ---- 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 **** --- 2699,2723 ---- #endif return hv_fetch(hv, key, klen, 0); } + + /* + * Provide function name for PL/Perl execution errors + */ + static void + plperl_exec_callback(void *arg) + { + if (current_call_data && current_call_data->prodesc && + current_call_data->prodesc->proname) + errcontext("PL/Perl function \"%s\"", current_call_data->prodesc->proname); + } + + /* + * 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); + }