1berry/postgres
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

Improve PL/Tcl's method for choosing Tcl names of procedures.

Browse Source 
Previously, the internal name of a PL/Tcl function was just
"__PLTcl_proc_NNNN", where NNNN is the function OID.  That's pretty
unhelpful when reading an error report.  Plus it prevents us from
testing the CONTEXT output for PL/Tcl errors, since the OIDs shown
in the regression tests wouldn't be stable.

Instead, base the internal name on the result of format_procedure(),
which will be unique in most cases.  For the edge cases where it's
not, we can append the function OID to make it unique.

Sadly, the pltcl_trigger.sql test script still has to suppress the
context reports, because they'd include trigger arguments which
contain relation OIDs per PL/Tcl's longstanding API for triggers.

I had to modify one existing test case to throw a different error
than before, because I found that Tcl 8.5 and Tcl 8.6 spell the
context message for the original error slightly differently.
We might have to make more adjustments in that vein once this
gets wider testing.

Patch by me; thanks to Pavel Stehule for the idea to use
format_procedure() rather than just the proname.

Discussion: https://postgr.es/m/890581.1717609350@sss.pgh.pa.us
This commit is contained in:
Tom Lane 2024-07-05 14:14:42 -04:00
parent aaab3ee9c6
commit ba8f00eef6
8 changed files with 520 additions and 46 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
doc/src/sgml/pltcl.sgml
View File

@ -1120,16 +1120,25 @@ CALL transaction_test1();
<para> <para>
In <productname>PostgreSQL</productname>, the same function name can be used for In <productname>PostgreSQL</productname>, the same function name can be used for
different function definitions as long as the number of arguments or their types different function definitions if the functions are placed in different
schemas, or if the number of arguments or their types
differ. Tcl, however, requires all procedure names to be distinct. differ. Tcl, however, requires all procedure names to be distinct.
PL/Tcl deals with this by making the internal Tcl procedure names contain PL/Tcl deals with this by including the argument type names in the
the object internal Tcl procedure name, and then appending the function's object
ID of the function from the system table <structname>pg_proc</structname> as part of their name. Thus, ID (OID) to the internal Tcl procedure name if necessary to make it
different from the names of all previously-loaded functions in the
same Tcl interpreter. Thus,
<productname>PostgreSQL</productname> functions with the same name <productname>PostgreSQL</productname> functions with the same name
and different argument types will be different Tcl procedures, too. This and different argument types will be different Tcl procedures, too. This
is not normally a concern for a PL/Tcl programmer, but it might be visible is not normally a concern for a PL/Tcl programmer, but it might be visible
when debugging. when debugging.
</para> </para>
<para>
For this reason among others, a PL/Tcl function cannot call another one
directly (that is, within Tcl). If you need to do that, you must go
through SQL, using <function>spi_exec</function> or a related command.
</para>
</sect1> </sect1>
</chapter> </chapter>

320
src/pl/tcl/expected/pltcl_queries.out
View File

@ -1,5 +1,3 @@
-- suppress CONTEXT so that function OIDs aren't in output
\set VERBOSITY terse
-- Test composite-type arguments -- Test composite-type arguments
select tcl_composite_arg_ref1(row('tkey', 42, 'ref2')); select tcl_composite_arg_ref1(row('tkey', 42, 'ref2'));
tcl_composite_arg_ref1 tcl_composite_arg_ref1
@ -73,9 +71,15 @@ select tcl_argisnull(null);
(1 row) (1 row)
-- test some error cases -- test some error cases
create function tcl_error(out a int, out b int) as $$return {$$ language pltcl; create function tcl_error(out a int, out b int) as $$returm 1$$ language pltcl;
select tcl_error(); select tcl_error();
ERROR: missing close-brace ERROR: invalid command name "returm"
CONTEXT: while executing
"returm 1"
(procedure "__PLTcl_proc_tcl_error" line 2)
invoked from within
"__PLTcl_proc_tcl_error"
in PL/Tcl function tcl_error()
create function bad_record(out a text, out b text) as $$return [list a]$$ language pltcl; create function bad_record(out a text, out b text) as $$return [list a]$$ language pltcl;
select bad_record(); select bad_record();
ERROR: column name/value list must have even number of elements ERROR: column name/value list must have even number of elements
@ -123,16 +127,34 @@ select 1, tcl_test_sequence(0,5);
create function non_srf() returns int as $$return_next 1$$ language pltcl; create function non_srf() returns int as $$return_next 1$$ language pltcl;
select non_srf(); select non_srf();
ERROR: return_next cannot be used in non-set-returning functions ERROR: return_next cannot be used in non-set-returning functions
CONTEXT: while executing
"return_next 1"
(procedure "__PLTcl_proc_non_srf" line 2)
invoked from within
"__PLTcl_proc_non_srf"
in PL/Tcl function non_srf()
create function bad_record_srf(out a text, out b text) returns setof record as $$ create function bad_record_srf(out a text, out b text) returns setof record as $$
return_next [list a] return_next [list a]
$$ language pltcl; $$ language pltcl;
select bad_record_srf(); select bad_record_srf();
ERROR: column name/value list must have even number of elements ERROR: column name/value list must have even number of elements
CONTEXT: while executing
"return_next [list a]"
(procedure "__PLTcl_proc_bad_record_srf" line 3)
invoked from within
"__PLTcl_proc_bad_record_srf"
in PL/Tcl function bad_record_srf()
create function bad_field_srf(out a text, out b text) returns setof record as $$ create function bad_field_srf(out a text, out b text) returns setof record as $$
return_next [list a 1 b 2 cow 3] return_next [list a 1 b 2 cow 3]
$$ language pltcl; $$ language pltcl;
select bad_field_srf(); select bad_field_srf();
ERROR: column name/value list contains nonexistent column name "cow" ERROR: column name/value list contains nonexistent column name "cow"
CONTEXT: while executing
"return_next [list a 1 b 2 cow 3]"
(procedure "__PLTcl_proc_bad_field_srf" line 3)
invoked from within
"__PLTcl_proc_bad_field_srf"
in PL/Tcl function bad_field_srf()
-- test composite and domain-over-composite results -- test composite and domain-over-composite results
create function tcl_composite_result(int) returns T_comp1 as $$ create function tcl_composite_result(int) returns T_comp1 as $$
return [list tkey tkey1 ref1 $1 ref2 ref22] return [list tkey tkey1 ref1 $1 ref2 ref22]
@ -172,7 +194,9 @@ $$ language pltcl;
select tcl_record_result(42); -- fail select tcl_record_result(42); -- fail
ERROR: function returning record called in context that cannot accept type record ERROR: function returning record called in context that cannot accept type record
select * from tcl_record_result(42); -- fail select * from tcl_record_result(42); -- fail
ERROR: a column definition list is required for functions returning "record" at character 15 ERROR: a column definition list is required for functions returning "record"
LINE 1: select * from tcl_record_result(42);
^
select * from tcl_record_result(42) as (q1 text, q2 int, q3 text); select * from tcl_record_result(42) as (q1 text, q2 int, q3 text);
q1 | q2 | q3 q1 | q2 | q3
----------+----+---------- ----------+----+----------
@ -190,6 +214,15 @@ ERROR: column name/value list contains nonexistent column name "q3"
-- test quote -- test quote
select tcl_eval('quote foo bar'); select tcl_eval('quote foo bar');
ERROR: wrong # args: should be "quote string" ERROR: wrong # args: should be "quote string"
CONTEXT: while executing
"quote foo bar"
("eval" body line 1)
invoked from within
"eval $1"
(procedure "__PLTcl_proc_tcl_eval_text" line 3)
invoked from within
"__PLTcl_proc_tcl_eval_text {quote foo bar}"
in PL/Tcl function tcl_eval(text)
select tcl_eval('quote [format %c 39]'); select tcl_eval('quote [format %c 39]');
tcl_eval tcl_eval
---------- ----------
@ -205,46 +238,217 @@ select tcl_eval('quote [format %c 92]');
-- Test argisnull -- Test argisnull
select tcl_eval('argisnull'); select tcl_eval('argisnull');
ERROR: wrong # args: should be "argisnull argno" ERROR: wrong # args: should be "argisnull argno"
CONTEXT: while executing
"argisnull"
("eval" body line 1)
invoked from within
"eval $1"
(procedure "__PLTcl_proc_tcl_eval_text" line 3)
invoked from within
"__PLTcl_proc_tcl_eval_text argisnull"
in PL/Tcl function tcl_eval(text)
select tcl_eval('argisnull 14'); select tcl_eval('argisnull 14');
ERROR: argno out of range ERROR: argno out of range
CONTEXT: while executing
"argisnull 14"
("eval" body line 1)
invoked from within
"eval $1"
(procedure "__PLTcl_proc_tcl_eval_text" line 3)
invoked from within
"__PLTcl_proc_tcl_eval_text {argisnull 14}"
in PL/Tcl function tcl_eval(text)
select tcl_eval('argisnull abc'); select tcl_eval('argisnull abc');
ERROR: expected integer but got "abc" ERROR: expected integer but got "abc"
CONTEXT: while executing
"argisnull abc"
("eval" body line 1)
invoked from within
"eval $1"
(procedure "__PLTcl_proc_tcl_eval_text" line 3)
invoked from within
"__PLTcl_proc_tcl_eval_text {argisnull abc}"
in PL/Tcl function tcl_eval(text)
-- Test return_null -- Test return_null
select tcl_eval('return_null 14'); select tcl_eval('return_null 14');
ERROR: wrong # args: should be "return_null " ERROR: wrong # args: should be "return_null "
CONTEXT: while executing
"return_null 14"
("eval" body line 1)
invoked from within
"eval $1"
(procedure "__PLTcl_proc_tcl_eval_text" line 3)
invoked from within
"__PLTcl_proc_tcl_eval_text {return_null 14}"
in PL/Tcl function tcl_eval(text)
-- Test spi_exec -- Test spi_exec
select tcl_eval('spi_exec'); select tcl_eval('spi_exec');
ERROR: wrong # args: should be "spi_exec ?-count n? ?-array name? query ?loop body?" ERROR: wrong # args: should be "spi_exec ?-count n? ?-array name? query ?loop body?"
CONTEXT: while executing
"spi_exec"
("eval" body line 1)
invoked from within
"eval $1"
(procedure "__PLTcl_proc_tcl_eval_text" line 3)
invoked from within
"__PLTcl_proc_tcl_eval_text spi_exec"
in PL/Tcl function tcl_eval(text)
select tcl_eval('spi_exec -count'); select tcl_eval('spi_exec -count');
ERROR: missing argument to -count or -array ERROR: missing argument to -count or -array
CONTEXT: while executing
"spi_exec -count"
("eval" body line 1)
invoked from within
"eval $1"
(procedure "__PLTcl_proc_tcl_eval_text" line 3)
invoked from within
"__PLTcl_proc_tcl_eval_text {spi_exec -count}"
in PL/Tcl function tcl_eval(text)
select tcl_eval('spi_exec -array'); select tcl_eval('spi_exec -array');
ERROR: missing argument to -count or -array ERROR: missing argument to -count or -array
CONTEXT: while executing
"spi_exec -array"
("eval" body line 1)
invoked from within
"eval $1"
(procedure "__PLTcl_proc_tcl_eval_text" line 3)
invoked from within
"__PLTcl_proc_tcl_eval_text {spi_exec -array}"
in PL/Tcl function tcl_eval(text)
select tcl_eval('spi_exec -count abc'); select tcl_eval('spi_exec -count abc');
ERROR: expected integer but got "abc" ERROR: expected integer but got "abc"
CONTEXT: while executing
"spi_exec -count abc"
("eval" body line 1)
invoked from within
"eval $1"
(procedure "__PLTcl_proc_tcl_eval_text" line 3)
invoked from within
"__PLTcl_proc_tcl_eval_text {spi_exec -count abc}"
in PL/Tcl function tcl_eval(text)
select tcl_eval('spi_exec query loop body toomuch'); select tcl_eval('spi_exec query loop body toomuch');
ERROR: wrong # args: should be "query ?loop body?" ERROR: wrong # args: should be "query ?loop body?"
CONTEXT: while executing
"spi_exec query loop body toomuch"
("eval" body line 1)
invoked from within
"eval $1"
(procedure "__PLTcl_proc_tcl_eval_text" line 3)
invoked from within
"__PLTcl_proc_tcl_eval_text {spi_exec query loop body toomuch}"
in PL/Tcl function tcl_eval(text)
select tcl_eval('spi_exec "begin; rollback;"'); select tcl_eval('spi_exec "begin; rollback;"');
ERROR: pltcl: SPI_execute failed: SPI_ERROR_TRANSACTION ERROR: pltcl: SPI_execute failed: SPI_ERROR_TRANSACTION
CONTEXT: while executing
"spi_exec "begin; rollback;""
("eval" body line 1)
invoked from within
"eval $1"
(procedure "__PLTcl_proc_tcl_eval_text" line 3)
invoked from within
"__PLTcl_proc_tcl_eval_text {spi_exec "begin; rollback;"}"
in PL/Tcl function tcl_eval(text)
-- Test spi_execp -- Test spi_execp
select tcl_eval('spi_execp'); select tcl_eval('spi_execp');
ERROR: missing argument to -count or -array ERROR: missing argument to -count or -array
CONTEXT: while executing
"spi_execp"
("eval" body line 1)
invoked from within
"eval $1"
(procedure "__PLTcl_proc_tcl_eval_text" line 3)
invoked from within
"__PLTcl_proc_tcl_eval_text spi_execp"
in PL/Tcl function tcl_eval(text)
select tcl_eval('spi_execp -count'); select tcl_eval('spi_execp -count');
ERROR: missing argument to -array, -count or -nulls ERROR: missing argument to -array, -count or -nulls
CONTEXT: while executing
"spi_execp -count"
("eval" body line 1)
invoked from within
"eval $1"
(procedure "__PLTcl_proc_tcl_eval_text" line 3)
invoked from within
"__PLTcl_proc_tcl_eval_text {spi_execp -count}"
in PL/Tcl function tcl_eval(text)
select tcl_eval('spi_execp -array'); select tcl_eval('spi_execp -array');
ERROR: missing argument to -array, -count or -nulls ERROR: missing argument to -array, -count or -nulls
CONTEXT: while executing
"spi_execp -array"
("eval" body line 1)
invoked from within
"eval $1"
(procedure "__PLTcl_proc_tcl_eval_text" line 3)
invoked from within
"__PLTcl_proc_tcl_eval_text {spi_execp -array}"
in PL/Tcl function tcl_eval(text)
select tcl_eval('spi_execp -count abc'); select tcl_eval('spi_execp -count abc');
ERROR: expected integer but got "abc" ERROR: expected integer but got "abc"
CONTEXT: while executing
"spi_execp -count abc"
("eval" body line 1)
invoked from within
"eval $1"
(procedure "__PLTcl_proc_tcl_eval_text" line 3)
invoked from within
"__PLTcl_proc_tcl_eval_text {spi_execp -count abc}"
in PL/Tcl function tcl_eval(text)
select tcl_eval('spi_execp -nulls'); select tcl_eval('spi_execp -nulls');
ERROR: missing argument to -array, -count or -nulls ERROR: missing argument to -array, -count or -nulls
CONTEXT: while executing
"spi_execp -nulls"
("eval" body line 1)
invoked from within
"eval $1"
(procedure "__PLTcl_proc_tcl_eval_text" line 3)
invoked from within
"__PLTcl_proc_tcl_eval_text {spi_execp -nulls}"
in PL/Tcl function tcl_eval(text)
select tcl_eval('spi_execp ""'); select tcl_eval('spi_execp ""');
ERROR: invalid queryid '' ERROR: invalid queryid ''
CONTEXT: while executing
"spi_execp """
("eval" body line 1)
invoked from within
"eval $1"
(procedure "__PLTcl_proc_tcl_eval_text" line 3)
invoked from within
"__PLTcl_proc_tcl_eval_text {spi_execp ""}"
in PL/Tcl function tcl_eval(text)
-- test spi_prepare -- test spi_prepare
select tcl_eval('spi_prepare'); select tcl_eval('spi_prepare');
ERROR: wrong # args: should be "spi_prepare query argtypes" ERROR: wrong # args: should be "spi_prepare query argtypes"
CONTEXT: while executing
"spi_prepare"
("eval" body line 1)
invoked from within
"eval $1"
(procedure "__PLTcl_proc_tcl_eval_text" line 3)
invoked from within
"__PLTcl_proc_tcl_eval_text spi_prepare"
in PL/Tcl function tcl_eval(text)
select tcl_eval('spi_prepare a b'); select tcl_eval('spi_prepare a b');
ERROR: type "b" does not exist ERROR: type "b" does not exist
CONTEXT: while executing
"spi_prepare a b"
("eval" body line 1)
invoked from within
"eval $1"
(procedure "__PLTcl_proc_tcl_eval_text" line 3)
invoked from within
"__PLTcl_proc_tcl_eval_text {spi_prepare a b}"
in PL/Tcl function tcl_eval(text)
select tcl_eval('spi_prepare a "b {"'); select tcl_eval('spi_prepare a "b {"');
ERROR: unmatched open brace in list ERROR: unmatched open brace in list
CONTEXT: while executing
"spi_prepare a "b {""
("eval" body line 1)
invoked from within
"eval $1"
(procedure "__PLTcl_proc_tcl_eval_text" line 3)
invoked from within
"__PLTcl_proc_tcl_eval_text spi_prepare\ a\ \"b\ \{\""
in PL/Tcl function tcl_eval(text)
select tcl_error_handling_test($tcl$spi_prepare "select moo" []$tcl$); select tcl_error_handling_test($tcl$spi_prepare "select moo" []$tcl$);
tcl_error_handling_test tcl_error_handling_test
-------------------------------------- --------------------------------------
@ -307,11 +511,38 @@ select tcl_error_handling_test('moo');
-- test elog -- test elog
select tcl_eval('elog'); select tcl_eval('elog');
ERROR: wrong # args: should be "elog level msg" ERROR: wrong # args: should be "elog level msg"
CONTEXT: while executing
"elog"
("eval" body line 1)
invoked from within
"eval $1"
(procedure "__PLTcl_proc_tcl_eval_text" line 3)
invoked from within
"__PLTcl_proc_tcl_eval_text elog"
in PL/Tcl function tcl_eval(text)
select tcl_eval('elog foo bar'); select tcl_eval('elog foo bar');
ERROR: bad priority "foo": must be DEBUG, LOG, INFO, NOTICE, WARNING, ERROR, or FATAL ERROR: bad priority "foo": must be DEBUG, LOG, INFO, NOTICE, WARNING, ERROR, or FATAL
CONTEXT: while executing
"elog foo bar"
("eval" body line 1)
invoked from within
"eval $1"
(procedure "__PLTcl_proc_tcl_eval_text" line 3)
invoked from within
"__PLTcl_proc_tcl_eval_text {elog foo bar}"
in PL/Tcl function tcl_eval(text)
-- test forced error -- test forced error
select tcl_eval('error "forced error"'); select tcl_eval('error "forced error"');
ERROR: forced error ERROR: forced error
CONTEXT: while executing
"error "forced error""
("eval" body line 1)
invoked from within
"eval $1"
(procedure "__PLTcl_proc_tcl_eval_text" line 3)
invoked from within
"__PLTcl_proc_tcl_eval_text {error "forced error"}"
in PL/Tcl function tcl_eval(text)
-- test loop control in spi_exec[p] -- test loop control in spi_exec[p]
select tcl_spi_exec(true, 'break'); select tcl_spi_exec(true, 'break');
NOTICE: col1 1, col2 foo NOTICE: col1 1, col2 foo
@ -339,6 +570,19 @@ NOTICE: col1 1, col2 foo
NOTICE: col1 2, col2 bar NOTICE: col1 2, col2 bar
NOTICE: action: error NOTICE: action: error
ERROR: error message ERROR: error message
CONTEXT: while executing
"error "error message""
invoked from within
"spi_execp -array A $prep {
elog NOTICE "col1 $A(col1), col2 $A(col2)"
switch $A(col1) {
2 {
elog NOTICE "..."
(procedure "__PLTcl_proc_tcl_spi_exec_boolean_text" line 6)
invoked from within
"__PLTcl_proc_tcl_spi_exec_boolean_text t error"
in PL/Tcl function tcl_spi_exec(boolean,text)
select tcl_spi_exec(true, 'return'); select tcl_spi_exec(true, 'return');
NOTICE: col1 1, col2 foo NOTICE: col1 1, col2 foo
NOTICE: col1 2, col2 bar NOTICE: col1 2, col2 bar
@ -374,6 +618,19 @@ NOTICE: col1 1, col2 foo
NOTICE: col1 2, col2 bar NOTICE: col1 2, col2 bar
NOTICE: action: error NOTICE: action: error
ERROR: error message ERROR: error message
CONTEXT: while executing
"error "error message""
invoked from within
"spi_exec -array A $query {
elog NOTICE "col1 $A(col1), col2 $A(col2)"
switch $A(col1) {
2 {
elog NOTICE "..."
(procedure "__PLTcl_proc_tcl_spi_exec_boolean_text" line 31)
invoked from within
"__PLTcl_proc_tcl_spi_exec_boolean_text f error"
in PL/Tcl function tcl_spi_exec(boolean,text)
select tcl_spi_exec(false, 'return'); select tcl_spi_exec(false, 'return');
NOTICE: col1 1, col2 foo NOTICE: col1 1, col2 foo
NOTICE: col1 2, col2 bar NOTICE: col1 2, col2 bar
@ -383,6 +640,59 @@ NOTICE: action: return
(1 row) (1 row)
-- test that we don't get confused by multiple funcs with same SQL name
create schema tcls1;
create function tcls1.somefunc(int) returns int as $$
return [expr $1 * 2]
$$ language pltcl;
create schema tcls2;
create function tcls2.somefunc(int) returns int as $$
return [expr $1 * 3]
$$ language pltcl;
set search_path = tcls1;
select tcls1.somefunc(11);
somefunc
----------
22
(1 row)
set search_path = tcls2;
select tcls2.somefunc(12);
somefunc
----------
36
(1 row)
set search_path = tcls1;
select tcls1.somefunc(13);
somefunc
----------
26
(1 row)
reset search_path;
-- test that it works to replace a function that's being executed
create function replaceme(text) returns text as $p$
spi_exec {
create or replace function replaceme(text) returns text as $$
return "$1 fum"
$$ language pltcl;
}
spi_exec {select replaceme('foe') as inner}
return "fee $1 $inner"
$p$ language pltcl;
select replaceme('fie');
replaceme
-----------------
fee fie foe fum
(1 row)
select replaceme('fie');
replaceme
-----------
fie fum
(1 row)
-- forcibly run the Tcl event loop for awhile, to check that we have not -- forcibly run the Tcl event loop for awhile, to check that we have not
-- messed things up too badly by disabling the Tcl notifier subsystem -- messed things up too badly by disabling the Tcl notifier subsystem
select tcl_eval($$ select tcl_eval($$

47
src/pl/tcl/expected/pltcl_transaction.out
View File

@ -1,5 +1,3 @@
-- suppress CONTEXT so that function OIDs aren't in output
\set VERBOSITY terse
CREATE TABLE test1 (a int, b text); CREATE TABLE test1 (a int, b text);
CREATE PROCEDURE transaction_test1() CREATE PROCEDURE transaction_test1()
LANGUAGE pltcl LANGUAGE pltcl
@ -41,6 +39,12 @@ return 1
$$; $$;
SELECT transaction_test2(); SELECT transaction_test2();
ERROR: invalid transaction termination ERROR: invalid transaction termination
CONTEXT: while executing
"commit"
(procedure "__PLTcl_proc_transaction_test2" line 6)
invoked from within
"__PLTcl_proc_transaction_test2"
in PL/Tcl function transaction_test2()
SELECT * FROM test1; SELECT * FROM test1;
a | b a | b
---+--- ---+---
@ -55,6 +59,17 @@ return 1
$$; $$;
SELECT transaction_test3(); SELECT transaction_test3();
ERROR: invalid transaction termination ERROR: invalid transaction termination
CONTEXT: while executing
"commit"
(procedure "__PLTcl_proc_transaction_test1" line 6)
invoked from within
"__PLTcl_proc_transaction_test1"
invoked from within
"spi_exec "CALL transaction_test1()""
(procedure "__PLTcl_proc_transaction_test3" line 3)
invoked from within
"__PLTcl_proc_transaction_test3"
in PL/Tcl function transaction_test3()
SELECT * FROM test1; SELECT * FROM test1;
a | b a | b
---+--- ---+---
@ -74,6 +89,17 @@ spi_exec -array row "SELECT * FROM test2 ORDER BY x" {
$$; $$;
CALL transaction_test4a(); CALL transaction_test4a();
ERROR: cannot commit while a subtransaction is active ERROR: cannot commit while a subtransaction is active
CONTEXT: while executing
"commit"
invoked from within
"spi_exec -array row "SELECT * FROM test2 ORDER BY x" {
spi_exec "INSERT INTO test1 (a) VALUES ($row(x))"
commit
}"
(procedure "__PLTcl_proc_transaction_test4a" line 3)
invoked from within
"__PLTcl_proc_transaction_test4a"
in PL/Tcl function transaction_test4a()
SELECT * FROM test1; SELECT * FROM test1;
a | b a | b
---+--- ---+---
@ -91,6 +117,17 @@ spi_exec -array row "SELECT * FROM test2 ORDER BY x" {
$$; $$;
CALL transaction_test4b(); CALL transaction_test4b();
ERROR: cannot roll back while a subtransaction is active ERROR: cannot roll back while a subtransaction is active
CONTEXT: while executing
"rollback"
invoked from within
"spi_exec -array row "SELECT * FROM test2 ORDER BY x" {
spi_exec "INSERT INTO test1 (a) VALUES ($row(x))"
rollback
}"
(procedure "__PLTcl_proc_transaction_test4b" line 3)
invoked from within
"__PLTcl_proc_transaction_test4b"
in PL/Tcl function transaction_test4b()
SELECT * FROM test1; SELECT * FROM test1;
a | b a | b
---+--- ---+---
@ -109,6 +146,12 @@ elog WARNING "should not get here"
$$; $$;
CALL transaction_testfk(); CALL transaction_testfk();
ERROR: insert or update on table "testfk" violates foreign key constraint "testfk_f1_fkey" ERROR: insert or update on table "testfk" violates foreign key constraint "testfk_f1_fkey"
CONTEXT: while executing
"commit"
(procedure "__PLTcl_proc_transaction_testfk" line 5)
invoked from within
"__PLTcl_proc_transaction_testfk"
in PL/Tcl function transaction_testfk()
SELECT * FROM testpk; SELECT * FROM testpk;
id id
---- ----

2
src/pl/tcl/expected/pltcl_trigger.out
View File

@ -1,4 +1,4 @@
-- suppress CONTEXT so that function OIDs aren't in output -- suppress CONTEXT so that table OIDs aren't in output
\set VERBOSITY terse \set VERBOSITY terse
-- --
-- Create the tables used in the test queries -- Create the tables used in the test queries

137
src/pl/tcl/pltcl.c
View File

@ -124,19 +124,21 @@ typedef struct pltcl_interp_desc
* The pltcl_proc_desc struct itself, as well as all subsidiary data, * The pltcl_proc_desc struct itself, as well as all subsidiary data,
* is stored in the memory context identified by the fn_cxt field. * is stored in the memory context identified by the fn_cxt field.
* We can reclaim all the data by deleting that context, and should do so * We can reclaim all the data by deleting that context, and should do so
* when the fn_refcount goes to zero. (But note that we do not bother * when the fn_refcount goes to zero. That will happen if we build a new
* trying to clean up Tcl's copy of the procedure definition: it's Tcl's * pltcl_proc_desc following an update of the pg_proc row. If that happens
* problem to manage its memory when we replace a proc definition. We do * while the old proc is being executed, we mustn't remove the struct until
* not clean up pltcl_proc_descs when a pg_proc row is deleted, only when * execution finishes. When building a new pltcl_proc_desc, we unlink
* it is updated, and the same policy applies to Tcl's copy as well.) * Tcl's copy of the old procedure definition, similarly relying on Tcl's
* internal reference counting to prevent that structure from disappearing
* while it's in use.
* *
* Note that the data in this struct is shared across all active calls; * Note that the data in this struct is shared across all active calls;
* nothing except the fn_refcount should be changed by a call instance. * nothing except the fn_refcount should be changed by a call instance.
**********************************************************************/ **********************************************************************/
typedef struct pltcl_proc_desc typedef struct pltcl_proc_desc
{ {
char *user_proname; /* user's name (from pg_proc.proname) */ char *user_proname; /* user's name (from format_procedure) */
char *internal_proname; /* Tcl name (based on function OID) */ char *internal_proname; /* Tcl proc name (NULL if deleted) */
MemoryContext fn_cxt; /* memory context for this procedure */ MemoryContext fn_cxt; /* memory context for this procedure */
unsigned long fn_refcount; /* number of active references */ unsigned long fn_refcount; /* number of active references */
TransactionId fn_xmin; /* xmin of pg_proc row */ TransactionId fn_xmin; /* xmin of pg_proc row */
@ -1375,13 +1377,29 @@ throw_tcl_error(Tcl_Interp *interp, const char *proname)
*/ */
char *emsg; char *emsg;
char *econtext; char *econtext;
int emsglen;
emsg = pstrdup(utf_u2e(Tcl_GetStringResult(interp))); emsg = pstrdup(utf_u2e(Tcl_GetStringResult(interp)));
econtext = utf_u2e(Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY)); econtext = utf_u2e(Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY));
/*
* Typically, the first line of errorInfo matches the primary error
* message (the interpreter result); don't print that twice if so.
*/
emsglen = strlen(emsg);
if (strncmp(emsg, econtext, emsglen) == 0 &&
econtext[emsglen] == '\n')
econtext += emsglen + 1;
/* Tcl likes to prefix the next line with some spaces, too */
while (*econtext == ' ')
econtext++;
/* Note: proname will already contain quoting if any is needed */
ereport(ERROR, ereport(ERROR,
(errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION), (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION),
errmsg("%s", emsg), errmsg("%s", emsg),
errcontext("%s\nin PL/Tcl function \"%s\"", errcontext("%s\nin PL/Tcl function %s",
econtext, proname))); econtext, proname)));
} }
@ -1405,6 +1423,7 @@ compile_pltcl_function(Oid fn_oid, Oid tgreloid,
pltcl_proc_desc *old_prodesc; pltcl_proc_desc *old_prodesc;
volatile MemoryContext proc_cxt = NULL; volatile MemoryContext proc_cxt = NULL;
Tcl_DString proc_internal_def; Tcl_DString proc_internal_def;
Tcl_DString proc_internal_name;
Tcl_DString proc_internal_body; Tcl_DString proc_internal_body;
/* We'll need the pg_proc tuple in any case... */ /* We'll need the pg_proc tuple in any case... */
@ -1435,6 +1454,7 @@ compile_pltcl_function(Oid fn_oid, Oid tgreloid,
* function's pg_proc entry without changing its OID. * function's pg_proc entry without changing its OID.
************************************************************/ ************************************************************/
if (prodesc != NULL && if (prodesc != NULL &&
prodesc->internal_proname != NULL &&
prodesc->fn_xmin == HeapTupleHeaderGetRawXmin(procTup->t_data) && prodesc->fn_xmin == HeapTupleHeaderGetRawXmin(procTup->t_data) &&
ItemPointerEquals(&prodesc->fn_tid, &procTup->t_self)) ItemPointerEquals(&prodesc->fn_tid, &procTup->t_self))
{ {
@ -1452,36 +1472,104 @@ compile_pltcl_function(Oid fn_oid, Oid tgreloid,
* Then we load the procedure into the Tcl interpreter. * Then we load the procedure into the Tcl interpreter.
************************************************************/ ************************************************************/
Tcl_DStringInit(&proc_internal_def); Tcl_DStringInit(&proc_internal_def);
Tcl_DStringInit(&proc_internal_name);
Tcl_DStringInit(&proc_internal_body); Tcl_DStringInit(&proc_internal_body);
PG_TRY(); PG_TRY();
{ {
bool is_trigger = OidIsValid(tgreloid); bool is_trigger = OidIsValid(tgreloid);
char internal_proname[128]; Tcl_CmdInfo cmdinfo;
const char *user_proname;
const char *internal_proname;
bool need_underscore;
HeapTuple typeTup; HeapTuple typeTup;
Form_pg_type typeStruct; Form_pg_type typeStruct;
char proc_internal_args[33 * FUNC_MAX_ARGS]; char proc_internal_args[33 * FUNC_MAX_ARGS];
Datum prosrcdatum; Datum prosrcdatum;
char *proc_source; char *proc_source;
char buf[48]; char buf[48];
pltcl_interp_desc *interp_desc;
Tcl_Interp *interp; Tcl_Interp *interp;
int i; int i;
int tcl_rc; int tcl_rc;
MemoryContext oldcontext; MemoryContext oldcontext;
/************************************************************ /************************************************************
* Build our internal proc name from the function's Oid. Append * Identify the interpreter to use for the function
* "_trigger" when appropriate to ensure the normal and trigger
* cases are kept separate. Note name must be all-ASCII.
************************************************************/ ************************************************************/
interp_desc = pltcl_fetch_interp(procStruct->prolang, pltrusted);
interp = interp_desc->interp;
/************************************************************
* If redefining the function, try to remove the old internal
* procedure from Tcl's namespace. The point of this is partly to
* allow re-use of the same internal proc name, and partly to avoid
* leaking the Tcl procedure object if we end up not choosing the same
* name. We assume that Tcl is smart enough to not physically delete
* the procedure object if it's currently being executed.
************************************************************/
if (prodesc != NULL &&
prodesc->internal_proname != NULL)
{
/* We simply ignore any error */
(void) Tcl_DeleteCommand(interp, prodesc->internal_proname);
/* Don't do this more than once */
prodesc->internal_proname = NULL;
}
/************************************************************
* Build the proc name we'll use in error messages.
************************************************************/
user_proname = format_procedure(fn_oid);
/************************************************************
* Build the internal proc name from the user_proname and/or OID.
* The internal name must be all-ASCII since we don't want to deal
* with encoding conversions. We don't want to worry about Tcl
* quoting rules either, so use only the characters of the function
* name that are ASCII alphanumerics, plus underscores to separate
* function name and arguments. If what we end up with isn't
* unique (that is, it matches some existing Tcl command name),
* append the function OID (perhaps repeatedly) so that it is unique.
************************************************************/
/* For historical reasons, use a function-type-specific prefix */
if (is_event_trigger) if (is_event_trigger)
snprintf(internal_proname, sizeof(internal_proname), Tcl_DStringAppend(&proc_internal_name,
"__PLTcl_proc_%u_evttrigger", fn_oid); "__PLTcl_evttrigger_", -1);
else if (is_trigger) else if (is_trigger)
snprintf(internal_proname, sizeof(internal_proname), Tcl_DStringAppend(&proc_internal_name,
"__PLTcl_proc_%u_trigger", fn_oid); "__PLTcl_trigger_", -1);
else else
snprintf(internal_proname, sizeof(internal_proname), Tcl_DStringAppend(&proc_internal_name,
"__PLTcl_proc_%u", fn_oid); "__PLTcl_proc_", -1);
/* Now add what we can from the user_proname */
need_underscore = false;
for (const char *ptr = user_proname; *ptr; ptr++)
{
if (strchr("ABCDEFGHIJKLMNOPQRSTUVWXYZ"
"abcdefghijklmnopqrstuvwxyz"
"0123456789_", *ptr) != NULL)
{
/* Done this way to avoid adding a trailing underscore */
if (need_underscore)
{
Tcl_DStringAppend(&proc_internal_name, "_", 1);
need_underscore = false;
}
Tcl_DStringAppend(&proc_internal_name, ptr, 1);
}
else if (strchr("(, ", *ptr) != NULL)
need_underscore = true;
}
/* If this name already exists, append fn_oid; repeat as needed */
while (Tcl_GetCommandInfo(interp,
Tcl_DStringValue(&proc_internal_name),
&cmdinfo))
{
snprintf(buf, sizeof(buf), "_%u", fn_oid);
Tcl_DStringAppend(&proc_internal_name, buf, -1);
}
internal_proname = Tcl_DStringValue(&proc_internal_name);
/************************************************************ /************************************************************
* Allocate a context that will hold all PG data for the procedure. * Allocate a context that will hold all PG data for the procedure.
@ -1496,7 +1584,7 @@ compile_pltcl_function(Oid fn_oid, Oid tgreloid,
************************************************************/ ************************************************************/
oldcontext = MemoryContextSwitchTo(proc_cxt); oldcontext = MemoryContextSwitchTo(proc_cxt);
prodesc = (pltcl_proc_desc *) palloc0(sizeof(pltcl_proc_desc)); prodesc = (pltcl_proc_desc *) palloc0(sizeof(pltcl_proc_desc));
prodesc->user_proname = pstrdup(NameStr(procStruct->proname)); prodesc->user_proname = pstrdup(user_proname);
MemoryContextSetIdentifier(proc_cxt, prodesc->user_proname); MemoryContextSetIdentifier(proc_cxt, prodesc->user_proname);
prodesc->internal_proname = pstrdup(internal_proname); prodesc->internal_proname = pstrdup(internal_proname);
prodesc->fn_cxt = proc_cxt; prodesc->fn_cxt = proc_cxt;
@ -1513,13 +1601,8 @@ compile_pltcl_function(Oid fn_oid, Oid tgreloid,
(procStruct->provolatile != PROVOLATILE_VOLATILE); (procStruct->provolatile != PROVOLATILE_VOLATILE);
/* And whether it is trusted */ /* And whether it is trusted */
prodesc->lanpltrusted = pltrusted; prodesc->lanpltrusted = pltrusted;
/* Save the associated interpreter, too */
/************************************************************ prodesc->interp_desc = interp_desc;
* Identify the interpreter to use for the function
************************************************************/
prodesc->interp_desc = pltcl_fetch_interp(procStruct->prolang,
prodesc->lanpltrusted);
interp = prodesc->interp_desc->interp;
/************************************************************ /************************************************************
* Get the required information for input conversion of the * Get the required information for input conversion of the
@ -1712,6 +1795,7 @@ compile_pltcl_function(Oid fn_oid, Oid tgreloid,
if (proc_cxt) if (proc_cxt)
MemoryContextDelete(proc_cxt); MemoryContextDelete(proc_cxt);
Tcl_DStringFree(&proc_internal_def); Tcl_DStringFree(&proc_internal_def);
Tcl_DStringFree(&proc_internal_name);
Tcl_DStringFree(&proc_internal_body); Tcl_DStringFree(&proc_internal_body);
PG_RE_THROW(); PG_RE_THROW();
} }
@ -1740,6 +1824,7 @@ compile_pltcl_function(Oid fn_oid, Oid tgreloid,
} }
Tcl_DStringFree(&proc_internal_def); Tcl_DStringFree(&proc_internal_def);
Tcl_DStringFree(&proc_internal_name);
Tcl_DStringFree(&proc_internal_body); Tcl_DStringFree(&proc_internal_body);
ReleaseSysCache(procTup); ReleaseSysCache(procTup);

38
src/pl/tcl/sql/pltcl_queries.sql
View File

@ -1,6 +1,3 @@
-- suppress CONTEXT so that function OIDs aren't in output
\set VERBOSITY terse
-- Test composite-type arguments -- Test composite-type arguments
select tcl_composite_arg_ref1(row('tkey', 42, 'ref2')); select tcl_composite_arg_ref1(row('tkey', 42, 'ref2'));
select tcl_composite_arg_ref2(row('tkey', 42, 'ref2')); select tcl_composite_arg_ref2(row('tkey', 42, 'ref2'));
@ -31,7 +28,7 @@ select tcl_argisnull('');
select tcl_argisnull(null); select tcl_argisnull(null);
-- test some error cases -- test some error cases
create function tcl_error(out a int, out b int) as $$return {$$ language pltcl; create function tcl_error(out a int, out b int) as $$returm 1$$ language pltcl;
select tcl_error(); select tcl_error();
create function bad_record(out a text, out b text) as $$return [list a]$$ language pltcl; create function bad_record(out a text, out b text) as $$return [list a]$$ language pltcl;
@ -157,6 +154,39 @@ select tcl_spi_exec(false, 'continue');
select tcl_spi_exec(false, 'error'); select tcl_spi_exec(false, 'error');
select tcl_spi_exec(false, 'return'); select tcl_spi_exec(false, 'return');
-- test that we don't get confused by multiple funcs with same SQL name
create schema tcls1;
create function tcls1.somefunc(int) returns int as $$
return [expr $1 * 2]
$$ language pltcl;
create schema tcls2;
create function tcls2.somefunc(int) returns int as $$
return [expr $1 * 3]
$$ language pltcl;
set search_path = tcls1;
select tcls1.somefunc(11);
set search_path = tcls2;
select tcls2.somefunc(12);
set search_path = tcls1;
select tcls1.somefunc(13);
reset search_path;
-- test that it works to replace a function that's being executed
create function replaceme(text) returns text as $p$
spi_exec {
create or replace function replaceme(text) returns text as $$
return "$1 fum"
$$ language pltcl;
}
spi_exec {select replaceme('foe') as inner}
return "fee $1 $inner"
$p$ language pltcl;
select replaceme('fie');
select replaceme('fie');
-- forcibly run the Tcl event loop for awhile, to check that we have not -- forcibly run the Tcl event loop for awhile, to check that we have not
-- messed things up too badly by disabling the Tcl notifier subsystem -- messed things up too badly by disabling the Tcl notifier subsystem
select tcl_eval($$ select tcl_eval($$

3
src/pl/tcl/sql/pltcl_transaction.sql
View File

@ -1,6 +1,3 @@
-- suppress CONTEXT so that function OIDs aren't in output
\set VERBOSITY terse
CREATE TABLE test1 (a int, b text); CREATE TABLE test1 (a int, b text);

2
src/pl/tcl/sql/pltcl_trigger.sql
View File

@ -1,4 +1,4 @@
-- suppress CONTEXT so that function OIDs aren't in output -- suppress CONTEXT so that table OIDs aren't in output
\set VERBOSITY terse \set VERBOSITY terse
-- --