aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--doc/src/sgml/pltcl.sgml17
-rw-r--r--src/pl/tcl/expected/pltcl_queries.out320
-rw-r--r--src/pl/tcl/expected/pltcl_transaction.out47
-rw-r--r--src/pl/tcl/expected/pltcl_trigger.out2
-rw-r--r--src/pl/tcl/pltcl.c137
-rw-r--r--src/pl/tcl/sql/pltcl_queries.sql38
-rw-r--r--src/pl/tcl/sql/pltcl_transaction.sql3
-rw-r--r--src/pl/tcl/sql/pltcl_trigger.sql2
8 files changed, 520 insertions, 46 deletions
diff --git a/doc/src/sgml/pltcl.sgml b/doc/src/sgml/pltcl.sgml
index b31f2c1330f..5a8e4c9d37e 100644
--- a/doc/src/sgml/pltcl.sgml
+++ b/doc/src/sgml/pltcl.sgml
@@ -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>
diff --git a/src/pl/tcl/expected/pltcl_queries.out b/src/pl/tcl/expected/pltcl_queries.out
index 2d922c2333e..35cc6e62aad 100644
--- a/src/pl/tcl/expected/pltcl_queries.out
+++ b/src/pl/tcl/expected/pltcl_queries.out
@@ -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($$
diff --git a/src/pl/tcl/expected/pltcl_transaction.out b/src/pl/tcl/expected/pltcl_transaction.out
index f557b791386..cf71b58d483 100644
--- a/src/pl/tcl/expected/pltcl_transaction.out
+++ b/src/pl/tcl/expected/pltcl_transaction.out
@@ -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
----
diff --git a/src/pl/tcl/expected/pltcl_trigger.out b/src/pl/tcl/expected/pltcl_trigger.out
index 008ea195095..129abd5ba67 100644
--- a/src/pl/tcl/expected/pltcl_trigger.out
+++ b/src/pl/tcl/expected/pltcl_trigger.out
@@ -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
diff --git a/src/pl/tcl/pltcl.c b/src/pl/tcl/pltcl.c
index 5b9c030c8d8..21b2b045933 100644
--- a/src/pl/tcl/pltcl.c
+++ b/src/pl/tcl/pltcl.c
@@ -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);
diff --git a/src/pl/tcl/sql/pltcl_queries.sql b/src/pl/tcl/sql/pltcl_queries.sql
index bbd2d979992..4f49b81ada8 100644
--- a/src/pl/tcl/sql/pltcl_queries.sql
+++ b/src/pl/tcl/sql/pltcl_queries.sql
@@ -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($$
diff --git a/src/pl/tcl/sql/pltcl_transaction.sql b/src/pl/tcl/sql/pltcl_transaction.sql
index bd759850a70..0784b7cd9fe 100644
--- a/src/pl/tcl/sql/pltcl_transaction.sql
+++ b/src/pl/tcl/sql/pltcl_transaction.sql
@@ -1,6 +1,3 @@
--- suppress CONTEXT so that function OIDs aren't in output
-\set VERBOSITY terse
-
CREATE TABLE test1 (a int, b text);
diff --git a/src/pl/tcl/sql/pltcl_trigger.sql b/src/pl/tcl/sql/pltcl_trigger.sql
index 2db75a333a0..2a244de83bc 100644
--- a/src/pl/tcl/sql/pltcl_trigger.sql
+++ b/src/pl/tcl/sql/pltcl_trigger.sql
@@ -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
--
generated by cgit v1.2.3 (git 2.25.1) at 2025-05-31 13:40:00 +0000