Skip to content

Commit e3f0271

Browse files
peterepetere
committed
errcontext support in PL/Perl
Author: Alexey Klyukin <alexk@commandprompt.com>
1 parent 384cad5 commit e3f0271

File tree

4 files changed

+112
-12
lines changed

4 files changed

+112
-12
lines changed

‎src/pl/plperl/expected/plperl.out‎

Lines changed: 16 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -122,8 +122,10 @@ CREATE OR REPLACE FUNCTION perl_set() RETURNS SETOF testrowperl AS $$
122122
$$ LANGUAGE plperl;
123123
SELECT perl_set();
124124
ERROR: SETOF-composite-returning PL/Perl function must call return_next with reference to hash
125+
CONTEXT: PL/Perl function "perl_set"
125126
SELECT * FROM perl_set();
126127
ERROR: SETOF-composite-returning PL/Perl function must call return_next with reference to hash
128+
CONTEXT: PL/Perl function "perl_set"
127129
CREATE OR REPLACE FUNCTION perl_set() RETURNS SETOF testrowperl AS $$
128130
return [
129131
{ f1 => 1, f2 => 'Hello', f3 => 'World' },
@@ -171,6 +173,7 @@ CREATE OR REPLACE FUNCTION perl_record() RETURNS record AS $$
171173
$$ LANGUAGE plperl;
172174
SELECT perl_record();
173175
ERROR: function returning record called in context that cannot accept type record
176+
CONTEXT: PL/Perl function "perl_record"
174177
SELECT * FROM perl_record();
175178
ERROR: a column definition list is required for functions returning "record"
176179
LINE 1: SELECT * FROM perl_record();
@@ -186,6 +189,7 @@ CREATE OR REPLACE FUNCTION perl_record_set() RETURNS SETOF record AS $$
186189
$$ LANGUAGE plperl;
187190
SELECT perl_record_set();
188191
ERROR: set-valued function called in context that cannot accept a set
192+
CONTEXT: PL/Perl function "perl_record_set"
189193
SELECT * FROM perl_record_set();
190194
ERROR: a column definition list is required for functions returning "record"
191195
LINE 1: SELECT * FROM perl_record_set();
@@ -204,12 +208,14 @@ CREATE OR REPLACE FUNCTION perl_record_set() RETURNS SETOF record AS $$
204208
$$ LANGUAGE plperl;
205209
SELECT perl_record_set();
206210
ERROR: set-valued function called in context that cannot accept a set
211+
CONTEXT: PL/Perl function "perl_record_set"
207212
SELECT * FROM perl_record_set();
208213
ERROR: a column definition list is required for functions returning "record"
209214
LINE 1: SELECT * FROM perl_record_set();
210215
^
211216
SELECT * FROM perl_record_set() AS (f1 integer, f2 text, f3 text);
212217
ERROR: SETOF-composite-returning PL/Perl function must call return_next with reference to hash
218+
CONTEXT: PL/Perl function "perl_record_set"
213219
CREATE OR REPLACE FUNCTION perl_record_set() RETURNS SETOF record AS $$
214220
return [
215221
{ f1 => 1, f2 => 'Hello', f3 => 'World' },
@@ -219,6 +225,7 @@ CREATE OR REPLACE FUNCTION perl_record_set() RETURNS SETOF record AS $$
219225
$$ LANGUAGE plperl;
220226
SELECT perl_record_set();
221227
ERROR: set-valued function called in context that cannot accept a set
228+
CONTEXT: PL/Perl function "perl_record_set"
222229
SELECT * FROM perl_record_set();
223230
ERROR: a column definition list is required for functions returning "record"
224231
LINE 1: SELECT * FROM perl_record_set();
@@ -308,11 +315,13 @@ CREATE OR REPLACE FUNCTION foo_bad() RETURNS footype AS $$
308315
$$ LANGUAGE plperl;
309316
SELECT * FROM foo_bad();
310317
ERROR: Perl hash contains nonexistent column "z"
318+
CONTEXT: PL/Perl function "foo_bad"
311319
CREATE OR REPLACE FUNCTION foo_bad() RETURNS footype AS $$
312320
return 42;
313321
$$ LANGUAGE plperl;
314322
SELECT * FROM foo_bad();
315323
ERROR: composite-returning PL/Perl function must return reference to hash
324+
CONTEXT: PL/Perl function "foo_bad"
316325
CREATE OR REPLACE FUNCTION foo_bad() RETURNS footype AS $$
317326
return [
318327
[1, 2],
@@ -321,16 +330,19 @@ return [
321330
$$ LANGUAGE plperl;
322331
SELECT * FROM foo_bad();
323332
ERROR: composite-returning PL/Perl function must return reference to hash
333+
CONTEXT: PL/Perl function "foo_bad"
324334
CREATE OR REPLACE FUNCTION foo_set_bad() RETURNS SETOF footype AS $$
325335
return 42;
326336
$$ LANGUAGE plperl;
327337
SELECT * FROM foo_set_bad();
328338
ERROR: set-returning PL/Perl function must return reference to array or use return_next
339+
CONTEXT: PL/Perl function "foo_set_bad"
329340
CREATE OR REPLACE FUNCTION foo_set_bad() RETURNS SETOF footype AS $$
330341
return {y => 3, z => 4};
331342
$$ LANGUAGE plperl;
332343
SELECT * FROM foo_set_bad();
333344
ERROR: set-returning PL/Perl function must return reference to array or use return_next
345+
CONTEXT: PL/Perl function "foo_set_bad"
334346
CREATE OR REPLACE FUNCTION foo_set_bad() RETURNS SETOF footype AS $$
335347
return [
336348
[1, 2],
@@ -339,13 +351,15 @@ return [
339351
$$ LANGUAGE plperl;
340352
SELECT * FROM foo_set_bad();
341353
ERROR: SETOF-composite-returning PL/Perl function must call return_next with reference to hash
354+
CONTEXT: PL/Perl function "foo_set_bad"
342355
CREATE OR REPLACE FUNCTION foo_set_bad() RETURNS SETOF footype AS $$
343356
return [
344357
{y => 3, z => 4}
345358
];
346359
$$ LANGUAGE plperl;
347360
SELECT * FROM foo_set_bad();
348361
ERROR: Perl hash contains nonexistent column "z"
362+
CONTEXT: PL/Perl function "foo_set_bad"
349363
--
350364
-- Check passing a tuple argument
351365
--
@@ -539,4 +553,5 @@ CREATE OR REPLACE FUNCTION perl_spi_prepared_bad(double precision) RETURNS doubl
539553
return $result;
540554
$$ LANGUAGE plperl;
541555
SELECT perl_spi_prepared_bad(4.35) as "double precision";
542-
ERROR: error from Perl function "perl_spi_prepared_bad": type "does_not_exist" does not exist at line 2.
556+
ERROR: type "does_not_exist" does not exist at line 2.
557+
CONTEXT: PL/Perl function "perl_spi_prepared_bad"

‎src/pl/plperl/expected/plperl_elog.out‎

Lines changed: 4 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -7,6 +7,7 @@ create or replace function perl_elog(text) returns void language plperl as $$
77
$$;
88
select perl_elog('explicit elog');
99
NOTICE: explicit elog
10+
CONTEXT: PL/Perl function "perl_elog"
1011
perl_elog
1112
-----------
1213

@@ -21,6 +22,7 @@ $$;
2122
select perl_warn('implicit elog via warn');
2223
NOTICE: implicit elog via warn at line 4.
2324

25+
CONTEXT: PL/Perl function "perl_warn"
2426
perl_warn
2527
-----------
2628

@@ -35,8 +37,9 @@ create or replace function uses_global() returns text language plperl as $$
3537
return 'uses_global worked';
3638

3739
$$;
38-
ERROR: creation of Perl function "uses_global" failed: Global symbol "$global" requires explicit package name at line 3.
40+
ERROR: Global symbol "$global" requires explicit package name at line 3.
3941
Global symbol "$other_global" requires explicit package name at line 4.
42+
CONTEXT: compilation of PL/Perl function "uses_global"
4043
select uses_global();
4144
ERROR: function uses_global() does not exist
4245
LINE 1: select uses_global();

‎src/pl/plperl/expected/plperl_trigger.out‎

Lines changed: 34 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -53,41 +53,75 @@ BEFORE INSERT OR UPDATE OR DELETE ON trigger_test
5353
FOR EACH ROW EXECUTE PROCEDURE trigger_data(23,'skidoo');
5454
insert into trigger_test values(1,'insert');
5555
NOTICE: $_TD->{argc} = '2'
56+
CONTEXT: PL/Perl function "trigger_data"
5657
NOTICE: $_TD->{args} = ['23', 'skidoo']
58+
CONTEXT: PL/Perl function "trigger_data"
5759
NOTICE: $_TD->{event} = 'INSERT'
60+
CONTEXT: PL/Perl function "trigger_data"
5861
NOTICE: $_TD->{level} = 'ROW'
62+
CONTEXT: PL/Perl function "trigger_data"
5963
NOTICE: $_TD->{name} = 'show_trigger_data_trig'
64+
CONTEXT: PL/Perl function "trigger_data"
6065
NOTICE: $_TD->{new} = {'i' => '1', 'v' => 'insert'}
66+
CONTEXT: PL/Perl function "trigger_data"
6167
NOTICE: $_TD->{relid} = 'bogus:12345'
68+
CONTEXT: PL/Perl function "trigger_data"
6269
NOTICE: $_TD->{relname} = 'trigger_test'
70+
CONTEXT: PL/Perl function "trigger_data"
6371
NOTICE: $_TD->{table_name} = 'trigger_test'
72+
CONTEXT: PL/Perl function "trigger_data"
6473
NOTICE: $_TD->{table_schema} = 'public'
74+
CONTEXT: PL/Perl function "trigger_data"
6575
NOTICE: $_TD->{when} = 'BEFORE'
76+
CONTEXT: PL/Perl function "trigger_data"
6677
update trigger_test set v = 'update' where i = 1;
6778
NOTICE: $_TD->{argc} = '2'
79+
CONTEXT: PL/Perl function "trigger_data"
6880
NOTICE: $_TD->{args} = ['23', 'skidoo']
81+
CONTEXT: PL/Perl function "trigger_data"
6982
NOTICE: $_TD->{event} = 'UPDATE'
83+
CONTEXT: PL/Perl function "trigger_data"
7084
NOTICE: $_TD->{level} = 'ROW'
85+
CONTEXT: PL/Perl function "trigger_data"
7186
NOTICE: $_TD->{name} = 'show_trigger_data_trig'
87+
CONTEXT: PL/Perl function "trigger_data"
7288
NOTICE: $_TD->{new} = {'i' => '1', 'v' => 'update'}
89+
CONTEXT: PL/Perl function "trigger_data"
7390
NOTICE: $_TD->{old} = {'i' => '1', 'v' => 'insert'}
91+
CONTEXT: PL/Perl function "trigger_data"
7492
NOTICE: $_TD->{relid} = 'bogus:12345'
93+
CONTEXT: PL/Perl function "trigger_data"
7594
NOTICE: $_TD->{relname} = 'trigger_test'
95+
CONTEXT: PL/Perl function "trigger_data"
7696
NOTICE: $_TD->{table_name} = 'trigger_test'
97+
CONTEXT: PL/Perl function "trigger_data"
7798
NOTICE: $_TD->{table_schema} = 'public'
99+
CONTEXT: PL/Perl function "trigger_data"
78100
NOTICE: $_TD->{when} = 'BEFORE'
101+
CONTEXT: PL/Perl function "trigger_data"
79102
delete from trigger_test;
80103
NOTICE: $_TD->{argc} = '2'
104+
CONTEXT: PL/Perl function "trigger_data"
81105
NOTICE: $_TD->{args} = ['23', 'skidoo']
106+
CONTEXT: PL/Perl function "trigger_data"
82107
NOTICE: $_TD->{event} = 'DELETE'
108+
CONTEXT: PL/Perl function "trigger_data"
83109
NOTICE: $_TD->{level} = 'ROW'
110+
CONTEXT: PL/Perl function "trigger_data"
84111
NOTICE: $_TD->{name} = 'show_trigger_data_trig'
112+
CONTEXT: PL/Perl function "trigger_data"
85113
NOTICE: $_TD->{old} = {'i' => '1', 'v' => 'update'}
114+
CONTEXT: PL/Perl function "trigger_data"
86115
NOTICE: $_TD->{relid} = 'bogus:12345'
116+
CONTEXT: PL/Perl function "trigger_data"
87117
NOTICE: $_TD->{relname} = 'trigger_test'
118+
CONTEXT: PL/Perl function "trigger_data"
88119
NOTICE: $_TD->{table_name} = 'trigger_test'
120+
CONTEXT: PL/Perl function "trigger_data"
89121
NOTICE: $_TD->{table_schema} = 'public'
122+
CONTEXT: PL/Perl function "trigger_data"
90123
NOTICE: $_TD->{when} = 'BEFORE'
124+
CONTEXT: PL/Perl function "trigger_data"
91125

92126
DROP TRIGGER show_trigger_data_trig on trigger_test;
93127

‎src/pl/plperl/plperl.c‎

Lines changed: 58 additions & 10 deletions
Original file line numberDiff line numberDiff line change
@@ -1,7 +1,7 @@
11
/**********************************************************************
22
* plperl.c - perl as a procedural language for PostgreSQL
33
*
4-
* $PostgreSQL: pgsql/src/pl/plperl/plperl.c,v 1.150 2009/06/11 14:49:14 momjian Exp $
4+
* $PostgreSQL: pgsql/src/pl/plperl/plperl.c,v 1.151 2009/09/16 06:06:12 petere Exp $
55
*
66
**********************************************************************/
77

@@ -162,6 +162,8 @@ static SV **hv_store_string(HV *hv, const char *key, SV *val);
162162
static SV **hv_fetch_string(HV *hv, const char *key);
163163
static SV *plperl_create_sub(char *proname, char *s, bool trusted);
164164
static SV *plperl_call_perl_func(plperl_proc_desc *desc, FunctionCallInfo fcinfo);
165+
static void plperl_compile_callback(void *arg);
166+
static void plperl_exec_callback(void *arg);
165167

166168
/*
167169
* 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)
10191021
LEAVE;
10201022
ereport(ERROR,
10211023
(errcode(ERRCODE_SYNTAX_ERROR),
1022-
errmsg("creation of Perl function \"%s\" failed: %s",
1023-
proname,
1024-
strip_trailing_ws(SvPV(ERRSV, PL_na)))));
1024+
errmsg("%s", strip_trailing_ws(SvPV(ERRSV, PL_na)))));
10251025
}
10261026

10271027
/*
@@ -1149,9 +1149,7 @@ plperl_call_perl_func(plperl_proc_desc *desc, FunctionCallInfo fcinfo)
11491149
LEAVE;
11501150
/* XXX need to find a way to assign an errcode here */
11511151
ereport(ERROR,
1152-
(errmsg("error from Perl function \"%s\": %s",
1153-
desc->proname,
1154-
strip_trailing_ws(SvPV(ERRSV, PL_na)))));
1152+
(errmsg("%s", strip_trailing_ws(SvPV(ERRSV, PL_na)))));
11551153
}
11561154

11571155
retval = newSVsv(POPs);
@@ -1207,9 +1205,7 @@ plperl_call_perl_trigger_func(plperl_proc_desc *desc, FunctionCallInfo fcinfo,
12071205
LEAVE;
12081206
/* XXX need to find a way to assign an errcode here */
12091207
ereport(ERROR,
1210-
(errmsg("error from Perl function \"%s\": %s",
1211-
desc->proname,
1212-
strip_trailing_ws(SvPV(ERRSV, PL_na)))));
1208+
(errmsg("%s", strip_trailing_ws(SvPV(ERRSV, PL_na)))));
12131209
}
12141210

12151211
retval = newSVsv(POPs);
@@ -1231,6 +1227,7 @@ plperl_func_handler(PG_FUNCTION_ARGS)
12311227
ReturnSetInfo *rsi;
12321228
SV *array_ret = NULL;
12331229
bool oldcontext = trusted_context;
1230+
ErrorContextCallback pl_error_context;
12341231

12351232
/*
12361233
* Create the call_data beforing connecting to SPI, so that it is not
@@ -1245,6 +1242,12 @@ plperl_func_handler(PG_FUNCTION_ARGS)
12451242
prodesc = compile_plperl_function(fcinfo->flinfo->fn_oid, false);
12461243
current_call_data->prodesc = prodesc;
12471244

1245+
/* Set a callback for error reporting */
1246+
pl_error_context.callback = plperl_exec_callback;
1247+
pl_error_context.previous = error_context_stack;
1248+
pl_error_context.arg = prodesc->proname;
1249+
error_context_stack = &pl_error_context;
1250+
12481251
rsi = (ReturnSetInfo *) fcinfo->resultinfo;
12491252

12501253
if (prodesc->fn_retisset)
@@ -1367,6 +1370,9 @@ plperl_func_handler(PG_FUNCTION_ARGS)
13671370
prodesc->result_typioparam, -1);
13681371
}
13691372

1373+
/* Restore the previous error callback */
1374+
error_context_stack = pl_error_context.previous;
1375+
13701376
if (array_ret == NULL)
13711377
SvREFCNT_dec(perlret);
13721378

@@ -1386,6 +1392,7 @@ plperl_trigger_handler(PG_FUNCTION_ARGS)
13861392
SV *svTD;
13871393
HV *hvTD;
13881394
bool oldcontext = trusted_context;
1395+
ErrorContextCallback pl_error_context;
13891396

13901397
/*
13911398
* Create the call_data beforing connecting to SPI, so that it is not
@@ -1402,6 +1409,12 @@ plperl_trigger_handler(PG_FUNCTION_ARGS)
14021409
prodesc = compile_plperl_function(fcinfo->flinfo->fn_oid, true);
14031410
current_call_data->prodesc = prodesc;
14041411

1412+
/* Set a callback for error reporting */
1413+
pl_error_context.callback = plperl_exec_callback;
1414+
pl_error_context.previous = error_context_stack;
1415+
pl_error_context.arg = prodesc->proname;
1416+
error_context_stack = &pl_error_context;
1417+
14051418
check_interp(prodesc->lanpltrusted);
14061419

14071420
svTD = plperl_trigger_build_args(fcinfo);
@@ -1471,6 +1484,9 @@ plperl_trigger_handler(PG_FUNCTION_ARGS)
14711484
retval = PointerGetDatum(trv);
14721485
}
14731486

1487+
/* Restore the previous error callback */
1488+
error_context_stack = pl_error_context.previous;
1489+
14741490
SvREFCNT_dec(svTD);
14751491
if (perlret)
14761492
SvREFCNT_dec(perlret);
@@ -1492,6 +1508,7 @@ compile_plperl_function(Oid fn_oid, bool is_trigger)
14921508
plperl_proc_entry *hash_entry;
14931509
bool found;
14941510
bool oldcontext = trusted_context;
1511+
ErrorContextCallback plperl_error_context;
14951512

14961513
/* We'll need the pg_proc tuple in any case... */
14971514
procTup = SearchSysCache(PROCOID,
@@ -1501,6 +1518,12 @@ compile_plperl_function(Oid fn_oid, bool is_trigger)
15011518
elog(ERROR, "cache lookup failed for function %u", fn_oid);
15021519
procStruct = (Form_pg_proc) GETSTRUCT(procTup);
15031520

1521+
/* Set a callback for reporting compilation errors */
1522+
plperl_error_context.callback = plperl_compile_callback;
1523+
plperl_error_context.previous = error_context_stack;
1524+
plperl_error_context.arg = NameStr(procStruct->proname);
1525+
error_context_stack = &plperl_error_context;
1526+
15041527
/************************************************************
15051528
* Build our internal proc name from the function's Oid
15061529
************************************************************/
@@ -1731,6 +1754,9 @@ compile_plperl_function(Oid fn_oid, bool is_trigger)
17311754
hash_entry->proc_data = prodesc;
17321755
}
17331756

1757+
/* restore previous error callback */
1758+
error_context_stack = plperl_error_context.previous;
1759+
17341760
ReleaseSysCache(procTup);
17351761

17361762
return prodesc;
@@ -2683,3 +2709,25 @@ hv_fetch_string(HV *hv, const char *key)
26832709
#endif
26842710
return hv_fetch(hv, key, klen, 0);
26852711
}
2712+
2713+
/*
2714+
* Provide function name for PL/Perl execution errors
2715+
*/
2716+
static void
2717+
plperl_exec_callback(void *arg)
2718+
{
2719+
char *procname = (char *) arg;
2720+
if (procname)
2721+
errcontext("PL/Perl function \"%s\"", procname);
2722+
}
2723+
2724+
/*
2725+
* Provide function name for PL/Perl compilation errors
2726+
*/
2727+
static void
2728+
plperl_compile_callback(void *arg)
2729+
{
2730+
char *procname = (char *) arg;
2731+
if (procname)
2732+
errcontext("compilation of PL/Perl function \"%s\"", procname);
2733+
}

0 commit comments

Comments
 (0)