errcontext support in PL/Perl

Author: Alexey Klyukin <alexk@commandprompt.com>

diff --git a/src/pl/plperl/expected/plperl.out b/src/pl/plperl/expected/plperl.out
index e1b0c75..c8a8fdb 100644 (file)
--- a/src/pl/plperl/expected/plperl.out
+++ b/src/pl/plperl/expected/plperl.out
@@ -122,8 +122,10 @@ CREATE OR REPLACE FUNCTION perl_set() RETURNS SETOF testrowperl AS $$
 $$  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' },
@@ -171,6 +173,7 @@ CREATE OR REPLACE FUNCTION perl_record() RETURNS record AS $$
 $$ 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();
@@ -186,6 +189,7 @@ CREATE OR REPLACE FUNCTION perl_record_set() RETURNS SETOF record AS $$
 $$  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();
@@ -204,12 +208,14 @@ CREATE OR REPLACE FUNCTION perl_record_set() RETURNS SETOF record AS $$
 $$  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' },
@@ -219,6 +225,7 @@ CREATE OR REPLACE FUNCTION perl_record_set() RETURNS SETOF record AS $$
 $$  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();
@@ -308,11 +315,13 @@ CREATE OR REPLACE FUNCTION foo_bad() RETURNS footype AS $$
 $$ 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],
@@ -321,16 +330,19 @@ return [
 $$ 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],
@@ -339,6 +351,7 @@ return [
 $$ 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}
@@ -346,6 +359,7 @@ return [
 $$ 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
 --
@@ -539,4 +553,5 @@ CREATE OR REPLACE FUNCTION perl_spi_prepared_bad(double precision) RETURNS doubl
   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.
+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 (file)
--- a/src/pl/plperl/expected/plperl_elog.out
+++ b/src/pl/plperl/expected/plperl_elog.out
@@ -7,6 +7,7 @@ create or replace function perl_elog(text) returns void language plperl as $$
 $$;
 select perl_elog('explicit elog');
 NOTICE:  explicit elog
+CONTEXT:  PL/Perl function "perl_elog"
  perl_elog 
 -----------
  
@@ -21,6 +22,7 @@ $$;
 select perl_warn('implicit elog via warn');
 NOTICE:  implicit elog via warn at line 4.
 
+CONTEXT:  PL/Perl function "perl_warn"
  perl_warn 
 -----------
  
@@ -35,8 +37,9 @@ create or replace function uses_global() returns text language plperl as $$
   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.
+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 (file)
--- a/src/pl/plperl/expected/plperl_trigger.out
+++ b/src/pl/plperl/expected/plperl_trigger.out
@@ -53,41 +53,75 @@ BEFORE INSERT OR UPDATE OR DELETE ON trigger_test
 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 9a64f57..6a30611 100644 (file)
--- a/src/pl/plperl/plperl.c
+++ b/src/pl/plperl/plperl.c
@@ -1,7 +1,7 @@
 /**********************************************************************
  * 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  *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
@@ -1019,9 +1021,7 @@ plperl_create_sub(char *proname, char *s, bool trusted)
                LEAVE;
                ereport(ERROR,
                                (errcode(ERRCODE_SYNTAX_ERROR),
-                                errmsg("creation of Perl function \"%s\" failed: %s",
-                                               proname,
-                                               strip_trailing_ws(SvPV(ERRSV, PL_na)))));
+                                errmsg("%s", strip_trailing_ws(SvPV(ERRSV, PL_na)))));
        }
 
        /*
@@ -1149,9 +1149,7 @@ plperl_call_perl_func(plperl_proc_desc *desc, FunctionCallInfo fcinfo)
                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)))));
+                               (errmsg("%s", strip_trailing_ws(SvPV(ERRSV, PL_na)))));
        }
 
        retval = newSVsv(POPs);
@@ -1207,9 +1205,7 @@ plperl_call_perl_trigger_func(plperl_proc_desc *desc, FunctionCallInfo fcinfo,
                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)))));
+                               (errmsg("%s", strip_trailing_ws(SvPV(ERRSV, PL_na)))));
        }
 
        retval = newSVsv(POPs);
@@ -1231,6 +1227,7 @@ plperl_func_handler(PG_FUNCTION_ARGS)
        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
@@ -1245,6 +1242,12 @@ plperl_func_handler(PG_FUNCTION_ARGS)
        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;
 
        if (prodesc->fn_retisset)
@@ -1367,6 +1370,9 @@ plperl_func_handler(PG_FUNCTION_ARGS)
                                                                   prodesc->result_typioparam, -1);
        }
 
+       /* Restore the previous error callback */
+       error_context_stack = pl_error_context.previous;
+       
        if (array_ret == NULL)
                SvREFCNT_dec(perlret);
 
@@ -1386,6 +1392,7 @@ plperl_trigger_handler(PG_FUNCTION_ARGS)
        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
@@ -1402,6 +1409,12 @@ plperl_trigger_handler(PG_FUNCTION_ARGS)
        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);
 
        svTD = plperl_trigger_build_args(fcinfo);
@@ -1471,6 +1484,9 @@ plperl_trigger_handler(PG_FUNCTION_ARGS)
                retval = PointerGetDatum(trv);
        }
 
+       /* Restore the previous error callback */
+       error_context_stack = pl_error_context.previous;
+
        SvREFCNT_dec(svTD);
        if (perlret)
                SvREFCNT_dec(perlret);
@@ -1492,6 +1508,7 @@ compile_plperl_function(Oid fn_oid, bool is_trigger)
        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,
@@ -1501,6 +1518,12 @@ compile_plperl_function(Oid fn_oid, bool is_trigger)
                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
         ************************************************************/
@@ -1731,6 +1754,9 @@ compile_plperl_function(Oid fn_oid, bool is_trigger)
                hash_entry->proc_data = prodesc;
        }
 
+       /* restore previous error callback */
+       error_context_stack = plperl_error_context.previous;
+
        ReleaseSysCache(procTup);
 
        return prodesc;
@@ -2683,3 +2709,25 @@ hv_fetch_string(HV *hv, const char *key)
 #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);
+}