mirror/postgresql
2
0
Fork 0
mirror of https://git.postgresql.org/git/postgresql.git synced 2025-01-12 15:39:35 +08:00
Code Issues Packages Projects Releases Wiki Activity

errcontext support in PL/Perl

Browse Source 
Author: Alexey Klyukin <alexk@commandprompt.com>
This commit is contained in:
Peter Eisentraut 2009-09-16 06:06:12 +00:00
parent 384cad5c7b
commit e3f027115a
4 changed files with 112 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
src/pl/plperl/expected/plperl.out
View File

@ -122,8 +122,10 @@ CREATE OR REPLACE FUNCTION perl_set() RETURNS SETOF testrowperl AS $$
$$ LANGUAGE plperl; $$ LANGUAGE plperl;
SELECT perl_set(); SELECT perl_set();
ERROR: SETOF-composite-returning PL/Perl function must call return_next with reference to hash 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(); SELECT * FROM perl_set();
ERROR: SETOF-composite-returning PL/Perl function must call return_next with reference to hash 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 $$ CREATE OR REPLACE FUNCTION perl_set() RETURNS SETOF testrowperl AS $$
return [ return [
{ f1 => 1, f2 => 'Hello', f3 => 'World' }, { f1 => 1, f2 => 'Hello', f3 => 'World' },
@ -171,6 +173,7 @@ CREATE OR REPLACE FUNCTION perl_record() RETURNS record AS $$
$$ LANGUAGE plperl; $$ LANGUAGE plperl;
SELECT perl_record(); SELECT perl_record();
ERROR: function returning record called in context that cannot accept type record ERROR: function returning record called in context that cannot accept type record
CONTEXT: PL/Perl function "perl_record"
SELECT * FROM perl_record(); SELECT * FROM perl_record();
ERROR: a column definition list is required for functions returning "record" ERROR: a column definition list is required for functions returning "record"
LINE 1: SELECT * FROM perl_record(); LINE 1: SELECT * FROM perl_record();
@ -186,6 +189,7 @@ CREATE OR REPLACE FUNCTION perl_record_set() RETURNS SETOF record AS $$
$$ LANGUAGE plperl; $$ LANGUAGE plperl;
SELECT perl_record_set(); SELECT perl_record_set();
ERROR: set-valued function called in context that cannot accept a 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(); SELECT * FROM perl_record_set();
ERROR: a column definition list is required for functions returning "record" ERROR: a column definition list is required for functions returning "record"
LINE 1: SELECT * FROM perl_record_set(); LINE 1: SELECT * FROM perl_record_set();
@ -204,12 +208,14 @@ CREATE OR REPLACE FUNCTION perl_record_set() RETURNS SETOF record AS $$
$$ LANGUAGE plperl; $$ LANGUAGE plperl;
SELECT perl_record_set(); SELECT perl_record_set();
ERROR: set-valued function called in context that cannot accept a 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(); SELECT * FROM perl_record_set();
ERROR: a column definition list is required for functions returning "record" ERROR: a column definition list is required for functions returning "record"
LINE 1: SELECT * FROM perl_record_set(); LINE 1: SELECT * FROM perl_record_set();
^ ^
SELECT * FROM perl_record_set() AS (f1 integer, f2 text, f3 text); 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 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 $$ CREATE OR REPLACE FUNCTION perl_record_set() RETURNS SETOF record AS $$
return [ return [
{ f1 => 1, f2 => 'Hello', f3 => 'World' }, { f1 => 1, f2 => 'Hello', f3 => 'World' },
@ -219,6 +225,7 @@ CREATE OR REPLACE FUNCTION perl_record_set() RETURNS SETOF record AS $$
$$ LANGUAGE plperl; $$ LANGUAGE plperl;
SELECT perl_record_set(); SELECT perl_record_set();
ERROR: set-valued function called in context that cannot accept a 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(); SELECT * FROM perl_record_set();
ERROR: a column definition list is required for functions returning "record" ERROR: a column definition list is required for functions returning "record"
LINE 1: SELECT * FROM perl_record_set(); LINE 1: SELECT * FROM perl_record_set();
@ -308,11 +315,13 @@ CREATE OR REPLACE FUNCTION foo_bad() RETURNS footype AS $$
$$ LANGUAGE plperl; $$ LANGUAGE plperl;
SELECT * FROM foo_bad(); SELECT * FROM foo_bad();
ERROR: Perl hash contains nonexistent column "z" ERROR: Perl hash contains nonexistent column "z"
CONTEXT: PL/Perl function "foo_bad"
CREATE OR REPLACE FUNCTION foo_bad() RETURNS footype AS $$ CREATE OR REPLACE FUNCTION foo_bad() RETURNS footype AS $$
return 42; return 42;
$$ LANGUAGE plperl; $$ LANGUAGE plperl;
SELECT * FROM foo_bad(); SELECT * FROM foo_bad();
ERROR: composite-returning PL/Perl function must return reference to hash 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 $$ CREATE OR REPLACE FUNCTION foo_bad() RETURNS footype AS $$
return [ return [
[1, 2], [1, 2],
@ -321,16 +330,19 @@ return [
$$ LANGUAGE plperl; $$ LANGUAGE plperl;
SELECT * FROM foo_bad(); SELECT * FROM foo_bad();
ERROR: composite-returning PL/Perl function must return reference to hash 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 $$ CREATE OR REPLACE FUNCTION foo_set_bad() RETURNS SETOF footype AS $$
return 42; return 42;
$$ LANGUAGE plperl; $$ LANGUAGE plperl;
SELECT * FROM foo_set_bad(); SELECT * FROM foo_set_bad();
ERROR: set-returning PL/Perl function must return reference to array or use return_next 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 $$ CREATE OR REPLACE FUNCTION foo_set_bad() RETURNS SETOF footype AS $$
return {y => 3, z => 4}; return {y => 3, z => 4};
$$ LANGUAGE plperl; $$ LANGUAGE plperl;
SELECT * FROM foo_set_bad(); SELECT * FROM foo_set_bad();
ERROR: set-returning PL/Perl function must return reference to array or use return_next 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 $$ CREATE OR REPLACE FUNCTION foo_set_bad() RETURNS SETOF footype AS $$
return [ return [
[1, 2], [1, 2],
@ -339,6 +351,7 @@ return [
$$ LANGUAGE plperl; $$ LANGUAGE plperl;
SELECT * FROM foo_set_bad(); SELECT * FROM foo_set_bad();
ERROR: SETOF-composite-returning PL/Perl function must call return_next with reference to hash 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 $$ CREATE OR REPLACE FUNCTION foo_set_bad() RETURNS SETOF footype AS $$
return [ return [
{y => 3, z => 4} {y => 3, z => 4}
@ -346,6 +359,7 @@ return [
$$ LANGUAGE plperl; $$ LANGUAGE plperl;
SELECT * FROM foo_set_bad(); SELECT * FROM foo_set_bad();
ERROR: Perl hash contains nonexistent column "z" ERROR: Perl hash contains nonexistent column "z"
CONTEXT: PL/Perl function "foo_set_bad"
-- --
-- Check passing a tuple argument -- Check passing a tuple argument
-- --
@ -539,4 +553,5 @@ CREATE OR REPLACE FUNCTION perl_spi_prepared_bad(double precision) RETURNS doubl
return $result; return $result;
$$ LANGUAGE plperl; $$ LANGUAGE plperl;
SELECT perl_spi_prepared_bad(4.35) as "double precision"; 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. ERROR: type "does_not_exist" does not exist at line 2.
CONTEXT: PL/Perl function "perl_spi_prepared_bad"

5
src/pl/plperl/expected/plperl_elog.out
View File

@ -7,6 +7,7 @@ create or replace function perl_elog(text) returns void language plperl as $$
$$; $$;
select perl_elog('explicit elog'); select perl_elog('explicit elog');
NOTICE: explicit elog NOTICE: explicit elog
CONTEXT: PL/Perl function "perl_elog"
perl_elog perl_elog
----------- -----------
@ -21,6 +22,7 @@ $$;
select perl_warn('implicit elog via warn'); select perl_warn('implicit elog via warn');
NOTICE: implicit elog via warn at line 4. NOTICE: implicit elog via warn at line 4.
CONTEXT: PL/Perl function "perl_warn"
perl_warn perl_warn
----------- -----------
@ -35,8 +37,9 @@ create or replace function uses_global() returns text language plperl as $$
return 'uses_global worked'; return 'uses_global worked';
$$; $$;
ERROR: creation of Perl function "uses_global" failed: Global symbol "$global" requires explicit package name at line 3. ERROR: Global symbol "$global" requires explicit package name at line 3.
Global symbol "$other_global" requires explicit package name at line 4. Global symbol "$other_global" requires explicit package name at line 4.
CONTEXT: compilation of PL/Perl function "uses_global"
select uses_global(); select uses_global();
ERROR: function uses_global() does not exist ERROR: function uses_global() does not exist
LINE 1: select uses_global(); LINE 1: select uses_global();

34
src/pl/plperl/expected/plperl_trigger.out
View File

@ -53,41 +53,75 @@ BEFORE INSERT OR UPDATE OR DELETE ON trigger_test
FOR EACH ROW EXECUTE PROCEDURE trigger_data(23,'skidoo'); FOR EACH ROW EXECUTE PROCEDURE trigger_data(23,'skidoo');
insert into trigger_test values(1,'insert'); insert into trigger_test values(1,'insert');
NOTICE: $_TD->{argc} = '2' NOTICE: $_TD->{argc} = '2'
CONTEXT: PL/Perl function "trigger_data"
NOTICE: $_TD->{args} = ['23', 'skidoo'] NOTICE: $_TD->{args} = ['23', 'skidoo']
CONTEXT: PL/Perl function "trigger_data"
NOTICE: $_TD->{event} = 'INSERT' NOTICE: $_TD->{event} = 'INSERT'
CONTEXT: PL/Perl function "trigger_data"
NOTICE: $_TD->{level} = 'ROW' NOTICE: $_TD->{level} = 'ROW'
CONTEXT: PL/Perl function "trigger_data"
NOTICE: $_TD->{name} = 'show_trigger_data_trig' NOTICE: $_TD->{name} = 'show_trigger_data_trig'
CONTEXT: PL/Perl function "trigger_data"
NOTICE: $_TD->{new} = {'i' => '1', 'v' => 'insert'} NOTICE: $_TD->{new} = {'i' => '1', 'v' => 'insert'}
CONTEXT: PL/Perl function "trigger_data"
NOTICE: $_TD->{relid} = 'bogus:12345' NOTICE: $_TD->{relid} = 'bogus:12345'
CONTEXT: PL/Perl function "trigger_data"
NOTICE: $_TD->{relname} = 'trigger_test' NOTICE: $_TD->{relname} = 'trigger_test'
CONTEXT: PL/Perl function "trigger_data"
NOTICE: $_TD->{table_name} = 'trigger_test' NOTICE: $_TD->{table_name} = 'trigger_test'
CONTEXT: PL/Perl function "trigger_data"
NOTICE: $_TD->{table_schema} = 'public' NOTICE: $_TD->{table_schema} = 'public'
CONTEXT: PL/Perl function "trigger_data"
NOTICE: $_TD->{when} = 'BEFORE' NOTICE: $_TD->{when} = 'BEFORE'
CONTEXT: PL/Perl function "trigger_data"
update trigger_test set v = 'update' where i = 1; update trigger_test set v = 'update' where i = 1;
NOTICE: $_TD->{argc} = '2' NOTICE: $_TD->{argc} = '2'
CONTEXT: PL/Perl function "trigger_data"
NOTICE: $_TD->{args} = ['23', 'skidoo'] NOTICE: $_TD->{args} = ['23', 'skidoo']
CONTEXT: PL/Perl function "trigger_data"
NOTICE: $_TD->{event} = 'UPDATE' NOTICE: $_TD->{event} = 'UPDATE'
CONTEXT: PL/Perl function "trigger_data"
NOTICE: $_TD->{level} = 'ROW' NOTICE: $_TD->{level} = 'ROW'
CONTEXT: PL/Perl function "trigger_data"
NOTICE: $_TD->{name} = 'show_trigger_data_trig' NOTICE: $_TD->{name} = 'show_trigger_data_trig'
CONTEXT: PL/Perl function "trigger_data"
NOTICE: $_TD->{new} = {'i' => '1', 'v' => 'update'} NOTICE: $_TD->{new} = {'i' => '1', 'v' => 'update'}
CONTEXT: PL/Perl function "trigger_data"
NOTICE: $_TD->{old} = {'i' => '1', 'v' => 'insert'} NOTICE: $_TD->{old} = {'i' => '1', 'v' => 'insert'}
CONTEXT: PL/Perl function "trigger_data"
NOTICE: $_TD->{relid} = 'bogus:12345' NOTICE: $_TD->{relid} = 'bogus:12345'
CONTEXT: PL/Perl function "trigger_data"
NOTICE: $_TD->{relname} = 'trigger_test' NOTICE: $_TD->{relname} = 'trigger_test'
CONTEXT: PL/Perl function "trigger_data"
NOTICE: $_TD->{table_name} = 'trigger_test' NOTICE: $_TD->{table_name} = 'trigger_test'
CONTEXT: PL/Perl function "trigger_data"
NOTICE: $_TD->{table_schema} = 'public' NOTICE: $_TD->{table_schema} = 'public'
CONTEXT: PL/Perl function "trigger_data"
NOTICE: $_TD->{when} = 'BEFORE' NOTICE: $_TD->{when} = 'BEFORE'
CONTEXT: PL/Perl function "trigger_data"
delete from trigger_test; delete from trigger_test;
NOTICE: $_TD->{argc} = '2' NOTICE: $_TD->{argc} = '2'
CONTEXT: PL/Perl function "trigger_data"
NOTICE: $_TD->{args} = ['23', 'skidoo'] NOTICE: $_TD->{args} = ['23', 'skidoo']
CONTEXT: PL/Perl function "trigger_data"
NOTICE: $_TD->{event} = 'DELETE' NOTICE: $_TD->{event} = 'DELETE'
CONTEXT: PL/Perl function "trigger_data"
NOTICE: $_TD->{level} = 'ROW' NOTICE: $_TD->{level} = 'ROW'
CONTEXT: PL/Perl function "trigger_data"
NOTICE: $_TD->{name} = 'show_trigger_data_trig' NOTICE: $_TD->{name} = 'show_trigger_data_trig'
CONTEXT: PL/Perl function "trigger_data"
NOTICE: $_TD->{old} = {'i' => '1', 'v' => 'update'} NOTICE: $_TD->{old} = {'i' => '1', 'v' => 'update'}
CONTEXT: PL/Perl function "trigger_data"
NOTICE: $_TD->{relid} = 'bogus:12345' NOTICE: $_TD->{relid} = 'bogus:12345'
CONTEXT: PL/Perl function "trigger_data"
NOTICE: $_TD->{relname} = 'trigger_test' NOTICE: $_TD->{relname} = 'trigger_test'
CONTEXT: PL/Perl function "trigger_data"
NOTICE: $_TD->{table_name} = 'trigger_test' NOTICE: $_TD->{table_name} = 'trigger_test'
CONTEXT: PL/Perl function "trigger_data"
NOTICE: $_TD->{table_schema} = 'public' NOTICE: $_TD->{table_schema} = 'public'
CONTEXT: PL/Perl function "trigger_data"
NOTICE: $_TD->{when} = 'BEFORE' NOTICE: $_TD->{when} = 'BEFORE'
CONTEXT: PL/Perl function "trigger_data"
DROP TRIGGER show_trigger_data_trig on trigger_test; DROP TRIGGER show_trigger_data_trig on trigger_test;

68
src/pl/plperl/plperl.c
View File

@ -1,7 +1,7 @@
/********************************************************************** /**********************************************************************
* plperl.c - perl as a procedural language for PostgreSQL * plperl.c - perl as a procedural language for PostgreSQL
* *
* $PostgreSQL: pgsql/src/pl/plperl/plperl.c,v 1.150 2009/06/11 14:49:14 momjian Exp $ * $PostgreSQL: pgsql/src/pl/plperl/plperl.c,v 1.151 2009/09/16 06:06:12 petere Exp $
* *
**********************************************************************/ **********************************************************************/
@ -162,6 +162,8 @@ static SV **hv_store_string(HV *hv, const char *key, SV *val);
static SV **hv_fetch_string(HV *hv, const char *key); static SV **hv_fetch_string(HV *hv, const char *key);
static SV *plperl_create_sub(char *proname, char *s, bool trusted); static SV *plperl_create_sub(char *proname, char *s, bool trusted);
static SV *plperl_call_perl_func(plperl_proc_desc *desc, FunctionCallInfo fcinfo); 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 * This routine is a crock, and so is everyplace that calls it. The problem
@ -1019,9 +1021,7 @@ plperl_create_sub(char *proname, char *s, bool trusted)
LEAVE; LEAVE;
ereport(ERROR, ereport(ERROR,
(errcode(ERRCODE_SYNTAX_ERROR), (errcode(ERRCODE_SYNTAX_ERROR),
errmsg("creation of Perl function \"%s\" failed: %s", errmsg("%s", strip_trailing_ws(SvPV(ERRSV, PL_na)))));
proname,
strip_trailing_ws(SvPV(ERRSV, PL_na)))));
} }
/* /*
@ -1149,9 +1149,7 @@ plperl_call_perl_func(plperl_proc_desc *desc, FunctionCallInfo fcinfo)
LEAVE; LEAVE;
/* XXX need to find a way to assign an errcode here */ /* XXX need to find a way to assign an errcode here */
ereport(ERROR, ereport(ERROR,
(errmsg("error from Perl function \"%s\": %s", (errmsg("%s", strip_trailing_ws(SvPV(ERRSV, PL_na)))));
desc->proname,
strip_trailing_ws(SvPV(ERRSV, PL_na)))));
} }
retval = newSVsv(POPs); retval = newSVsv(POPs);
@ -1207,9 +1205,7 @@ plperl_call_perl_trigger_func(plperl_proc_desc *desc, FunctionCallInfo fcinfo,
LEAVE; LEAVE;
/* XXX need to find a way to assign an errcode here */ /* XXX need to find a way to assign an errcode here */
ereport(ERROR, ereport(ERROR,
(errmsg("error from Perl function \"%s\": %s", (errmsg("%s", strip_trailing_ws(SvPV(ERRSV, PL_na)))));
desc->proname,
strip_trailing_ws(SvPV(ERRSV, PL_na)))));
} }
retval = newSVsv(POPs); retval = newSVsv(POPs);
@ -1231,6 +1227,7 @@ plperl_func_handler(PG_FUNCTION_ARGS)
ReturnSetInfo *rsi; ReturnSetInfo *rsi;
SV *array_ret = NULL; SV *array_ret = NULL;
bool oldcontext = trusted_context; bool oldcontext = trusted_context;
ErrorContextCallback pl_error_context;
/* /*
* Create the call_data beforing connecting to SPI, so that it is not * Create the call_data beforing connecting to SPI, so that it is not
@ -1245,6 +1242,12 @@ plperl_func_handler(PG_FUNCTION_ARGS)
prodesc = compile_plperl_function(fcinfo->flinfo->fn_oid, false); prodesc = compile_plperl_function(fcinfo->flinfo->fn_oid, false);
current_call_data->prodesc = prodesc; 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; rsi = (ReturnSetInfo *) fcinfo->resultinfo;
if (prodesc->fn_retisset) if (prodesc->fn_retisset)
@ -1367,6 +1370,9 @@ plperl_func_handler(PG_FUNCTION_ARGS)
prodesc->result_typioparam, -1); prodesc->result_typioparam, -1);
} }
/* Restore the previous error callback */
error_context_stack = pl_error_context.previous;
if (array_ret == NULL) if (array_ret == NULL)
SvREFCNT_dec(perlret); SvREFCNT_dec(perlret);
@ -1386,6 +1392,7 @@ plperl_trigger_handler(PG_FUNCTION_ARGS)
SV *svTD; SV *svTD;
HV *hvTD; HV *hvTD;
bool oldcontext = trusted_context; bool oldcontext = trusted_context;
ErrorContextCallback pl_error_context;
/* /*
* Create the call_data beforing connecting to SPI, so that it is not * Create the call_data beforing connecting to SPI, so that it is not
@ -1402,6 +1409,12 @@ plperl_trigger_handler(PG_FUNCTION_ARGS)
prodesc = compile_plperl_function(fcinfo->flinfo->fn_oid, true); prodesc = compile_plperl_function(fcinfo->flinfo->fn_oid, true);
current_call_data->prodesc = prodesc; 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); check_interp(prodesc->lanpltrusted);
svTD = plperl_trigger_build_args(fcinfo); svTD = plperl_trigger_build_args(fcinfo);
@ -1471,6 +1484,9 @@ plperl_trigger_handler(PG_FUNCTION_ARGS)
retval = PointerGetDatum(trv); retval = PointerGetDatum(trv);
} }
/* Restore the previous error callback */
error_context_stack = pl_error_context.previous;
SvREFCNT_dec(svTD); SvREFCNT_dec(svTD);
if (perlret) if (perlret)
SvREFCNT_dec(perlret); SvREFCNT_dec(perlret);
@ -1492,6 +1508,7 @@ compile_plperl_function(Oid fn_oid, bool is_trigger)
plperl_proc_entry *hash_entry; plperl_proc_entry *hash_entry;
bool found; bool found;
bool oldcontext = trusted_context; bool oldcontext = trusted_context;
ErrorContextCallback plperl_error_context;
/* We'll need the pg_proc tuple in any case... */ /* We'll need the pg_proc tuple in any case... */
procTup = SearchSysCache(PROCOID, procTup = SearchSysCache(PROCOID,
@ -1501,6 +1518,12 @@ compile_plperl_function(Oid fn_oid, bool is_trigger)
elog(ERROR, "cache lookup failed for function %u", fn_oid); elog(ERROR, "cache lookup failed for function %u", fn_oid);
procStruct = (Form_pg_proc) GETSTRUCT(procTup); 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 * Build our internal proc name from the function's Oid
************************************************************/ ************************************************************/
@ -1731,6 +1754,9 @@ compile_plperl_function(Oid fn_oid, bool is_trigger)
hash_entry->proc_data = prodesc; hash_entry->proc_data = prodesc;
} }
/* restore previous error callback */
error_context_stack = plperl_error_context.previous;
ReleaseSysCache(procTup); ReleaseSysCache(procTup);
return prodesc; return prodesc;
@ -2683,3 +2709,25 @@ hv_fetch_string(HV *hv, const char *key)
#endif #endif
return hv_fetch(hv, key, klen, 0); 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);
}