open-dsi
/
postgres
mirror of https://github.com/postgres/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
pull/166/head
Tom Lane 2 years ago
parent aaab3ee9c6
commit ba8f00eef6
8 changed files with 520 additions and 46 deletions
Show all changes Ignore whitespace when comparing lines Ignore changes in amount of whitespace Ignore changes in whitespace at EOL
Show Stats Download Patch File Download Diff File
  1. 17
      doc/src/sgml/pltcl.sgml
  2. 320
      src/pl/tcl/expected/pltcl_queries.out
  3. 47
      src/pl/tcl/expected/pltcl_transaction.out
  4. 2
      src/pl/tcl/expected/pltcl_trigger.out
  5. 137
      src/pl/tcl/pltcl.c
  6. 38
      src/pl/tcl/sql/pltcl_queries.sql
  7. 3
      src/pl/tcl/sql/pltcl_transaction.sql
  8. 2
      src/pl/tcl/sql/pltcl_trigger.sql

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

@ -1120,16 +1120,25 @@ CALL transaction_test1();
<para>
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.
PL/Tcl deals with this by making the internal Tcl procedure names contain
the object
ID of the function from the system table <structname>pg_proc</structname> as part of their name. Thus,
PL/Tcl deals with this by including the argument type names in the
internal Tcl procedure name, and then appending the function's object
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
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
when debugging.
</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>
</chapter>

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

@ -1,5 +1,3 @@
-- suppress CONTEXT so that function OIDs aren't in output
\set VERBOSITY terse
-- Test composite-type arguments
select tcl_composite_arg_ref1(row('tkey', 42, 'ref2'));
tcl_composite_arg_ref1
@ -73,9 +71,15 @@ select tcl_argisnull(null);
(1 row)
-- 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();
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;
select bad_record();
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;
select non_srf();
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 $$
return_next [list a]
$$ language pltcl;
select bad_record_srf();
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 $$
return_next [list a 1 b 2 cow 3]
$$ language pltcl;
select bad_field_srf();
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
create function tcl_composite_result(int) returns T_comp1 as $$
return [list tkey tkey1 ref1 $1 ref2 ref22]
@ -172,7 +194,9 @@ $$ language pltcl;
select tcl_record_result(42); -- fail
ERROR: function returning record called in context that cannot accept type record
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);
q1 | q2 | q3
----------+----+----------
@ -190,6 +214,15 @@ ERROR: column name/value list contains nonexistent column name "q3"
-- test quote
select tcl_eval('quote foo bar');
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]');
tcl_eval
----------
@ -205,46 +238,217 @@ select tcl_eval('quote [format %c 92]');
-- Test argisnull
select tcl_eval('argisnull');
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');
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');
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
select tcl_eval('return_null 14');
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
select tcl_eval('spi_exec');
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');
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');
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');
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');
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;"');
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
select tcl_eval('spi_execp');
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');
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');
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');
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');
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 ""');
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
select tcl_eval('spi_prepare');
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');
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 {"');
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$);
tcl_error_handling_test
--------------------------------------
@ -307,11 +511,38 @@ select tcl_error_handling_test('moo');
-- test elog
select tcl_eval('elog');
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');
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
select tcl_eval('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]
select tcl_spi_exec(true, 'break');
NOTICE: col1 1, col2 foo
@ -339,6 +570,19 @@ NOTICE: col1 1, col2 foo
NOTICE: col1 2, col2 bar
NOTICE: action: error
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');
NOTICE: col1 1, col2 foo
NOTICE: col1 2, col2 bar
@ -374,6 +618,19 @@ NOTICE: col1 1, col2 foo
NOTICE: col1 2, col2 bar
NOTICE: action: error
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');
NOTICE: col1 1, col2 foo
NOTICE: col1 2, col2 bar
@ -383,6 +640,59 @@ NOTICE: action: return
(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
-- messed things up too badly by disabling the Tcl notifier subsystem
select tcl_eval($$

47
src/pl/tcl/expected/pltcl_transaction.out
Unescape 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 PROCEDURE transaction_test1()
LANGUAGE pltcl
@ -41,6 +39,12 @@ return 1
$$;
SELECT transaction_test2();
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;
a | b
---+---
@ -55,6 +59,17 @@ return 1
$$;
SELECT transaction_test3();
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;
a | b
---+---
@ -74,6 +89,17 @@ spi_exec -array row "SELECT * FROM test2 ORDER BY x" {
$$;
CALL transaction_test4a();
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;
a | b
---+---
@ -91,6 +117,17 @@ spi_exec -array row "SELECT * FROM test2 ORDER BY x" {
$$;
CALL transaction_test4b();
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;
a | b
---+---
@ -109,6 +146,12 @@ elog WARNING "should not get here"
$$;
CALL transaction_testfk();
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;
id
----

2
src/pl/tcl/expected/pltcl_trigger.out
Unescape 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
--
-- Create the tables used in the test queries

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

@ -124,19 +124,21 @@ typedef struct pltcl_interp_desc
* The pltcl_proc_desc struct itself, as well as all subsidiary data,
* 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
* when the fn_refcount goes to zero. (But note that we do not bother
* trying to clean up Tcl's copy of the procedure definition: it's Tcl's
* problem to manage its memory when we replace a proc definition. We do
* not clean up pltcl_proc_descs when a pg_proc row is deleted, only when
* it is updated, and the same policy applies to Tcl's copy as well.)
* when the fn_refcount goes to zero. That will happen if we build a new
* pltcl_proc_desc following an update of the pg_proc row. If that happens
* while the old proc is being executed, we mustn't remove the struct until
* execution finishes. When building a new pltcl_proc_desc, we unlink
* 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;
* nothing except the fn_refcount should be changed by a call instance.
**********************************************************************/
typedef struct pltcl_proc_desc
{
char *user_proname; /* user's name (from pg_proc.proname) */
char *internal_proname; /* Tcl name (based on function OID) */
char *user_proname; /* user's name (from format_procedure) */
char *internal_proname; /* Tcl proc name (NULL if deleted) */
MemoryContext fn_cxt; /* memory context for this procedure */
unsigned long fn_refcount; /* number of active references */
TransactionId fn_xmin; /* xmin of pg_proc row */
@ -1375,13 +1377,29 @@ throw_tcl_error(Tcl_Interp *interp, const char *proname)
*/
char *emsg;
char *econtext;
int emsglen;
emsg = pstrdup(utf_u2e(Tcl_GetStringResult(interp)));
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,
(errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION),
errmsg("%s", emsg),
errcontext("%s\nin PL/Tcl function \"%s\"",
errcontext("%s\nin PL/Tcl function %s",
econtext, proname)));
}
@ -1405,6 +1423,7 @@ compile_pltcl_function(Oid fn_oid, Oid tgreloid,
pltcl_proc_desc *old_prodesc;
volatile MemoryContext proc_cxt = NULL;
Tcl_DString proc_internal_def;
Tcl_DString proc_internal_name;
Tcl_DString proc_internal_body;
/* 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.
************************************************************/
if (prodesc != NULL &&
prodesc->internal_proname != NULL &&
prodesc->fn_xmin == HeapTupleHeaderGetRawXmin(procTup->t_data) &&
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.
************************************************************/
Tcl_DStringInit(&proc_internal_def);
Tcl_DStringInit(&proc_internal_name);
Tcl_DStringInit(&proc_internal_body);
PG_TRY();
{
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;
Form_pg_type typeStruct;
char proc_internal_args[33 * FUNC_MAX_ARGS];
Datum prosrcdatum;
char *proc_source;
char buf[48];
pltcl_interp_desc *interp_desc;
Tcl_Interp *interp;
int i;
int tcl_rc;
MemoryContext oldcontext;
/************************************************************
* Build our internal proc name from the function's Oid. Append
* "_trigger" when appropriate to ensure the normal and trigger
* cases are kept separate. Note name must be all-ASCII.
* Identify the interpreter to use for the function
************************************************************/
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)
snprintf(internal_proname, sizeof(internal_proname),
"__PLTcl_proc_%u_evttrigger", fn_oid);
Tcl_DStringAppend(&proc_internal_name,
"__PLTcl_evttrigger_", -1);
else if (is_trigger)
snprintf(internal_proname, sizeof(internal_proname),
"__PLTcl_proc_%u_trigger", fn_oid);
Tcl_DStringAppend(&proc_internal_name,
"__PLTcl_trigger_", -1);
else
snprintf(internal_proname, sizeof(internal_proname),
"__PLTcl_proc_%u", fn_oid);
Tcl_DStringAppend(&proc_internal_name,
"__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.
@ -1496,7 +1584,7 @@ compile_pltcl_function(Oid fn_oid, Oid tgreloid,
************************************************************/
oldcontext = MemoryContextSwitchTo(proc_cxt);
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);
prodesc->internal_proname = pstrdup(internal_proname);
prodesc->fn_cxt = proc_cxt;
@ -1513,13 +1601,8 @@ compile_pltcl_function(Oid fn_oid, Oid tgreloid,
(procStruct->provolatile != PROVOLATILE_VOLATILE);
/* And whether it is trusted */
prodesc->lanpltrusted = pltrusted;
/************************************************************
* Identify the interpreter to use for the function
************************************************************/
prodesc->interp_desc = pltcl_fetch_interp(procStruct->prolang,
prodesc->lanpltrusted);
interp = prodesc->interp_desc->interp;
/* Save the associated interpreter, too */
prodesc->interp_desc = interp_desc;
/************************************************************
* Get the required information for input conversion of the
@ -1712,6 +1795,7 @@ compile_pltcl_function(Oid fn_oid, Oid tgreloid,
if (proc_cxt)
MemoryContextDelete(proc_cxt);
Tcl_DStringFree(&proc_internal_def);
Tcl_DStringFree(&proc_internal_name);
Tcl_DStringFree(&proc_internal_body);
PG_RE_THROW();
}
@ -1740,6 +1824,7 @@ compile_pltcl_function(Oid fn_oid, Oid tgreloid,
}
Tcl_DStringFree(&proc_internal_def);
Tcl_DStringFree(&proc_internal_name);
Tcl_DStringFree(&proc_internal_body);
ReleaseSysCache(procTup);

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

@ -1,6 +1,3 @@
-- suppress CONTEXT so that function OIDs aren't in output
\set VERBOSITY terse
-- Test composite-type arguments
select tcl_composite_arg_ref1(row('tkey', 42, 'ref2'));
select tcl_composite_arg_ref2(row('tkey', 42, 'ref2'));
@ -31,7 +28,7 @@ select tcl_argisnull('');
select tcl_argisnull(null);
-- 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();
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, '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
-- messed things up too badly by disabling the Tcl notifier subsystem
select tcl_eval($$

3
src/pl/tcl/sql/pltcl_transaction.sql
Unescape 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);

2
src/pl/tcl/sql/pltcl_trigger.sql
Unescape 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
--

Write Preview
Loading…
Cancel
Save