summaryrefslogtreecommitdiffstats
path: root/src/pl/tcl
diff options
context:
space:
mode:
Diffstat (limited to 'src/pl/tcl')
-rw-r--r--src/pl/tcl/.gitignore6
-rw-r--r--src/pl/tcl/Makefile103
-rw-r--r--src/pl/tcl/expected/pltcl_call.out72
-rw-r--r--src/pl/tcl/expected/pltcl_queries.out397
-rw-r--r--src/pl/tcl/expected/pltcl_setup.out263
-rw-r--r--src/pl/tcl/expected/pltcl_start_proc.out31
-rw-r--r--src/pl/tcl/expected/pltcl_subxact.out143
-rw-r--r--src/pl/tcl/expected/pltcl_transaction.out149
-rw-r--r--src/pl/tcl/expected/pltcl_trigger.out888
-rw-r--r--src/pl/tcl/expected/pltcl_unicode.out45
-rw-r--r--src/pl/tcl/generate-pltclerrcodes.pl40
-rw-r--r--src/pl/tcl/meson.build64
-rw-r--r--src/pl/tcl/nls.mk5
-rw-r--r--src/pl/tcl/pltcl--1.0.sql12
-rw-r--r--src/pl/tcl/pltcl.c3288
-rw-r--r--src/pl/tcl/pltcl.control8
-rw-r--r--src/pl/tcl/pltclerrcodes.h998
-rw-r--r--src/pl/tcl/pltclu--1.0.sql9
-rw-r--r--src/pl/tcl/pltclu.control7
-rw-r--r--src/pl/tcl/po/LINGUAS1
-rw-r--r--src/pl/tcl/po/cs.po117
-rw-r--r--src/pl/tcl/po/de.po115
-rw-r--r--src/pl/tcl/po/el.po118
-rw-r--r--src/pl/tcl/po/es.po119
-rw-r--r--src/pl/tcl/po/fr.po140
-rw-r--r--src/pl/tcl/po/it.po127
-rw-r--r--src/pl/tcl/po/ja.po117
-rw-r--r--src/pl/tcl/po/ka.po117
-rw-r--r--src/pl/tcl/po/ko.po118
-rw-r--r--src/pl/tcl/po/meson.build3
-rw-r--r--src/pl/tcl/po/pl.po136
-rw-r--r--src/pl/tcl/po/pt_BR.po117
-rw-r--r--src/pl/tcl/po/ro.po56
-rw-r--r--src/pl/tcl/po/ru.po135
-rw-r--r--src/pl/tcl/po/sv.po116
-rw-r--r--src/pl/tcl/po/tr.po117
-rw-r--r--src/pl/tcl/po/uk.po115
-rw-r--r--src/pl/tcl/po/vi.po107
-rw-r--r--src/pl/tcl/po/zh_CN.po111
-rw-r--r--src/pl/tcl/po/zh_TW.po135
-rw-r--r--src/pl/tcl/sql/pltcl_call.sql78
-rw-r--r--src/pl/tcl/sql/pltcl_queries.sql166
-rw-r--r--src/pl/tcl/sql/pltcl_setup.sql278
-rw-r--r--src/pl/tcl/sql/pltcl_start_proc.sql21
-rw-r--r--src/pl/tcl/sql/pltcl_subxact.sql95
-rw-r--r--src/pl/tcl/sql/pltcl_transaction.sql135
-rw-r--r--src/pl/tcl/sql/pltcl_trigger.sql603
-rw-r--r--src/pl/tcl/sql/pltcl_unicode.sql38
48 files changed, 10179 insertions, 0 deletions
diff --git a/src/pl/tcl/.gitignore b/src/pl/tcl/.gitignore
new file mode 100644
index 0000000..62b62eb
--- /dev/null
+++ b/src/pl/tcl/.gitignore
@@ -0,0 +1,6 @@
+/pltclerrcodes.h
+
+# Generated subdirectories
+/log/
+/results/
+/tmp_check/
diff --git a/src/pl/tcl/Makefile b/src/pl/tcl/Makefile
new file mode 100644
index 0000000..314f9b2
--- /dev/null
+++ b/src/pl/tcl/Makefile
@@ -0,0 +1,103 @@
+#-------------------------------------------------------------------------
+#
+# Makefile for the PL/Tcl procedural language
+#
+# src/pl/tcl/Makefile
+#
+#-------------------------------------------------------------------------
+
+subdir = src/pl/tcl
+top_builddir = ../../..
+include $(top_builddir)/src/Makefile.global
+
+
+override CPPFLAGS := -I. -I$(srcdir) $(TCL_INCLUDE_SPEC) $(CPPFLAGS)
+
+# On Windows, we don't link directly with the Tcl library; see below
+ifneq ($(PORTNAME), win32)
+SHLIB_LINK = $(TCL_LIB_SPEC) $(TCL_LIBS)
+endif
+
+PGFILEDESC = "PL/Tcl - procedural language"
+
+NAME = pltcl
+
+OBJS = \
+ $(WIN32RES) \
+ pltcl.o
+
+DATA = pltcl.control pltcl--1.0.sql \
+ pltclu.control pltclu--1.0.sql
+
+REGRESS_OPTS = --dbname=$(PL_TESTDB) --load-extension=pltcl
+REGRESS = pltcl_setup pltcl_queries pltcl_trigger pltcl_call pltcl_start_proc pltcl_subxact pltcl_unicode pltcl_transaction
+
+# Tcl on win32 ships with import libraries only for Microsoft Visual C++,
+# which are not compatible with mingw gcc. Therefore we need to build a
+# new import library to link with.
+ifeq ($(PORTNAME), win32)
+
+tclwithver = $(subst -l,,$(filter -l%, $(TCL_LIB_SPEC)))
+TCLDLL = $(dir $(TCLSH))/$(tclwithver).dll
+
+OBJS += lib$(tclwithver).a
+
+lib$(tclwithver).a: $(tclwithver).def
+ dlltool --dllname $(tclwithver).dll --def $(tclwithver).def --output-lib lib$(tclwithver).a
+
+$(tclwithver).def: $(TCLDLL)
+ gendef - $^ > $@
+
+endif # win32
+
+
+include $(top_srcdir)/src/Makefile.shlib
+
+
+all: all-lib
+
+# Force this dependency to be known even without dependency info built:
+pltcl.o: pltclerrcodes.h
+
+# generate pltclerrcodes.h from src/backend/utils/errcodes.txt
+pltclerrcodes.h: $(top_srcdir)/src/backend/utils/errcodes.txt generate-pltclerrcodes.pl
+ $(PERL) $(srcdir)/generate-pltclerrcodes.pl $< > $@
+
+distprep: pltclerrcodes.h
+
+install: all install-lib install-data
+
+installdirs: installdirs-lib
+ $(MKDIR_P) '$(DESTDIR)$(datadir)/extension'
+
+uninstall: uninstall-lib uninstall-data
+
+install-data: installdirs
+ $(INSTALL_DATA) $(addprefix $(srcdir)/, $(DATA)) '$(DESTDIR)$(datadir)/extension/'
+
+uninstall-data:
+ rm -f $(addprefix '$(DESTDIR)$(datadir)/extension'/, $(notdir $(DATA)))
+
+.PHONY: install-data uninstall-data
+
+
+check: submake
+ $(pg_regress_check) $(REGRESS_OPTS) $(REGRESS)
+
+installcheck: submake
+ $(pg_regress_installcheck) $(REGRESS_OPTS) $(REGRESS)
+
+.PHONY: submake
+submake:
+ $(MAKE) -C $(top_builddir)/src/test/regress pg_regress$(X)
+
+# pltclerrcodes.h is in the distribution tarball, so don't clean it here.
+clean distclean: clean-lib
+ rm -f $(OBJS)
+ rm -rf $(pg_regress_clean_files)
+ifeq ($(PORTNAME), win32)
+ rm -f $(tclwithver).def
+endif
+
+maintainer-clean: distclean
+ rm -f pltclerrcodes.h
diff --git a/src/pl/tcl/expected/pltcl_call.out b/src/pl/tcl/expected/pltcl_call.out
new file mode 100644
index 0000000..e449837
--- /dev/null
+++ b/src/pl/tcl/expected/pltcl_call.out
@@ -0,0 +1,72 @@
+CREATE PROCEDURE test_proc1()
+LANGUAGE pltcl
+AS $$
+unset
+$$;
+CALL test_proc1();
+CREATE PROCEDURE test_proc2()
+LANGUAGE pltcl
+AS $$
+return 5
+$$;
+CALL test_proc2();
+CREATE TABLE test1 (a int);
+CREATE PROCEDURE test_proc3(x int)
+LANGUAGE pltcl
+AS $$
+spi_exec "INSERT INTO test1 VALUES ($1)"
+$$;
+CALL test_proc3(55);
+SELECT * FROM test1;
+ a
+----
+ 55
+(1 row)
+
+-- output arguments
+CREATE PROCEDURE test_proc5(INOUT a text)
+LANGUAGE pltcl
+AS $$
+set aa [concat $1 "+" $1]
+return [list a $aa]
+$$;
+CALL test_proc5('abc');
+ a
+-----------
+ abc + abc
+(1 row)
+
+CREATE PROCEDURE test_proc6(a int, INOUT b int, INOUT c int)
+LANGUAGE pltcl
+AS $$
+set bb [expr $2 * $1]
+set cc [expr $3 * $1]
+return [list b $bb c $cc]
+$$;
+CALL test_proc6(2, 3, 4);
+ b | c
+---+---
+ 6 | 8
+(1 row)
+
+-- OUT parameters
+CREATE PROCEDURE test_proc9(IN a int, OUT b int)
+LANGUAGE pltcl
+AS $$
+elog NOTICE "a: $1"
+return [list b [expr {$1 * 2}]]
+$$;
+DO $$
+DECLARE _a int; _b int;
+BEGIN
+ _a := 10; _b := 30;
+ CALL test_proc9(_a, _b);
+ RAISE NOTICE '_a: %, _b: %', _a, _b;
+END
+$$;
+NOTICE: a: 10
+NOTICE: _a: 10, _b: 20
+DROP PROCEDURE test_proc1;
+DROP PROCEDURE test_proc2;
+DROP PROCEDURE test_proc3;
+DROP TABLE test1;
diff --git a/src/pl/tcl/expected/pltcl_queries.out b/src/pl/tcl/expected/pltcl_queries.out
new file mode 100644
index 0000000..2d922c2
--- /dev/null
+++ b/src/pl/tcl/expected/pltcl_queries.out
@@ -0,0 +1,397 @@
+-- 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
+------------------------
+ 42
+(1 row)
+
+select tcl_composite_arg_ref2(row('tkey', 42, 'ref2'));
+ tcl_composite_arg_ref2
+------------------------
+ ref2
+(1 row)
+
+-- More tests for composite argument/result types
+create domain d_comp1 as T_comp1 check ((value).ref1 > 0);
+create function tcl_record_arg(record, fldname text) returns int as '
+ return $1($2)
+' language pltcl;
+select tcl_record_arg(row('tkey', 42, 'ref2')::T_comp1, 'ref1');
+ tcl_record_arg
+----------------
+ 42
+(1 row)
+
+select tcl_record_arg(row('tkey', 42, 'ref2')::d_comp1, 'ref1');
+ tcl_record_arg
+----------------
+ 42
+(1 row)
+
+select tcl_record_arg(row(2,4), 'f2');
+ tcl_record_arg
+----------------
+ 4
+(1 row)
+
+create function tcl_cdomain_arg(d_comp1) returns int as '
+ return $1(ref1)
+' language pltcl;
+select tcl_cdomain_arg(row('tkey', 42, 'ref2'));
+ tcl_cdomain_arg
+-----------------
+ 42
+(1 row)
+
+select tcl_cdomain_arg(row('tkey', 42, 'ref2')::T_comp1);
+ tcl_cdomain_arg
+-----------------
+ 42
+(1 row)
+
+select tcl_cdomain_arg(row('tkey', -1, 'ref2')); -- fail
+ERROR: value for domain d_comp1 violates check constraint "d_comp1_check"
+-- Test argisnull primitive
+select tcl_argisnull('foo');
+ tcl_argisnull
+---------------
+ f
+(1 row)
+
+select tcl_argisnull('');
+ tcl_argisnull
+---------------
+ f
+(1 row)
+
+select tcl_argisnull(null);
+ tcl_argisnull
+---------------
+ t
+(1 row)
+
+-- test some error cases
+create function tcl_error(out a int, out b int) as $$return {$$ language pltcl;
+select tcl_error();
+ERROR: missing close-brace
+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
+create function bad_field(out a text, out b text) as $$return [list a 1 b 2 cow 3]$$ language pltcl;
+select bad_field();
+ERROR: column name/value list contains nonexistent column name "cow"
+-- test compound return
+select * from tcl_test_cube_squared(5);
+ squared | cubed
+---------+-------
+ 25 | 125
+(1 row)
+
+-- test SRF
+select * from tcl_test_squared_rows(0,5);
+ x | y
+---+----
+ 0 | 0
+ 1 | 1
+ 2 | 4
+ 3 | 9
+ 4 | 16
+(5 rows)
+
+select * from tcl_test_sequence(0,5) as a;
+ a
+---
+ 0
+ 1
+ 2
+ 3
+ 4
+(5 rows)
+
+select 1, tcl_test_sequence(0,5);
+ ?column? | tcl_test_sequence
+----------+-------------------
+ 1 | 0
+ 1 | 1
+ 1 | 2
+ 1 | 3
+ 1 | 4
+(5 rows)
+
+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
+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
+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"
+-- 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]
+$$ language pltcl;
+select tcl_composite_result(1001);
+ tcl_composite_result
+--------------------------------------------
+ ("tkey1 ",1001,"ref22 ")
+(1 row)
+
+select * from tcl_composite_result(1002);
+ tkey | ref1 | ref2
+------------+------+----------------------
+ tkey1 | 1002 | ref22
+(1 row)
+
+create function tcl_dcomposite_result(int) returns d_comp1 as $$
+return [list tkey tkey2 ref1 $1 ref2 ref42]
+$$ language pltcl;
+select tcl_dcomposite_result(1001);
+ tcl_dcomposite_result
+--------------------------------------------
+ ("tkey2 ",1001,"ref42 ")
+(1 row)
+
+select * from tcl_dcomposite_result(1002);
+ tkey | ref1 | ref2
+------------+------+----------------------
+ tkey2 | 1002 | ref42
+(1 row)
+
+select * from tcl_dcomposite_result(-1); -- fail
+ERROR: value for domain d_comp1 violates check constraint "d_comp1_check"
+create function tcl_record_result(int) returns record as $$
+return [list q1 sometext q2 $1 q3 moretext]
+$$ 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
+select * from tcl_record_result(42) as (q1 text, q2 int, q3 text);
+ q1 | q2 | q3
+----------+----+----------
+ sometext | 42 | moretext
+(1 row)
+
+select * from tcl_record_result(42) as (q1 text, q2 int, q3 text, q4 int);
+ q1 | q2 | q3 | q4
+----------+----+----------+----
+ sometext | 42 | moretext |
+(1 row)
+
+select * from tcl_record_result(42) as (q1 text, q2 int, q4 int); -- fail
+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"
+select tcl_eval('quote [format %c 39]');
+ tcl_eval
+----------
+ ''
+(1 row)
+
+select tcl_eval('quote [format %c 92]');
+ tcl_eval
+----------
+ \\
+(1 row)
+
+-- Test argisnull
+select tcl_eval('argisnull');
+ERROR: wrong # args: should be "argisnull argno"
+select tcl_eval('argisnull 14');
+ERROR: argno out of range
+select tcl_eval('argisnull abc');
+ERROR: expected integer but got "abc"
+-- Test return_null
+select tcl_eval('return_null 14');
+ERROR: wrong # args: should be "return_null "
+-- Test spi_exec
+select tcl_eval('spi_exec');
+ERROR: wrong # args: should be "spi_exec ?-count n? ?-array name? query ?loop body?"
+select tcl_eval('spi_exec -count');
+ERROR: missing argument to -count or -array
+select tcl_eval('spi_exec -array');
+ERROR: missing argument to -count or -array
+select tcl_eval('spi_exec -count abc');
+ERROR: expected integer but got "abc"
+select tcl_eval('spi_exec query loop body toomuch');
+ERROR: wrong # args: should be "query ?loop body?"
+select tcl_eval('spi_exec "begin; rollback;"');
+ERROR: pltcl: SPI_execute failed: SPI_ERROR_TRANSACTION
+-- Test spi_execp
+select tcl_eval('spi_execp');
+ERROR: missing argument to -count or -array
+select tcl_eval('spi_execp -count');
+ERROR: missing argument to -array, -count or -nulls
+select tcl_eval('spi_execp -array');
+ERROR: missing argument to -array, -count or -nulls
+select tcl_eval('spi_execp -count abc');
+ERROR: expected integer but got "abc"
+select tcl_eval('spi_execp -nulls');
+ERROR: missing argument to -array, -count or -nulls
+select tcl_eval('spi_execp ""');
+ERROR: invalid queryid ''
+-- test spi_prepare
+select tcl_eval('spi_prepare');
+ERROR: wrong # args: should be "spi_prepare query argtypes"
+select tcl_eval('spi_prepare a b');
+ERROR: type "b" does not exist
+select tcl_eval('spi_prepare a "b {"');
+ERROR: unmatched open brace in list
+select tcl_error_handling_test($tcl$spi_prepare "select moo" []$tcl$);
+ tcl_error_handling_test
+--------------------------------------
+ SQLSTATE: 42703 +
+ condition: undefined_column +
+ cursor_position: 8 +
+ message: column "moo" does not exist+
+ statement: select moo
+(1 row)
+
+-- test full error text
+select tcl_error_handling_test($tcl$
+spi_exec "DO $$
+BEGIN
+RAISE 'my message'
+ USING HINT = 'my hint'
+ , DETAIL = 'my detail'
+ , SCHEMA = 'my schema'
+ , TABLE = 'my table'
+ , COLUMN = 'my column'
+ , CONSTRAINT = 'my constraint'
+ , DATATYPE = 'my datatype'
+;
+END$$;"
+$tcl$);
+ tcl_error_handling_test
+--------------------------------------------------------------
+ SQLSTATE: P0001 +
+ column: my column +
+ condition: raise_exception +
+ constraint: my constraint +
+ context: PL/pgSQL function inline_code_block line 3 at RAISE+
+ SQL statement "DO $$ +
+ BEGIN +
+ RAISE 'my message' +
+ USING HINT = 'my hint' +
+ , DETAIL = 'my detail' +
+ , SCHEMA = 'my schema' +
+ , TABLE = 'my table' +
+ , COLUMN = 'my column' +
+ , CONSTRAINT = 'my constraint' +
+ , DATATYPE = 'my datatype' +
+ ; +
+ END$$;" +
+ datatype: my datatype +
+ detail: my detail +
+ hint: my hint +
+ message: my message +
+ schema: my schema +
+ table: my table
+(1 row)
+
+-- verify tcl_error_handling_test() properly reports non-postgres errors
+select tcl_error_handling_test('moo');
+ tcl_error_handling_test
+----------------------------
+ invalid command name "moo"
+(1 row)
+
+-- test elog
+select tcl_eval('elog');
+ERROR: wrong # args: should be "elog level msg"
+select tcl_eval('elog foo bar');
+ERROR: bad priority "foo": must be DEBUG, LOG, INFO, NOTICE, WARNING, ERROR, or FATAL
+-- test forced error
+select tcl_eval('error "forced error"');
+ERROR: forced error
+-- test loop control in spi_exec[p]
+select tcl_spi_exec(true, 'break');
+NOTICE: col1 1, col2 foo
+NOTICE: col1 2, col2 bar
+NOTICE: action: break
+NOTICE: end of function
+ tcl_spi_exec
+--------------
+
+(1 row)
+
+select tcl_spi_exec(true, 'continue');
+NOTICE: col1 1, col2 foo
+NOTICE: col1 2, col2 bar
+NOTICE: action: continue
+NOTICE: col1 3, col2 baz
+NOTICE: end of function
+ tcl_spi_exec
+--------------
+
+(1 row)
+
+select tcl_spi_exec(true, 'error');
+NOTICE: col1 1, col2 foo
+NOTICE: col1 2, col2 bar
+NOTICE: action: error
+ERROR: error message
+select tcl_spi_exec(true, 'return');
+NOTICE: col1 1, col2 foo
+NOTICE: col1 2, col2 bar
+NOTICE: action: return
+ tcl_spi_exec
+--------------
+
+(1 row)
+
+select tcl_spi_exec(false, 'break');
+NOTICE: col1 1, col2 foo
+NOTICE: col1 2, col2 bar
+NOTICE: action: break
+NOTICE: end of function
+ tcl_spi_exec
+--------------
+
+(1 row)
+
+select tcl_spi_exec(false, 'continue');
+NOTICE: col1 1, col2 foo
+NOTICE: col1 2, col2 bar
+NOTICE: action: continue
+NOTICE: col1 3, col2 baz
+NOTICE: end of function
+ tcl_spi_exec
+--------------
+
+(1 row)
+
+select tcl_spi_exec(false, 'error');
+NOTICE: col1 1, col2 foo
+NOTICE: col1 2, col2 bar
+NOTICE: action: error
+ERROR: error message
+select tcl_spi_exec(false, 'return');
+NOTICE: col1 1, col2 foo
+NOTICE: col1 2, col2 bar
+NOTICE: action: return
+ tcl_spi_exec
+--------------
+
+(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($$
+ unset -nocomplain ::tcl_vwait
+ after 100 {set ::tcl_vwait 1}
+ vwait ::tcl_vwait
+ unset -nocomplain ::tcl_vwait$$);
+ tcl_eval
+----------
+
+(1 row)
+
diff --git a/src/pl/tcl/expected/pltcl_setup.out b/src/pl/tcl/expected/pltcl_setup.out
new file mode 100644
index 0000000..a8fdcf3
--- /dev/null
+++ b/src/pl/tcl/expected/pltcl_setup.out
@@ -0,0 +1,263 @@
+create table T_comp1 (
+ tkey char(10),
+ ref1 int4,
+ ref2 char(20)
+);
+create function tcl_composite_arg_ref1(T_comp1) returns int as '
+ return $1(ref1)
+' language pltcl;
+create function tcl_composite_arg_ref2(T_comp1) returns text as '
+ return $1(ref2)
+' language pltcl;
+create function tcl_argisnull(text) returns bool as '
+ argisnull 1
+' language pltcl;
+create function tcl_int4add(int4,int4) returns int4 as '
+ return [expr $1 + $2]
+' language pltcl;
+-- We use split(n) as a quick-and-dirty way of parsing the input array
+-- value, which comes in as a string like '{1,2}'. There are better ways...
+create function tcl_int4_accum(int4[], int4) returns int4[] as '
+ set state [split $1 "{,}"]
+ set newsum [expr {[lindex $state 1] + $2}]
+ set newcnt [expr {[lindex $state 2] + 1}]
+ return "{$newsum,$newcnt}"
+' language pltcl;
+create function tcl_int4_avg(int4[]) returns int4 as '
+ set state [split $1 "{,}"]
+ if {[lindex $state 2] == 0} { return_null }
+ return [expr {[lindex $state 1] / [lindex $state 2]}]
+' language pltcl;
+create aggregate tcl_avg (
+ sfunc = tcl_int4_accum,
+ basetype = int4,
+ stype = int4[],
+ finalfunc = tcl_int4_avg,
+ initcond = '{0,0}'
+ );
+create aggregate tcl_sum (
+ sfunc = tcl_int4add,
+ basetype = int4,
+ stype = int4,
+ initcond1 = 0
+ );
+create function tcl_int4lt(int4,int4) returns bool as '
+ if {$1 < $2} {
+ return t
+ }
+ return f
+' language pltcl;
+create function tcl_int4le(int4,int4) returns bool as '
+ if {$1 <= $2} {
+ return t
+ }
+ return f
+' language pltcl;
+create function tcl_int4eq(int4,int4) returns bool as '
+ if {$1 == $2} {
+ return t
+ }
+ return f
+' language pltcl;
+create function tcl_int4ge(int4,int4) returns bool as '
+ if {$1 >= $2} {
+ return t
+ }
+ return f
+' language pltcl;
+create function tcl_int4gt(int4,int4) returns bool as '
+ if {$1 > $2} {
+ return t
+ }
+ return f
+' language pltcl;
+create operator @< (
+ leftarg = int4,
+ rightarg = int4,
+ procedure = tcl_int4lt
+ );
+create operator @<= (
+ leftarg = int4,
+ rightarg = int4,
+ procedure = tcl_int4le
+ );
+create operator @= (
+ leftarg = int4,
+ rightarg = int4,
+ procedure = tcl_int4eq
+ );
+create operator @>= (
+ leftarg = int4,
+ rightarg = int4,
+ procedure = tcl_int4ge
+ );
+create operator @> (
+ leftarg = int4,
+ rightarg = int4,
+ procedure = tcl_int4gt
+ );
+create function tcl_int4cmp(int4,int4) returns int4 as '
+ if {$1 < $2} {
+ return -1
+ }
+ if {$1 > $2} {
+ return 1
+ }
+ return 0
+' language pltcl;
+CREATE OPERATOR CLASS tcl_int4_ops
+ FOR TYPE int4 USING btree AS
+ OPERATOR 1 @<,
+ OPERATOR 2 @<=,
+ OPERATOR 3 @=,
+ OPERATOR 4 @>=,
+ OPERATOR 5 @>,
+ FUNCTION 1 tcl_int4cmp(int4,int4) ;
+--
+-- Test usage of Tcl's "clock" command. In recent Tcl versions this
+-- command fails without working "unknown" support, so it's a good canary
+-- for initialization problems.
+--
+create function tcl_date_week(int4,int4,int4) returns text as $$
+ return [clock format [clock scan "$2/$3/$1" -gmt 1] -format "%U" -gmt 1]
+$$ language pltcl immutable;
+select tcl_date_week(2010,1,26);
+ tcl_date_week
+---------------
+ 04
+(1 row)
+
+select tcl_date_week(2001,10,24);
+ tcl_date_week
+---------------
+ 42
+(1 row)
+
+-- test pltcl event triggers
+create function tclsnitch() returns event_trigger language pltcl as $$
+ elog NOTICE "tclsnitch: $TG_event $TG_tag"
+$$;
+create event trigger tcl_a_snitch on ddl_command_start execute procedure tclsnitch();
+create event trigger tcl_b_snitch on ddl_command_end execute procedure tclsnitch();
+create function foobar() returns int language sql as $$select 1;$$;
+NOTICE: tclsnitch: ddl_command_start CREATE FUNCTION
+NOTICE: tclsnitch: ddl_command_end CREATE FUNCTION
+alter function foobar() cost 77;
+NOTICE: tclsnitch: ddl_command_start ALTER FUNCTION
+NOTICE: tclsnitch: ddl_command_end ALTER FUNCTION
+drop function foobar();
+NOTICE: tclsnitch: ddl_command_start DROP FUNCTION
+NOTICE: tclsnitch: ddl_command_end DROP FUNCTION
+create table foo();
+NOTICE: tclsnitch: ddl_command_start CREATE TABLE
+NOTICE: tclsnitch: ddl_command_end CREATE TABLE
+drop table foo;
+NOTICE: tclsnitch: ddl_command_start DROP TABLE
+NOTICE: tclsnitch: ddl_command_end DROP TABLE
+drop event trigger tcl_a_snitch;
+drop event trigger tcl_b_snitch;
+create function tcl_test_cube_squared(in int, out squared int, out cubed int) as $$
+ return [list squared [expr {$1 * $1}] cubed [expr {$1 * $1 * $1}]]
+$$ language pltcl;
+create function tcl_test_squared_rows(int,int) returns table (x int, y int) as $$
+ for {set i $1} {$i < $2} {incr i} {
+ return_next [list y [expr {$i * $i}] x $i]
+ }
+$$ language pltcl;
+create function tcl_test_sequence(int,int) returns setof int as $$
+ for {set i $1} {$i < $2} {incr i} {
+ return_next $i
+ }
+$$ language pltcl;
+create function tcl_eval(string text) returns text as $$
+ eval $1
+$$ language pltcl;
+-- test use of errorCode in error handling
+create function tcl_error_handling_test(text) returns text
+language pltcl
+as $function$
+ if {[catch $1 err]} {
+ # If not a Postgres error, just return the basic error message
+ if {[lindex $::errorCode 0] != "POSTGRES"} {
+ return $err
+ }
+
+ # Get rid of keys that can't be expected to remain constant
+ array set myArray $::errorCode
+ unset myArray(POSTGRES)
+ unset -nocomplain myArray(funcname)
+ unset -nocomplain myArray(filename)
+ unset -nocomplain myArray(lineno)
+
+ # Format into something nicer
+ set vals []
+ foreach {key} [lsort [array names myArray]] {
+ set value [string map {"\n" "\n\t"} $myArray($key)]
+ lappend vals "$key: $value"
+ }
+ return [join $vals "\n"]
+ } else {
+ return "no error"
+ }
+$function$;
+-- test spi_exec and spi_execp with -array
+create function tcl_spi_exec(
+ prepare boolean,
+ action text
+)
+returns void language pltcl AS $function$
+set query "select * from (values (1,'foo'),(2,'bar'),(3,'baz')) v(col1,col2)"
+if {$1 == "t"} {
+ set prep [spi_prepare $query {}]
+ spi_execp -array A $prep {
+ elog NOTICE "col1 $A(col1), col2 $A(col2)"
+
+ switch $A(col1) {
+ 2 {
+ elog NOTICE "action: $2"
+ switch $2 {
+ break {
+ break
+ }
+ continue {
+ continue
+ }
+ return {
+ return
+ }
+ error {
+ error "error message"
+ }
+ }
+ error "should not get here"
+ }
+ }
+ }
+} else {
+ spi_exec -array A $query {
+ elog NOTICE "col1 $A(col1), col2 $A(col2)"
+
+ switch $A(col1) {
+ 2 {
+ elog NOTICE "action: $2"
+ switch $2 {
+ break {
+ break
+ }
+ continue {
+ continue
+ }
+ return {
+ return
+ }
+ error {
+ error "error message"
+ }
+ }
+ error "should not get here"
+ }
+ }
+ }
+}
+elog NOTICE "end of function"
+$function$;
diff --git a/src/pl/tcl/expected/pltcl_start_proc.out b/src/pl/tcl/expected/pltcl_start_proc.out
new file mode 100644
index 0000000..9946cd9
--- /dev/null
+++ b/src/pl/tcl/expected/pltcl_start_proc.out
@@ -0,0 +1,31 @@
+--
+-- Test start_proc execution
+--
+SET pltcl.start_proc = 'no_such_function';
+select tcl_int4add(1, 2);
+ERROR: function no_such_function() does not exist
+CONTEXT: processing pltcl.start_proc parameter
+select tcl_int4add(1, 2);
+ERROR: function no_such_function() does not exist
+CONTEXT: processing pltcl.start_proc parameter
+create function tcl_initialize() returns void as
+$$ elog NOTICE "in tcl_initialize" $$ language pltcl SECURITY DEFINER;
+SET pltcl.start_proc = 'public.tcl_initialize';
+select tcl_int4add(1, 2); -- fail
+ERROR: function "public.tcl_initialize" must not be SECURITY DEFINER
+CONTEXT: processing pltcl.start_proc parameter
+create or replace function tcl_initialize() returns void as
+$$ elog NOTICE "in tcl_initialize" $$ language pltcl;
+select tcl_int4add(1, 2);
+NOTICE: in tcl_initialize
+ tcl_int4add
+-------------
+ 3
+(1 row)
+
+select tcl_int4add(1, 2);
+ tcl_int4add
+-------------
+ 3
+(1 row)
+
diff --git a/src/pl/tcl/expected/pltcl_subxact.out b/src/pl/tcl/expected/pltcl_subxact.out
new file mode 100644
index 0000000..5e19bbb
--- /dev/null
+++ b/src/pl/tcl/expected/pltcl_subxact.out
@@ -0,0 +1,143 @@
+--
+-- Test explicit subtransactions
+--
+CREATE TABLE subtransaction_tbl (
+ i integer
+);
+--
+-- We use this wrapper to catch errors and return errormsg only,
+-- because values of $::errorinfo variable contain procedure name which
+-- includes OID, so it's not stable
+--
+CREATE FUNCTION pltcl_wrapper(statement text) RETURNS text
+AS $$
+ if [catch {spi_exec $1} msg] {
+ return "ERROR: $msg"
+ } else {
+ return "SUCCESS: $msg"
+ }
+$$ LANGUAGE pltcl;
+-- Test subtransaction successfully committed
+CREATE FUNCTION subtransaction_ctx_success() RETURNS void
+AS $$
+ spi_exec "INSERT INTO subtransaction_tbl VALUES(1)"
+ subtransaction {
+ spi_exec "INSERT INTO subtransaction_tbl VALUES(2)"
+ }
+$$ LANGUAGE pltcl;
+BEGIN;
+INSERT INTO subtransaction_tbl VALUES(0);
+SELECT subtransaction_ctx_success();
+ subtransaction_ctx_success
+----------------------------
+
+(1 row)
+
+COMMIT;
+SELECT * FROM subtransaction_tbl;
+ i
+---
+ 0
+ 1
+ 2
+(3 rows)
+
+TRUNCATE subtransaction_tbl;
+-- Test subtransaction rollback
+CREATE FUNCTION subtransaction_ctx_test(what_error text = NULL) RETURNS void
+AS $$
+ spi_exec "INSERT INTO subtransaction_tbl VALUES (1)"
+ subtransaction {
+ spi_exec "INSERT INTO subtransaction_tbl VALUES (2)"
+ if {$1 == "SPI"} {
+ spi_exec "INSERT INTO subtransaction_tbl VALUES ('oops')"
+ } elseif { $1 == "Tcl"} {
+ elog ERROR "Tcl error"
+ }
+ }
+$$ LANGUAGE pltcl;
+SELECT pltcl_wrapper('SELECT subtransaction_ctx_test()');
+ pltcl_wrapper
+---------------
+ SUCCESS: 1
+(1 row)
+
+SELECT * FROM subtransaction_tbl;
+ i
+---
+ 1
+ 2
+(2 rows)
+
+TRUNCATE subtransaction_tbl;
+SELECT pltcl_wrapper('SELECT subtransaction_ctx_test(''SPI'')');
+ pltcl_wrapper
+------------------------------------------------------
+ ERROR: invalid input syntax for type integer: "oops"
+(1 row)
+
+SELECT * FROM subtransaction_tbl;
+ i
+---
+(0 rows)
+
+TRUNCATE subtransaction_tbl;
+SELECT pltcl_wrapper('SELECT subtransaction_ctx_test(''Tcl'')');
+ pltcl_wrapper
+------------------
+ ERROR: Tcl error
+(1 row)
+
+SELECT * FROM subtransaction_tbl;
+ i
+---
+(0 rows)
+
+TRUNCATE subtransaction_tbl;
+-- Nested subtransactions
+CREATE FUNCTION subtransaction_nested_test(swallow boolean = 'f') RETURNS text
+AS $$
+spi_exec "INSERT INTO subtransaction_tbl VALUES (1)"
+subtransaction {
+ spi_exec "INSERT INTO subtransaction_tbl VALUES (2)"
+ if [catch {
+ subtransaction {
+ spi_exec "INSERT INTO subtransaction_tbl VALUES (3)"
+ spi_exec "error"
+ }
+ } errormsg] {
+ if {$1 != "t"} {
+ error $errormsg $::errorInfo $::errorCode
+ }
+ elog NOTICE "Swallowed $errormsg"
+ }
+}
+return "ok"
+$$ LANGUAGE pltcl;
+SELECT pltcl_wrapper('SELECT subtransaction_nested_test()');
+ pltcl_wrapper
+----------------------------------------
+ ERROR: syntax error at or near "error"
+(1 row)
+
+SELECT * FROM subtransaction_tbl;
+ i
+---
+(0 rows)
+
+TRUNCATE subtransaction_tbl;
+SELECT pltcl_wrapper('SELECT subtransaction_nested_test(''t'')');
+NOTICE: Swallowed syntax error at or near "error"
+ pltcl_wrapper
+---------------
+ SUCCESS: 1
+(1 row)
+
+SELECT * FROM subtransaction_tbl;
+ i
+---
+ 1
+ 2
+(2 rows)
+
+TRUNCATE subtransaction_tbl;
diff --git a/src/pl/tcl/expected/pltcl_transaction.out b/src/pl/tcl/expected/pltcl_transaction.out
new file mode 100644
index 0000000..f557b79
--- /dev/null
+++ b/src/pl/tcl/expected/pltcl_transaction.out
@@ -0,0 +1,149 @@
+-- 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
+AS $$
+for {set i 0} {$i < 10} {incr i} {
+ spi_exec "INSERT INTO test1 (a) VALUES ($i)"
+ if {$i % 2 == 0} {
+ commit
+ } else {
+ rollback
+ }
+}
+$$;
+CALL transaction_test1();
+SELECT * FROM test1;
+ a | b
+---+---
+ 0 |
+ 2 |
+ 4 |
+ 6 |
+ 8 |
+(5 rows)
+
+TRUNCATE test1;
+-- not allowed in a function
+CREATE FUNCTION transaction_test2() RETURNS int
+LANGUAGE pltcl
+AS $$
+for {set i 0} {$i < 10} {incr i} {
+ spi_exec "INSERT INTO test1 (a) VALUES ($i)"
+ if {$i % 2 == 0} {
+ commit
+ } else {
+ rollback
+ }
+}
+return 1
+$$;
+SELECT transaction_test2();
+ERROR: invalid transaction termination
+SELECT * FROM test1;
+ a | b
+---+---
+(0 rows)
+
+-- also not allowed if procedure is called from a function
+CREATE FUNCTION transaction_test3() RETURNS int
+LANGUAGE pltcl
+AS $$
+spi_exec "CALL transaction_test1()"
+return 1
+$$;
+SELECT transaction_test3();
+ERROR: invalid transaction termination
+SELECT * FROM test1;
+ a | b
+---+---
+(0 rows)
+
+-- commit inside cursor loop
+CREATE TABLE test2 (x int);
+INSERT INTO test2 VALUES (0), (1), (2), (3), (4);
+TRUNCATE test1;
+CREATE PROCEDURE transaction_test4a()
+LANGUAGE pltcl
+AS $$
+spi_exec -array row "SELECT * FROM test2 ORDER BY x" {
+ spi_exec "INSERT INTO test1 (a) VALUES ($row(x))"
+ commit
+}
+$$;
+CALL transaction_test4a();
+ERROR: cannot commit while a subtransaction is active
+SELECT * FROM test1;
+ a | b
+---+---
+(0 rows)
+
+-- rollback inside cursor loop
+TRUNCATE test1;
+CREATE PROCEDURE transaction_test4b()
+LANGUAGE pltcl
+AS $$
+spi_exec -array row "SELECT * FROM test2 ORDER BY x" {
+ spi_exec "INSERT INTO test1 (a) VALUES ($row(x))"
+ rollback
+}
+$$;
+CALL transaction_test4b();
+ERROR: cannot roll back while a subtransaction is active
+SELECT * FROM test1;
+ a | b
+---+---
+(0 rows)
+
+-- check handling of an error during COMMIT
+CREATE TABLE testpk (id int PRIMARY KEY);
+CREATE TABLE testfk(f1 int REFERENCES testpk DEFERRABLE INITIALLY DEFERRED);
+CREATE PROCEDURE transaction_testfk()
+LANGUAGE pltcl
+AS $$
+# this insert will fail during commit:
+spi_exec "INSERT INTO testfk VALUES (0)"
+commit
+elog WARNING "should not get here"
+$$;
+CALL transaction_testfk();
+ERROR: insert or update on table "testfk" violates foreign key constraint "testfk_f1_fkey"
+SELECT * FROM testpk;
+ id
+----
+(0 rows)
+
+SELECT * FROM testfk;
+ f1
+----
+(0 rows)
+
+CREATE OR REPLACE PROCEDURE transaction_testfk()
+LANGUAGE pltcl
+AS $$
+# this insert will fail during commit:
+spi_exec "INSERT INTO testfk VALUES (0)"
+if [catch {commit} msg] {
+ elog INFO $msg
+}
+# these inserts should work:
+spi_exec "INSERT INTO testpk VALUES (1)"
+spi_exec "INSERT INTO testfk VALUES (1)"
+$$;
+CALL transaction_testfk();
+INFO: insert or update on table "testfk" violates foreign key constraint "testfk_f1_fkey"
+SELECT * FROM testpk;
+ id
+----
+ 1
+(1 row)
+
+SELECT * FROM testfk;
+ f1
+----
+ 1
+(1 row)
+
+DROP TABLE test1;
+DROP TABLE test2;
diff --git a/src/pl/tcl/expected/pltcl_trigger.out b/src/pl/tcl/expected/pltcl_trigger.out
new file mode 100644
index 0000000..008ea19
--- /dev/null
+++ b/src/pl/tcl/expected/pltcl_trigger.out
@@ -0,0 +1,888 @@
+-- suppress CONTEXT so that function OIDs aren't in output
+\set VERBOSITY terse
+--
+-- Create the tables used in the test queries
+--
+-- T_pkey1 is the primary key table for T_dta1. Entries from T_pkey1
+-- Cannot be changed or deleted if they are referenced from T_dta1.
+--
+-- T_pkey2 is the primary key table for T_dta2. If the key values in
+-- T_pkey2 are changed, the references in T_dta2 follow. If entries
+-- are deleted, the referencing entries from T_dta2 are deleted too.
+-- The values for field key2 in T_pkey2 are silently converted to
+-- upper case on insert/update.
+--
+create table T_pkey1 (
+ key1 int4,
+ key2 char(20),
+ txt char(40)
+);
+create table T_pkey2 (
+ key1 int4,
+ key2 char(20),
+ txt char(40)
+);
+create table T_dta1 (
+ tkey char(10),
+ ref1 int4,
+ ref2 char(20)
+);
+create table T_dta2 (
+ tkey char(10),
+ ref1 int4,
+ ref2 char(20)
+);
+--
+-- Function to check key existence in T_pkey1
+--
+create function check_pkey1_exists(int4, bpchar) returns bool as E'
+ if {![info exists GD]} {
+ set GD(plan) [spi_prepare \\
+ "select 1 from T_pkey1 \\
+ where key1 = \\$1 and key2 = \\$2" \\
+ {int4 bpchar}]
+ }
+
+ set n [spi_execp -count 1 $GD(plan) [list $1 $2]]
+
+ if {$n > 0} {
+ return "t"
+ }
+ return "f"
+' language pltcl;
+-- dump trigger data
+CREATE TABLE trigger_test (
+ i int,
+ v text,
+ dropme text,
+ test_skip boolean DEFAULT false,
+ test_return_null boolean DEFAULT false,
+ test_argisnull boolean DEFAULT false
+);
+-- Make certain dropped attributes are handled correctly
+ALTER TABLE trigger_test DROP dropme;
+CREATE TABLE trigger_test_generated (
+ i int,
+ j int GENERATED ALWAYS AS (i * 2) STORED
+);
+CREATE VIEW trigger_test_view AS SELECT i, v FROM trigger_test;
+CREATE FUNCTION trigger_data() returns trigger language pltcl as $_$
+ if {$TG_table_name eq "trigger_test" && $TG_level eq "ROW" && $TG_op ne "DELETE"} {
+ # Special case tests
+ if {$NEW(test_return_null) eq "t" } {
+ return_null
+ }
+ if {$NEW(test_argisnull) eq "t" } {
+ set should_error [argisnull 1]
+ }
+ if {$NEW(test_skip) eq "t" } {
+ elog NOTICE "SKIPPING OPERATION $TG_op"
+ return SKIP
+ }
+ }
+
+ if { [info exists TG_relid] } {
+ set TG_relid "bogus:12345"
+ }
+
+ set dnames [info locals {[a-zA-Z]*} ]
+
+ foreach key [lsort $dnames] {
+
+ if { [array exists $key] } {
+ set str "{"
+ foreach akey [lsort [ array names $key ] ] {
+ if {[string length $str] > 1} { set str "$str, " }
+ set cmd "($akey)"
+ set cmd "set val \$$key$cmd"
+ eval $cmd
+ set str "$str$akey: $val"
+ }
+ set str "$str}"
+ elog NOTICE "$key: $str"
+ } else {
+ set val [eval list "\$$key" ]
+ elog NOTICE "$key: $val"
+ }
+ }
+
+
+ return OK
+
+$_$;
+CREATE TRIGGER show_trigger_data_trig
+BEFORE INSERT OR UPDATE OR DELETE ON trigger_test
+FOR EACH ROW EXECUTE PROCEDURE trigger_data(23,'skidoo');
+CREATE TRIGGER statement_trigger
+BEFORE INSERT OR UPDATE OR DELETE OR TRUNCATE ON trigger_test
+FOR EACH STATEMENT EXECUTE PROCEDURE trigger_data(42,'statement trigger');
+CREATE TRIGGER show_trigger_data_trig_before
+BEFORE INSERT OR UPDATE OR DELETE ON trigger_test_generated
+FOR EACH ROW EXECUTE PROCEDURE trigger_data();
+CREATE TRIGGER show_trigger_data_trig_after
+AFTER INSERT OR UPDATE OR DELETE ON trigger_test_generated
+FOR EACH ROW EXECUTE PROCEDURE trigger_data();
+CREATE TRIGGER show_trigger_data_view_trig
+INSTEAD OF INSERT OR UPDATE OR DELETE ON trigger_test_view
+FOR EACH ROW EXECUTE PROCEDURE trigger_data(24,'skidoo view');
+--
+-- Trigger function on every change to T_pkey1
+--
+create function trig_pkey1_before() returns trigger as E'
+ #
+ # Create prepared plans on the first call
+ #
+ if {![info exists GD]} {
+ #
+ # Plan to check for duplicate key in T_pkey1
+ #
+ set GD(plan_pkey1) [spi_prepare \\
+ "select check_pkey1_exists(\\$1, \\$2) as ret" \\
+ {int4 bpchar}]
+ #
+ # Plan to check for references from T_dta1
+ #
+ set GD(plan_dta1) [spi_prepare \\
+ "select 1 from T_dta1 \\
+ where ref1 = \\$1 and ref2 = \\$2" \\
+ {int4 bpchar}]
+ }
+
+ #
+ # Initialize flags
+ #
+ set check_old_ref 0
+ set check_new_dup 0
+
+ switch $TG_op {
+ INSERT {
+ #
+ # Must check for duplicate key on INSERT
+ #
+ set check_new_dup 1
+ }
+ UPDATE {
+ #
+ # Must check for duplicate key on UPDATE only if
+ # the key changes. In that case we must check for
+ # references to OLD values too.
+ #
+ if {[string compare $NEW(key1) $OLD(key1)] != 0} {
+ set check_old_ref 1
+ set check_new_dup 1
+ }
+ if {[string compare $NEW(key2) $OLD(key2)] != 0} {
+ set check_old_ref 1
+ set check_new_dup 1
+ }
+ }
+ DELETE {
+ #
+ # Must only check for references to OLD on DELETE
+ #
+ set check_old_ref 1
+ }
+ }
+
+ if {$check_new_dup} {
+ #
+ # Check for duplicate key
+ #
+ spi_execp -count 1 $GD(plan_pkey1) [list $NEW(key1) $NEW(key2)]
+ if {$ret == "t"} {
+ elog ERROR \\
+ "duplicate key ''$NEW(key1)'', ''$NEW(key2)'' for T_pkey1"
+ }
+ }
+
+ if {$check_old_ref} {
+ #
+ # Check for references to OLD
+ #
+ set n [spi_execp -count 1 $GD(plan_dta1) [list $OLD(key1) $OLD(key2)]]
+ if {$n > 0} {
+ elog ERROR \\
+ "key ''$OLD(key1)'', ''$OLD(key2)'' referenced by T_dta1"
+ }
+ }
+
+ #
+ # Anything is fine - let operation pass through
+ #
+ return OK
+' language pltcl;
+create trigger pkey1_before before insert or update or delete on T_pkey1
+ for each row execute procedure
+ trig_pkey1_before();
+--
+-- Trigger function to check for duplicate keys in T_pkey2
+-- and to force key2 to be upper case only without leading whitespaces
+--
+create function trig_pkey2_before() returns trigger as E'
+ #
+ # Prepare plan on first call
+ #
+ if {![info exists GD]} {
+ set GD(plan_pkey2) [spi_prepare \\
+ "select 1 from T_pkey2 \\
+ where key1 = \\$1 and key2 = \\$2" \\
+ {int4 bpchar}]
+ }
+
+ #
+ # Convert key2 value
+ #
+ set NEW(key2) [string toupper [string trim $NEW(key2)]]
+
+ #
+ # Check for duplicate key
+ #
+ set n [spi_execp -count 1 $GD(plan_pkey2) [list $NEW(key1) $NEW(key2)]]
+ if {$n > 0} {
+ elog ERROR \\
+ "duplicate key ''$NEW(key1)'', ''$NEW(key2)'' for T_pkey2"
+ }
+
+ #
+ # Return modified tuple in NEW
+ #
+ return [array get NEW]
+' language pltcl;
+create trigger pkey2_before before insert or update on T_pkey2
+ for each row execute procedure
+ trig_pkey2_before();
+--
+-- Trigger function to force references from T_dta2 follow changes
+-- in T_pkey2 or be deleted too. This must be done AFTER the changes
+-- in T_pkey2 are done so the trigger for primkey check on T_dta2
+-- fired on our updates will see the new key values in T_pkey2.
+--
+create function trig_pkey2_after() returns trigger as E'
+ #
+ # Prepare plans on first call
+ #
+ if {![info exists GD]} {
+ #
+ # Plan to update references from T_dta2
+ #
+ set GD(plan_dta2_upd) [spi_prepare \\
+ "update T_dta2 set ref1 = \\$3, ref2 = \\$4 \\
+ where ref1 = \\$1 and ref2 = \\$2" \\
+ {int4 bpchar int4 bpchar}]
+ #
+ # Plan to delete references from T_dta2
+ #
+ set GD(plan_dta2_del) [spi_prepare \\
+ "delete from T_dta2 \\
+ where ref1 = \\$1 and ref2 = \\$2" \\
+ {int4 bpchar}]
+ }
+
+ #
+ # Initialize flags
+ #
+ set old_ref_follow 0
+ set old_ref_delete 0
+
+ switch $TG_op {
+ UPDATE {
+ #
+ # On update we must let old references follow
+ #
+ set NEW(key2) [string toupper $NEW(key2)]
+
+ if {[string compare $NEW(key1) $OLD(key1)] != 0} {
+ set old_ref_follow 1
+ }
+ if {[string compare $NEW(key2) $OLD(key2)] != 0} {
+ set old_ref_follow 1
+ }
+ }
+ DELETE {
+ #
+ # On delete we must delete references too
+ #
+ set old_ref_delete 1
+ }
+ }
+
+ if {$old_ref_follow} {
+ #
+ # Let old references follow and fire NOTICE message if
+ # there where some
+ #
+ set n [spi_execp $GD(plan_dta2_upd) \\
+ [list $OLD(key1) $OLD(key2) $NEW(key1) $NEW(key2)]]
+ if {$n > 0} {
+ elog NOTICE \\
+ "updated $n entries in T_dta2 for new key in T_pkey2"
+ }
+ }
+
+ if {$old_ref_delete} {
+ #
+ # delete references and fire NOTICE message if
+ # there where some
+ #
+ set n [spi_execp $GD(plan_dta2_del) \\
+ [list $OLD(key1) $OLD(key2)]]
+ if {$n > 0} {
+ elog NOTICE \\
+ "deleted $n entries from T_dta2"
+ }
+ }
+
+ return OK
+' language pltcl;
+create trigger pkey2_after after update or delete on T_pkey2
+ for each row execute procedure
+ trig_pkey2_after();
+--
+-- Generic trigger function to check references in T_dta1 and T_dta2
+--
+create function check_primkey() returns trigger as E'
+ #
+ # For every trigger/relation pair we create
+ # a saved plan and hold them in GD
+ #
+ set plankey [list "plan" $TG_name $TG_relid]
+ set planrel [list "relname" $TG_relid]
+
+ #
+ # Extract the pkey relation name
+ #
+ set keyidx [expr [llength $args] / 2]
+ set keyrel [string tolower [lindex $args $keyidx]]
+
+ if {![info exists GD($plankey)]} {
+ #
+ # We must prepare a new plan. Build up a query string
+ # for the primary key check.
+ #
+ set keylist [lrange $args [expr $keyidx + 1] end]
+
+ set query "select 1 from $keyrel"
+ set qual " where"
+ set typlist ""
+ set idx 1
+ foreach key $keylist {
+ set key [string tolower $key]
+ #
+ # Add the qual part to the query string
+ #
+ append query "$qual $key = \\$$idx"
+ set qual " and"
+
+ #
+ # Lookup the fields type in pg_attribute
+ #
+ set n [spi_exec "select T.typname \\
+ from pg_catalog.pg_type T, pg_catalog.pg_attribute A, pg_catalog.pg_class C \\
+ where C.relname = ''[quote $keyrel]'' \\
+ and C.oid = A.attrelid \\
+ and A.attname = ''[quote $key]'' \\
+ and A.atttypid = T.oid"]
+ if {$n != 1} {
+ elog ERROR "table $keyrel doesn''t have a field named $key"
+ }
+
+ #
+ # Append the fields type to the argument type list
+ #
+ lappend typlist $typname
+ incr idx
+ }
+
+ #
+ # Prepare the plan
+ #
+ set GD($plankey) [spi_prepare $query $typlist]
+
+ #
+ # Lookup and remember the table name for later error messages
+ #
+ spi_exec "select relname from pg_catalog.pg_class \\
+ where oid = ''$TG_relid''::oid"
+ set GD($planrel) $relname
+ }
+
+ #
+ # Build the argument list from the NEW row
+ #
+ incr keyidx -1
+ set arglist ""
+ foreach arg [lrange $args 0 $keyidx] {
+ lappend arglist $NEW($arg)
+ }
+
+ #
+ # Check for the primary key
+ #
+ set n [spi_execp -count 1 $GD($plankey) $arglist]
+ if {$n <= 0} {
+ elog ERROR "key for $GD($planrel) not in $keyrel"
+ }
+
+ #
+ # Anything is fine
+ #
+ return OK
+' language pltcl;
+create trigger dta1_before before insert or update on T_dta1
+ for each row execute procedure
+ check_primkey('ref1', 'ref2', 'T_pkey1', 'key1', 'key2');
+create trigger dta2_before before insert or update on T_dta2
+ for each row execute procedure
+ check_primkey('ref1', 'ref2', 'T_pkey2', 'key1', 'key2');
+insert into T_pkey1 values (1, 'key1-1', 'test key');
+insert into T_pkey1 values (1, 'key1-2', 'test key');
+insert into T_pkey1 values (1, 'key1-3', 'test key');
+insert into T_pkey1 values (2, 'key2-1', 'test key');
+insert into T_pkey1 values (2, 'key2-2', 'test key');
+insert into T_pkey1 values (2, 'key2-3', 'test key');
+insert into T_pkey2 values (1, 'key1-1', 'test key');
+insert into T_pkey2 values (1, 'key1-2', 'test key');
+insert into T_pkey2 values (1, 'key1-3', 'test key');
+insert into T_pkey2 values (2, 'key2-1', 'test key');
+insert into T_pkey2 values (2, 'key2-2', 'test key');
+insert into T_pkey2 values (2, 'key2-3', 'test key');
+select * from T_pkey1;
+ key1 | key2 | txt
+------+----------------------+------------------------------------------
+ 1 | key1-1 | test key
+ 1 | key1-2 | test key
+ 1 | key1-3 | test key
+ 2 | key2-1 | test key
+ 2 | key2-2 | test key
+ 2 | key2-3 | test key
+(6 rows)
+
+-- key2 in T_pkey2 should have upper case only
+select * from T_pkey2;
+ key1 | key2 | txt
+------+----------------------+------------------------------------------
+ 1 | KEY1-1 | test key
+ 1 | KEY1-2 | test key
+ 1 | KEY1-3 | test key
+ 2 | KEY2-1 | test key
+ 2 | KEY2-2 | test key
+ 2 | KEY2-3 | test key
+(6 rows)
+
+insert into T_pkey1 values (1, 'KEY1-3', 'should work');
+-- Due to the upper case translation in trigger this must fail
+insert into T_pkey2 values (1, 'KEY1-3', 'should fail');
+ERROR: duplicate key '1', 'KEY1-3' for T_pkey2
+insert into T_dta1 values ('trec 1', 1, 'key1-1');
+insert into T_dta1 values ('trec 2', 1, 'key1-2');
+insert into T_dta1 values ('trec 3', 1, 'key1-3');
+-- Must fail due to unknown key in T_pkey1
+insert into T_dta1 values ('trec 4', 1, 'key1-4');
+ERROR: key for t_dta1 not in t_pkey1
+insert into T_dta2 values ('trec 1', 1, 'KEY1-1');
+insert into T_dta2 values ('trec 2', 1, 'KEY1-2');
+insert into T_dta2 values ('trec 3', 1, 'KEY1-3');
+-- Must fail due to unknown key in T_pkey2
+insert into T_dta2 values ('trec 4', 1, 'KEY1-4');
+ERROR: key for t_dta2 not in t_pkey2
+select * from T_dta1;
+ tkey | ref1 | ref2
+------------+------+----------------------
+ trec 1 | 1 | key1-1
+ trec 2 | 1 | key1-2
+ trec 3 | 1 | key1-3
+(3 rows)
+
+select * from T_dta2;
+ tkey | ref1 | ref2
+------------+------+----------------------
+ trec 1 | 1 | KEY1-1
+ trec 2 | 1 | KEY1-2
+ trec 3 | 1 | KEY1-3
+(3 rows)
+
+update T_pkey1 set key2 = 'key2-9' where key1 = 2 and key2 = 'key2-1';
+update T_pkey1 set key2 = 'key1-9' where key1 = 1 and key2 = 'key1-1';
+ERROR: key '1', 'key1-1 ' referenced by T_dta1
+delete from T_pkey1 where key1 = 2 and key2 = 'key2-2';
+delete from T_pkey1 where key1 = 1 and key2 = 'key1-2';
+ERROR: key '1', 'key1-2 ' referenced by T_dta1
+update T_pkey2 set key2 = 'KEY2-9' where key1 = 2 and key2 = 'KEY2-1';
+update T_pkey2 set key2 = 'KEY1-9' where key1 = 1 and key2 = 'KEY1-1';
+NOTICE: updated 1 entries in T_dta2 for new key in T_pkey2
+delete from T_pkey2 where key1 = 2 and key2 = 'KEY2-2';
+delete from T_pkey2 where key1 = 1 and key2 = 'KEY1-2';
+NOTICE: deleted 1 entries from T_dta2
+select * from T_pkey1;
+ key1 | key2 | txt
+------+----------------------+------------------------------------------
+ 1 | key1-1 | test key
+ 1 | key1-2 | test key
+ 1 | key1-3 | test key
+ 2 | key2-3 | test key
+ 1 | KEY1-3 | should work
+ 2 | key2-9 | test key
+(6 rows)
+
+select * from T_pkey2;
+ key1 | key2 | txt
+------+----------------------+------------------------------------------
+ 1 | KEY1-3 | test key
+ 2 | KEY2-3 | test key
+ 2 | KEY2-9 | test key
+ 1 | KEY1-9 | test key
+(4 rows)
+
+select * from T_dta1;
+ tkey | ref1 | ref2
+------------+------+----------------------
+ trec 1 | 1 | key1-1
+ trec 2 | 1 | key1-2
+ trec 3 | 1 | key1-3
+(3 rows)
+
+select * from T_dta2;
+ tkey | ref1 | ref2
+------------+------+----------------------
+ trec 3 | 1 | KEY1-3
+ trec 1 | 1 | KEY1-9
+(2 rows)
+
+select tcl_avg(key1) from T_pkey1;
+ tcl_avg
+---------
+ 1
+(1 row)
+
+select tcl_sum(key1) from T_pkey1;
+ tcl_sum
+---------
+ 8
+(1 row)
+
+select tcl_avg(key1) from T_pkey2;
+ tcl_avg
+---------
+ 1
+(1 row)
+
+select tcl_sum(key1) from T_pkey2;
+ tcl_sum
+---------
+ 6
+(1 row)
+
+-- The following should return NULL instead of 0
+select tcl_avg(key1) from T_pkey1 where key1 = 99;
+ tcl_avg
+---------
+
+(1 row)
+
+select tcl_sum(key1) from T_pkey1 where key1 = 99;
+ tcl_sum
+---------
+ 0
+(1 row)
+
+select 1 @< 2;
+ ?column?
+----------
+ t
+(1 row)
+
+select 100 @< 4;
+ ?column?
+----------
+ f
+(1 row)
+
+select * from T_pkey1 order by key1 using @<, key2 collate "C";
+ key1 | key2 | txt
+------+----------------------+------------------------------------------
+ 1 | KEY1-3 | should work
+ 1 | key1-1 | test key
+ 1 | key1-2 | test key
+ 1 | key1-3 | test key
+ 2 | key2-3 | test key
+ 2 | key2-9 | test key
+(6 rows)
+
+select * from T_pkey2 order by key1 using @<, key2 collate "C";
+ key1 | key2 | txt
+------+----------------------+------------------------------------------
+ 1 | KEY1-3 | test key
+ 1 | KEY1-9 | test key
+ 2 | KEY2-3 | test key
+ 2 | KEY2-9 | test key
+(4 rows)
+
+-- show dump of trigger data
+insert into trigger_test values(1,'insert');
+NOTICE: NEW: {}
+NOTICE: OLD: {}
+NOTICE: TG_level: STATEMENT
+NOTICE: TG_name: statement_trigger
+NOTICE: TG_op: INSERT
+NOTICE: TG_relatts: {{} i v {} test_skip test_return_null test_argisnull}
+NOTICE: TG_relid: bogus:12345
+NOTICE: TG_table_name: trigger_test
+NOTICE: TG_table_schema: public
+NOTICE: TG_when: BEFORE
+NOTICE: args: {42 {statement trigger}}
+NOTICE: NEW: {i: 1, test_argisnull: f, test_return_null: f, test_skip: f, v: insert}
+NOTICE: OLD: {}
+NOTICE: TG_level: ROW
+NOTICE: TG_name: show_trigger_data_trig
+NOTICE: TG_op: INSERT
+NOTICE: TG_relatts: {{} i v {} test_skip test_return_null test_argisnull}
+NOTICE: TG_relid: bogus:12345
+NOTICE: TG_table_name: trigger_test
+NOTICE: TG_table_schema: public
+NOTICE: TG_when: BEFORE
+NOTICE: args: {23 skidoo}
+insert into trigger_test_generated (i) values (1);
+NOTICE: NEW: {i: 1}
+NOTICE: OLD: {}
+NOTICE: TG_level: ROW
+NOTICE: TG_name: show_trigger_data_trig_before
+NOTICE: TG_op: INSERT
+NOTICE: TG_relatts: {{} i j}
+NOTICE: TG_relid: bogus:12345
+NOTICE: TG_table_name: trigger_test_generated
+NOTICE: TG_table_schema: public
+NOTICE: TG_when: BEFORE
+NOTICE: args: {}
+NOTICE: NEW: {i: 1, j: 2}
+NOTICE: OLD: {}
+NOTICE: TG_level: ROW
+NOTICE: TG_name: show_trigger_data_trig_after
+NOTICE: TG_op: INSERT
+NOTICE: TG_relatts: {{} i j}
+NOTICE: TG_relid: bogus:12345
+NOTICE: TG_table_name: trigger_test_generated
+NOTICE: TG_table_schema: public
+NOTICE: TG_when: AFTER
+NOTICE: args: {}
+update trigger_test_generated set i = 11 where i = 1;
+NOTICE: NEW: {i: 11}
+NOTICE: OLD: {i: 1, j: 2}
+NOTICE: TG_level: ROW
+NOTICE: TG_name: show_trigger_data_trig_before
+NOTICE: TG_op: UPDATE
+NOTICE: TG_relatts: {{} i j}
+NOTICE: TG_relid: bogus:12345
+NOTICE: TG_table_name: trigger_test_generated
+NOTICE: TG_table_schema: public
+NOTICE: TG_when: BEFORE
+NOTICE: args: {}
+NOTICE: NEW: {i: 11, j: 22}
+NOTICE: OLD: {i: 1, j: 2}
+NOTICE: TG_level: ROW
+NOTICE: TG_name: show_trigger_data_trig_after
+NOTICE: TG_op: UPDATE
+NOTICE: TG_relatts: {{} i j}
+NOTICE: TG_relid: bogus:12345
+NOTICE: TG_table_name: trigger_test_generated
+NOTICE: TG_table_schema: public
+NOTICE: TG_when: AFTER
+NOTICE: args: {}
+delete from trigger_test_generated;
+NOTICE: NEW: {}
+NOTICE: OLD: {i: 11, j: 22}
+NOTICE: TG_level: ROW
+NOTICE: TG_name: show_trigger_data_trig_before
+NOTICE: TG_op: DELETE
+NOTICE: TG_relatts: {{} i j}
+NOTICE: TG_relid: bogus:12345
+NOTICE: TG_table_name: trigger_test_generated
+NOTICE: TG_table_schema: public
+NOTICE: TG_when: BEFORE
+NOTICE: args: {}
+NOTICE: NEW: {}
+NOTICE: OLD: {i: 11, j: 22}
+NOTICE: TG_level: ROW
+NOTICE: TG_name: show_trigger_data_trig_after
+NOTICE: TG_op: DELETE
+NOTICE: TG_relatts: {{} i j}
+NOTICE: TG_relid: bogus:12345
+NOTICE: TG_table_name: trigger_test_generated
+NOTICE: TG_table_schema: public
+NOTICE: TG_when: AFTER
+NOTICE: args: {}
+insert into trigger_test_view values(2,'insert');
+NOTICE: NEW: {i: 2, v: insert}
+NOTICE: OLD: {}
+NOTICE: TG_level: ROW
+NOTICE: TG_name: show_trigger_data_view_trig
+NOTICE: TG_op: INSERT
+NOTICE: TG_relatts: {{} i v}
+NOTICE: TG_relid: bogus:12345
+NOTICE: TG_table_name: trigger_test_view
+NOTICE: TG_table_schema: public
+NOTICE: TG_when: {INSTEAD OF}
+NOTICE: args: {24 {skidoo view}}
+update trigger_test_view set v = 'update' where i=1;
+NOTICE: NEW: {i: 1, v: update}
+NOTICE: OLD: {i: 1, v: insert}
+NOTICE: TG_level: ROW
+NOTICE: TG_name: show_trigger_data_view_trig
+NOTICE: TG_op: UPDATE
+NOTICE: TG_relatts: {{} i v}
+NOTICE: TG_relid: bogus:12345
+NOTICE: TG_table_name: trigger_test_view
+NOTICE: TG_table_schema: public
+NOTICE: TG_when: {INSTEAD OF}
+NOTICE: args: {24 {skidoo view}}
+delete from trigger_test_view;
+NOTICE: NEW: {}
+NOTICE: OLD: {i: 1, v: insert}
+NOTICE: TG_level: ROW
+NOTICE: TG_name: show_trigger_data_view_trig
+NOTICE: TG_op: DELETE
+NOTICE: TG_relatts: {{} i v}
+NOTICE: TG_relid: bogus:12345
+NOTICE: TG_table_name: trigger_test_view
+NOTICE: TG_table_schema: public
+NOTICE: TG_when: {INSTEAD OF}
+NOTICE: args: {24 {skidoo view}}
+update trigger_test set v = 'update', test_skip=true where i = 1;
+NOTICE: NEW: {}
+NOTICE: OLD: {}
+NOTICE: TG_level: STATEMENT
+NOTICE: TG_name: statement_trigger
+NOTICE: TG_op: UPDATE
+NOTICE: TG_relatts: {{} i v {} test_skip test_return_null test_argisnull}
+NOTICE: TG_relid: bogus:12345
+NOTICE: TG_table_name: trigger_test
+NOTICE: TG_table_schema: public
+NOTICE: TG_when: BEFORE
+NOTICE: args: {42 {statement trigger}}
+NOTICE: SKIPPING OPERATION UPDATE
+update trigger_test set v = 'update' where i = 1;
+NOTICE: NEW: {}
+NOTICE: OLD: {}
+NOTICE: TG_level: STATEMENT
+NOTICE: TG_name: statement_trigger
+NOTICE: TG_op: UPDATE
+NOTICE: TG_relatts: {{} i v {} test_skip test_return_null test_argisnull}
+NOTICE: TG_relid: bogus:12345
+NOTICE: TG_table_name: trigger_test
+NOTICE: TG_table_schema: public
+NOTICE: TG_when: BEFORE
+NOTICE: args: {42 {statement trigger}}
+NOTICE: NEW: {i: 1, test_argisnull: f, test_return_null: f, test_skip: f, v: update}
+NOTICE: OLD: {i: 1, test_argisnull: f, test_return_null: f, test_skip: f, v: insert}
+NOTICE: TG_level: ROW
+NOTICE: TG_name: show_trigger_data_trig
+NOTICE: TG_op: UPDATE
+NOTICE: TG_relatts: {{} i v {} test_skip test_return_null test_argisnull}
+NOTICE: TG_relid: bogus:12345
+NOTICE: TG_table_name: trigger_test
+NOTICE: TG_table_schema: public
+NOTICE: TG_when: BEFORE
+NOTICE: args: {23 skidoo}
+delete from trigger_test;
+NOTICE: NEW: {}
+NOTICE: OLD: {}
+NOTICE: TG_level: STATEMENT
+NOTICE: TG_name: statement_trigger
+NOTICE: TG_op: DELETE
+NOTICE: TG_relatts: {{} i v {} test_skip test_return_null test_argisnull}
+NOTICE: TG_relid: bogus:12345
+NOTICE: TG_table_name: trigger_test
+NOTICE: TG_table_schema: public
+NOTICE: TG_when: BEFORE
+NOTICE: args: {42 {statement trigger}}
+NOTICE: NEW: {}
+NOTICE: OLD: {i: 1, test_argisnull: f, test_return_null: f, test_skip: f, v: update}
+NOTICE: TG_level: ROW
+NOTICE: TG_name: show_trigger_data_trig
+NOTICE: TG_op: DELETE
+NOTICE: TG_relatts: {{} i v {} test_skip test_return_null test_argisnull}
+NOTICE: TG_relid: bogus:12345
+NOTICE: TG_table_name: trigger_test
+NOTICE: TG_table_schema: public
+NOTICE: TG_when: BEFORE
+NOTICE: args: {23 skidoo}
+truncate trigger_test;
+NOTICE: NEW: {}
+NOTICE: OLD: {}
+NOTICE: TG_level: STATEMENT
+NOTICE: TG_name: statement_trigger
+NOTICE: TG_op: TRUNCATE
+NOTICE: TG_relatts: {{} i v {} test_skip test_return_null test_argisnull}
+NOTICE: TG_relid: bogus:12345
+NOTICE: TG_table_name: trigger_test
+NOTICE: TG_table_schema: public
+NOTICE: TG_when: BEFORE
+NOTICE: args: {42 {statement trigger}}
+DROP TRIGGER show_trigger_data_trig_before ON trigger_test_generated;
+DROP TRIGGER show_trigger_data_trig_after ON trigger_test_generated;
+-- should error
+insert into trigger_test(test_argisnull) values(true);
+NOTICE: NEW: {}
+NOTICE: OLD: {}
+NOTICE: TG_level: STATEMENT
+NOTICE: TG_name: statement_trigger
+NOTICE: TG_op: INSERT
+NOTICE: TG_relatts: {{} i v {} test_skip test_return_null test_argisnull}
+NOTICE: TG_relid: bogus:12345
+NOTICE: TG_table_name: trigger_test
+NOTICE: TG_table_schema: public
+NOTICE: TG_when: BEFORE
+NOTICE: args: {42 {statement trigger}}
+ERROR: argisnull cannot be used in triggers
+-- should error
+insert into trigger_test(test_return_null) values(true);
+NOTICE: NEW: {}
+NOTICE: OLD: {}
+NOTICE: TG_level: STATEMENT
+NOTICE: TG_name: statement_trigger
+NOTICE: TG_op: INSERT
+NOTICE: TG_relatts: {{} i v {} test_skip test_return_null test_argisnull}
+NOTICE: TG_relid: bogus:12345
+NOTICE: TG_table_name: trigger_test
+NOTICE: TG_table_schema: public
+NOTICE: TG_when: BEFORE
+NOTICE: args: {42 {statement trigger}}
+ERROR: return_null cannot be used in triggers
+-- test transition table visibility
+create table transition_table_test (id int, name text);
+insert into transition_table_test values (1, 'a');
+create function transition_table_test_f() returns trigger language pltcl as
+$$
+ spi_exec -array C "SELECT id, name FROM old_table" {
+ elog INFO "old: $C(id) -> $C(name)"
+ }
+ spi_exec -array C "SELECT id, name FROM new_table" {
+ elog INFO "new: $C(id) -> $C(name)"
+ }
+ return OK
+$$;
+CREATE TRIGGER a_t AFTER UPDATE ON transition_table_test
+ REFERENCING OLD TABLE AS old_table NEW TABLE AS new_table
+ FOR EACH STATEMENT EXECUTE PROCEDURE transition_table_test_f();
+update transition_table_test set name = 'b';
+INFO: old: 1 -> a
+INFO: new: 1 -> b
+drop table transition_table_test;
+drop function transition_table_test_f();
+-- dealing with generated columns
+CREATE FUNCTION generated_test_func1() RETURNS trigger
+LANGUAGE pltcl
+AS $$
+# not allowed
+set NEW(j) 5
+return [array get NEW]
+$$;
+CREATE TRIGGER generated_test_trigger1 BEFORE INSERT ON trigger_test_generated
+FOR EACH ROW EXECUTE PROCEDURE generated_test_func1();
+TRUNCATE trigger_test_generated;
+INSERT INTO trigger_test_generated (i) VALUES (1);
+ERROR: cannot set generated column "j"
+SELECT * FROM trigger_test_generated;
+ i | j
+---+---
+(0 rows)
+
diff --git a/src/pl/tcl/expected/pltcl_unicode.out b/src/pl/tcl/expected/pltcl_unicode.out
new file mode 100644
index 0000000..eea7d70
--- /dev/null
+++ b/src/pl/tcl/expected/pltcl_unicode.out
@@ -0,0 +1,45 @@
+--
+-- Unicode handling
+--
+-- Note: this test case is known to fail if the database encoding is
+-- EUC_CN, EUC_JP, EUC_KR, or EUC_TW, for lack of any equivalent to
+-- U+00A0 (no-break space) in those encodings. However, testing with
+-- plain ASCII data would be rather useless, so we must live with that.
+--
+SET client_encoding TO UTF8;
+CREATE TABLE unicode_test (
+ testvalue text NOT NULL
+);
+CREATE FUNCTION unicode_return() RETURNS text AS $$
+ return "\xA0"
+$$ LANGUAGE pltcl;
+CREATE FUNCTION unicode_trigger() RETURNS trigger AS $$
+ set NEW(testvalue) "\xA0"
+ return [array get NEW]
+$$ LANGUAGE pltcl;
+CREATE TRIGGER unicode_test_bi BEFORE INSERT ON unicode_test
+ FOR EACH ROW EXECUTE PROCEDURE unicode_trigger();
+CREATE FUNCTION unicode_plan1() RETURNS text AS $$
+ set plan [ spi_prepare {SELECT $1 AS testvalue} [ list "text" ] ]
+ spi_execp $plan [ list "\xA0" ]
+ return $testvalue
+$$ LANGUAGE pltcl;
+SELECT unicode_return();
+ unicode_return
+----------------
+  
+(1 row)
+
+INSERT INTO unicode_test (testvalue) VALUES ('test');
+SELECT * FROM unicode_test;
+ testvalue
+-----------
+  
+(1 row)
+
+SELECT unicode_plan1();
+ unicode_plan1
+---------------
+  
+(1 row)
+
diff --git a/src/pl/tcl/generate-pltclerrcodes.pl b/src/pl/tcl/generate-pltclerrcodes.pl
new file mode 100644
index 0000000..9c23091
--- /dev/null
+++ b/src/pl/tcl/generate-pltclerrcodes.pl
@@ -0,0 +1,40 @@
+#!/usr/bin/perl
+#
+# Generate the pltclerrcodes.h header from errcodes.txt
+# Copyright (c) 2000-2023, PostgreSQL Global Development Group
+
+use strict;
+use warnings;
+
+print
+ "/* autogenerated from src/backend/utils/errcodes.txt, do not edit */\n";
+print "/* there is deliberately not an #ifndef PLTCLERRCODES_H here */\n";
+
+open my $errcodes, '<', $ARGV[0] or die;
+
+while (<$errcodes>)
+{
+ chomp;
+
+ # Skip comments
+ next if /^#/;
+ next if /^\s*$/;
+
+ # Skip section headers
+ next if /^Section:/;
+
+ die unless /^([^\s]{5})\s+([EWS])\s+([^\s]+)(?:\s+)?([^\s]+)?/;
+
+ (my $sqlstate, my $type, my $errcode_macro, my $condition_name) =
+ ($1, $2, $3, $4);
+
+ # Skip non-errors
+ next unless $type eq 'E';
+
+ # Skip lines without PL/pgSQL condition names
+ next unless defined($condition_name);
+
+ print "\n{\n\t\"$condition_name\", $errcode_macro\n},\n";
+}
+
+close $errcodes;
diff --git a/src/pl/tcl/meson.build b/src/pl/tcl/meson.build
new file mode 100644
index 0000000..9a7faaa
--- /dev/null
+++ b/src/pl/tcl/meson.build
@@ -0,0 +1,64 @@
+# Copyright (c) 2022-2023, PostgreSQL Global Development Group
+
+if not tcl_dep.found()
+ subdir_done()
+endif
+
+pltcl_sources = files(
+ 'pltcl.c',
+)
+
+gen_pltclerrcodes = files('generate-pltclerrcodes.pl')
+pltcl_sources += custom_target('pltclerrcodes.h',
+ input: files('../../backend/utils/errcodes.txt'),
+ output: 'pltclerrcodes.h',
+ capture: true,
+ command: [perl, gen_pltclerrcodes, '@INPUT@']
+)
+
+if host_system == 'windows'
+ pltcl_sources += rc_lib_gen.process(win32ver_rc, extra_args: [
+ '--NAME', 'pltcl',
+ '--FILEDESC', 'PL/Tcl - procedural language',])
+endif
+
+pltcl = shared_module('pltcl',
+ pltcl_sources,
+ c_pch: pch_postgres_h,
+ include_directories: [include_directories('.'), postgres_inc],
+ kwargs: pg_mod_args + {
+ 'dependencies': [tcl_dep, pg_mod_args['dependencies']],
+ },
+)
+pl_targets += pltcl
+
+install_data(
+ 'pltcl.control',
+ 'pltcl--1.0.sql',
+ 'pltclu.control',
+ 'pltclu--1.0.sql',
+ install_dir: dir_data_extension,
+)
+
+pltcl_regress = [
+ 'pltcl_setup',
+ 'pltcl_queries',
+ 'pltcl_trigger',
+ 'pltcl_call',
+ 'pltcl_start_proc',
+ 'pltcl_subxact',
+ 'pltcl_unicode',
+ 'pltcl_transaction',
+]
+
+tests += {
+ 'name': 'pltcl',
+ 'sd': meson.current_source_dir(),
+ 'bd': meson.current_build_dir(),
+ 'regress': {
+ 'sql': pltcl_regress,
+ 'regress_args': ['--load-extension=pltcl'],
+ },
+}
+
+subdir('po', if_found: libintl)
diff --git a/src/pl/tcl/nls.mk b/src/pl/tcl/nls.mk
new file mode 100644
index 0000000..8366998
--- /dev/null
+++ b/src/pl/tcl/nls.mk
@@ -0,0 +1,5 @@
+# src/pl/tcl/nls.mk
+CATALOG_NAME = pltcl
+GETTEXT_FILES = pltcl.c
+GETTEXT_TRIGGERS = $(BACKEND_COMMON_GETTEXT_TRIGGERS)
+GETTEXT_FLAGS = $(BACKEND_COMMON_GETTEXT_FLAGS)
diff --git a/src/pl/tcl/pltcl--1.0.sql b/src/pl/tcl/pltcl--1.0.sql
new file mode 100644
index 0000000..2ed2b92
--- /dev/null
+++ b/src/pl/tcl/pltcl--1.0.sql
@@ -0,0 +1,12 @@
+/* src/pl/tcl/pltcl--1.0.sql */
+
+CREATE FUNCTION pltcl_call_handler() RETURNS language_handler
+ LANGUAGE c AS 'MODULE_PATHNAME';
+
+CREATE TRUSTED LANGUAGE pltcl
+ HANDLER pltcl_call_handler;
+
+-- The language object, but not the functions, can be owned by a non-superuser.
+ALTER LANGUAGE pltcl OWNER TO @extowner@;
+
+COMMENT ON LANGUAGE pltcl IS 'PL/Tcl procedural language';
diff --git a/src/pl/tcl/pltcl.c b/src/pl/tcl/pltcl.c
new file mode 100644
index 0000000..e8f9d7b
--- /dev/null
+++ b/src/pl/tcl/pltcl.c
@@ -0,0 +1,3288 @@
+/**********************************************************************
+ * pltcl.c - PostgreSQL support for Tcl as
+ * procedural language (PL)
+ *
+ * src/pl/tcl/pltcl.c
+ *
+ **********************************************************************/
+
+#include "postgres.h"
+
+#include <tcl.h>
+
+#include <unistd.h>
+#include <fcntl.h>
+
+#include "access/htup_details.h"
+#include "access/xact.h"
+#include "catalog/objectaccess.h"
+#include "catalog/pg_proc.h"
+#include "catalog/pg_type.h"
+#include "commands/event_trigger.h"
+#include "commands/trigger.h"
+#include "executor/spi.h"
+#include "fmgr.h"
+#include "funcapi.h"
+#include "mb/pg_wchar.h"
+#include "miscadmin.h"
+#include "nodes/makefuncs.h"
+#include "parser/parse_func.h"
+#include "parser/parse_type.h"
+#include "pgstat.h"
+#include "tcop/tcopprot.h"
+#include "utils/acl.h"
+#include "utils/builtins.h"
+#include "utils/lsyscache.h"
+#include "utils/memutils.h"
+#include "utils/regproc.h"
+#include "utils/rel.h"
+#include "utils/syscache.h"
+#include "utils/typcache.h"
+
+
+PG_MODULE_MAGIC;
+
+#define HAVE_TCL_VERSION(maj,min) \
+ ((TCL_MAJOR_VERSION > maj) || \
+ (TCL_MAJOR_VERSION == maj && TCL_MINOR_VERSION >= min))
+
+/* Insist on Tcl >= 8.4 */
+#if !HAVE_TCL_VERSION(8,4)
+#error PostgreSQL only supports Tcl 8.4 or later.
+#endif
+
+/* Hack to deal with Tcl 8.6 const-ification without losing compatibility */
+#ifndef CONST86
+#define CONST86
+#endif
+
+/* define our text domain for translations */
+#undef TEXTDOMAIN
+#define TEXTDOMAIN PG_TEXTDOMAIN("pltcl")
+
+
+/*
+ * Support for converting between UTF8 (which is what all strings going into
+ * or out of Tcl should be) and the database encoding.
+ *
+ * If you just use utf_u2e() or utf_e2u() directly, they will leak some
+ * palloc'd space when doing a conversion. This is not worth worrying about
+ * if it only happens, say, once per PL/Tcl function call. If it does seem
+ * worth worrying about, use the wrapper macros.
+ */
+
+static inline char *
+utf_u2e(const char *src)
+{
+ return pg_any_to_server(src, strlen(src), PG_UTF8);
+}
+
+static inline char *
+utf_e2u(const char *src)
+{
+ return pg_server_to_any(src, strlen(src), PG_UTF8);
+}
+
+#define UTF_BEGIN \
+ do { \
+ const char *_pltcl_utf_src = NULL; \
+ char *_pltcl_utf_dst = NULL
+
+#define UTF_END \
+ if (_pltcl_utf_src != (const char *) _pltcl_utf_dst) \
+ pfree(_pltcl_utf_dst); \
+ } while (0)
+
+#define UTF_U2E(x) \
+ (_pltcl_utf_dst = utf_u2e(_pltcl_utf_src = (x)))
+
+#define UTF_E2U(x) \
+ (_pltcl_utf_dst = utf_e2u(_pltcl_utf_src = (x)))
+
+
+/**********************************************************************
+ * Information associated with a Tcl interpreter. We have one interpreter
+ * that is used for all pltclu (untrusted) functions. For pltcl (trusted)
+ * functions, there is a separate interpreter for each effective SQL userid.
+ * (This is needed to ensure that an unprivileged user can't inject Tcl code
+ * that'll be executed with the privileges of some other SQL user.)
+ *
+ * The pltcl_interp_desc structs are kept in a Postgres hash table indexed
+ * by userid OID, with OID 0 used for the single untrusted interpreter.
+ **********************************************************************/
+typedef struct pltcl_interp_desc
+{
+ Oid user_id; /* Hash key (must be first!) */
+ Tcl_Interp *interp; /* The interpreter */
+ Tcl_HashTable query_hash; /* pltcl_query_desc structs */
+} pltcl_interp_desc;
+
+
+/**********************************************************************
+ * The information we cache about loaded procedures
+ *
+ * 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.)
+ *
+ * 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) */
+ MemoryContext fn_cxt; /* memory context for this procedure */
+ unsigned long fn_refcount; /* number of active references */
+ TransactionId fn_xmin; /* xmin of pg_proc row */
+ ItemPointerData fn_tid; /* TID of pg_proc row */
+ bool fn_readonly; /* is function readonly? */
+ bool lanpltrusted; /* is it pltcl (vs. pltclu)? */
+ pltcl_interp_desc *interp_desc; /* interpreter to use */
+ Oid result_typid; /* OID of fn's result type */
+ FmgrInfo result_in_func; /* input function for fn's result type */
+ Oid result_typioparam; /* param to pass to same */
+ bool fn_retisset; /* true if function returns a set */
+ bool fn_retistuple; /* true if function returns composite */
+ bool fn_retisdomain; /* true if function returns domain */
+ void *domain_info; /* opaque cache for domain checks */
+ int nargs; /* number of arguments */
+ /* these arrays have nargs entries: */
+ FmgrInfo *arg_out_func; /* output fns for arg types */
+ bool *arg_is_rowtype; /* is each arg composite? */
+} pltcl_proc_desc;
+
+
+/**********************************************************************
+ * The information we cache about prepared and saved plans
+ **********************************************************************/
+typedef struct pltcl_query_desc
+{
+ char qname[20];
+ SPIPlanPtr plan;
+ int nargs;
+ Oid *argtypes;
+ FmgrInfo *arginfuncs;
+ Oid *argtypioparams;
+} pltcl_query_desc;
+
+
+/**********************************************************************
+ * For speedy lookup, we maintain a hash table mapping from
+ * function OID + trigger flag + user OID to pltcl_proc_desc pointers.
+ * The reason the pltcl_proc_desc struct isn't directly part of the hash
+ * entry is to simplify recovery from errors during compile_pltcl_function.
+ *
+ * Note: if the same function is called by multiple userIDs within a session,
+ * there will be a separate pltcl_proc_desc entry for each userID in the case
+ * of pltcl functions, but only one entry for pltclu functions, because we
+ * set user_id = 0 for that case.
+ **********************************************************************/
+typedef struct pltcl_proc_key
+{
+ Oid proc_id; /* Function OID */
+
+ /*
+ * is_trigger is really a bool, but declare as Oid to ensure this struct
+ * contains no padding
+ */
+ Oid is_trigger; /* is it a trigger function? */
+ Oid user_id; /* User calling the function, or 0 */
+} pltcl_proc_key;
+
+typedef struct pltcl_proc_ptr
+{
+ pltcl_proc_key proc_key; /* Hash key (must be first!) */
+ pltcl_proc_desc *proc_ptr;
+} pltcl_proc_ptr;
+
+
+/**********************************************************************
+ * Per-call state
+ **********************************************************************/
+typedef struct pltcl_call_state
+{
+ /* Call info struct, or NULL in a trigger */
+ FunctionCallInfo fcinfo;
+
+ /* Trigger data, if we're in a normal (not event) trigger; else NULL */
+ TriggerData *trigdata;
+
+ /* Function we're executing (NULL if not yet identified) */
+ pltcl_proc_desc *prodesc;
+
+ /*
+ * Information for SRFs and functions returning composite types.
+ * ret_tupdesc and attinmeta are set up if either fn_retistuple or
+ * fn_retisset, since even a scalar-returning SRF needs a tuplestore.
+ */
+ TupleDesc ret_tupdesc; /* return rowtype, if retistuple or retisset */
+ AttInMetadata *attinmeta; /* metadata for building tuples of that type */
+
+ ReturnSetInfo *rsi; /* passed-in ReturnSetInfo, if any */
+ Tuplestorestate *tuple_store; /* SRFs accumulate result here */
+ MemoryContext tuple_store_cxt; /* context and resowner for tuplestore */
+ ResourceOwner tuple_store_owner;
+} pltcl_call_state;
+
+
+/**********************************************************************
+ * Global data
+ **********************************************************************/
+static char *pltcl_start_proc = NULL;
+static char *pltclu_start_proc = NULL;
+static bool pltcl_pm_init_done = false;
+static Tcl_Interp *pltcl_hold_interp = NULL;
+static HTAB *pltcl_interp_htab = NULL;
+static HTAB *pltcl_proc_htab = NULL;
+
+/* this is saved and restored by pltcl_handler */
+static pltcl_call_state *pltcl_current_call_state = NULL;
+
+/**********************************************************************
+ * Lookup table for SQLSTATE condition names
+ **********************************************************************/
+typedef struct
+{
+ const char *label;
+ int sqlerrstate;
+} TclExceptionNameMap;
+
+static const TclExceptionNameMap exception_name_map[] = {
+#include "pltclerrcodes.h" /* pgrminclude ignore */
+ {NULL, 0}
+};
+
+/**********************************************************************
+ * Forward declarations
+ **********************************************************************/
+
+static void pltcl_init_interp(pltcl_interp_desc *interp_desc,
+ Oid prolang, bool pltrusted);
+static pltcl_interp_desc *pltcl_fetch_interp(Oid prolang, bool pltrusted);
+static void call_pltcl_start_proc(Oid prolang, bool pltrusted);
+static void start_proc_error_callback(void *arg);
+
+static Datum pltcl_handler(PG_FUNCTION_ARGS, bool pltrusted);
+
+static Datum pltcl_func_handler(PG_FUNCTION_ARGS, pltcl_call_state *call_state,
+ bool pltrusted);
+static HeapTuple pltcl_trigger_handler(PG_FUNCTION_ARGS, pltcl_call_state *call_state,
+ bool pltrusted);
+static void pltcl_event_trigger_handler(PG_FUNCTION_ARGS, pltcl_call_state *call_state,
+ bool pltrusted);
+
+static void throw_tcl_error(Tcl_Interp *interp, const char *proname);
+
+static pltcl_proc_desc *compile_pltcl_function(Oid fn_oid, Oid tgreloid,
+ bool is_event_trigger,
+ bool pltrusted);
+
+static int pltcl_elog(ClientData cdata, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const objv[]);
+static void pltcl_construct_errorCode(Tcl_Interp *interp, ErrorData *edata);
+static const char *pltcl_get_condition_name(int sqlstate);
+static int pltcl_quote(ClientData cdata, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const objv[]);
+static int pltcl_argisnull(ClientData cdata, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const objv[]);
+static int pltcl_returnnull(ClientData cdata, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const objv[]);
+static int pltcl_returnnext(ClientData cdata, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const objv[]);
+static int pltcl_SPI_execute(ClientData cdata, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const objv[]);
+static int pltcl_process_SPI_result(Tcl_Interp *interp,
+ const char *arrayname,
+ Tcl_Obj *loop_body,
+ int spi_rc,
+ SPITupleTable *tuptable,
+ uint64 ntuples);
+static int pltcl_SPI_prepare(ClientData cdata, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const objv[]);
+static int pltcl_SPI_execute_plan(ClientData cdata, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const objv[]);
+static int pltcl_subtransaction(ClientData cdata, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const objv[]);
+static int pltcl_commit(ClientData cdata, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const objv[]);
+static int pltcl_rollback(ClientData cdata, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const objv[]);
+
+static void pltcl_subtrans_begin(MemoryContext oldcontext,
+ ResourceOwner oldowner);
+static void pltcl_subtrans_commit(MemoryContext oldcontext,
+ ResourceOwner oldowner);
+static void pltcl_subtrans_abort(Tcl_Interp *interp,
+ MemoryContext oldcontext,
+ ResourceOwner oldowner);
+
+static void pltcl_set_tuple_values(Tcl_Interp *interp, const char *arrayname,
+ uint64 tupno, HeapTuple tuple, TupleDesc tupdesc);
+static Tcl_Obj *pltcl_build_tuple_argument(HeapTuple tuple, TupleDesc tupdesc, bool include_generated);
+static HeapTuple pltcl_build_tuple_result(Tcl_Interp *interp,
+ Tcl_Obj **kvObjv, int kvObjc,
+ pltcl_call_state *call_state);
+static void pltcl_init_tuple_store(pltcl_call_state *call_state);
+
+
+/*
+ * Hack to override Tcl's builtin Notifier subsystem. This prevents the
+ * backend from becoming multithreaded, which breaks all sorts of things.
+ * That happens in the default version of Tcl_InitNotifier if the TCL library
+ * has been compiled with multithreading support (i.e. when TCL_THREADS is
+ * defined under Unix, and in all cases under Windows).
+ * It's okay to disable the notifier because we never enter the Tcl event loop
+ * from Postgres, so the notifier capabilities are initialized, but never
+ * used. Only InitNotifier and DeleteFileHandler ever seem to get called
+ * within Postgres, but we implement all the functions for completeness.
+ */
+static ClientData
+pltcl_InitNotifier(void)
+{
+ static int fakeThreadKey; /* To give valid address for ClientData */
+
+ return (ClientData) &(fakeThreadKey);
+}
+
+static void
+pltcl_FinalizeNotifier(ClientData clientData)
+{
+}
+
+static void
+pltcl_SetTimer(CONST86 Tcl_Time *timePtr)
+{
+}
+
+static void
+pltcl_AlertNotifier(ClientData clientData)
+{
+}
+
+static void
+pltcl_CreateFileHandler(int fd, int mask,
+ Tcl_FileProc *proc, ClientData clientData)
+{
+}
+
+static void
+pltcl_DeleteFileHandler(int fd)
+{
+}
+
+static void
+pltcl_ServiceModeHook(int mode)
+{
+}
+
+static int
+pltcl_WaitForEvent(CONST86 Tcl_Time *timePtr)
+{
+ return 0;
+}
+
+
+/*
+ * _PG_init() - library load-time initialization
+ *
+ * DO NOT make this static nor change its name!
+ *
+ * The work done here must be safe to do in the postmaster process,
+ * in case the pltcl library is preloaded in the postmaster.
+ */
+void
+_PG_init(void)
+{
+ Tcl_NotifierProcs notifier;
+ HASHCTL hash_ctl;
+
+ /* Be sure we do initialization only once (should be redundant now) */
+ if (pltcl_pm_init_done)
+ return;
+
+ pg_bindtextdomain(TEXTDOMAIN);
+
+#ifdef WIN32
+ /* Required on win32 to prevent error loading init.tcl */
+ Tcl_FindExecutable("");
+#endif
+
+ /*
+ * Override the functions in the Notifier subsystem. See comments above.
+ */
+ notifier.setTimerProc = pltcl_SetTimer;
+ notifier.waitForEventProc = pltcl_WaitForEvent;
+ notifier.createFileHandlerProc = pltcl_CreateFileHandler;
+ notifier.deleteFileHandlerProc = pltcl_DeleteFileHandler;
+ notifier.initNotifierProc = pltcl_InitNotifier;
+ notifier.finalizeNotifierProc = pltcl_FinalizeNotifier;
+ notifier.alertNotifierProc = pltcl_AlertNotifier;
+ notifier.serviceModeHookProc = pltcl_ServiceModeHook;
+ Tcl_SetNotifier(&notifier);
+
+ /************************************************************
+ * Create the dummy hold interpreter to prevent close of
+ * stdout and stderr on DeleteInterp
+ ************************************************************/
+ if ((pltcl_hold_interp = Tcl_CreateInterp()) == NULL)
+ elog(ERROR, "could not create dummy Tcl interpreter");
+ if (Tcl_Init(pltcl_hold_interp) == TCL_ERROR)
+ elog(ERROR, "could not initialize dummy Tcl interpreter");
+
+ /************************************************************
+ * Create the hash table for working interpreters
+ ************************************************************/
+ hash_ctl.keysize = sizeof(Oid);
+ hash_ctl.entrysize = sizeof(pltcl_interp_desc);
+ pltcl_interp_htab = hash_create("PL/Tcl interpreters",
+ 8,
+ &hash_ctl,
+ HASH_ELEM | HASH_BLOBS);
+
+ /************************************************************
+ * Create the hash table for function lookup
+ ************************************************************/
+ hash_ctl.keysize = sizeof(pltcl_proc_key);
+ hash_ctl.entrysize = sizeof(pltcl_proc_ptr);
+ pltcl_proc_htab = hash_create("PL/Tcl functions",
+ 100,
+ &hash_ctl,
+ HASH_ELEM | HASH_BLOBS);
+
+ /************************************************************
+ * Define PL/Tcl's custom GUCs
+ ************************************************************/
+ DefineCustomStringVariable("pltcl.start_proc",
+ gettext_noop("PL/Tcl function to call once when pltcl is first used."),
+ NULL,
+ &pltcl_start_proc,
+ NULL,
+ PGC_SUSET, 0,
+ NULL, NULL, NULL);
+ DefineCustomStringVariable("pltclu.start_proc",
+ gettext_noop("PL/TclU function to call once when pltclu is first used."),
+ NULL,
+ &pltclu_start_proc,
+ NULL,
+ PGC_SUSET, 0,
+ NULL, NULL, NULL);
+
+ MarkGUCPrefixReserved("pltcl");
+ MarkGUCPrefixReserved("pltclu");
+
+ pltcl_pm_init_done = true;
+}
+
+/**********************************************************************
+ * pltcl_init_interp() - initialize a new Tcl interpreter
+ **********************************************************************/
+static void
+pltcl_init_interp(pltcl_interp_desc *interp_desc, Oid prolang, bool pltrusted)
+{
+ Tcl_Interp *interp;
+ char interpname[32];
+
+ /************************************************************
+ * Create the Tcl interpreter subsidiary to pltcl_hold_interp.
+ * Note: Tcl automatically does Tcl_Init in the untrusted case,
+ * and it's not wanted in the trusted case.
+ ************************************************************/
+ snprintf(interpname, sizeof(interpname), "subsidiary_%u", interp_desc->user_id);
+ if ((interp = Tcl_CreateSlave(pltcl_hold_interp, interpname,
+ pltrusted ? 1 : 0)) == NULL)
+ elog(ERROR, "could not create subsidiary Tcl interpreter");
+
+ /************************************************************
+ * Initialize the query hash table associated with interpreter
+ ************************************************************/
+ Tcl_InitHashTable(&interp_desc->query_hash, TCL_STRING_KEYS);
+
+ /************************************************************
+ * Install the commands for SPI support in the interpreter
+ ************************************************************/
+ Tcl_CreateObjCommand(interp, "elog",
+ pltcl_elog, NULL, NULL);
+ Tcl_CreateObjCommand(interp, "quote",
+ pltcl_quote, NULL, NULL);
+ Tcl_CreateObjCommand(interp, "argisnull",
+ pltcl_argisnull, NULL, NULL);
+ Tcl_CreateObjCommand(interp, "return_null",
+ pltcl_returnnull, NULL, NULL);
+ Tcl_CreateObjCommand(interp, "return_next",
+ pltcl_returnnext, NULL, NULL);
+ Tcl_CreateObjCommand(interp, "spi_exec",
+ pltcl_SPI_execute, NULL, NULL);
+ Tcl_CreateObjCommand(interp, "spi_prepare",
+ pltcl_SPI_prepare, NULL, NULL);
+ Tcl_CreateObjCommand(interp, "spi_execp",
+ pltcl_SPI_execute_plan, NULL, NULL);
+ Tcl_CreateObjCommand(interp, "subtransaction",
+ pltcl_subtransaction, NULL, NULL);
+ Tcl_CreateObjCommand(interp, "commit",
+ pltcl_commit, NULL, NULL);
+ Tcl_CreateObjCommand(interp, "rollback",
+ pltcl_rollback, NULL, NULL);
+
+ /************************************************************
+ * Call the appropriate start_proc, if there is one.
+ *
+ * We must set interp_desc->interp before the call, else the start_proc
+ * won't find the interpreter it's supposed to use. But, if the
+ * start_proc fails, we want to abandon use of the interpreter.
+ ************************************************************/
+ PG_TRY();
+ {
+ interp_desc->interp = interp;
+ call_pltcl_start_proc(prolang, pltrusted);
+ }
+ PG_CATCH();
+ {
+ interp_desc->interp = NULL;
+ Tcl_DeleteInterp(interp);
+ PG_RE_THROW();
+ }
+ PG_END_TRY();
+}
+
+/**********************************************************************
+ * pltcl_fetch_interp() - fetch the Tcl interpreter to use for a function
+ *
+ * This also takes care of any on-first-use initialization required.
+ **********************************************************************/
+static pltcl_interp_desc *
+pltcl_fetch_interp(Oid prolang, bool pltrusted)
+{
+ Oid user_id;
+ pltcl_interp_desc *interp_desc;
+ bool found;
+
+ /* Find or create the interpreter hashtable entry for this userid */
+ if (pltrusted)
+ user_id = GetUserId();
+ else
+ user_id = InvalidOid;
+
+ interp_desc = hash_search(pltcl_interp_htab, &user_id,
+ HASH_ENTER,
+ &found);
+ if (!found)
+ interp_desc->interp = NULL;
+
+ /* If we haven't yet successfully made an interpreter, try to do that */
+ if (!interp_desc->interp)
+ pltcl_init_interp(interp_desc, prolang, pltrusted);
+
+ return interp_desc;
+}
+
+
+/**********************************************************************
+ * call_pltcl_start_proc() - Call user-defined initialization proc, if any
+ **********************************************************************/
+static void
+call_pltcl_start_proc(Oid prolang, bool pltrusted)
+{
+ LOCAL_FCINFO(fcinfo, 0);
+ char *start_proc;
+ const char *gucname;
+ ErrorContextCallback errcallback;
+ List *namelist;
+ Oid procOid;
+ HeapTuple procTup;
+ Form_pg_proc procStruct;
+ AclResult aclresult;
+ FmgrInfo finfo;
+ PgStat_FunctionCallUsage fcusage;
+
+ /* select appropriate GUC */
+ start_proc = pltrusted ? pltcl_start_proc : pltclu_start_proc;
+ gucname = pltrusted ? "pltcl.start_proc" : "pltclu.start_proc";
+
+ /* Nothing to do if it's empty or unset */
+ if (start_proc == NULL || start_proc[0] == '\0')
+ return;
+
+ /* Set up errcontext callback to make errors more helpful */
+ errcallback.callback = start_proc_error_callback;
+ errcallback.arg = unconstify(char *, gucname);
+ errcallback.previous = error_context_stack;
+ error_context_stack = &errcallback;
+
+ /* Parse possibly-qualified identifier and look up the function */
+ namelist = stringToQualifiedNameList(start_proc, NULL);
+ procOid = LookupFuncName(namelist, 0, NULL, false);
+
+ /* Current user must have permission to call function */
+ aclresult = object_aclcheck(ProcedureRelationId, procOid, GetUserId(), ACL_EXECUTE);
+ if (aclresult != ACLCHECK_OK)
+ aclcheck_error(aclresult, OBJECT_FUNCTION, start_proc);
+
+ /* Get the function's pg_proc entry */
+ procTup = SearchSysCache1(PROCOID, ObjectIdGetDatum(procOid));
+ if (!HeapTupleIsValid(procTup))
+ elog(ERROR, "cache lookup failed for function %u", procOid);
+ procStruct = (Form_pg_proc) GETSTRUCT(procTup);
+
+ /* It must be same language as the function we're currently calling */
+ if (procStruct->prolang != prolang)
+ ereport(ERROR,
+ (errcode(ERRCODE_OBJECT_NOT_IN_PREREQUISITE_STATE),
+ errmsg("function \"%s\" is in the wrong language",
+ start_proc)));
+
+ /*
+ * It must not be SECURITY DEFINER, either. This together with the
+ * language match check ensures that the function will execute in the same
+ * Tcl interpreter we just finished initializing.
+ */
+ if (procStruct->prosecdef)
+ ereport(ERROR,
+ (errcode(ERRCODE_OBJECT_NOT_IN_PREREQUISITE_STATE),
+ errmsg("function \"%s\" must not be SECURITY DEFINER",
+ start_proc)));
+
+ /* A-OK */
+ ReleaseSysCache(procTup);
+
+ /*
+ * Call the function using the normal SQL function call mechanism. We
+ * could perhaps cheat and jump directly to pltcl_handler(), but it seems
+ * better to do it this way so that the call is exposed to, eg, call
+ * statistics collection.
+ */
+ InvokeFunctionExecuteHook(procOid);
+ fmgr_info(procOid, &finfo);
+ InitFunctionCallInfoData(*fcinfo, &finfo,
+ 0,
+ InvalidOid, NULL, NULL);
+ pgstat_init_function_usage(fcinfo, &fcusage);
+ (void) FunctionCallInvoke(fcinfo);
+ pgstat_end_function_usage(&fcusage, true);
+
+ /* Pop the error context stack */
+ error_context_stack = errcallback.previous;
+}
+
+/*
+ * Error context callback for errors occurring during start_proc processing.
+ */
+static void
+start_proc_error_callback(void *arg)
+{
+ const char *gucname = (const char *) arg;
+
+ /* translator: %s is "pltcl.start_proc" or "pltclu.start_proc" */
+ errcontext("processing %s parameter", gucname);
+}
+
+
+/**********************************************************************
+ * pltcl_call_handler - This is the only visible function
+ * of the PL interpreter. The PostgreSQL
+ * function manager and trigger manager
+ * call this function for execution of
+ * PL/Tcl procedures.
+ **********************************************************************/
+PG_FUNCTION_INFO_V1(pltcl_call_handler);
+
+/* keep non-static */
+Datum
+pltcl_call_handler(PG_FUNCTION_ARGS)
+{
+ return pltcl_handler(fcinfo, true);
+}
+
+/*
+ * Alternative handler for unsafe functions
+ */
+PG_FUNCTION_INFO_V1(pltclu_call_handler);
+
+/* keep non-static */
+Datum
+pltclu_call_handler(PG_FUNCTION_ARGS)
+{
+ return pltcl_handler(fcinfo, false);
+}
+
+
+/**********************************************************************
+ * pltcl_handler() - Handler for function and trigger calls, for
+ * both trusted and untrusted interpreters.
+ **********************************************************************/
+static Datum
+pltcl_handler(PG_FUNCTION_ARGS, bool pltrusted)
+{
+ Datum retval = (Datum) 0;
+ pltcl_call_state current_call_state;
+ pltcl_call_state *save_call_state;
+
+ /*
+ * Initialize current_call_state to nulls/zeroes; in particular, set its
+ * prodesc pointer to null. Anything that sets it non-null should
+ * increase the prodesc's fn_refcount at the same time. We'll decrease
+ * the refcount, and then delete the prodesc if it's no longer referenced,
+ * on the way out of this function. This ensures that prodescs live as
+ * long as needed even if somebody replaces the originating pg_proc row
+ * while they're executing.
+ */
+ memset(&current_call_state, 0, sizeof(current_call_state));
+
+ /*
+ * Ensure that static pointer is saved/restored properly
+ */
+ save_call_state = pltcl_current_call_state;
+ pltcl_current_call_state = &current_call_state;
+
+ PG_TRY();
+ {
+ /*
+ * Determine if called as function or trigger and call appropriate
+ * subhandler
+ */
+ if (CALLED_AS_TRIGGER(fcinfo))
+ {
+ /* invoke the trigger handler */
+ retval = PointerGetDatum(pltcl_trigger_handler(fcinfo,
+ &current_call_state,
+ pltrusted));
+ }
+ else if (CALLED_AS_EVENT_TRIGGER(fcinfo))
+ {
+ /* invoke the event trigger handler */
+ pltcl_event_trigger_handler(fcinfo, &current_call_state, pltrusted);
+ retval = (Datum) 0;
+ }
+ else
+ {
+ /* invoke the regular function handler */
+ current_call_state.fcinfo = fcinfo;
+ retval = pltcl_func_handler(fcinfo, &current_call_state, pltrusted);
+ }
+ }
+ PG_FINALLY();
+ {
+ /* Restore static pointer, then clean up the prodesc refcount if any */
+ /*
+ * (We're being paranoid in case an error is thrown in context
+ * deletion)
+ */
+ pltcl_current_call_state = save_call_state;
+ if (current_call_state.prodesc != NULL)
+ {
+ Assert(current_call_state.prodesc->fn_refcount > 0);
+ if (--current_call_state.prodesc->fn_refcount == 0)
+ MemoryContextDelete(current_call_state.prodesc->fn_cxt);
+ }
+ }
+ PG_END_TRY();
+
+ return retval;
+}
+
+
+/**********************************************************************
+ * pltcl_func_handler() - Handler for regular function calls
+ **********************************************************************/
+static Datum
+pltcl_func_handler(PG_FUNCTION_ARGS, pltcl_call_state *call_state,
+ bool pltrusted)
+{
+ bool nonatomic;
+ pltcl_proc_desc *prodesc;
+ Tcl_Interp *volatile interp;
+ Tcl_Obj *tcl_cmd;
+ int i;
+ int tcl_rc;
+ Datum retval;
+
+ nonatomic = fcinfo->context &&
+ IsA(fcinfo->context, CallContext) &&
+ !castNode(CallContext, fcinfo->context)->atomic;
+
+ /* Connect to SPI manager */
+ if (SPI_connect_ext(nonatomic ? SPI_OPT_NONATOMIC : 0) != SPI_OK_CONNECT)
+ elog(ERROR, "could not connect to SPI manager");
+
+ /* Find or compile the function */
+ prodesc = compile_pltcl_function(fcinfo->flinfo->fn_oid, InvalidOid,
+ false, pltrusted);
+
+ call_state->prodesc = prodesc;
+ prodesc->fn_refcount++;
+
+ interp = prodesc->interp_desc->interp;
+
+ /*
+ * If we're a SRF, check caller can handle materialize mode, and save
+ * relevant info into call_state. We must ensure that the returned
+ * tuplestore is owned by the caller's context, even if we first create it
+ * inside a subtransaction.
+ */
+ if (prodesc->fn_retisset)
+ {
+ ReturnSetInfo *rsi = (ReturnSetInfo *) fcinfo->resultinfo;
+
+ if (!rsi || !IsA(rsi, ReturnSetInfo))
+ ereport(ERROR,
+ (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
+ errmsg("set-valued function called in context that cannot accept a set")));
+
+ if (!(rsi->allowedModes & SFRM_Materialize))
+ ereport(ERROR,
+ (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
+ errmsg("materialize mode required, but it is not allowed in this context")));
+
+ call_state->rsi = rsi;
+ call_state->tuple_store_cxt = rsi->econtext->ecxt_per_query_memory;
+ call_state->tuple_store_owner = CurrentResourceOwner;
+ }
+
+ /************************************************************
+ * Create the tcl command to call the internal
+ * proc in the Tcl interpreter
+ ************************************************************/
+ tcl_cmd = Tcl_NewObj();
+ Tcl_ListObjAppendElement(NULL, tcl_cmd,
+ Tcl_NewStringObj(prodesc->internal_proname, -1));
+
+ /* We hold a refcount on tcl_cmd just to be sure it stays around */
+ Tcl_IncrRefCount(tcl_cmd);
+
+ /************************************************************
+ * Add all call arguments to the command
+ ************************************************************/
+ PG_TRY();
+ {
+ for (i = 0; i < prodesc->nargs; i++)
+ {
+ if (prodesc->arg_is_rowtype[i])
+ {
+ /**************************************************
+ * For tuple values, add a list for 'array set ...'
+ **************************************************/
+ if (fcinfo->args[i].isnull)
+ Tcl_ListObjAppendElement(NULL, tcl_cmd, Tcl_NewObj());
+ else
+ {
+ HeapTupleHeader td;
+ Oid tupType;
+ int32 tupTypmod;
+ TupleDesc tupdesc;
+ HeapTupleData tmptup;
+ Tcl_Obj *list_tmp;
+
+ td = DatumGetHeapTupleHeader(fcinfo->args[i].value);
+ /* Extract rowtype info and find a tupdesc */
+ tupType = HeapTupleHeaderGetTypeId(td);
+ tupTypmod = HeapTupleHeaderGetTypMod(td);
+ tupdesc = lookup_rowtype_tupdesc(tupType, tupTypmod);
+ /* Build a temporary HeapTuple control structure */
+ tmptup.t_len = HeapTupleHeaderGetDatumLength(td);
+ tmptup.t_data = td;
+
+ list_tmp = pltcl_build_tuple_argument(&tmptup, tupdesc, true);
+ Tcl_ListObjAppendElement(NULL, tcl_cmd, list_tmp);
+
+ ReleaseTupleDesc(tupdesc);
+ }
+ }
+ else
+ {
+ /**************************************************
+ * Single values are added as string element
+ * of their external representation
+ **************************************************/
+ if (fcinfo->args[i].isnull)
+ Tcl_ListObjAppendElement(NULL, tcl_cmd, Tcl_NewObj());
+ else
+ {
+ char *tmp;
+
+ tmp = OutputFunctionCall(&prodesc->arg_out_func[i],
+ fcinfo->args[i].value);
+ UTF_BEGIN;
+ Tcl_ListObjAppendElement(NULL, tcl_cmd,
+ Tcl_NewStringObj(UTF_E2U(tmp), -1));
+ UTF_END;
+ pfree(tmp);
+ }
+ }
+ }
+ }
+ PG_CATCH();
+ {
+ /* Release refcount to free tcl_cmd */
+ Tcl_DecrRefCount(tcl_cmd);
+ PG_RE_THROW();
+ }
+ PG_END_TRY();
+
+ /************************************************************
+ * Call the Tcl function
+ *
+ * We assume no PG error can be thrown directly from this call.
+ ************************************************************/
+ tcl_rc = Tcl_EvalObjEx(interp, tcl_cmd, (TCL_EVAL_DIRECT | TCL_EVAL_GLOBAL));
+
+ /* Release refcount to free tcl_cmd (and all subsidiary objects) */
+ Tcl_DecrRefCount(tcl_cmd);
+
+ /************************************************************
+ * Check for errors reported by Tcl.
+ ************************************************************/
+ if (tcl_rc != TCL_OK)
+ throw_tcl_error(interp, prodesc->user_proname);
+
+ /************************************************************
+ * Disconnect from SPI manager and then create the return
+ * value datum (if the input function does a palloc for it
+ * this must not be allocated in the SPI memory context
+ * because SPI_finish would free it). But don't try to call
+ * the result_in_func if we've been told to return a NULL;
+ * the Tcl result may not be a valid value of the result type
+ * in that case.
+ ************************************************************/
+ if (SPI_finish() != SPI_OK_FINISH)
+ elog(ERROR, "SPI_finish() failed");
+
+ if (prodesc->fn_retisset)
+ {
+ ReturnSetInfo *rsi = call_state->rsi;
+
+ /* We already checked this is OK */
+ rsi->returnMode = SFRM_Materialize;
+
+ /* If we produced any tuples, send back the result */
+ if (call_state->tuple_store)
+ {
+ rsi->setResult = call_state->tuple_store;
+ if (call_state->ret_tupdesc)
+ {
+ MemoryContext oldcxt;
+
+ oldcxt = MemoryContextSwitchTo(call_state->tuple_store_cxt);
+ rsi->setDesc = CreateTupleDescCopy(call_state->ret_tupdesc);
+ MemoryContextSwitchTo(oldcxt);
+ }
+ }
+ retval = (Datum) 0;
+ fcinfo->isnull = true;
+ }
+ else if (fcinfo->isnull)
+ {
+ retval = InputFunctionCall(&prodesc->result_in_func,
+ NULL,
+ prodesc->result_typioparam,
+ -1);
+ }
+ else if (prodesc->fn_retistuple)
+ {
+ TupleDesc td;
+ HeapTuple tup;
+ Tcl_Obj *resultObj;
+ Tcl_Obj **resultObjv;
+ int resultObjc;
+
+ /*
+ * Set up data about result type. XXX it's tempting to consider
+ * caching this in the prodesc, in the common case where the rowtype
+ * is determined by the function not the calling query. But we'd have
+ * to be able to deal with ADD/DROP/ALTER COLUMN events when the
+ * result type is a named composite type, so it's not exactly trivial.
+ * Maybe worth improving someday.
+ */
+ switch (get_call_result_type(fcinfo, NULL, &td))
+ {
+ case TYPEFUNC_COMPOSITE:
+ /* success */
+ break;
+ case TYPEFUNC_COMPOSITE_DOMAIN:
+ Assert(prodesc->fn_retisdomain);
+ break;
+ case TYPEFUNC_RECORD:
+ /* failed to determine actual type of RECORD */
+ ereport(ERROR,
+ (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
+ errmsg("function returning record called in context "
+ "that cannot accept type record")));
+ break;
+ default:
+ /* result type isn't composite? */
+ elog(ERROR, "return type must be a row type");
+ break;
+ }
+
+ Assert(!call_state->ret_tupdesc);
+ Assert(!call_state->attinmeta);
+ call_state->ret_tupdesc = td;
+ call_state->attinmeta = TupleDescGetAttInMetadata(td);
+
+ /* Convert function result to tuple */
+ resultObj = Tcl_GetObjResult(interp);
+ if (Tcl_ListObjGetElements(interp, resultObj, &resultObjc, &resultObjv) == TCL_ERROR)
+ throw_tcl_error(interp, prodesc->user_proname);
+
+ tup = pltcl_build_tuple_result(interp, resultObjv, resultObjc,
+ call_state);
+ retval = HeapTupleGetDatum(tup);
+ }
+ else
+ retval = InputFunctionCall(&prodesc->result_in_func,
+ utf_u2e(Tcl_GetStringResult(interp)),
+ prodesc->result_typioparam,
+ -1);
+
+ return retval;
+}
+
+
+/**********************************************************************
+ * pltcl_trigger_handler() - Handler for trigger calls
+ **********************************************************************/
+static HeapTuple
+pltcl_trigger_handler(PG_FUNCTION_ARGS, pltcl_call_state *call_state,
+ bool pltrusted)
+{
+ pltcl_proc_desc *prodesc;
+ Tcl_Interp *volatile interp;
+ TriggerData *trigdata = (TriggerData *) fcinfo->context;
+ char *stroid;
+ TupleDesc tupdesc;
+ volatile HeapTuple rettup;
+ Tcl_Obj *tcl_cmd;
+ Tcl_Obj *tcl_trigtup;
+ int tcl_rc;
+ int i;
+ const char *result;
+ int result_Objc;
+ Tcl_Obj **result_Objv;
+ int rc PG_USED_FOR_ASSERTS_ONLY;
+
+ call_state->trigdata = trigdata;
+
+ /* Connect to SPI manager */
+ if (SPI_connect() != SPI_OK_CONNECT)
+ elog(ERROR, "could not connect to SPI manager");
+
+ /* Make transition tables visible to this SPI connection */
+ rc = SPI_register_trigger_data(trigdata);
+ Assert(rc >= 0);
+
+ /* Find or compile the function */
+ prodesc = compile_pltcl_function(fcinfo->flinfo->fn_oid,
+ RelationGetRelid(trigdata->tg_relation),
+ false, /* not an event trigger */
+ pltrusted);
+
+ call_state->prodesc = prodesc;
+ prodesc->fn_refcount++;
+
+ interp = prodesc->interp_desc->interp;
+
+ tupdesc = RelationGetDescr(trigdata->tg_relation);
+
+ /************************************************************
+ * Create the tcl command to call the internal
+ * proc in the interpreter
+ ************************************************************/
+ tcl_cmd = Tcl_NewObj();
+ Tcl_IncrRefCount(tcl_cmd);
+
+ PG_TRY();
+ {
+ /* The procedure name (note this is all ASCII, so no utf_e2u) */
+ Tcl_ListObjAppendElement(NULL, tcl_cmd,
+ Tcl_NewStringObj(prodesc->internal_proname, -1));
+
+ /* The trigger name for argument TG_name */
+ Tcl_ListObjAppendElement(NULL, tcl_cmd,
+ Tcl_NewStringObj(utf_e2u(trigdata->tg_trigger->tgname), -1));
+
+ /* The oid of the trigger relation for argument TG_relid */
+ /* Consider not converting to a string for more performance? */
+ stroid = DatumGetCString(DirectFunctionCall1(oidout,
+ ObjectIdGetDatum(trigdata->tg_relation->rd_id)));
+ Tcl_ListObjAppendElement(NULL, tcl_cmd,
+ Tcl_NewStringObj(stroid, -1));
+ pfree(stroid);
+
+ /* The name of the table the trigger is acting on: TG_table_name */
+ stroid = SPI_getrelname(trigdata->tg_relation);
+ Tcl_ListObjAppendElement(NULL, tcl_cmd,
+ Tcl_NewStringObj(utf_e2u(stroid), -1));
+ pfree(stroid);
+
+ /* The schema of the table the trigger is acting on: TG_table_schema */
+ stroid = SPI_getnspname(trigdata->tg_relation);
+ Tcl_ListObjAppendElement(NULL, tcl_cmd,
+ Tcl_NewStringObj(utf_e2u(stroid), -1));
+ pfree(stroid);
+
+ /* A list of attribute names for argument TG_relatts */
+ tcl_trigtup = Tcl_NewObj();
+ Tcl_ListObjAppendElement(NULL, tcl_trigtup, Tcl_NewObj());
+ for (i = 0; i < tupdesc->natts; i++)
+ {
+ Form_pg_attribute att = TupleDescAttr(tupdesc, i);
+
+ if (att->attisdropped)
+ Tcl_ListObjAppendElement(NULL, tcl_trigtup, Tcl_NewObj());
+ else
+ Tcl_ListObjAppendElement(NULL, tcl_trigtup,
+ Tcl_NewStringObj(utf_e2u(NameStr(att->attname)), -1));
+ }
+ Tcl_ListObjAppendElement(NULL, tcl_cmd, tcl_trigtup);
+
+ /* The when part of the event for TG_when */
+ if (TRIGGER_FIRED_BEFORE(trigdata->tg_event))
+ Tcl_ListObjAppendElement(NULL, tcl_cmd,
+ Tcl_NewStringObj("BEFORE", -1));
+ else if (TRIGGER_FIRED_AFTER(trigdata->tg_event))
+ Tcl_ListObjAppendElement(NULL, tcl_cmd,
+ Tcl_NewStringObj("AFTER", -1));
+ else if (TRIGGER_FIRED_INSTEAD(trigdata->tg_event))
+ Tcl_ListObjAppendElement(NULL, tcl_cmd,
+ Tcl_NewStringObj("INSTEAD OF", -1));
+ else
+ elog(ERROR, "unrecognized WHEN tg_event: %u", trigdata->tg_event);
+
+ /* The level part of the event for TG_level */
+ if (TRIGGER_FIRED_FOR_ROW(trigdata->tg_event))
+ {
+ Tcl_ListObjAppendElement(NULL, tcl_cmd,
+ Tcl_NewStringObj("ROW", -1));
+
+ /*
+ * Now the command part of the event for TG_op and data for NEW
+ * and OLD
+ *
+ * Note: In BEFORE trigger, stored generated columns are not
+ * computed yet, so don't make them accessible in NEW row.
+ */
+ if (TRIGGER_FIRED_BY_INSERT(trigdata->tg_event))
+ {
+ Tcl_ListObjAppendElement(NULL, tcl_cmd,
+ Tcl_NewStringObj("INSERT", -1));
+
+ Tcl_ListObjAppendElement(NULL, tcl_cmd,
+ pltcl_build_tuple_argument(trigdata->tg_trigtuple,
+ tupdesc,
+ !TRIGGER_FIRED_BEFORE(trigdata->tg_event)));
+ Tcl_ListObjAppendElement(NULL, tcl_cmd, Tcl_NewObj());
+
+ rettup = trigdata->tg_trigtuple;
+ }
+ else if (TRIGGER_FIRED_BY_DELETE(trigdata->tg_event))
+ {
+ Tcl_ListObjAppendElement(NULL, tcl_cmd,
+ Tcl_NewStringObj("DELETE", -1));
+
+ Tcl_ListObjAppendElement(NULL, tcl_cmd, Tcl_NewObj());
+ Tcl_ListObjAppendElement(NULL, tcl_cmd,
+ pltcl_build_tuple_argument(trigdata->tg_trigtuple,
+ tupdesc,
+ true));
+
+ rettup = trigdata->tg_trigtuple;
+ }
+ else if (TRIGGER_FIRED_BY_UPDATE(trigdata->tg_event))
+ {
+ Tcl_ListObjAppendElement(NULL, tcl_cmd,
+ Tcl_NewStringObj("UPDATE", -1));
+
+ Tcl_ListObjAppendElement(NULL, tcl_cmd,
+ pltcl_build_tuple_argument(trigdata->tg_newtuple,
+ tupdesc,
+ !TRIGGER_FIRED_BEFORE(trigdata->tg_event)));
+ Tcl_ListObjAppendElement(NULL, tcl_cmd,
+ pltcl_build_tuple_argument(trigdata->tg_trigtuple,
+ tupdesc,
+ true));
+
+ rettup = trigdata->tg_newtuple;
+ }
+ else
+ elog(ERROR, "unrecognized OP tg_event: %u", trigdata->tg_event);
+ }
+ else if (TRIGGER_FIRED_FOR_STATEMENT(trigdata->tg_event))
+ {
+ Tcl_ListObjAppendElement(NULL, tcl_cmd,
+ Tcl_NewStringObj("STATEMENT", -1));
+
+ if (TRIGGER_FIRED_BY_INSERT(trigdata->tg_event))
+ Tcl_ListObjAppendElement(NULL, tcl_cmd,
+ Tcl_NewStringObj("INSERT", -1));
+ else if (TRIGGER_FIRED_BY_DELETE(trigdata->tg_event))
+ Tcl_ListObjAppendElement(NULL, tcl_cmd,
+ Tcl_NewStringObj("DELETE", -1));
+ else if (TRIGGER_FIRED_BY_UPDATE(trigdata->tg_event))
+ Tcl_ListObjAppendElement(NULL, tcl_cmd,
+ Tcl_NewStringObj("UPDATE", -1));
+ else if (TRIGGER_FIRED_BY_TRUNCATE(trigdata->tg_event))
+ Tcl_ListObjAppendElement(NULL, tcl_cmd,
+ Tcl_NewStringObj("TRUNCATE", -1));
+ else
+ elog(ERROR, "unrecognized OP tg_event: %u", trigdata->tg_event);
+
+ Tcl_ListObjAppendElement(NULL, tcl_cmd, Tcl_NewObj());
+ Tcl_ListObjAppendElement(NULL, tcl_cmd, Tcl_NewObj());
+
+ rettup = (HeapTuple) NULL;
+ }
+ else
+ elog(ERROR, "unrecognized LEVEL tg_event: %u", trigdata->tg_event);
+
+ /* Finally append the arguments from CREATE TRIGGER */
+ for (i = 0; i < trigdata->tg_trigger->tgnargs; i++)
+ Tcl_ListObjAppendElement(NULL, tcl_cmd,
+ Tcl_NewStringObj(utf_e2u(trigdata->tg_trigger->tgargs[i]), -1));
+ }
+ PG_CATCH();
+ {
+ Tcl_DecrRefCount(tcl_cmd);
+ PG_RE_THROW();
+ }
+ PG_END_TRY();
+
+ /************************************************************
+ * Call the Tcl function
+ *
+ * We assume no PG error can be thrown directly from this call.
+ ************************************************************/
+ tcl_rc = Tcl_EvalObjEx(interp, tcl_cmd, (TCL_EVAL_DIRECT | TCL_EVAL_GLOBAL));
+
+ /* Release refcount to free tcl_cmd (and all subsidiary objects) */
+ Tcl_DecrRefCount(tcl_cmd);
+
+ /************************************************************
+ * Check for errors reported by Tcl.
+ ************************************************************/
+ if (tcl_rc != TCL_OK)
+ throw_tcl_error(interp, prodesc->user_proname);
+
+ /************************************************************
+ * Exit SPI environment.
+ ************************************************************/
+ if (SPI_finish() != SPI_OK_FINISH)
+ elog(ERROR, "SPI_finish() failed");
+
+ /************************************************************
+ * The return value from the procedure might be one of
+ * the magic strings OK or SKIP, or a list from array get.
+ * We can check for OK or SKIP without worrying about encoding.
+ ************************************************************/
+ result = Tcl_GetStringResult(interp);
+
+ if (strcmp(result, "OK") == 0)
+ return rettup;
+ if (strcmp(result, "SKIP") == 0)
+ return (HeapTuple) NULL;
+
+ /************************************************************
+ * Otherwise, the return value should be a column name/value list
+ * specifying the modified tuple to return.
+ ************************************************************/
+ if (Tcl_ListObjGetElements(interp, Tcl_GetObjResult(interp),
+ &result_Objc, &result_Objv) != TCL_OK)
+ ereport(ERROR,
+ (errcode(ERRCODE_E_R_I_E_TRIGGER_PROTOCOL_VIOLATED),
+ errmsg("could not split return value from trigger: %s",
+ utf_u2e(Tcl_GetStringResult(interp)))));
+
+ /* Convert function result to tuple */
+ rettup = pltcl_build_tuple_result(interp, result_Objv, result_Objc,
+ call_state);
+
+ return rettup;
+}
+
+/**********************************************************************
+ * pltcl_event_trigger_handler() - Handler for event trigger calls
+ **********************************************************************/
+static void
+pltcl_event_trigger_handler(PG_FUNCTION_ARGS, pltcl_call_state *call_state,
+ bool pltrusted)
+{
+ pltcl_proc_desc *prodesc;
+ Tcl_Interp *volatile interp;
+ EventTriggerData *tdata = (EventTriggerData *) fcinfo->context;
+ Tcl_Obj *tcl_cmd;
+ int tcl_rc;
+
+ /* Connect to SPI manager */
+ if (SPI_connect() != SPI_OK_CONNECT)
+ elog(ERROR, "could not connect to SPI manager");
+
+ /* Find or compile the function */
+ prodesc = compile_pltcl_function(fcinfo->flinfo->fn_oid,
+ InvalidOid, true, pltrusted);
+
+ call_state->prodesc = prodesc;
+ prodesc->fn_refcount++;
+
+ interp = prodesc->interp_desc->interp;
+
+ /* Create the tcl command and call the internal proc */
+ tcl_cmd = Tcl_NewObj();
+ Tcl_IncrRefCount(tcl_cmd);
+ Tcl_ListObjAppendElement(NULL, tcl_cmd,
+ Tcl_NewStringObj(prodesc->internal_proname, -1));
+ Tcl_ListObjAppendElement(NULL, tcl_cmd,
+ Tcl_NewStringObj(utf_e2u(tdata->event), -1));
+ Tcl_ListObjAppendElement(NULL, tcl_cmd,
+ Tcl_NewStringObj(utf_e2u(GetCommandTagName(tdata->tag)),
+ -1));
+
+ tcl_rc = Tcl_EvalObjEx(interp, tcl_cmd, (TCL_EVAL_DIRECT | TCL_EVAL_GLOBAL));
+
+ /* Release refcount to free tcl_cmd (and all subsidiary objects) */
+ Tcl_DecrRefCount(tcl_cmd);
+
+ /* Check for errors reported by Tcl. */
+ if (tcl_rc != TCL_OK)
+ throw_tcl_error(interp, prodesc->user_proname);
+
+ if (SPI_finish() != SPI_OK_FINISH)
+ elog(ERROR, "SPI_finish() failed");
+}
+
+
+/**********************************************************************
+ * throw_tcl_error - ereport an error returned from the Tcl interpreter
+ **********************************************************************/
+static void
+throw_tcl_error(Tcl_Interp *interp, const char *proname)
+{
+ /*
+ * Caution is needed here because Tcl_GetVar could overwrite the
+ * interpreter result (even though it's not really supposed to), and we
+ * can't control the order of evaluation of ereport arguments. Hence, make
+ * real sure we have our own copy of the result string before invoking
+ * Tcl_GetVar.
+ */
+ char *emsg;
+ char *econtext;
+
+ emsg = pstrdup(utf_u2e(Tcl_GetStringResult(interp)));
+ econtext = utf_u2e(Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY));
+ ereport(ERROR,
+ (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION),
+ errmsg("%s", emsg),
+ errcontext("%s\nin PL/Tcl function \"%s\"",
+ econtext, proname)));
+}
+
+
+/**********************************************************************
+ * compile_pltcl_function - compile (or hopefully just look up) function
+ *
+ * tgreloid is the OID of the relation when compiling a trigger, or zero
+ * (InvalidOid) when compiling a plain function.
+ **********************************************************************/
+static pltcl_proc_desc *
+compile_pltcl_function(Oid fn_oid, Oid tgreloid,
+ bool is_event_trigger, bool pltrusted)
+{
+ HeapTuple procTup;
+ Form_pg_proc procStruct;
+ pltcl_proc_key proc_key;
+ pltcl_proc_ptr *proc_ptr;
+ bool found;
+ pltcl_proc_desc *prodesc;
+ pltcl_proc_desc *old_prodesc;
+ volatile MemoryContext proc_cxt = NULL;
+ Tcl_DString proc_internal_def;
+ Tcl_DString proc_internal_body;
+
+ /* We'll need the pg_proc tuple in any case... */
+ procTup = SearchSysCache1(PROCOID, ObjectIdGetDatum(fn_oid));
+ if (!HeapTupleIsValid(procTup))
+ elog(ERROR, "cache lookup failed for function %u", fn_oid);
+ procStruct = (Form_pg_proc) GETSTRUCT(procTup);
+
+ /*
+ * Look up function in pltcl_proc_htab; if it's not there, create an entry
+ * and set the entry's proc_ptr to NULL.
+ */
+ proc_key.proc_id = fn_oid;
+ proc_key.is_trigger = OidIsValid(tgreloid);
+ proc_key.user_id = pltrusted ? GetUserId() : InvalidOid;
+
+ proc_ptr = hash_search(pltcl_proc_htab, &proc_key,
+ HASH_ENTER,
+ &found);
+ if (!found)
+ proc_ptr->proc_ptr = NULL;
+
+ prodesc = proc_ptr->proc_ptr;
+
+ /************************************************************
+ * If it's present, must check whether it's still up to date.
+ * This is needed because CREATE OR REPLACE FUNCTION can modify the
+ * function's pg_proc entry without changing its OID.
+ ************************************************************/
+ if (prodesc != NULL &&
+ prodesc->fn_xmin == HeapTupleHeaderGetRawXmin(procTup->t_data) &&
+ ItemPointerEquals(&prodesc->fn_tid, &procTup->t_self))
+ {
+ /* It's still up-to-date, so we can use it */
+ ReleaseSysCache(procTup);
+ return prodesc;
+ }
+
+ /************************************************************
+ * If we haven't found it in the hashtable, we analyze
+ * the functions arguments and returntype and store
+ * the in-/out-functions in the prodesc block and create
+ * a new hashtable entry for it.
+ *
+ * Then we load the procedure into the Tcl interpreter.
+ ************************************************************/
+ Tcl_DStringInit(&proc_internal_def);
+ Tcl_DStringInit(&proc_internal_body);
+ PG_TRY();
+ {
+ bool is_trigger = OidIsValid(tgreloid);
+ char internal_proname[128];
+ HeapTuple typeTup;
+ Form_pg_type typeStruct;
+ char proc_internal_args[33 * FUNC_MAX_ARGS];
+ Datum prosrcdatum;
+ char *proc_source;
+ char buf[48];
+ 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.
+ ************************************************************/
+ if (is_event_trigger)
+ snprintf(internal_proname, sizeof(internal_proname),
+ "__PLTcl_proc_%u_evttrigger", fn_oid);
+ else if (is_trigger)
+ snprintf(internal_proname, sizeof(internal_proname),
+ "__PLTcl_proc_%u_trigger", fn_oid);
+ else
+ snprintf(internal_proname, sizeof(internal_proname),
+ "__PLTcl_proc_%u", fn_oid);
+
+ /************************************************************
+ * Allocate a context that will hold all PG data for the procedure.
+ ************************************************************/
+ proc_cxt = AllocSetContextCreate(TopMemoryContext,
+ "PL/Tcl function",
+ ALLOCSET_SMALL_SIZES);
+
+ /************************************************************
+ * Allocate and fill a new procedure description block.
+ * struct prodesc and subsidiary data must all live in proc_cxt.
+ ************************************************************/
+ oldcontext = MemoryContextSwitchTo(proc_cxt);
+ prodesc = (pltcl_proc_desc *) palloc0(sizeof(pltcl_proc_desc));
+ prodesc->user_proname = pstrdup(NameStr(procStruct->proname));
+ MemoryContextSetIdentifier(proc_cxt, prodesc->user_proname);
+ prodesc->internal_proname = pstrdup(internal_proname);
+ prodesc->fn_cxt = proc_cxt;
+ prodesc->fn_refcount = 0;
+ prodesc->fn_xmin = HeapTupleHeaderGetRawXmin(procTup->t_data);
+ prodesc->fn_tid = procTup->t_self;
+ prodesc->nargs = procStruct->pronargs;
+ prodesc->arg_out_func = (FmgrInfo *) palloc0(prodesc->nargs * sizeof(FmgrInfo));
+ prodesc->arg_is_rowtype = (bool *) palloc0(prodesc->nargs * sizeof(bool));
+ MemoryContextSwitchTo(oldcontext);
+
+ /* Remember if function is STABLE/IMMUTABLE */
+ prodesc->fn_readonly =
+ (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;
+
+ /************************************************************
+ * Get the required information for input conversion of the
+ * return value.
+ ************************************************************/
+ if (!is_trigger && !is_event_trigger)
+ {
+ Oid rettype = procStruct->prorettype;
+
+ typeTup = SearchSysCache1(TYPEOID, ObjectIdGetDatum(rettype));
+ if (!HeapTupleIsValid(typeTup))
+ elog(ERROR, "cache lookup failed for type %u", rettype);
+ typeStruct = (Form_pg_type) GETSTRUCT(typeTup);
+
+ /* Disallow pseudotype result, except VOID and RECORD */
+ if (typeStruct->typtype == TYPTYPE_PSEUDO)
+ {
+ if (rettype == VOIDOID ||
+ rettype == RECORDOID)
+ /* okay */ ;
+ else if (rettype == TRIGGEROID ||
+ rettype == EVENT_TRIGGEROID)
+ ereport(ERROR,
+ (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
+ errmsg("trigger functions can only be called as triggers")));
+ else
+ ereport(ERROR,
+ (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
+ errmsg("PL/Tcl functions cannot return type %s",
+ format_type_be(rettype))));
+ }
+
+ prodesc->result_typid = rettype;
+ fmgr_info_cxt(typeStruct->typinput,
+ &(prodesc->result_in_func),
+ proc_cxt);
+ prodesc->result_typioparam = getTypeIOParam(typeTup);
+
+ prodesc->fn_retisset = procStruct->proretset;
+ prodesc->fn_retistuple = type_is_rowtype(rettype);
+ prodesc->fn_retisdomain = (typeStruct->typtype == TYPTYPE_DOMAIN);
+ prodesc->domain_info = NULL;
+
+ ReleaseSysCache(typeTup);
+ }
+
+ /************************************************************
+ * Get the required information for output conversion
+ * of all procedure arguments, and set up argument naming info.
+ ************************************************************/
+ if (!is_trigger && !is_event_trigger)
+ {
+ proc_internal_args[0] = '\0';
+ for (i = 0; i < prodesc->nargs; i++)
+ {
+ Oid argtype = procStruct->proargtypes.values[i];
+
+ typeTup = SearchSysCache1(TYPEOID, ObjectIdGetDatum(argtype));
+ if (!HeapTupleIsValid(typeTup))
+ elog(ERROR, "cache lookup failed for type %u", argtype);
+ typeStruct = (Form_pg_type) GETSTRUCT(typeTup);
+
+ /* Disallow pseudotype argument, except RECORD */
+ if (typeStruct->typtype == TYPTYPE_PSEUDO &&
+ argtype != RECORDOID)
+ ereport(ERROR,
+ (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
+ errmsg("PL/Tcl functions cannot accept type %s",
+ format_type_be(argtype))));
+
+ if (type_is_rowtype(argtype))
+ {
+ prodesc->arg_is_rowtype[i] = true;
+ snprintf(buf, sizeof(buf), "__PLTcl_Tup_%d", i + 1);
+ }
+ else
+ {
+ prodesc->arg_is_rowtype[i] = false;
+ fmgr_info_cxt(typeStruct->typoutput,
+ &(prodesc->arg_out_func[i]),
+ proc_cxt);
+ snprintf(buf, sizeof(buf), "%d", i + 1);
+ }
+
+ if (i > 0)
+ strcat(proc_internal_args, " ");
+ strcat(proc_internal_args, buf);
+
+ ReleaseSysCache(typeTup);
+ }
+ }
+ else if (is_trigger)
+ {
+ /* trigger procedure has fixed args */
+ strcpy(proc_internal_args,
+ "TG_name TG_relid TG_table_name TG_table_schema TG_relatts TG_when TG_level TG_op __PLTcl_Tup_NEW __PLTcl_Tup_OLD args");
+ }
+ else if (is_event_trigger)
+ {
+ /* event trigger procedure has fixed args */
+ strcpy(proc_internal_args, "TG_event TG_tag");
+ }
+
+ /************************************************************
+ * Create the tcl command to define the internal
+ * procedure
+ *
+ * Leave this code as DString - performance is not critical here,
+ * and we don't want to duplicate the knowledge of the Tcl quoting
+ * rules that's embedded in Tcl_DStringAppendElement.
+ ************************************************************/
+ Tcl_DStringAppendElement(&proc_internal_def, "proc");
+ Tcl_DStringAppendElement(&proc_internal_def, internal_proname);
+ Tcl_DStringAppendElement(&proc_internal_def, proc_internal_args);
+
+ /************************************************************
+ * prefix procedure body with
+ * upvar #0 <internal_proname> GD
+ * and with appropriate setting of arguments
+ ************************************************************/
+ Tcl_DStringAppend(&proc_internal_body, "upvar #0 ", -1);
+ Tcl_DStringAppend(&proc_internal_body, internal_proname, -1);
+ Tcl_DStringAppend(&proc_internal_body, " GD\n", -1);
+ if (is_trigger)
+ {
+ Tcl_DStringAppend(&proc_internal_body,
+ "array set NEW $__PLTcl_Tup_NEW\n", -1);
+ Tcl_DStringAppend(&proc_internal_body,
+ "array set OLD $__PLTcl_Tup_OLD\n", -1);
+ Tcl_DStringAppend(&proc_internal_body,
+ "set i 0\n"
+ "set v 0\n"
+ "foreach v $args {\n"
+ " incr i\n"
+ " set $i $v\n"
+ "}\n"
+ "unset i v\n\n", -1);
+ }
+ else if (is_event_trigger)
+ {
+ /* no argument support for event triggers */
+ }
+ else
+ {
+ for (i = 0; i < prodesc->nargs; i++)
+ {
+ if (prodesc->arg_is_rowtype[i])
+ {
+ snprintf(buf, sizeof(buf),
+ "array set %d $__PLTcl_Tup_%d\n",
+ i + 1, i + 1);
+ Tcl_DStringAppend(&proc_internal_body, buf, -1);
+ }
+ }
+ }
+
+ /************************************************************
+ * Add user's function definition to proc body
+ ************************************************************/
+ prosrcdatum = SysCacheGetAttrNotNull(PROCOID, procTup,
+ Anum_pg_proc_prosrc);
+ proc_source = TextDatumGetCString(prosrcdatum);
+ UTF_BEGIN;
+ Tcl_DStringAppend(&proc_internal_body, UTF_E2U(proc_source), -1);
+ UTF_END;
+ pfree(proc_source);
+ Tcl_DStringAppendElement(&proc_internal_def,
+ Tcl_DStringValue(&proc_internal_body));
+
+ /************************************************************
+ * Create the procedure in the interpreter
+ ************************************************************/
+ tcl_rc = Tcl_EvalEx(interp,
+ Tcl_DStringValue(&proc_internal_def),
+ Tcl_DStringLength(&proc_internal_def),
+ TCL_EVAL_GLOBAL);
+ if (tcl_rc != TCL_OK)
+ ereport(ERROR,
+ (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION),
+ errmsg("could not create internal procedure \"%s\": %s",
+ internal_proname,
+ utf_u2e(Tcl_GetStringResult(interp)))));
+ }
+ PG_CATCH();
+ {
+ /*
+ * If we failed anywhere above, clean up whatever got allocated. It
+ * should all be in the proc_cxt, except for the DStrings.
+ */
+ if (proc_cxt)
+ MemoryContextDelete(proc_cxt);
+ Tcl_DStringFree(&proc_internal_def);
+ Tcl_DStringFree(&proc_internal_body);
+ PG_RE_THROW();
+ }
+ PG_END_TRY();
+
+ /*
+ * Install the new proc description block in the hashtable, incrementing
+ * its refcount (the hashtable link counts as a reference). Then, if
+ * there was a previous definition of the function, decrement that one's
+ * refcount, and delete it if no longer referenced. The order of
+ * operations here is important: if something goes wrong during the
+ * MemoryContextDelete, leaking some memory for the old definition is OK,
+ * but we don't want to corrupt the live hashtable entry. (Likewise,
+ * freeing the DStrings is pretty low priority if that happens.)
+ */
+ old_prodesc = proc_ptr->proc_ptr;
+
+ proc_ptr->proc_ptr = prodesc;
+ prodesc->fn_refcount++;
+
+ if (old_prodesc != NULL)
+ {
+ Assert(old_prodesc->fn_refcount > 0);
+ if (--old_prodesc->fn_refcount == 0)
+ MemoryContextDelete(old_prodesc->fn_cxt);
+ }
+
+ Tcl_DStringFree(&proc_internal_def);
+ Tcl_DStringFree(&proc_internal_body);
+
+ ReleaseSysCache(procTup);
+
+ return prodesc;
+}
+
+
+/**********************************************************************
+ * pltcl_elog() - elog() support for PLTcl
+ **********************************************************************/
+static int
+pltcl_elog(ClientData cdata, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const objv[])
+{
+ volatile int level;
+ MemoryContext oldcontext;
+ int priIndex;
+
+ static const char *logpriorities[] = {
+ "DEBUG", "LOG", "INFO", "NOTICE",
+ "WARNING", "ERROR", "FATAL", (const char *) NULL
+ };
+
+ static const int loglevels[] = {
+ DEBUG2, LOG, INFO, NOTICE,
+ WARNING, ERROR, FATAL
+ };
+
+ if (objc != 3)
+ {
+ Tcl_WrongNumArgs(interp, 1, objv, "level msg");
+ return TCL_ERROR;
+ }
+
+ if (Tcl_GetIndexFromObj(interp, objv[1], logpriorities, "priority",
+ TCL_EXACT, &priIndex) != TCL_OK)
+ return TCL_ERROR;
+
+ level = loglevels[priIndex];
+
+ if (level == ERROR)
+ {
+ /*
+ * We just pass the error back to Tcl. If it's not caught, it'll
+ * eventually get converted to a PG error when we reach the call
+ * handler.
+ */
+ Tcl_SetObjResult(interp, objv[2]);
+ return TCL_ERROR;
+ }
+
+ /*
+ * For non-error messages, just pass 'em to ereport(). We do not expect
+ * that this will fail, but just on the off chance it does, report the
+ * error back to Tcl. Note we are assuming that ereport() can't have any
+ * internal failures that are so bad as to require a transaction abort.
+ *
+ * This path is also used for FATAL errors, which aren't going to come
+ * back to us at all.
+ */
+ oldcontext = CurrentMemoryContext;
+ PG_TRY();
+ {
+ UTF_BEGIN;
+ ereport(level,
+ (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION),
+ errmsg("%s", UTF_U2E(Tcl_GetString(objv[2])))));
+ UTF_END;
+ }
+ PG_CATCH();
+ {
+ ErrorData *edata;
+
+ /* Must reset elog.c's state */
+ MemoryContextSwitchTo(oldcontext);
+ edata = CopyErrorData();
+ FlushErrorState();
+
+ /* Pass the error data to Tcl */
+ pltcl_construct_errorCode(interp, edata);
+ UTF_BEGIN;
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(UTF_E2U(edata->message), -1));
+ UTF_END;
+ FreeErrorData(edata);
+
+ return TCL_ERROR;
+ }
+ PG_END_TRY();
+
+ return TCL_OK;
+}
+
+
+/**********************************************************************
+ * pltcl_construct_errorCode() - construct a Tcl errorCode
+ * list with detailed information from the PostgreSQL server
+ **********************************************************************/
+static void
+pltcl_construct_errorCode(Tcl_Interp *interp, ErrorData *edata)
+{
+ Tcl_Obj *obj = Tcl_NewObj();
+
+ Tcl_ListObjAppendElement(interp, obj,
+ Tcl_NewStringObj("POSTGRES", -1));
+ Tcl_ListObjAppendElement(interp, obj,
+ Tcl_NewStringObj(PG_VERSION, -1));
+ Tcl_ListObjAppendElement(interp, obj,
+ Tcl_NewStringObj("SQLSTATE", -1));
+ Tcl_ListObjAppendElement(interp, obj,
+ Tcl_NewStringObj(unpack_sql_state(edata->sqlerrcode), -1));
+ Tcl_ListObjAppendElement(interp, obj,
+ Tcl_NewStringObj("condition", -1));
+ Tcl_ListObjAppendElement(interp, obj,
+ Tcl_NewStringObj(pltcl_get_condition_name(edata->sqlerrcode), -1));
+ Tcl_ListObjAppendElement(interp, obj,
+ Tcl_NewStringObj("message", -1));
+ UTF_BEGIN;
+ Tcl_ListObjAppendElement(interp, obj,
+ Tcl_NewStringObj(UTF_E2U(edata->message), -1));
+ UTF_END;
+ if (edata->detail)
+ {
+ Tcl_ListObjAppendElement(interp, obj,
+ Tcl_NewStringObj("detail", -1));
+ UTF_BEGIN;
+ Tcl_ListObjAppendElement(interp, obj,
+ Tcl_NewStringObj(UTF_E2U(edata->detail), -1));
+ UTF_END;
+ }
+ if (edata->hint)
+ {
+ Tcl_ListObjAppendElement(interp, obj,
+ Tcl_NewStringObj("hint", -1));
+ UTF_BEGIN;
+ Tcl_ListObjAppendElement(interp, obj,
+ Tcl_NewStringObj(UTF_E2U(edata->hint), -1));
+ UTF_END;
+ }
+ if (edata->context)
+ {
+ Tcl_ListObjAppendElement(interp, obj,
+ Tcl_NewStringObj("context", -1));
+ UTF_BEGIN;
+ Tcl_ListObjAppendElement(interp, obj,
+ Tcl_NewStringObj(UTF_E2U(edata->context), -1));
+ UTF_END;
+ }
+ if (edata->schema_name)
+ {
+ Tcl_ListObjAppendElement(interp, obj,
+ Tcl_NewStringObj("schema", -1));
+ UTF_BEGIN;
+ Tcl_ListObjAppendElement(interp, obj,
+ Tcl_NewStringObj(UTF_E2U(edata->schema_name), -1));
+ UTF_END;
+ }
+ if (edata->table_name)
+ {
+ Tcl_ListObjAppendElement(interp, obj,
+ Tcl_NewStringObj("table", -1));
+ UTF_BEGIN;
+ Tcl_ListObjAppendElement(interp, obj,
+ Tcl_NewStringObj(UTF_E2U(edata->table_name), -1));
+ UTF_END;
+ }
+ if (edata->column_name)
+ {
+ Tcl_ListObjAppendElement(interp, obj,
+ Tcl_NewStringObj("column", -1));
+ UTF_BEGIN;
+ Tcl_ListObjAppendElement(interp, obj,
+ Tcl_NewStringObj(UTF_E2U(edata->column_name), -1));
+ UTF_END;
+ }
+ if (edata->datatype_name)
+ {
+ Tcl_ListObjAppendElement(interp, obj,
+ Tcl_NewStringObj("datatype", -1));
+ UTF_BEGIN;
+ Tcl_ListObjAppendElement(interp, obj,
+ Tcl_NewStringObj(UTF_E2U(edata->datatype_name), -1));
+ UTF_END;
+ }
+ if (edata->constraint_name)
+ {
+ Tcl_ListObjAppendElement(interp, obj,
+ Tcl_NewStringObj("constraint", -1));
+ UTF_BEGIN;
+ Tcl_ListObjAppendElement(interp, obj,
+ Tcl_NewStringObj(UTF_E2U(edata->constraint_name), -1));
+ UTF_END;
+ }
+ /* cursorpos is never interesting here; report internal query/pos */
+ if (edata->internalquery)
+ {
+ Tcl_ListObjAppendElement(interp, obj,
+ Tcl_NewStringObj("statement", -1));
+ UTF_BEGIN;
+ Tcl_ListObjAppendElement(interp, obj,
+ Tcl_NewStringObj(UTF_E2U(edata->internalquery), -1));
+ UTF_END;
+ }
+ if (edata->internalpos > 0)
+ {
+ Tcl_ListObjAppendElement(interp, obj,
+ Tcl_NewStringObj("cursor_position", -1));
+ Tcl_ListObjAppendElement(interp, obj,
+ Tcl_NewIntObj(edata->internalpos));
+ }
+ if (edata->filename)
+ {
+ Tcl_ListObjAppendElement(interp, obj,
+ Tcl_NewStringObj("filename", -1));
+ UTF_BEGIN;
+ Tcl_ListObjAppendElement(interp, obj,
+ Tcl_NewStringObj(UTF_E2U(edata->filename), -1));
+ UTF_END;
+ }
+ if (edata->lineno > 0)
+ {
+ Tcl_ListObjAppendElement(interp, obj,
+ Tcl_NewStringObj("lineno", -1));
+ Tcl_ListObjAppendElement(interp, obj,
+ Tcl_NewIntObj(edata->lineno));
+ }
+ if (edata->funcname)
+ {
+ Tcl_ListObjAppendElement(interp, obj,
+ Tcl_NewStringObj("funcname", -1));
+ UTF_BEGIN;
+ Tcl_ListObjAppendElement(interp, obj,
+ Tcl_NewStringObj(UTF_E2U(edata->funcname), -1));
+ UTF_END;
+ }
+
+ Tcl_SetObjErrorCode(interp, obj);
+}
+
+
+/**********************************************************************
+ * pltcl_get_condition_name() - find name for SQLSTATE
+ **********************************************************************/
+static const char *
+pltcl_get_condition_name(int sqlstate)
+{
+ int i;
+
+ for (i = 0; exception_name_map[i].label != NULL; i++)
+ {
+ if (exception_name_map[i].sqlerrstate == sqlstate)
+ return exception_name_map[i].label;
+ }
+ return "unrecognized_sqlstate";
+}
+
+
+/**********************************************************************
+ * pltcl_quote() - quote literal strings that are to
+ * be used in SPI_execute query strings
+ **********************************************************************/
+static int
+pltcl_quote(ClientData cdata, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const objv[])
+{
+ char *tmp;
+ const char *cp1;
+ char *cp2;
+ int length;
+
+ /************************************************************
+ * Check call syntax
+ ************************************************************/
+ if (objc != 2)
+ {
+ Tcl_WrongNumArgs(interp, 1, objv, "string");
+ return TCL_ERROR;
+ }
+
+ /************************************************************
+ * Allocate space for the maximum the string can
+ * grow to and initialize pointers
+ ************************************************************/
+ cp1 = Tcl_GetStringFromObj(objv[1], &length);
+ tmp = palloc(length * 2 + 1);
+ cp2 = tmp;
+
+ /************************************************************
+ * Walk through string and double every quote and backslash
+ ************************************************************/
+ while (*cp1)
+ {
+ if (*cp1 == '\'')
+ *cp2++ = '\'';
+ else
+ {
+ if (*cp1 == '\\')
+ *cp2++ = '\\';
+ }
+ *cp2++ = *cp1++;
+ }
+
+ /************************************************************
+ * Terminate the string and set it as result
+ ************************************************************/
+ *cp2 = '\0';
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(tmp, -1));
+ pfree(tmp);
+ return TCL_OK;
+}
+
+
+/**********************************************************************
+ * pltcl_argisnull() - determine if a specific argument is NULL
+ **********************************************************************/
+static int
+pltcl_argisnull(ClientData cdata, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const objv[])
+{
+ int argno;
+ FunctionCallInfo fcinfo = pltcl_current_call_state->fcinfo;
+
+ /************************************************************
+ * Check call syntax
+ ************************************************************/
+ if (objc != 2)
+ {
+ Tcl_WrongNumArgs(interp, 1, objv, "argno");
+ return TCL_ERROR;
+ }
+
+ /************************************************************
+ * Check that we're called as a normal function
+ ************************************************************/
+ if (fcinfo == NULL)
+ {
+ Tcl_SetObjResult(interp,
+ Tcl_NewStringObj("argisnull cannot be used in triggers", -1));
+ return TCL_ERROR;
+ }
+
+ /************************************************************
+ * Get the argument number
+ ************************************************************/
+ if (Tcl_GetIntFromObj(interp, objv[1], &argno) != TCL_OK)
+ return TCL_ERROR;
+
+ /************************************************************
+ * Check that the argno is valid
+ ************************************************************/
+ argno--;
+ if (argno < 0 || argno >= fcinfo->nargs)
+ {
+ Tcl_SetObjResult(interp,
+ Tcl_NewStringObj("argno out of range", -1));
+ return TCL_ERROR;
+ }
+
+ /************************************************************
+ * Get the requested NULL state
+ ************************************************************/
+ Tcl_SetObjResult(interp, Tcl_NewBooleanObj(PG_ARGISNULL(argno)));
+ return TCL_OK;
+}
+
+
+/**********************************************************************
+ * pltcl_returnnull() - Cause a NULL return from the current function
+ **********************************************************************/
+static int
+pltcl_returnnull(ClientData cdata, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const objv[])
+{
+ FunctionCallInfo fcinfo = pltcl_current_call_state->fcinfo;
+
+ /************************************************************
+ * Check call syntax
+ ************************************************************/
+ if (objc != 1)
+ {
+ Tcl_WrongNumArgs(interp, 1, objv, "");
+ return TCL_ERROR;
+ }
+
+ /************************************************************
+ * Check that we're called as a normal function
+ ************************************************************/
+ if (fcinfo == NULL)
+ {
+ Tcl_SetObjResult(interp,
+ Tcl_NewStringObj("return_null cannot be used in triggers", -1));
+ return TCL_ERROR;
+ }
+
+ /************************************************************
+ * Set the NULL return flag and cause Tcl to return from the
+ * procedure.
+ ************************************************************/
+ fcinfo->isnull = true;
+
+ return TCL_RETURN;
+}
+
+
+/**********************************************************************
+ * pltcl_returnnext() - Add a row to the result tuplestore in a SRF.
+ **********************************************************************/
+static int
+pltcl_returnnext(ClientData cdata, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const objv[])
+{
+ pltcl_call_state *call_state = pltcl_current_call_state;
+ FunctionCallInfo fcinfo = call_state->fcinfo;
+ pltcl_proc_desc *prodesc = call_state->prodesc;
+ MemoryContext oldcontext = CurrentMemoryContext;
+ ResourceOwner oldowner = CurrentResourceOwner;
+ volatile int result = TCL_OK;
+
+ /*
+ * Check that we're called as a set-returning function
+ */
+ if (fcinfo == NULL)
+ {
+ Tcl_SetObjResult(interp,
+ Tcl_NewStringObj("return_next cannot be used in triggers", -1));
+ return TCL_ERROR;
+ }
+
+ if (!prodesc->fn_retisset)
+ {
+ Tcl_SetObjResult(interp,
+ Tcl_NewStringObj("return_next cannot be used in non-set-returning functions", -1));
+ return TCL_ERROR;
+ }
+
+ /*
+ * Check call syntax
+ */
+ if (objc != 2)
+ {
+ Tcl_WrongNumArgs(interp, 1, objv, "result");
+ return TCL_ERROR;
+ }
+
+ /*
+ * The rest might throw elog(ERROR), so must run in a subtransaction.
+ *
+ * A small advantage of using a subtransaction is that it provides a
+ * short-lived memory context for free, so we needn't worry about leaking
+ * memory here. To use that context, call BeginInternalSubTransaction
+ * directly instead of going through pltcl_subtrans_begin.
+ */
+ BeginInternalSubTransaction(NULL);
+ PG_TRY();
+ {
+ /* Set up tuple store if first output row */
+ if (call_state->tuple_store == NULL)
+ pltcl_init_tuple_store(call_state);
+
+ if (prodesc->fn_retistuple)
+ {
+ Tcl_Obj **rowObjv;
+ int rowObjc;
+
+ /* result should be a list, so break it down */
+ if (Tcl_ListObjGetElements(interp, objv[1], &rowObjc, &rowObjv) == TCL_ERROR)
+ result = TCL_ERROR;
+ else
+ {
+ HeapTuple tuple;
+
+ tuple = pltcl_build_tuple_result(interp, rowObjv, rowObjc,
+ call_state);
+ tuplestore_puttuple(call_state->tuple_store, tuple);
+ }
+ }
+ else
+ {
+ Datum retval;
+ bool isNull = false;
+
+ /* for paranoia's sake, check that tupdesc has exactly one column */
+ if (call_state->ret_tupdesc->natts != 1)
+ elog(ERROR, "wrong result type supplied in return_next");
+
+ retval = InputFunctionCall(&prodesc->result_in_func,
+ utf_u2e((char *) Tcl_GetString(objv[1])),
+ prodesc->result_typioparam,
+ -1);
+ tuplestore_putvalues(call_state->tuple_store, call_state->ret_tupdesc,
+ &retval, &isNull);
+ }
+
+ pltcl_subtrans_commit(oldcontext, oldowner);
+ }
+ PG_CATCH();
+ {
+ pltcl_subtrans_abort(interp, oldcontext, oldowner);
+ return TCL_ERROR;
+ }
+ PG_END_TRY();
+
+ return result;
+}
+
+
+/*----------
+ * Support for running SPI operations inside subtransactions
+ *
+ * Intended usage pattern is:
+ *
+ * MemoryContext oldcontext = CurrentMemoryContext;
+ * ResourceOwner oldowner = CurrentResourceOwner;
+ *
+ * ...
+ * pltcl_subtrans_begin(oldcontext, oldowner);
+ * PG_TRY();
+ * {
+ * do something risky;
+ * pltcl_subtrans_commit(oldcontext, oldowner);
+ * }
+ * PG_CATCH();
+ * {
+ * pltcl_subtrans_abort(interp, oldcontext, oldowner);
+ * return TCL_ERROR;
+ * }
+ * PG_END_TRY();
+ * return TCL_OK;
+ *----------
+ */
+static void
+pltcl_subtrans_begin(MemoryContext oldcontext, ResourceOwner oldowner)
+{
+ BeginInternalSubTransaction(NULL);
+
+ /* Want to run inside function's memory context */
+ MemoryContextSwitchTo(oldcontext);
+}
+
+static void
+pltcl_subtrans_commit(MemoryContext oldcontext, ResourceOwner oldowner)
+{
+ /* Commit the inner transaction, return to outer xact context */
+ ReleaseCurrentSubTransaction();
+ MemoryContextSwitchTo(oldcontext);
+ CurrentResourceOwner = oldowner;
+}
+
+static void
+pltcl_subtrans_abort(Tcl_Interp *interp,
+ MemoryContext oldcontext, ResourceOwner oldowner)
+{
+ ErrorData *edata;
+
+ /* Save error info */
+ MemoryContextSwitchTo(oldcontext);
+ edata = CopyErrorData();
+ FlushErrorState();
+
+ /* Abort the inner transaction */
+ RollbackAndReleaseCurrentSubTransaction();
+ MemoryContextSwitchTo(oldcontext);
+ CurrentResourceOwner = oldowner;
+
+ /* Pass the error data to Tcl */
+ pltcl_construct_errorCode(interp, edata);
+ UTF_BEGIN;
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(UTF_E2U(edata->message), -1));
+ UTF_END;
+ FreeErrorData(edata);
+}
+
+
+/**********************************************************************
+ * pltcl_SPI_execute() - The builtin SPI_execute command
+ * for the Tcl interpreter
+ **********************************************************************/
+static int
+pltcl_SPI_execute(ClientData cdata, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const objv[])
+{
+ int my_rc;
+ int spi_rc;
+ int query_idx;
+ int i;
+ int optIndex;
+ int count = 0;
+ const char *volatile arrayname = NULL;
+ Tcl_Obj *volatile loop_body = NULL;
+ MemoryContext oldcontext = CurrentMemoryContext;
+ ResourceOwner oldowner = CurrentResourceOwner;
+
+ enum options
+ {
+ OPT_ARRAY, OPT_COUNT
+ };
+
+ static const char *options[] = {
+ "-array", "-count", (const char *) NULL
+ };
+
+ /************************************************************
+ * Check the call syntax and get the options
+ ************************************************************/
+ if (objc < 2)
+ {
+ Tcl_WrongNumArgs(interp, 1, objv,
+ "?-count n? ?-array name? query ?loop body?");
+ return TCL_ERROR;
+ }
+
+ i = 1;
+ while (i < objc)
+ {
+ if (Tcl_GetIndexFromObj(NULL, objv[i], options, NULL,
+ TCL_EXACT, &optIndex) != TCL_OK)
+ break;
+
+ if (++i >= objc)
+ {
+ Tcl_SetObjResult(interp,
+ Tcl_NewStringObj("missing argument to -count or -array", -1));
+ return TCL_ERROR;
+ }
+
+ switch ((enum options) optIndex)
+ {
+ case OPT_ARRAY:
+ arrayname = Tcl_GetString(objv[i++]);
+ break;
+
+ case OPT_COUNT:
+ if (Tcl_GetIntFromObj(interp, objv[i++], &count) != TCL_OK)
+ return TCL_ERROR;
+ break;
+ }
+ }
+
+ query_idx = i;
+ if (query_idx >= objc || query_idx + 2 < objc)
+ {
+ Tcl_WrongNumArgs(interp, query_idx - 1, objv, "query ?loop body?");
+ return TCL_ERROR;
+ }
+
+ if (query_idx + 1 < objc)
+ loop_body = objv[query_idx + 1];
+
+ /************************************************************
+ * Execute the query inside a sub-transaction, so we can cope with
+ * errors sanely
+ ************************************************************/
+
+ pltcl_subtrans_begin(oldcontext, oldowner);
+
+ PG_TRY();
+ {
+ UTF_BEGIN;
+ spi_rc = SPI_execute(UTF_U2E(Tcl_GetString(objv[query_idx])),
+ pltcl_current_call_state->prodesc->fn_readonly, count);
+ UTF_END;
+
+ my_rc = pltcl_process_SPI_result(interp,
+ arrayname,
+ loop_body,
+ spi_rc,
+ SPI_tuptable,
+ SPI_processed);
+
+ pltcl_subtrans_commit(oldcontext, oldowner);
+ }
+ PG_CATCH();
+ {
+ pltcl_subtrans_abort(interp, oldcontext, oldowner);
+ return TCL_ERROR;
+ }
+ PG_END_TRY();
+
+ return my_rc;
+}
+
+/*
+ * Process the result from SPI_execute or SPI_execute_plan
+ *
+ * Shared code between pltcl_SPI_execute and pltcl_SPI_execute_plan
+ */
+static int
+pltcl_process_SPI_result(Tcl_Interp *interp,
+ const char *arrayname,
+ Tcl_Obj *loop_body,
+ int spi_rc,
+ SPITupleTable *tuptable,
+ uint64 ntuples)
+{
+ int my_rc = TCL_OK;
+ int loop_rc;
+ HeapTuple *tuples;
+ TupleDesc tupdesc;
+
+ switch (spi_rc)
+ {
+ case SPI_OK_SELINTO:
+ case SPI_OK_INSERT:
+ case SPI_OK_DELETE:
+ case SPI_OK_UPDATE:
+ case SPI_OK_MERGE:
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(ntuples));
+ break;
+
+ case SPI_OK_UTILITY:
+ case SPI_OK_REWRITTEN:
+ if (tuptable == NULL)
+ {
+ Tcl_SetObjResult(interp, Tcl_NewIntObj(0));
+ break;
+ }
+ /* fall through for utility returning tuples */
+ /* FALLTHROUGH */
+
+ case SPI_OK_SELECT:
+ case SPI_OK_INSERT_RETURNING:
+ case SPI_OK_DELETE_RETURNING:
+ case SPI_OK_UPDATE_RETURNING:
+
+ /*
+ * Process the tuples we got
+ */
+ tuples = tuptable->vals;
+ tupdesc = tuptable->tupdesc;
+
+ if (loop_body == NULL)
+ {
+ /*
+ * If there is no loop body given, just set the variables from
+ * the first tuple (if any)
+ */
+ if (ntuples > 0)
+ pltcl_set_tuple_values(interp, arrayname, 0,
+ tuples[0], tupdesc);
+ }
+ else
+ {
+ /*
+ * There is a loop body - process all tuples and evaluate the
+ * body on each
+ */
+ uint64 i;
+
+ for (i = 0; i < ntuples; i++)
+ {
+ pltcl_set_tuple_values(interp, arrayname, i,
+ tuples[i], tupdesc);
+
+ loop_rc = Tcl_EvalObjEx(interp, loop_body, 0);
+
+ if (loop_rc == TCL_OK)
+ continue;
+ if (loop_rc == TCL_CONTINUE)
+ continue;
+ if (loop_rc == TCL_RETURN)
+ {
+ my_rc = TCL_RETURN;
+ break;
+ }
+ if (loop_rc == TCL_BREAK)
+ break;
+ my_rc = TCL_ERROR;
+ break;
+ }
+ }
+
+ if (my_rc == TCL_OK)
+ {
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(ntuples));
+ }
+ break;
+
+ default:
+ Tcl_AppendResult(interp, "pltcl: SPI_execute failed: ",
+ SPI_result_code_string(spi_rc), NULL);
+ my_rc = TCL_ERROR;
+ break;
+ }
+
+ SPI_freetuptable(tuptable);
+
+ return my_rc;
+}
+
+
+/**********************************************************************
+ * pltcl_SPI_prepare() - Builtin support for prepared plans
+ * The Tcl command SPI_prepare
+ * always saves the plan using
+ * SPI_keepplan and returns a key for
+ * access. There is no chance to prepare
+ * and not save the plan currently.
+ **********************************************************************/
+static int
+pltcl_SPI_prepare(ClientData cdata, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const objv[])
+{
+ volatile MemoryContext plan_cxt = NULL;
+ int nargs;
+ Tcl_Obj **argsObj;
+ pltcl_query_desc *qdesc;
+ int i;
+ Tcl_HashEntry *hashent;
+ int hashnew;
+ Tcl_HashTable *query_hash;
+ MemoryContext oldcontext = CurrentMemoryContext;
+ ResourceOwner oldowner = CurrentResourceOwner;
+
+ /************************************************************
+ * Check the call syntax
+ ************************************************************/
+ if (objc != 3)
+ {
+ Tcl_WrongNumArgs(interp, 1, objv, "query argtypes");
+ return TCL_ERROR;
+ }
+
+ /************************************************************
+ * Split the argument type list
+ ************************************************************/
+ if (Tcl_ListObjGetElements(interp, objv[2], &nargs, &argsObj) != TCL_OK)
+ return TCL_ERROR;
+
+ /************************************************************
+ * Allocate the new querydesc structure
+ *
+ * struct qdesc and subsidiary data all live in plan_cxt. Note that if the
+ * function is recompiled for whatever reason, permanent memory leaks
+ * occur. FIXME someday.
+ ************************************************************/
+ plan_cxt = AllocSetContextCreate(TopMemoryContext,
+ "PL/Tcl spi_prepare query",
+ ALLOCSET_SMALL_SIZES);
+ MemoryContextSwitchTo(plan_cxt);
+ qdesc = (pltcl_query_desc *) palloc0(sizeof(pltcl_query_desc));
+ snprintf(qdesc->qname, sizeof(qdesc->qname), "%p", qdesc);
+ qdesc->nargs = nargs;
+ qdesc->argtypes = (Oid *) palloc(nargs * sizeof(Oid));
+ qdesc->arginfuncs = (FmgrInfo *) palloc(nargs * sizeof(FmgrInfo));
+ qdesc->argtypioparams = (Oid *) palloc(nargs * sizeof(Oid));
+ MemoryContextSwitchTo(oldcontext);
+
+ /************************************************************
+ * Execute the prepare inside a sub-transaction, so we can cope with
+ * errors sanely
+ ************************************************************/
+
+ pltcl_subtrans_begin(oldcontext, oldowner);
+
+ PG_TRY();
+ {
+ /************************************************************
+ * Resolve argument type names and then look them up by oid
+ * in the system cache, and remember the required information
+ * for input conversion.
+ ************************************************************/
+ for (i = 0; i < nargs; i++)
+ {
+ Oid typId,
+ typInput,
+ typIOParam;
+ int32 typmod;
+
+ (void) parseTypeString(Tcl_GetString(argsObj[i]),
+ &typId, &typmod, NULL);
+
+ getTypeInputInfo(typId, &typInput, &typIOParam);
+
+ qdesc->argtypes[i] = typId;
+ fmgr_info_cxt(typInput, &(qdesc->arginfuncs[i]), plan_cxt);
+ qdesc->argtypioparams[i] = typIOParam;
+ }
+
+ /************************************************************
+ * Prepare the plan and check for errors
+ ************************************************************/
+ UTF_BEGIN;
+ qdesc->plan = SPI_prepare(UTF_U2E(Tcl_GetString(objv[1])),
+ nargs, qdesc->argtypes);
+ UTF_END;
+
+ if (qdesc->plan == NULL)
+ elog(ERROR, "SPI_prepare() failed");
+
+ /************************************************************
+ * Save the plan into permanent memory (right now it's in the
+ * SPI procCxt, which will go away at function end).
+ ************************************************************/
+ if (SPI_keepplan(qdesc->plan))
+ elog(ERROR, "SPI_keepplan() failed");
+
+ pltcl_subtrans_commit(oldcontext, oldowner);
+ }
+ PG_CATCH();
+ {
+ pltcl_subtrans_abort(interp, oldcontext, oldowner);
+
+ MemoryContextDelete(plan_cxt);
+
+ return TCL_ERROR;
+ }
+ PG_END_TRY();
+
+ /************************************************************
+ * Insert a hashtable entry for the plan and return
+ * the key to the caller
+ ************************************************************/
+ query_hash = &pltcl_current_call_state->prodesc->interp_desc->query_hash;
+
+ hashent = Tcl_CreateHashEntry(query_hash, qdesc->qname, &hashnew);
+ Tcl_SetHashValue(hashent, (ClientData) qdesc);
+
+ /* qname is ASCII, so no need for encoding conversion */
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(qdesc->qname, -1));
+ return TCL_OK;
+}
+
+
+/**********************************************************************
+ * pltcl_SPI_execute_plan() - Execute a prepared plan
+ **********************************************************************/
+static int
+pltcl_SPI_execute_plan(ClientData cdata, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const objv[])
+{
+ int my_rc;
+ int spi_rc;
+ int i;
+ int j;
+ int optIndex;
+ Tcl_HashEntry *hashent;
+ pltcl_query_desc *qdesc;
+ const char *nulls = NULL;
+ const char *arrayname = NULL;
+ Tcl_Obj *loop_body = NULL;
+ int count = 0;
+ int callObjc;
+ Tcl_Obj **callObjv = NULL;
+ Datum *argvalues;
+ MemoryContext oldcontext = CurrentMemoryContext;
+ ResourceOwner oldowner = CurrentResourceOwner;
+ Tcl_HashTable *query_hash;
+
+ enum options
+ {
+ OPT_ARRAY, OPT_COUNT, OPT_NULLS
+ };
+
+ static const char *options[] = {
+ "-array", "-count", "-nulls", (const char *) NULL
+ };
+
+ /************************************************************
+ * Get the options and check syntax
+ ************************************************************/
+ i = 1;
+ while (i < objc)
+ {
+ if (Tcl_GetIndexFromObj(NULL, objv[i], options, NULL,
+ TCL_EXACT, &optIndex) != TCL_OK)
+ break;
+
+ if (++i >= objc)
+ {
+ Tcl_SetObjResult(interp,
+ Tcl_NewStringObj("missing argument to -array, -count or -nulls", -1));
+ return TCL_ERROR;
+ }
+
+ switch ((enum options) optIndex)
+ {
+ case OPT_ARRAY:
+ arrayname = Tcl_GetString(objv[i++]);
+ break;
+
+ case OPT_COUNT:
+ if (Tcl_GetIntFromObj(interp, objv[i++], &count) != TCL_OK)
+ return TCL_ERROR;
+ break;
+
+ case OPT_NULLS:
+ nulls = Tcl_GetString(objv[i++]);
+ break;
+ }
+ }
+
+ /************************************************************
+ * Get the prepared plan descriptor by its key
+ ************************************************************/
+ if (i >= objc)
+ {
+ Tcl_SetObjResult(interp,
+ Tcl_NewStringObj("missing argument to -count or -array", -1));
+ return TCL_ERROR;
+ }
+
+ query_hash = &pltcl_current_call_state->prodesc->interp_desc->query_hash;
+
+ hashent = Tcl_FindHashEntry(query_hash, Tcl_GetString(objv[i]));
+ if (hashent == NULL)
+ {
+ Tcl_AppendResult(interp, "invalid queryid '", Tcl_GetString(objv[i]), "'", NULL);
+ return TCL_ERROR;
+ }
+ qdesc = (pltcl_query_desc *) Tcl_GetHashValue(hashent);
+ i++;
+
+ /************************************************************
+ * If a nulls string is given, check for correct length
+ ************************************************************/
+ if (nulls != NULL)
+ {
+ if (strlen(nulls) != qdesc->nargs)
+ {
+ Tcl_SetObjResult(interp,
+ Tcl_NewStringObj("length of nulls string doesn't match number of arguments",
+ -1));
+ return TCL_ERROR;
+ }
+ }
+
+ /************************************************************
+ * If there was an argtype list on preparation, we need
+ * an argument value list now
+ ************************************************************/
+ if (qdesc->nargs > 0)
+ {
+ if (i >= objc)
+ {
+ Tcl_SetObjResult(interp,
+ Tcl_NewStringObj("argument list length doesn't match number of arguments for query",
+ -1));
+ return TCL_ERROR;
+ }
+
+ /************************************************************
+ * Split the argument values
+ ************************************************************/
+ if (Tcl_ListObjGetElements(interp, objv[i++], &callObjc, &callObjv) != TCL_OK)
+ return TCL_ERROR;
+
+ /************************************************************
+ * Check that the number of arguments matches
+ ************************************************************/
+ if (callObjc != qdesc->nargs)
+ {
+ Tcl_SetObjResult(interp,
+ Tcl_NewStringObj("argument list length doesn't match number of arguments for query",
+ -1));
+ return TCL_ERROR;
+ }
+ }
+ else
+ callObjc = 0;
+
+ /************************************************************
+ * Get loop body if present
+ ************************************************************/
+ if (i < objc)
+ loop_body = objv[i++];
+
+ if (i != objc)
+ {
+ Tcl_WrongNumArgs(interp, 1, objv,
+ "?-count n? ?-array name? ?-nulls string? "
+ "query ?args? ?loop body?");
+ return TCL_ERROR;
+ }
+
+ /************************************************************
+ * Execute the plan inside a sub-transaction, so we can cope with
+ * errors sanely
+ ************************************************************/
+
+ pltcl_subtrans_begin(oldcontext, oldowner);
+
+ PG_TRY();
+ {
+ /************************************************************
+ * Setup the value array for SPI_execute_plan() using
+ * the type specific input functions
+ ************************************************************/
+ argvalues = (Datum *) palloc(callObjc * sizeof(Datum));
+
+ for (j = 0; j < callObjc; j++)
+ {
+ if (nulls && nulls[j] == 'n')
+ {
+ argvalues[j] = InputFunctionCall(&qdesc->arginfuncs[j],
+ NULL,
+ qdesc->argtypioparams[j],
+ -1);
+ }
+ else
+ {
+ UTF_BEGIN;
+ argvalues[j] = InputFunctionCall(&qdesc->arginfuncs[j],
+ UTF_U2E(Tcl_GetString(callObjv[j])),
+ qdesc->argtypioparams[j],
+ -1);
+ UTF_END;
+ }
+ }
+
+ /************************************************************
+ * Execute the plan
+ ************************************************************/
+ spi_rc = SPI_execute_plan(qdesc->plan, argvalues, nulls,
+ pltcl_current_call_state->prodesc->fn_readonly,
+ count);
+
+ my_rc = pltcl_process_SPI_result(interp,
+ arrayname,
+ loop_body,
+ spi_rc,
+ SPI_tuptable,
+ SPI_processed);
+
+ pltcl_subtrans_commit(oldcontext, oldowner);
+ }
+ PG_CATCH();
+ {
+ pltcl_subtrans_abort(interp, oldcontext, oldowner);
+ return TCL_ERROR;
+ }
+ PG_END_TRY();
+
+ return my_rc;
+}
+
+
+/**********************************************************************
+ * pltcl_subtransaction() - Execute some Tcl code in a subtransaction
+ *
+ * The subtransaction is aborted if the Tcl code fragment returns TCL_ERROR,
+ * otherwise it's subcommitted.
+ **********************************************************************/
+static int
+pltcl_subtransaction(ClientData cdata, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const objv[])
+{
+ MemoryContext oldcontext = CurrentMemoryContext;
+ ResourceOwner oldowner = CurrentResourceOwner;
+ int retcode;
+
+ if (objc != 2)
+ {
+ Tcl_WrongNumArgs(interp, 1, objv, "command");
+ return TCL_ERROR;
+ }
+
+ /*
+ * Note: we don't use pltcl_subtrans_begin and friends here because we
+ * don't want the error handling in pltcl_subtrans_abort. But otherwise
+ * the processing should be about the same as in those functions.
+ */
+ BeginInternalSubTransaction(NULL);
+ MemoryContextSwitchTo(oldcontext);
+
+ retcode = Tcl_EvalObjEx(interp, objv[1], 0);
+
+ if (retcode == TCL_ERROR)
+ {
+ /* Rollback the subtransaction */
+ RollbackAndReleaseCurrentSubTransaction();
+ }
+ else
+ {
+ /* Commit the subtransaction */
+ ReleaseCurrentSubTransaction();
+ }
+
+ /* In either case, restore previous memory context and resource owner */
+ MemoryContextSwitchTo(oldcontext);
+ CurrentResourceOwner = oldowner;
+
+ return retcode;
+}
+
+
+/**********************************************************************
+ * pltcl_commit()
+ *
+ * Commit the transaction and start a new one.
+ **********************************************************************/
+static int
+pltcl_commit(ClientData cdata, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const objv[])
+{
+ MemoryContext oldcontext = CurrentMemoryContext;
+
+ PG_TRY();
+ {
+ SPI_commit();
+ }
+ PG_CATCH();
+ {
+ ErrorData *edata;
+
+ /* Save error info */
+ MemoryContextSwitchTo(oldcontext);
+ edata = CopyErrorData();
+ FlushErrorState();
+
+ /* Pass the error data to Tcl */
+ pltcl_construct_errorCode(interp, edata);
+ UTF_BEGIN;
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(UTF_E2U(edata->message), -1));
+ UTF_END;
+ FreeErrorData(edata);
+
+ return TCL_ERROR;
+ }
+ PG_END_TRY();
+
+ return TCL_OK;
+}
+
+
+/**********************************************************************
+ * pltcl_rollback()
+ *
+ * Abort the transaction and start a new one.
+ **********************************************************************/
+static int
+pltcl_rollback(ClientData cdata, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const objv[])
+{
+ MemoryContext oldcontext = CurrentMemoryContext;
+
+ PG_TRY();
+ {
+ SPI_rollback();
+ }
+ PG_CATCH();
+ {
+ ErrorData *edata;
+
+ /* Save error info */
+ MemoryContextSwitchTo(oldcontext);
+ edata = CopyErrorData();
+ FlushErrorState();
+
+ /* Pass the error data to Tcl */
+ pltcl_construct_errorCode(interp, edata);
+ UTF_BEGIN;
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(UTF_E2U(edata->message), -1));
+ UTF_END;
+ FreeErrorData(edata);
+
+ return TCL_ERROR;
+ }
+ PG_END_TRY();
+
+ return TCL_OK;
+}
+
+
+/**********************************************************************
+ * pltcl_set_tuple_values() - Set variables for all attributes
+ * of a given tuple
+ *
+ * Note: arrayname is presumed to be UTF8; it usually came from Tcl
+ **********************************************************************/
+static void
+pltcl_set_tuple_values(Tcl_Interp *interp, const char *arrayname,
+ uint64 tupno, HeapTuple tuple, TupleDesc tupdesc)
+{
+ int i;
+ char *outputstr;
+ Datum attr;
+ bool isnull;
+ const char *attname;
+ Oid typoutput;
+ bool typisvarlena;
+ const char **arrptr;
+ const char **nameptr;
+ const char *nullname = NULL;
+
+ /************************************************************
+ * Prepare pointers for Tcl_SetVar2Ex() below
+ ************************************************************/
+ if (arrayname == NULL)
+ {
+ arrptr = &attname;
+ nameptr = &nullname;
+ }
+ else
+ {
+ arrptr = &arrayname;
+ nameptr = &attname;
+
+ /*
+ * When outputting to an array, fill the ".tupno" element with the
+ * current tuple number. This will be overridden below if ".tupno" is
+ * in use as an actual field name in the rowtype.
+ */
+ Tcl_SetVar2Ex(interp, arrayname, ".tupno", Tcl_NewWideIntObj(tupno), 0);
+ }
+
+ for (i = 0; i < tupdesc->natts; i++)
+ {
+ Form_pg_attribute att = TupleDescAttr(tupdesc, i);
+
+ /* ignore dropped attributes */
+ if (att->attisdropped)
+ continue;
+
+ /************************************************************
+ * Get the attribute name
+ ************************************************************/
+ UTF_BEGIN;
+ attname = pstrdup(UTF_E2U(NameStr(att->attname)));
+ UTF_END;
+
+ /************************************************************
+ * Get the attributes value
+ ************************************************************/
+ attr = heap_getattr(tuple, i + 1, tupdesc, &isnull);
+
+ /************************************************************
+ * If there is a value, set the variable
+ * If not, unset it
+ *
+ * Hmmm - Null attributes will cause functions to
+ * crash if they don't expect them - need something
+ * smarter here.
+ ************************************************************/
+ if (!isnull)
+ {
+ getTypeOutputInfo(att->atttypid, &typoutput, &typisvarlena);
+ outputstr = OidOutputFunctionCall(typoutput, attr);
+ UTF_BEGIN;
+ Tcl_SetVar2Ex(interp, *arrptr, *nameptr,
+ Tcl_NewStringObj(UTF_E2U(outputstr), -1), 0);
+ UTF_END;
+ pfree(outputstr);
+ }
+ else
+ Tcl_UnsetVar2(interp, *arrptr, *nameptr, 0);
+
+ pfree(unconstify(char *, attname));
+ }
+}
+
+
+/**********************************************************************
+ * pltcl_build_tuple_argument() - Build a list object usable for 'array set'
+ * from all attributes of a given tuple
+ **********************************************************************/
+static Tcl_Obj *
+pltcl_build_tuple_argument(HeapTuple tuple, TupleDesc tupdesc, bool include_generated)
+{
+ Tcl_Obj *retobj = Tcl_NewObj();
+ int i;
+ char *outputstr;
+ Datum attr;
+ bool isnull;
+ char *attname;
+ Oid typoutput;
+ bool typisvarlena;
+
+ for (i = 0; i < tupdesc->natts; i++)
+ {
+ Form_pg_attribute att = TupleDescAttr(tupdesc, i);
+
+ /* ignore dropped attributes */
+ if (att->attisdropped)
+ continue;
+
+ if (att->attgenerated)
+ {
+ /* don't include unless requested */
+ if (!include_generated)
+ continue;
+ }
+
+ /************************************************************
+ * Get the attribute name
+ ************************************************************/
+ attname = NameStr(att->attname);
+
+ /************************************************************
+ * Get the attributes value
+ ************************************************************/
+ attr = heap_getattr(tuple, i + 1, tupdesc, &isnull);
+
+ /************************************************************
+ * If there is a value, append the attribute name and the
+ * value to the list
+ *
+ * Hmmm - Null attributes will cause functions to
+ * crash if they don't expect them - need something
+ * smarter here.
+ ************************************************************/
+ if (!isnull)
+ {
+ getTypeOutputInfo(att->atttypid,
+ &typoutput, &typisvarlena);
+ outputstr = OidOutputFunctionCall(typoutput, attr);
+ UTF_BEGIN;
+ Tcl_ListObjAppendElement(NULL, retobj,
+ Tcl_NewStringObj(UTF_E2U(attname), -1));
+ UTF_END;
+ UTF_BEGIN;
+ Tcl_ListObjAppendElement(NULL, retobj,
+ Tcl_NewStringObj(UTF_E2U(outputstr), -1));
+ UTF_END;
+ pfree(outputstr);
+ }
+ }
+
+ return retobj;
+}
+
+/**********************************************************************
+ * pltcl_build_tuple_result() - Build a tuple of function's result rowtype
+ * from a Tcl list of column names and values
+ *
+ * In a trigger function, we build a tuple of the trigger table's rowtype.
+ *
+ * Note: this function leaks memory. Even if we made it clean up its own
+ * mess, there's no way to prevent the datatype input functions it calls
+ * from leaking. Run it in a short-lived context, unless we're about to
+ * exit the procedure anyway.
+ **********************************************************************/
+static HeapTuple
+pltcl_build_tuple_result(Tcl_Interp *interp, Tcl_Obj **kvObjv, int kvObjc,
+ pltcl_call_state *call_state)
+{
+ HeapTuple tuple;
+ TupleDesc tupdesc;
+ AttInMetadata *attinmeta;
+ char **values;
+ int i;
+
+ if (call_state->ret_tupdesc)
+ {
+ tupdesc = call_state->ret_tupdesc;
+ attinmeta = call_state->attinmeta;
+ }
+ else if (call_state->trigdata)
+ {
+ tupdesc = RelationGetDescr(call_state->trigdata->tg_relation);
+ attinmeta = TupleDescGetAttInMetadata(tupdesc);
+ }
+ else
+ {
+ elog(ERROR, "PL/Tcl function does not return a tuple");
+ tupdesc = NULL; /* keep compiler quiet */
+ attinmeta = NULL;
+ }
+
+ values = (char **) palloc0(tupdesc->natts * sizeof(char *));
+
+ if (kvObjc % 2 != 0)
+ ereport(ERROR,
+ (errcode(ERRCODE_INVALID_PARAMETER_VALUE),
+ errmsg("column name/value list must have even number of elements")));
+
+ for (i = 0; i < kvObjc; i += 2)
+ {
+ char *fieldName = utf_u2e(Tcl_GetString(kvObjv[i]));
+ int attn = SPI_fnumber(tupdesc, fieldName);
+
+ /*
+ * We silently ignore ".tupno", if it's present but doesn't match any
+ * actual output column. This allows direct use of a row returned by
+ * pltcl_set_tuple_values().
+ */
+ if (attn == SPI_ERROR_NOATTRIBUTE)
+ {
+ if (strcmp(fieldName, ".tupno") == 0)
+ continue;
+ ereport(ERROR,
+ (errcode(ERRCODE_UNDEFINED_COLUMN),
+ errmsg("column name/value list contains nonexistent column name \"%s\"",
+ fieldName)));
+ }
+
+ if (attn <= 0)
+ ereport(ERROR,
+ (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
+ errmsg("cannot set system attribute \"%s\"",
+ fieldName)));
+
+ if (TupleDescAttr(tupdesc, attn - 1)->attgenerated)
+ ereport(ERROR,
+ (errcode(ERRCODE_E_R_I_E_TRIGGER_PROTOCOL_VIOLATED),
+ errmsg("cannot set generated column \"%s\"",
+ fieldName)));
+
+ values[attn - 1] = utf_u2e(Tcl_GetString(kvObjv[i + 1]));
+ }
+
+ tuple = BuildTupleFromCStrings(attinmeta, values);
+
+ /* if result type is domain-over-composite, check domain constraints */
+ if (call_state->prodesc->fn_retisdomain)
+ domain_check(HeapTupleGetDatum(tuple), false,
+ call_state->prodesc->result_typid,
+ &call_state->prodesc->domain_info,
+ call_state->prodesc->fn_cxt);
+
+ return tuple;
+}
+
+/**********************************************************************
+ * pltcl_init_tuple_store() - Initialize the result tuplestore for a SRF
+ **********************************************************************/
+static void
+pltcl_init_tuple_store(pltcl_call_state *call_state)
+{
+ ReturnSetInfo *rsi = call_state->rsi;
+ MemoryContext oldcxt;
+ ResourceOwner oldowner;
+
+ /* Should be in a SRF */
+ Assert(rsi);
+ /* Should be first time through */
+ Assert(!call_state->tuple_store);
+ Assert(!call_state->attinmeta);
+
+ /* We expect caller to provide an appropriate result tupdesc */
+ Assert(rsi->expectedDesc);
+ call_state->ret_tupdesc = rsi->expectedDesc;
+
+ /*
+ * Switch to the right memory context and resource owner for storing the
+ * tuplestore. If we're within a subtransaction opened for an exception
+ * block, for example, we must still create the tuplestore in the resource
+ * owner that was active when this function was entered, and not in the
+ * subtransaction's resource owner.
+ */
+ oldcxt = MemoryContextSwitchTo(call_state->tuple_store_cxt);
+ oldowner = CurrentResourceOwner;
+ CurrentResourceOwner = call_state->tuple_store_owner;
+
+ call_state->tuple_store =
+ tuplestore_begin_heap(rsi->allowedModes & SFRM_Materialize_Random,
+ false, work_mem);
+
+ /* Build attinmeta in this context, too */
+ call_state->attinmeta = TupleDescGetAttInMetadata(call_state->ret_tupdesc);
+
+ CurrentResourceOwner = oldowner;
+ MemoryContextSwitchTo(oldcxt);
+}
diff --git a/src/pl/tcl/pltcl.control b/src/pl/tcl/pltcl.control
new file mode 100644
index 0000000..1568c17
--- /dev/null
+++ b/src/pl/tcl/pltcl.control
@@ -0,0 +1,8 @@
+# pltcl extension
+comment = 'PL/Tcl procedural language'
+default_version = '1.0'
+module_pathname = '$libdir/pltcl'
+relocatable = false
+schema = pg_catalog
+superuser = true
+trusted = true
diff --git a/src/pl/tcl/pltclerrcodes.h b/src/pl/tcl/pltclerrcodes.h
new file mode 100644
index 0000000..b3ca6df
--- /dev/null
+++ b/src/pl/tcl/pltclerrcodes.h
@@ -0,0 +1,998 @@
+/* autogenerated from src/backend/utils/errcodes.txt, do not edit */
+/* there is deliberately not an #ifndef PLTCLERRCODES_H here */
+
+{
+ "sql_statement_not_yet_complete", ERRCODE_SQL_STATEMENT_NOT_YET_COMPLETE
+},
+
+{
+ "connection_exception", ERRCODE_CONNECTION_EXCEPTION
+},
+
+{
+ "connection_does_not_exist", ERRCODE_CONNECTION_DOES_NOT_EXIST
+},
+
+{
+ "connection_failure", ERRCODE_CONNECTION_FAILURE
+},
+
+{
+ "sqlclient_unable_to_establish_sqlconnection", ERRCODE_SQLCLIENT_UNABLE_TO_ESTABLISH_SQLCONNECTION
+},
+
+{
+ "sqlserver_rejected_establishment_of_sqlconnection", ERRCODE_SQLSERVER_REJECTED_ESTABLISHMENT_OF_SQLCONNECTION
+},
+
+{
+ "transaction_resolution_unknown", ERRCODE_TRANSACTION_RESOLUTION_UNKNOWN
+},
+
+{
+ "protocol_violation", ERRCODE_PROTOCOL_VIOLATION
+},
+
+{
+ "triggered_action_exception", ERRCODE_TRIGGERED_ACTION_EXCEPTION
+},
+
+{
+ "feature_not_supported", ERRCODE_FEATURE_NOT_SUPPORTED
+},
+
+{
+ "invalid_transaction_initiation", ERRCODE_INVALID_TRANSACTION_INITIATION
+},
+
+{
+ "locator_exception", ERRCODE_LOCATOR_EXCEPTION
+},
+
+{
+ "invalid_locator_specification", ERRCODE_L_E_INVALID_SPECIFICATION
+},
+
+{
+ "invalid_grantor", ERRCODE_INVALID_GRANTOR
+},
+
+{
+ "invalid_grant_operation", ERRCODE_INVALID_GRANT_OPERATION
+},
+
+{
+ "invalid_role_specification", ERRCODE_INVALID_ROLE_SPECIFICATION
+},
+
+{
+ "diagnostics_exception", ERRCODE_DIAGNOSTICS_EXCEPTION
+},
+
+{
+ "stacked_diagnostics_accessed_without_active_handler", ERRCODE_STACKED_DIAGNOSTICS_ACCESSED_WITHOUT_ACTIVE_HANDLER
+},
+
+{
+ "case_not_found", ERRCODE_CASE_NOT_FOUND
+},
+
+{
+ "cardinality_violation", ERRCODE_CARDINALITY_VIOLATION
+},
+
+{
+ "data_exception", ERRCODE_DATA_EXCEPTION
+},
+
+{
+ "array_subscript_error", ERRCODE_ARRAY_SUBSCRIPT_ERROR
+},
+
+{
+ "character_not_in_repertoire", ERRCODE_CHARACTER_NOT_IN_REPERTOIRE
+},
+
+{
+ "datetime_field_overflow", ERRCODE_DATETIME_FIELD_OVERFLOW
+},
+
+{
+ "division_by_zero", ERRCODE_DIVISION_BY_ZERO
+},
+
+{
+ "error_in_assignment", ERRCODE_ERROR_IN_ASSIGNMENT
+},
+
+{
+ "escape_character_conflict", ERRCODE_ESCAPE_CHARACTER_CONFLICT
+},
+
+{
+ "indicator_overflow", ERRCODE_INDICATOR_OVERFLOW
+},
+
+{
+ "interval_field_overflow", ERRCODE_INTERVAL_FIELD_OVERFLOW
+},
+
+{
+ "invalid_argument_for_logarithm", ERRCODE_INVALID_ARGUMENT_FOR_LOG
+},
+
+{
+ "invalid_argument_for_ntile_function", ERRCODE_INVALID_ARGUMENT_FOR_NTILE
+},
+
+{
+ "invalid_argument_for_nth_value_function", ERRCODE_INVALID_ARGUMENT_FOR_NTH_VALUE
+},
+
+{
+ "invalid_argument_for_power_function", ERRCODE_INVALID_ARGUMENT_FOR_POWER_FUNCTION
+},
+
+{
+ "invalid_argument_for_width_bucket_function", ERRCODE_INVALID_ARGUMENT_FOR_WIDTH_BUCKET_FUNCTION
+},
+
+{
+ "invalid_character_value_for_cast", ERRCODE_INVALID_CHARACTER_VALUE_FOR_CAST
+},
+
+{
+ "invalid_datetime_format", ERRCODE_INVALID_DATETIME_FORMAT
+},
+
+{
+ "invalid_escape_character", ERRCODE_INVALID_ESCAPE_CHARACTER
+},
+
+{
+ "invalid_escape_octet", ERRCODE_INVALID_ESCAPE_OCTET
+},
+
+{
+ "invalid_escape_sequence", ERRCODE_INVALID_ESCAPE_SEQUENCE
+},
+
+{
+ "nonstandard_use_of_escape_character", ERRCODE_NONSTANDARD_USE_OF_ESCAPE_CHARACTER
+},
+
+{
+ "invalid_indicator_parameter_value", ERRCODE_INVALID_INDICATOR_PARAMETER_VALUE
+},
+
+{
+ "invalid_parameter_value", ERRCODE_INVALID_PARAMETER_VALUE
+},
+
+{
+ "invalid_preceding_or_following_size", ERRCODE_INVALID_PRECEDING_OR_FOLLOWING_SIZE
+},
+
+{
+ "invalid_regular_expression", ERRCODE_INVALID_REGULAR_EXPRESSION
+},
+
+{
+ "invalid_row_count_in_limit_clause", ERRCODE_INVALID_ROW_COUNT_IN_LIMIT_CLAUSE
+},
+
+{
+ "invalid_row_count_in_result_offset_clause", ERRCODE_INVALID_ROW_COUNT_IN_RESULT_OFFSET_CLAUSE
+},
+
+{
+ "invalid_tablesample_argument", ERRCODE_INVALID_TABLESAMPLE_ARGUMENT
+},
+
+{
+ "invalid_tablesample_repeat", ERRCODE_INVALID_TABLESAMPLE_REPEAT
+},
+
+{
+ "invalid_time_zone_displacement_value", ERRCODE_INVALID_TIME_ZONE_DISPLACEMENT_VALUE
+},
+
+{
+ "invalid_use_of_escape_character", ERRCODE_INVALID_USE_OF_ESCAPE_CHARACTER
+},
+
+{
+ "most_specific_type_mismatch", ERRCODE_MOST_SPECIFIC_TYPE_MISMATCH
+},
+
+{
+ "null_value_not_allowed", ERRCODE_NULL_VALUE_NOT_ALLOWED
+},
+
+{
+ "null_value_no_indicator_parameter", ERRCODE_NULL_VALUE_NO_INDICATOR_PARAMETER
+},
+
+{
+ "numeric_value_out_of_range", ERRCODE_NUMERIC_VALUE_OUT_OF_RANGE
+},
+
+{
+ "sequence_generator_limit_exceeded", ERRCODE_SEQUENCE_GENERATOR_LIMIT_EXCEEDED
+},
+
+{
+ "string_data_length_mismatch", ERRCODE_STRING_DATA_LENGTH_MISMATCH
+},
+
+{
+ "string_data_right_truncation", ERRCODE_STRING_DATA_RIGHT_TRUNCATION
+},
+
+{
+ "substring_error", ERRCODE_SUBSTRING_ERROR
+},
+
+{
+ "trim_error", ERRCODE_TRIM_ERROR
+},
+
+{
+ "unterminated_c_string", ERRCODE_UNTERMINATED_C_STRING
+},
+
+{
+ "zero_length_character_string", ERRCODE_ZERO_LENGTH_CHARACTER_STRING
+},
+
+{
+ "floating_point_exception", ERRCODE_FLOATING_POINT_EXCEPTION
+},
+
+{
+ "invalid_text_representation", ERRCODE_INVALID_TEXT_REPRESENTATION
+},
+
+{
+ "invalid_binary_representation", ERRCODE_INVALID_BINARY_REPRESENTATION
+},
+
+{
+ "bad_copy_file_format", ERRCODE_BAD_COPY_FILE_FORMAT
+},
+
+{
+ "untranslatable_character", ERRCODE_UNTRANSLATABLE_CHARACTER
+},
+
+{
+ "not_an_xml_document", ERRCODE_NOT_AN_XML_DOCUMENT
+},
+
+{
+ "invalid_xml_document", ERRCODE_INVALID_XML_DOCUMENT
+},
+
+{
+ "invalid_xml_content", ERRCODE_INVALID_XML_CONTENT
+},
+
+{
+ "invalid_xml_comment", ERRCODE_INVALID_XML_COMMENT
+},
+
+{
+ "invalid_xml_processing_instruction", ERRCODE_INVALID_XML_PROCESSING_INSTRUCTION
+},
+
+{
+ "duplicate_json_object_key_value", ERRCODE_DUPLICATE_JSON_OBJECT_KEY_VALUE
+},
+
+{
+ "invalid_argument_for_sql_json_datetime_function", ERRCODE_INVALID_ARGUMENT_FOR_SQL_JSON_DATETIME_FUNCTION
+},
+
+{
+ "invalid_json_text", ERRCODE_INVALID_JSON_TEXT
+},
+
+{
+ "invalid_sql_json_subscript", ERRCODE_INVALID_SQL_JSON_SUBSCRIPT
+},
+
+{
+ "more_than_one_sql_json_item", ERRCODE_MORE_THAN_ONE_SQL_JSON_ITEM
+},
+
+{
+ "no_sql_json_item", ERRCODE_NO_SQL_JSON_ITEM
+},
+
+{
+ "non_numeric_sql_json_item", ERRCODE_NON_NUMERIC_SQL_JSON_ITEM
+},
+
+{
+ "non_unique_keys_in_a_json_object", ERRCODE_NON_UNIQUE_KEYS_IN_A_JSON_OBJECT
+},
+
+{
+ "singleton_sql_json_item_required", ERRCODE_SINGLETON_SQL_JSON_ITEM_REQUIRED
+},
+
+{
+ "sql_json_array_not_found", ERRCODE_SQL_JSON_ARRAY_NOT_FOUND
+},
+
+{
+ "sql_json_member_not_found", ERRCODE_SQL_JSON_MEMBER_NOT_FOUND
+},
+
+{
+ "sql_json_number_not_found", ERRCODE_SQL_JSON_NUMBER_NOT_FOUND
+},
+
+{
+ "sql_json_object_not_found", ERRCODE_SQL_JSON_OBJECT_NOT_FOUND
+},
+
+{
+ "too_many_json_array_elements", ERRCODE_TOO_MANY_JSON_ARRAY_ELEMENTS
+},
+
+{
+ "too_many_json_object_members", ERRCODE_TOO_MANY_JSON_OBJECT_MEMBERS
+},
+
+{
+ "sql_json_scalar_required", ERRCODE_SQL_JSON_SCALAR_REQUIRED
+},
+
+{
+ "sql_json_item_cannot_be_cast_to_target_type", ERRCODE_SQL_JSON_ITEM_CANNOT_BE_CAST_TO_TARGET_TYPE
+},
+
+{
+ "integrity_constraint_violation", ERRCODE_INTEGRITY_CONSTRAINT_VIOLATION
+},
+
+{
+ "restrict_violation", ERRCODE_RESTRICT_VIOLATION
+},
+
+{
+ "not_null_violation", ERRCODE_NOT_NULL_VIOLATION
+},
+
+{
+ "foreign_key_violation", ERRCODE_FOREIGN_KEY_VIOLATION
+},
+
+{
+ "unique_violation", ERRCODE_UNIQUE_VIOLATION
+},
+
+{
+ "check_violation", ERRCODE_CHECK_VIOLATION
+},
+
+{
+ "exclusion_violation", ERRCODE_EXCLUSION_VIOLATION
+},
+
+{
+ "invalid_cursor_state", ERRCODE_INVALID_CURSOR_STATE
+},
+
+{
+ "invalid_transaction_state", ERRCODE_INVALID_TRANSACTION_STATE
+},
+
+{
+ "active_sql_transaction", ERRCODE_ACTIVE_SQL_TRANSACTION
+},
+
+{
+ "branch_transaction_already_active", ERRCODE_BRANCH_TRANSACTION_ALREADY_ACTIVE
+},
+
+{
+ "held_cursor_requires_same_isolation_level", ERRCODE_HELD_CURSOR_REQUIRES_SAME_ISOLATION_LEVEL
+},
+
+{
+ "inappropriate_access_mode_for_branch_transaction", ERRCODE_INAPPROPRIATE_ACCESS_MODE_FOR_BRANCH_TRANSACTION
+},
+
+{
+ "inappropriate_isolation_level_for_branch_transaction", ERRCODE_INAPPROPRIATE_ISOLATION_LEVEL_FOR_BRANCH_TRANSACTION
+},
+
+{
+ "no_active_sql_transaction_for_branch_transaction", ERRCODE_NO_ACTIVE_SQL_TRANSACTION_FOR_BRANCH_TRANSACTION
+},
+
+{
+ "read_only_sql_transaction", ERRCODE_READ_ONLY_SQL_TRANSACTION
+},
+
+{
+ "schema_and_data_statement_mixing_not_supported", ERRCODE_SCHEMA_AND_DATA_STATEMENT_MIXING_NOT_SUPPORTED
+},
+
+{
+ "no_active_sql_transaction", ERRCODE_NO_ACTIVE_SQL_TRANSACTION
+},
+
+{
+ "in_failed_sql_transaction", ERRCODE_IN_FAILED_SQL_TRANSACTION
+},
+
+{
+ "idle_in_transaction_session_timeout", ERRCODE_IDLE_IN_TRANSACTION_SESSION_TIMEOUT
+},
+
+{
+ "invalid_sql_statement_name", ERRCODE_INVALID_SQL_STATEMENT_NAME
+},
+
+{
+ "triggered_data_change_violation", ERRCODE_TRIGGERED_DATA_CHANGE_VIOLATION
+},
+
+{
+ "invalid_authorization_specification", ERRCODE_INVALID_AUTHORIZATION_SPECIFICATION
+},
+
+{
+ "invalid_password", ERRCODE_INVALID_PASSWORD
+},
+
+{
+ "dependent_privilege_descriptors_still_exist", ERRCODE_DEPENDENT_PRIVILEGE_DESCRIPTORS_STILL_EXIST
+},
+
+{
+ "dependent_objects_still_exist", ERRCODE_DEPENDENT_OBJECTS_STILL_EXIST
+},
+
+{
+ "invalid_transaction_termination", ERRCODE_INVALID_TRANSACTION_TERMINATION
+},
+
+{
+ "sql_routine_exception", ERRCODE_SQL_ROUTINE_EXCEPTION
+},
+
+{
+ "function_executed_no_return_statement", ERRCODE_S_R_E_FUNCTION_EXECUTED_NO_RETURN_STATEMENT
+},
+
+{
+ "modifying_sql_data_not_permitted", ERRCODE_S_R_E_MODIFYING_SQL_DATA_NOT_PERMITTED
+},
+
+{
+ "prohibited_sql_statement_attempted", ERRCODE_S_R_E_PROHIBITED_SQL_STATEMENT_ATTEMPTED
+},
+
+{
+ "reading_sql_data_not_permitted", ERRCODE_S_R_E_READING_SQL_DATA_NOT_PERMITTED
+},
+
+{
+ "invalid_cursor_name", ERRCODE_INVALID_CURSOR_NAME
+},
+
+{
+ "external_routine_exception", ERRCODE_EXTERNAL_ROUTINE_EXCEPTION
+},
+
+{
+ "containing_sql_not_permitted", ERRCODE_E_R_E_CONTAINING_SQL_NOT_PERMITTED
+},
+
+{
+ "modifying_sql_data_not_permitted", ERRCODE_E_R_E_MODIFYING_SQL_DATA_NOT_PERMITTED
+},
+
+{
+ "prohibited_sql_statement_attempted", ERRCODE_E_R_E_PROHIBITED_SQL_STATEMENT_ATTEMPTED
+},
+
+{
+ "reading_sql_data_not_permitted", ERRCODE_E_R_E_READING_SQL_DATA_NOT_PERMITTED
+},
+
+{
+ "external_routine_invocation_exception", ERRCODE_EXTERNAL_ROUTINE_INVOCATION_EXCEPTION
+},
+
+{
+ "invalid_sqlstate_returned", ERRCODE_E_R_I_E_INVALID_SQLSTATE_RETURNED
+},
+
+{
+ "null_value_not_allowed", ERRCODE_E_R_I_E_NULL_VALUE_NOT_ALLOWED
+},
+
+{
+ "trigger_protocol_violated", ERRCODE_E_R_I_E_TRIGGER_PROTOCOL_VIOLATED
+},
+
+{
+ "srf_protocol_violated", ERRCODE_E_R_I_E_SRF_PROTOCOL_VIOLATED
+},
+
+{
+ "event_trigger_protocol_violated", ERRCODE_E_R_I_E_EVENT_TRIGGER_PROTOCOL_VIOLATED
+},
+
+{
+ "savepoint_exception", ERRCODE_SAVEPOINT_EXCEPTION
+},
+
+{
+ "invalid_savepoint_specification", ERRCODE_S_E_INVALID_SPECIFICATION
+},
+
+{
+ "invalid_catalog_name", ERRCODE_INVALID_CATALOG_NAME
+},
+
+{
+ "invalid_schema_name", ERRCODE_INVALID_SCHEMA_NAME
+},
+
+{
+ "transaction_rollback", ERRCODE_TRANSACTION_ROLLBACK
+},
+
+{
+ "transaction_integrity_constraint_violation", ERRCODE_T_R_INTEGRITY_CONSTRAINT_VIOLATION
+},
+
+{
+ "serialization_failure", ERRCODE_T_R_SERIALIZATION_FAILURE
+},
+
+{
+ "statement_completion_unknown", ERRCODE_T_R_STATEMENT_COMPLETION_UNKNOWN
+},
+
+{
+ "deadlock_detected", ERRCODE_T_R_DEADLOCK_DETECTED
+},
+
+{
+ "syntax_error_or_access_rule_violation", ERRCODE_SYNTAX_ERROR_OR_ACCESS_RULE_VIOLATION
+},
+
+{
+ "syntax_error", ERRCODE_SYNTAX_ERROR
+},
+
+{
+ "insufficient_privilege", ERRCODE_INSUFFICIENT_PRIVILEGE
+},
+
+{
+ "cannot_coerce", ERRCODE_CANNOT_COERCE
+},
+
+{
+ "grouping_error", ERRCODE_GROUPING_ERROR
+},
+
+{
+ "windowing_error", ERRCODE_WINDOWING_ERROR
+},
+
+{
+ "invalid_recursion", ERRCODE_INVALID_RECURSION
+},
+
+{
+ "invalid_foreign_key", ERRCODE_INVALID_FOREIGN_KEY
+},
+
+{
+ "invalid_name", ERRCODE_INVALID_NAME
+},
+
+{
+ "name_too_long", ERRCODE_NAME_TOO_LONG
+},
+
+{
+ "reserved_name", ERRCODE_RESERVED_NAME
+},
+
+{
+ "datatype_mismatch", ERRCODE_DATATYPE_MISMATCH
+},
+
+{
+ "indeterminate_datatype", ERRCODE_INDETERMINATE_DATATYPE
+},
+
+{
+ "collation_mismatch", ERRCODE_COLLATION_MISMATCH
+},
+
+{
+ "indeterminate_collation", ERRCODE_INDETERMINATE_COLLATION
+},
+
+{
+ "wrong_object_type", ERRCODE_WRONG_OBJECT_TYPE
+},
+
+{
+ "generated_always", ERRCODE_GENERATED_ALWAYS
+},
+
+{
+ "undefined_column", ERRCODE_UNDEFINED_COLUMN
+},
+
+{
+ "undefined_function", ERRCODE_UNDEFINED_FUNCTION
+},
+
+{
+ "undefined_table", ERRCODE_UNDEFINED_TABLE
+},
+
+{
+ "undefined_parameter", ERRCODE_UNDEFINED_PARAMETER
+},
+
+{
+ "undefined_object", ERRCODE_UNDEFINED_OBJECT
+},
+
+{
+ "duplicate_column", ERRCODE_DUPLICATE_COLUMN
+},
+
+{
+ "duplicate_cursor", ERRCODE_DUPLICATE_CURSOR
+},
+
+{
+ "duplicate_database", ERRCODE_DUPLICATE_DATABASE
+},
+
+{
+ "duplicate_function", ERRCODE_DUPLICATE_FUNCTION
+},
+
+{
+ "duplicate_prepared_statement", ERRCODE_DUPLICATE_PSTATEMENT
+},
+
+{
+ "duplicate_schema", ERRCODE_DUPLICATE_SCHEMA
+},
+
+{
+ "duplicate_table", ERRCODE_DUPLICATE_TABLE
+},
+
+{
+ "duplicate_alias", ERRCODE_DUPLICATE_ALIAS
+},
+
+{
+ "duplicate_object", ERRCODE_DUPLICATE_OBJECT
+},
+
+{
+ "ambiguous_column", ERRCODE_AMBIGUOUS_COLUMN
+},
+
+{
+ "ambiguous_function", ERRCODE_AMBIGUOUS_FUNCTION
+},
+
+{
+ "ambiguous_parameter", ERRCODE_AMBIGUOUS_PARAMETER
+},
+
+{
+ "ambiguous_alias", ERRCODE_AMBIGUOUS_ALIAS
+},
+
+{
+ "invalid_column_reference", ERRCODE_INVALID_COLUMN_REFERENCE
+},
+
+{
+ "invalid_column_definition", ERRCODE_INVALID_COLUMN_DEFINITION
+},
+
+{
+ "invalid_cursor_definition", ERRCODE_INVALID_CURSOR_DEFINITION
+},
+
+{
+ "invalid_database_definition", ERRCODE_INVALID_DATABASE_DEFINITION
+},
+
+{
+ "invalid_function_definition", ERRCODE_INVALID_FUNCTION_DEFINITION
+},
+
+{
+ "invalid_prepared_statement_definition", ERRCODE_INVALID_PSTATEMENT_DEFINITION
+},
+
+{
+ "invalid_schema_definition", ERRCODE_INVALID_SCHEMA_DEFINITION
+},
+
+{
+ "invalid_table_definition", ERRCODE_INVALID_TABLE_DEFINITION
+},
+
+{
+ "invalid_object_definition", ERRCODE_INVALID_OBJECT_DEFINITION
+},
+
+{
+ "with_check_option_violation", ERRCODE_WITH_CHECK_OPTION_VIOLATION
+},
+
+{
+ "insufficient_resources", ERRCODE_INSUFFICIENT_RESOURCES
+},
+
+{
+ "disk_full", ERRCODE_DISK_FULL
+},
+
+{
+ "out_of_memory", ERRCODE_OUT_OF_MEMORY
+},
+
+{
+ "too_many_connections", ERRCODE_TOO_MANY_CONNECTIONS
+},
+
+{
+ "configuration_limit_exceeded", ERRCODE_CONFIGURATION_LIMIT_EXCEEDED
+},
+
+{
+ "program_limit_exceeded", ERRCODE_PROGRAM_LIMIT_EXCEEDED
+},
+
+{
+ "statement_too_complex", ERRCODE_STATEMENT_TOO_COMPLEX
+},
+
+{
+ "too_many_columns", ERRCODE_TOO_MANY_COLUMNS
+},
+
+{
+ "too_many_arguments", ERRCODE_TOO_MANY_ARGUMENTS
+},
+
+{
+ "object_not_in_prerequisite_state", ERRCODE_OBJECT_NOT_IN_PREREQUISITE_STATE
+},
+
+{
+ "object_in_use", ERRCODE_OBJECT_IN_USE
+},
+
+{
+ "cant_change_runtime_param", ERRCODE_CANT_CHANGE_RUNTIME_PARAM
+},
+
+{
+ "lock_not_available", ERRCODE_LOCK_NOT_AVAILABLE
+},
+
+{
+ "unsafe_new_enum_value_usage", ERRCODE_UNSAFE_NEW_ENUM_VALUE_USAGE
+},
+
+{
+ "operator_intervention", ERRCODE_OPERATOR_INTERVENTION
+},
+
+{
+ "query_canceled", ERRCODE_QUERY_CANCELED
+},
+
+{
+ "admin_shutdown", ERRCODE_ADMIN_SHUTDOWN
+},
+
+{
+ "crash_shutdown", ERRCODE_CRASH_SHUTDOWN
+},
+
+{
+ "cannot_connect_now", ERRCODE_CANNOT_CONNECT_NOW
+},
+
+{
+ "database_dropped", ERRCODE_DATABASE_DROPPED
+},
+
+{
+ "idle_session_timeout", ERRCODE_IDLE_SESSION_TIMEOUT
+},
+
+{
+ "system_error", ERRCODE_SYSTEM_ERROR
+},
+
+{
+ "io_error", ERRCODE_IO_ERROR
+},
+
+{
+ "undefined_file", ERRCODE_UNDEFINED_FILE
+},
+
+{
+ "duplicate_file", ERRCODE_DUPLICATE_FILE
+},
+
+{
+ "snapshot_too_old", ERRCODE_SNAPSHOT_TOO_OLD
+},
+
+{
+ "config_file_error", ERRCODE_CONFIG_FILE_ERROR
+},
+
+{
+ "lock_file_exists", ERRCODE_LOCK_FILE_EXISTS
+},
+
+{
+ "fdw_error", ERRCODE_FDW_ERROR
+},
+
+{
+ "fdw_column_name_not_found", ERRCODE_FDW_COLUMN_NAME_NOT_FOUND
+},
+
+{
+ "fdw_dynamic_parameter_value_needed", ERRCODE_FDW_DYNAMIC_PARAMETER_VALUE_NEEDED
+},
+
+{
+ "fdw_function_sequence_error", ERRCODE_FDW_FUNCTION_SEQUENCE_ERROR
+},
+
+{
+ "fdw_inconsistent_descriptor_information", ERRCODE_FDW_INCONSISTENT_DESCRIPTOR_INFORMATION
+},
+
+{
+ "fdw_invalid_attribute_value", ERRCODE_FDW_INVALID_ATTRIBUTE_VALUE
+},
+
+{
+ "fdw_invalid_column_name", ERRCODE_FDW_INVALID_COLUMN_NAME
+},
+
+{
+ "fdw_invalid_column_number", ERRCODE_FDW_INVALID_COLUMN_NUMBER
+},
+
+{
+ "fdw_invalid_data_type", ERRCODE_FDW_INVALID_DATA_TYPE
+},
+
+{
+ "fdw_invalid_data_type_descriptors", ERRCODE_FDW_INVALID_DATA_TYPE_DESCRIPTORS
+},
+
+{
+ "fdw_invalid_descriptor_field_identifier", ERRCODE_FDW_INVALID_DESCRIPTOR_FIELD_IDENTIFIER
+},
+
+{
+ "fdw_invalid_handle", ERRCODE_FDW_INVALID_HANDLE
+},
+
+{
+ "fdw_invalid_option_index", ERRCODE_FDW_INVALID_OPTION_INDEX
+},
+
+{
+ "fdw_invalid_option_name", ERRCODE_FDW_INVALID_OPTION_NAME
+},
+
+{
+ "fdw_invalid_string_length_or_buffer_length", ERRCODE_FDW_INVALID_STRING_LENGTH_OR_BUFFER_LENGTH
+},
+
+{
+ "fdw_invalid_string_format", ERRCODE_FDW_INVALID_STRING_FORMAT
+},
+
+{
+ "fdw_invalid_use_of_null_pointer", ERRCODE_FDW_INVALID_USE_OF_NULL_POINTER
+},
+
+{
+ "fdw_too_many_handles", ERRCODE_FDW_TOO_MANY_HANDLES
+},
+
+{
+ "fdw_out_of_memory", ERRCODE_FDW_OUT_OF_MEMORY
+},
+
+{
+ "fdw_no_schemas", ERRCODE_FDW_NO_SCHEMAS
+},
+
+{
+ "fdw_option_name_not_found", ERRCODE_FDW_OPTION_NAME_NOT_FOUND
+},
+
+{
+ "fdw_reply_handle", ERRCODE_FDW_REPLY_HANDLE
+},
+
+{
+ "fdw_schema_not_found", ERRCODE_FDW_SCHEMA_NOT_FOUND
+},
+
+{
+ "fdw_table_not_found", ERRCODE_FDW_TABLE_NOT_FOUND
+},
+
+{
+ "fdw_unable_to_create_execution", ERRCODE_FDW_UNABLE_TO_CREATE_EXECUTION
+},
+
+{
+ "fdw_unable_to_create_reply", ERRCODE_FDW_UNABLE_TO_CREATE_REPLY
+},
+
+{
+ "fdw_unable_to_establish_connection", ERRCODE_FDW_UNABLE_TO_ESTABLISH_CONNECTION
+},
+
+{
+ "plpgsql_error", ERRCODE_PLPGSQL_ERROR
+},
+
+{
+ "raise_exception", ERRCODE_RAISE_EXCEPTION
+},
+
+{
+ "no_data_found", ERRCODE_NO_DATA_FOUND
+},
+
+{
+ "too_many_rows", ERRCODE_TOO_MANY_ROWS
+},
+
+{
+ "assert_failure", ERRCODE_ASSERT_FAILURE
+},
+
+{
+ "internal_error", ERRCODE_INTERNAL_ERROR
+},
+
+{
+ "data_corrupted", ERRCODE_DATA_CORRUPTED
+},
+
+{
+ "index_corrupted", ERRCODE_INDEX_CORRUPTED
+},
diff --git a/src/pl/tcl/pltclu--1.0.sql b/src/pl/tcl/pltclu--1.0.sql
new file mode 100644
index 0000000..fca869f
--- /dev/null
+++ b/src/pl/tcl/pltclu--1.0.sql
@@ -0,0 +1,9 @@
+/* src/pl/tcl/pltclu--1.0.sql */
+
+CREATE FUNCTION pltclu_call_handler() RETURNS language_handler
+ LANGUAGE c AS 'MODULE_PATHNAME';
+
+CREATE LANGUAGE pltclu
+ HANDLER pltclu_call_handler;
+
+COMMENT ON LANGUAGE pltclu IS 'PL/TclU untrusted procedural language';
diff --git a/src/pl/tcl/pltclu.control b/src/pl/tcl/pltclu.control
new file mode 100644
index 0000000..1418dc5
--- /dev/null
+++ b/src/pl/tcl/pltclu.control
@@ -0,0 +1,7 @@
+# pltclu extension
+comment = 'PL/TclU untrusted procedural language'
+default_version = '1.0'
+module_pathname = '$libdir/pltcl'
+relocatable = false
+schema = pg_catalog
+superuser = true
diff --git a/src/pl/tcl/po/LINGUAS b/src/pl/tcl/po/LINGUAS
new file mode 100644
index 0000000..f6e1dc7
--- /dev/null
+++ b/src/pl/tcl/po/LINGUAS
@@ -0,0 +1 @@
+cs de el es fr it ja ka ko pl pt_BR ro ru sv tr uk vi zh_CN zh_TW
diff --git a/src/pl/tcl/po/cs.po b/src/pl/tcl/po/cs.po
new file mode 100644
index 0000000..e48dff2
--- /dev/null
+++ b/src/pl/tcl/po/cs.po
@@ -0,0 +1,117 @@
+# Czech message translation file for pltcl
+# Copyright (C) 2012 PostgreSQL Global Development Group
+# This file is distributed under the same license as the PostgreSQL package.
+#
+# Tomáš Vondra <tv@fuzzy.cz>, 2012, 2013.
+msgid ""
+msgstr ""
+"Project-Id-Version: pltcl-cs (PostgreSQL 9.3)\n"
+"Report-Msgid-Bugs-To: pgsql-bugs@lists.postgresql.org\n"
+"POT-Creation-Date: 2019-09-27 08:07+0000\n"
+"PO-Revision-Date: 2019-09-27 21:02+0200\n"
+"Last-Translator: Tomas Vondra <tv@fuzzy.cz>\n"
+"Language-Team: Czech <info@cspug.cx>\n"
+"Language: cs\n"
+"MIME-Version: 1.0\n"
+"Content-Type: text/plain; charset=UTF-8\n"
+"Content-Transfer-Encoding: 8bit\n"
+"X-Generator: Poedit 2.2.3\n"
+
+#: pltcl.c:464
+msgid "PL/Tcl function to call once when pltcl is first used."
+msgstr "PL/Tcl funkce kterou zavolat jednou při prvním použití pltcl."
+
+#: pltcl.c:471
+msgid "PL/TclU function to call once when pltclu is first used."
+msgstr "PL/TclU funkce kterou zavolat jednou při prvním použití pltclu."
+
+#: pltcl.c:636
+#, c-format
+msgid "function \"%s\" is in the wrong language"
+msgstr "funkce \"%s\" je ve špatném jazyce"
+
+#: pltcl.c:647
+#, c-format
+msgid "function \"%s\" must not be SECURITY DEFINER"
+msgstr "funkce \"%s\" nesmí být SECURITY DEFINER"
+
+#. translator: %s is "pltcl.start_proc" or "pltclu.start_proc"
+#: pltcl.c:681
+#, c-format
+msgid "processing %s parameter"
+msgstr "zpracovávám %s parametr"
+
+#: pltcl.c:842
+#, c-format
+msgid "set-valued function called in context that cannot accept a set"
+msgstr "set-valued funkce volána v kontextu který nemůže přijmout více řádek"
+
+#: pltcl.c:1015
+#, c-format
+msgid "function returning record called in context that cannot accept type record"
+msgstr "funkce vracející záznam volána v kontextu který nemůže přijmout záznam"
+
+#: pltcl.c:1299
+#, c-format
+msgid "could not split return value from trigger: %s"
+msgstr "z triggeru nelze oddělit návratovou hodnotu: %s"
+
+#: pltcl.c:1379 pltcl.c:1809
+#, c-format
+msgid "%s"
+msgstr "%s"
+
+#: pltcl.c:1380
+#, c-format
+msgid ""
+"%s\n"
+"in PL/Tcl function \"%s\""
+msgstr ""
+"%s\n"
+"v PL/Tcl funkci \"%s\""
+
+#: pltcl.c:1544
+#, c-format
+msgid "trigger functions can only be called as triggers"
+msgstr "funkce pro obsluhu triggerů mohou být volané pouze prostřednictvím triggerů"
+
+#: pltcl.c:1548
+#, c-format
+msgid "PL/Tcl functions cannot return type %s"
+msgstr "PL/Tcl funkce nemohou vracet datový typ %s"
+
+#: pltcl.c:1587
+#, c-format
+msgid "PL/Tcl functions cannot accept type %s"
+msgstr "PL/Tcl funkce nemohou přijímat datový typ %s"
+
+#: pltcl.c:1701
+#, c-format
+msgid "could not create internal procedure \"%s\": %s"
+msgstr "nelze vytvořit interní proceduru \"%s\": %s"
+
+#: pltcl.c:3208
+#, c-format
+msgid "column name/value list must have even number of elements"
+msgstr "seznam názvů sloupců a hodnot musí mít sudý počet položek"
+
+#: pltcl.c:3226
+#, c-format
+msgid "column name/value list contains nonexistent column name \"%s\""
+msgstr "seznam názvů sloupců a hodnot obsahuje neexistující název sloupce \"%s\""
+
+#: pltcl.c:3233
+#, c-format
+msgid "cannot set system attribute \"%s\""
+msgstr "nelze nastavit systémový atribut \"%s\""
+
+#: pltcl.c:3239
+#, c-format
+msgid "cannot set generated column \"%s\""
+msgstr "nelze přiřazovat do generovaného sloupce \"%s\""
+
+#~ msgid "PL/Tcl functions cannot return composite types"
+#~ msgstr "PL/Tcl funkce nemohou vracet složené datové typy"
+
+#~ msgid "out of memory"
+#~ msgstr "paměť vyčerpána"
diff --git a/src/pl/tcl/po/de.po b/src/pl/tcl/po/de.po
new file mode 100644
index 0000000..e191a2b
--- /dev/null
+++ b/src/pl/tcl/po/de.po
@@ -0,0 +1,115 @@
+# German message translation file for PL/Tcl
+# Peter Eisentraut <peter@eisentraut.org>, 2009 - 2022.
+#
+# Use these quotes: »%s«
+#
+msgid ""
+msgstr ""
+"Project-Id-Version: PostgreSQL 15\n"
+"Report-Msgid-Bugs-To: pgsql-bugs@lists.postgresql.org\n"
+"POT-Creation-Date: 2022-04-08 12:09+0000\n"
+"PO-Revision-Date: 2022-04-08 14:40+0200\n"
+"Last-Translator: Peter Eisentraut <peter@eisentraut.org>\n"
+"Language-Team: German <pgsql-translators@postgresql.org>\n"
+"Language: de\n"
+"MIME-Version: 1.0\n"
+"Content-Type: text/plain; charset=UTF-8\n"
+"Content-Transfer-Encoding: 8bit\n"
+
+#: pltcl.c:463
+msgid "PL/Tcl function to call once when pltcl is first used."
+msgstr "PL/Tcl-Funktion, die einmal aufgerufen wird, wenn pltcl zum ersten Mal benutzt wird."
+
+#: pltcl.c:470
+msgid "PL/TclU function to call once when pltclu is first used."
+msgstr "PL/Tcl-Funktion, die einmal aufgerufen wird, wenn pltclu zum ersten Mal benutzt wird."
+
+#: pltcl.c:637
+#, c-format
+msgid "function \"%s\" is in the wrong language"
+msgstr "Funktion »%s« ist in der falschen Sprache"
+
+#: pltcl.c:648
+#, c-format
+msgid "function \"%s\" must not be SECURITY DEFINER"
+msgstr "Funktion »%s« darf nicht SECURITY DEFINER sein"
+
+#. translator: %s is "pltcl.start_proc" or "pltclu.start_proc"
+#: pltcl.c:682
+#, c-format
+msgid "processing %s parameter"
+msgstr "Verarbeiten von Parameter von %s"
+
+#: pltcl.c:835
+#, c-format
+msgid "set-valued function called in context that cannot accept a set"
+msgstr "Funktion mit Mengenergebnis in einem Zusammenhang aufgerufen, der keine Mengenergebnisse verarbeiten kann"
+
+#: pltcl.c:840
+#, c-format
+msgid "materialize mode required, but it is not allowed in this context"
+msgstr "Materialisierungsmodus wird benötigt, ist aber in diesem Zusammenhang nicht erlaubt"
+
+#: pltcl.c:1013
+#, c-format
+msgid "function returning record called in context that cannot accept type record"
+msgstr "Funktion, die einen Record zurückgibt, in einem Zusammenhang aufgerufen, der Typ record nicht verarbeiten kann"
+
+#: pltcl.c:1297
+#, c-format
+msgid "could not split return value from trigger: %s"
+msgstr "konnte Rückgabewert des Triggers nicht splitten: %s"
+
+#: pltcl.c:1378 pltcl.c:1808
+#, c-format
+msgid "%s"
+msgstr "%s"
+
+#: pltcl.c:1379
+#, c-format
+msgid ""
+"%s\n"
+"in PL/Tcl function \"%s\""
+msgstr ""
+"%s\n"
+"in PL/Tcl-Funktion »%s«"
+
+#: pltcl.c:1543
+#, c-format
+msgid "trigger functions can only be called as triggers"
+msgstr "Triggerfunktionen können nur als Trigger aufgerufen werden"
+
+#: pltcl.c:1547
+#, c-format
+msgid "PL/Tcl functions cannot return type %s"
+msgstr "PL/Tcl-Funktionen können keinen Rückgabetyp %s haben"
+
+#: pltcl.c:1586
+#, c-format
+msgid "PL/Tcl functions cannot accept type %s"
+msgstr "PL/Tcl-Funktionen können Typ %s nicht annehmen"
+
+#: pltcl.c:1700
+#, c-format
+msgid "could not create internal procedure \"%s\": %s"
+msgstr "konnte interne Prozedur »%s« nicht erzeugen: %s"
+
+#: pltcl.c:3202
+#, c-format
+msgid "column name/value list must have even number of elements"
+msgstr "Liste der Spaltennamen/-werte muss gerade Anzahl Elemente haben"
+
+#: pltcl.c:3220
+#, c-format
+msgid "column name/value list contains nonexistent column name \"%s\""
+msgstr "Liste der Spaltennamen/-werte enthält nicht existierenden Spaltennamen »%s«"
+
+#: pltcl.c:3227
+#, c-format
+msgid "cannot set system attribute \"%s\""
+msgstr "Systemattribut »%s« kann nicht gesetzt werden"
+
+#: pltcl.c:3233
+#, c-format
+msgid "cannot set generated column \"%s\""
+msgstr "kann generierte Spalte »%s« nicht setzen"
diff --git a/src/pl/tcl/po/el.po b/src/pl/tcl/po/el.po
new file mode 100644
index 0000000..6d0bd50
--- /dev/null
+++ b/src/pl/tcl/po/el.po
@@ -0,0 +1,118 @@
+# Greek message translation file for pltcl
+# Copyright (C) 2021 PostgreSQL Global Development Group
+# This file is distributed under the same license as the pltcl (PostgreSQL) package.
+# Georgios Kokolatos <gkokolatos@pm.me>, 2021
+#
+#
+#
+msgid ""
+msgstr ""
+"Project-Id-Version: pltcl (PostgreSQL) 15\n"
+"Report-Msgid-Bugs-To: pgsql-bugs@lists.postgresql.org\n"
+"POT-Creation-Date: 2023-04-14 09:08+0000\n"
+"PO-Revision-Date: 2023-04-14 15:05+0200\n"
+"Last-Translator: Georgios Kokolatos <gkokolatos@pm.me>\n"
+"Language-Team: \n"
+"Language: el\n"
+"MIME-Version: 1.0\n"
+"Content-Type: text/plain; charset=UTF-8\n"
+"Content-Transfer-Encoding: 8bit\n"
+"X-Generator: Poedit 3.2.2\n"
+
+#: pltcl.c:463
+msgid "PL/Tcl function to call once when pltcl is first used."
+msgstr "Συνάρτηση PL/Tcl για να καλέσει μία μόνο φορά όταν χρησιμοποιείται pltcl για πρώτη φορά."
+
+#: pltcl.c:470
+msgid "PL/TclU function to call once when pltclu is first used."
+msgstr "Συνάρτηση PL/Tcl για να καλέσει μία μόνο φορά όταν χρησιμοποιείται pltclu για πρώτη φορά ."
+
+#: pltcl.c:637
+#, c-format
+msgid "function \"%s\" is in the wrong language"
+msgstr "η συνάρτηση «%s» βρίσκεται σε λάθος γλώσσα"
+
+#: pltcl.c:648
+#, c-format
+msgid "function \"%s\" must not be SECURITY DEFINER"
+msgstr "η συνάρτηση «%s» δεν πρέπει να είναι SECURITY DEFINER"
+
+#. translator: %s is "pltcl.start_proc" or "pltclu.start_proc"
+#: pltcl.c:682
+#, c-format
+msgid "processing %s parameter"
+msgstr "επεξεργάζεται παράμετρο %s"
+
+#: pltcl.c:835
+#, c-format
+msgid "set-valued function called in context that cannot accept a set"
+msgstr "set-valued συνάρτηση καλείται σε περιεχόμενο που δεν μπορεί να δεχτεί ένα σύνολο"
+
+#: pltcl.c:840
+#, c-format
+msgid "materialize mode required, but it is not allowed in this context"
+msgstr "επιβάλλεται λειτουργία υλοποίησης, αλλά δεν επιτρέπεται σε αυτό το περιεχόμενο"
+
+#: pltcl.c:1013
+#, c-format
+msgid "function returning record called in context that cannot accept type record"
+msgstr "συνάρτηση που επιστρέφει εγγραφή καλείται σε περιεχόμενο που δεν δύναται να αποδεχτεί τύπο εγγραφής"
+
+#: pltcl.c:1296
+#, c-format
+msgid "could not split return value from trigger: %s"
+msgstr "δεν ήταν δυνατός ο διαχωρισμός επιστρεφόμενης τιμής από έναυσμα: %s"
+
+#: pltcl.c:1377 pltcl.c:1807
+#, c-format
+msgid "%s"
+msgstr "%s"
+
+#: pltcl.c:1378
+#, c-format
+msgid ""
+"%s\n"
+"in PL/Tcl function \"%s\""
+msgstr ""
+"%s\n"
+"στη συνάρτηση PL/Tcl «%s»"
+
+#: pltcl.c:1542
+#, c-format
+msgid "trigger functions can only be called as triggers"
+msgstr "συναρτήσεις εναυσμάτων μπορούν να κληθούν μόνο ως εναύσματα"
+
+#: pltcl.c:1546
+#, c-format
+msgid "PL/Tcl functions cannot return type %s"
+msgstr "συναρτήσεις PL/Tcl δεν είναι δυνατό να επιστρέψουν τύπο %s"
+
+#: pltcl.c:1585
+#, c-format
+msgid "PL/Tcl functions cannot accept type %s"
+msgstr "συναρτήσεις PL/Tcl δεν είναι δυνατό να δεχτούν τύπο %s"
+
+#: pltcl.c:1699
+#, c-format
+msgid "could not create internal procedure \"%s\": %s"
+msgstr "δεν ήταν δυνατή η δημιουργία εσωτερικής διαδικασίας «%s»: %s"
+
+#: pltcl.c:3202
+#, c-format
+msgid "column name/value list must have even number of elements"
+msgstr "λίστα ονόματος/τιμής στήλης πρέπει να έχει άρτιο αριθμό στοιχείων"
+
+#: pltcl.c:3220
+#, c-format
+msgid "column name/value list contains nonexistent column name \"%s\""
+msgstr "λίστα ονόματος/τιμής στήλης περιέχει ανύπαρκτο όνομα στήλης «%s»"
+
+#: pltcl.c:3227
+#, c-format
+msgid "cannot set system attribute \"%s\""
+msgstr "δεν είναι δυνατός ο ορισμός του χαρακτηριστικού συστήματος «%s»"
+
+#: pltcl.c:3233
+#, c-format
+msgid "cannot set generated column \"%s\""
+msgstr "δεν είναι δυνατός ο ορισμός δημιουργημένης στήλης «%s»"
diff --git a/src/pl/tcl/po/es.po b/src/pl/tcl/po/es.po
new file mode 100644
index 0000000..ff271b4
--- /dev/null
+++ b/src/pl/tcl/po/es.po
@@ -0,0 +1,119 @@
+# Spanish translation file for pltcl
+#
+# Copyright (c) 2009-2021, PostgreSQL Global Development Group
+# This file is distributed under the same license as the PostgreSQL package.
+#
+# Emanuel Calvo Franco <postgres.arg@gmail.com>, 2009.
+# Alvaro Herrera <alvherre@alvh.no-ip.org>, 2009-2012, 2015
+#
+msgid ""
+msgstr ""
+"Project-Id-Version: pltcl (PostgreSQL) 16\n"
+"Report-Msgid-Bugs-To: pgsql-bugs@lists.postgresql.org\n"
+"POT-Creation-Date: 2023-05-22 07:08+0000\n"
+"PO-Revision-Date: 2023-05-22 12:06+0200\n"
+"Last-Translator: Carlos Chapi <carlos.chapi@2ndquadrant.com>\n"
+"Language-Team: PgSQL-es-Ayuda <pgsql-es-ayuda@lists.postgresql.org>\n"
+"Language: es\n"
+"MIME-Version: 1.0\n"
+"Content-Type: text/plain; charset=UTF-8\n"
+"Content-Transfer-Encoding: 8bit\n"
+"X-Generator: Poedit 2.0.2\n"
+
+#: pltcl.c:462
+msgid "PL/Tcl function to call once when pltcl is first used."
+msgstr "función PL/Tcl a ejecutar cuando se use pltcl por primera vez."
+
+#: pltcl.c:469
+msgid "PL/TclU function to call once when pltclu is first used."
+msgstr "función PL/TclU a ejecutar cuando se use pltclu por primera vez."
+
+#: pltcl.c:636
+#, c-format
+msgid "function \"%s\" is in the wrong language"
+msgstr "la función «%s» está en el lenguaje equivocado"
+
+#: pltcl.c:647
+#, c-format
+msgid "function \"%s\" must not be SECURITY DEFINER"
+msgstr "la función «%s» no debe ser SECURITY DEFINER"
+
+#. translator: %s is "pltcl.start_proc" or "pltclu.start_proc"
+#: pltcl.c:681
+#, c-format
+msgid "processing %s parameter"
+msgstr "procesando el parámetro %s"
+
+#: pltcl.c:834
+#, c-format
+msgid "set-valued function called in context that cannot accept a set"
+msgstr "se llamó una función que retorna un conjunto en un contexto que no puede aceptarlo"
+
+#: pltcl.c:839
+#, c-format
+msgid "materialize mode required, but it is not allowed in this context"
+msgstr "se requiere un nodo «materialize», pero no está permitido en este contexto"
+
+#: pltcl.c:1012
+#, c-format
+msgid "function returning record called in context that cannot accept type record"
+msgstr "se llamó una función que retorna un registro en un contexto que no puede aceptarlo"
+
+#: pltcl.c:1295
+#, c-format
+msgid "could not split return value from trigger: %s"
+msgstr "no se pudo separar el valor de retorno del disparador: %s"
+
+#: pltcl.c:1376 pltcl.c:1803
+#, c-format
+msgid "%s"
+msgstr "%s"
+
+#: pltcl.c:1377
+#, c-format
+msgid ""
+"%s\n"
+"in PL/Tcl function \"%s\""
+msgstr ""
+"%s\n"
+"en función PL/Tcl \"%s\""
+
+#: pltcl.c:1540
+#, c-format
+msgid "trigger functions can only be called as triggers"
+msgstr "las funciones disparadoras sólo pueden ser invocadas como disparadores"
+
+#: pltcl.c:1544
+#, c-format
+msgid "PL/Tcl functions cannot return type %s"
+msgstr "las funciones PL/Tcl no pueden retornar tipo %s"
+
+#: pltcl.c:1583
+#, c-format
+msgid "PL/Tcl functions cannot accept type %s"
+msgstr "las funciones PL/Tcl no pueden aceptar el tipog%s"
+
+#: pltcl.c:1695
+#, c-format
+msgid "could not create internal procedure \"%s\": %s"
+msgstr "no se pudo crear procedimiento interno «%s»: %s"
+
+#: pltcl.c:3199
+#, c-format
+msgid "column name/value list must have even number of elements"
+msgstr "la lista de nombres de columnas y valores debe tener un número par de elementos"
+
+#: pltcl.c:3217
+#, c-format
+msgid "column name/value list contains nonexistent column name \"%s\""
+msgstr "la lista de nombres de columnas y valores contiene el nombre de columna no existente «%s»"
+
+#: pltcl.c:3224
+#, c-format
+msgid "cannot set system attribute \"%s\""
+msgstr "no se puede definir el atributo de sistema «%s»"
+
+#: pltcl.c:3230
+#, c-format
+msgid "cannot set generated column \"%s\""
+msgstr "no se puede definir el atributo generado «%s»"
diff --git a/src/pl/tcl/po/fr.po b/src/pl/tcl/po/fr.po
new file mode 100644
index 0000000..2af48d8
--- /dev/null
+++ b/src/pl/tcl/po/fr.po
@@ -0,0 +1,140 @@
+# LANGUAGE message translation file for pltcl
+# Copyright (C) 2009-2022 PostgreSQL Global Development Group
+# This file is distributed under the same license as the pltcl (PostgreSQL) package.
+#
+# Use these quotes: « %s »
+#
+# Guillaume Lelarge <guillaume@lelarge.info>, 2009-2022.
+#
+msgid ""
+msgstr ""
+"Project-Id-Version: PostgreSQL 15\n"
+"Report-Msgid-Bugs-To: pgsql-bugs@lists.postgresql.org\n"
+"POT-Creation-Date: 2022-04-12 05:16+0000\n"
+"PO-Revision-Date: 2022-04-12 17:29+0200\n"
+"Last-Translator: Guillaume Lelarge <guillaume@lelarge.info>\n"
+"Language-Team: French <guillaume@lelarge.info>\n"
+"Language: fr\n"
+"MIME-Version: 1.0\n"
+"Content-Type: text/plain; charset=UTF-8\n"
+"Content-Transfer-Encoding: 8bit\n"
+"Plural-Forms: nplurals=2; plural=(n > 1);\n"
+"X-Generator: Poedit 3.0.1\n"
+
+#: pltcl.c:463
+msgid "PL/Tcl function to call once when pltcl is first used."
+msgstr "Fonction PL/Tcl à appeler une fois quand pltcl est utilisé pour la première fois."
+
+#: pltcl.c:470
+msgid "PL/TclU function to call once when pltclu is first used."
+msgstr "Fonction PL/TclU à appeler une fois quand pltcl est utilisé pour la première fois."
+
+#: pltcl.c:637
+#, c-format
+msgid "function \"%s\" is in the wrong language"
+msgstr "la fonction « %s » est dans le mauvais langage"
+
+#: pltcl.c:648
+#, c-format
+msgid "function \"%s\" must not be SECURITY DEFINER"
+msgstr "la fonction « %s » doit être définie en SECURITY DEFINER"
+
+#. translator: %s is "pltcl.start_proc" or "pltclu.start_proc"
+#: pltcl.c:682
+#, c-format
+msgid "processing %s parameter"
+msgstr "traitement du paramètre %s"
+
+#: pltcl.c:835
+#, c-format
+msgid "set-valued function called in context that cannot accept a set"
+msgstr "la fonction renvoyant un ensemble a été appelée dans un contexte qui n'accepte pas un ensemble"
+
+#: pltcl.c:840
+#, c-format
+msgid "materialize mode required, but it is not allowed in this context"
+msgstr "mode matérialisé requis mais interdit dans ce contexte"
+
+#: pltcl.c:1013
+#, c-format
+msgid "function returning record called in context that cannot accept type record"
+msgstr ""
+"fonction renvoyant le type record appelée dans un contexte qui ne peut pas\n"
+"accepter le type record"
+
+#: pltcl.c:1297
+#, c-format
+msgid "could not split return value from trigger: %s"
+msgstr "n'a pas pu séparer la valeur de retour du trigger : %s"
+
+#: pltcl.c:1378 pltcl.c:1808
+#, c-format
+msgid "%s"
+msgstr "%s"
+
+#: pltcl.c:1379
+#, c-format
+msgid ""
+"%s\n"
+"in PL/Tcl function \"%s\""
+msgstr ""
+"%s\n"
+"dans la fonction PL/Tcl « %s »"
+
+#: pltcl.c:1543
+#, c-format
+msgid "trigger functions can only be called as triggers"
+msgstr "les fonctions trigger peuvent seulement être appelées par des triggers"
+
+#: pltcl.c:1547
+#, c-format
+msgid "PL/Tcl functions cannot return type %s"
+msgstr "les fonctions PL/Tcl ne peuvent pas renvoyer le type %s"
+
+#: pltcl.c:1586
+#, c-format
+msgid "PL/Tcl functions cannot accept type %s"
+msgstr "les fonctions PL/Tcl ne peuvent pas accepter le type %s"
+
+#: pltcl.c:1700
+#, c-format
+msgid "could not create internal procedure \"%s\": %s"
+msgstr "n'a pas pu créer la procédure interne « %s » : %s"
+
+#: pltcl.c:3202
+#, c-format
+msgid "column name/value list must have even number of elements"
+msgstr "la liste de nom de colonne/valeur doit avoir un nombre pair d'éléments"
+
+#: pltcl.c:3220
+#, c-format
+msgid "column name/value list contains nonexistent column name \"%s\""
+msgstr "la liste de nom de colonne/valeur contient des noms de colonne inexistantes (« %s »)"
+
+#: pltcl.c:3227
+#, c-format
+msgid "cannot set system attribute \"%s\""
+msgstr "ne peut pas initialiser l'attribut système « %s »"
+
+#: pltcl.c:3233
+#, c-format
+msgid "cannot set generated column \"%s\""
+msgstr "ne peut pas initialiser la colonne générée « %s »"
+
+#~ msgid "PL/Tcl functions cannot return composite types"
+#~ msgstr "les fonctions PL/Tcl ne peuvent pas renvoyer des types composites"
+
+#~ msgid "could not load module \"unknown\": %s"
+#~ msgstr "n'a pas pu charger le module « unknown » : %s"
+
+#~ msgid "module \"unknown\" not found in pltcl_modules"
+#~ msgstr "module « unkown » introuvable dans pltcl_modules"
+
+#~ msgid "out of memory"
+#~ msgstr "mémoire épuisée"
+
+#~ msgid "trigger's return list must have even number of elements"
+#~ msgstr "la liste de retour du trigger doit avoir un nombre pair d'éléments"
+
+#~ msgid "unrecognized attribute \"%s\""
+#~ msgstr "attribut « %s » non reconnu"
diff --git a/src/pl/tcl/po/it.po b/src/pl/tcl/po/it.po
new file mode 100644
index 0000000..01e64c6
--- /dev/null
+++ b/src/pl/tcl/po/it.po
@@ -0,0 +1,127 @@
+#
+# pltcl.po
+# Italian message translation file for pltcl
+#
+# For development and bug report please use:
+# https://github.com/dvarrazzo/postgresql-it
+#
+# Copyright (C) 2012-2017 PostgreSQL Global Development Group
+# Copyright (C) 2010, Associazione Culturale ITPUG
+#
+# Daniele Varrazzo <daniele.varrazzo@gmail.com>, 2012-2017.
+# Flavio Spada <f.spada@sbv.mi.it>
+#
+# This file is distributed under the same license as the PostgreSQL package.
+#
+msgid ""
+msgstr ""
+"Project-Id-Version: pltcl (PostgreSQL) 10\n"
+"Report-Msgid-Bugs-To: pgsql-bugs@lists.postgresql.org\n"
+"POT-Creation-Date: 2022-09-26 08:08+0000\n"
+"PO-Revision-Date: 2022-09-26 15:04+0200\n"
+"Last-Translator: Daniele Varrazzo <daniele.varrazzo@gmail.com>\n"
+"Language-Team: https://github.com/dvarrazzo/postgresql-it\n"
+"Language: it\n"
+"MIME-Version: 1.0\n"
+"Content-Type: text/plain; charset=UTF-8\n"
+"Content-Transfer-Encoding: 8bit\n"
+"Plural-Forms: nplurals=2; plural=n != 1;\n"
+"X-Generator: Poedit 3.1.1\n"
+
+#: pltcl.c:463
+msgid "PL/Tcl function to call once when pltcl is first used."
+msgstr "Funzione PL/Tcl da richiamare una volta quando pltcl è usato la prima volta."
+
+#: pltcl.c:470
+msgid "PL/TclU function to call once when pltclu is first used."
+msgstr "Funzione PL/TclU da richiamare una volta quando pltcl è usato la prima volta."
+
+#: pltcl.c:637
+#, c-format
+msgid "function \"%s\" is in the wrong language"
+msgstr "la funzione \"%s\" è nel linguaggio sbagliato"
+
+#: pltcl.c:648
+#, c-format
+msgid "function \"%s\" must not be SECURITY DEFINER"
+msgstr "la funzione \"%s\" non può essere SECURITY DEFINER"
+
+#. translator: %s is "pltcl.start_proc" or "pltclu.start_proc"
+#: pltcl.c:682
+#, c-format
+msgid "processing %s parameter"
+msgstr "esecuzione del parametro %s"
+
+#: pltcl.c:835
+#, c-format
+msgid "set-valued function called in context that cannot accept a set"
+msgstr "funzione che restituisce insiemi richiamata in un contesto che non può accettare un insieme"
+
+#: pltcl.c:840
+#, c-format
+msgid "materialize mode required, but it is not allowed in this context"
+msgstr "necessaria modalità materializzata, ma non ammessa in questo contesto"
+
+#: pltcl.c:1013
+#, c-format
+msgid "function returning record called in context that cannot accept type record"
+msgstr "funzione che restituisce record richiamata in un contesto che non può accettare record"
+
+#: pltcl.c:1296
+#, c-format
+msgid "could not split return value from trigger: %s"
+msgstr "divisione del valore di ritorno del trigger fallita: %s"
+
+#: pltcl.c:1377 pltcl.c:1807
+#, c-format
+msgid "%s"
+msgstr "%s"
+
+#: pltcl.c:1378
+#, c-format
+msgid ""
+"%s\n"
+"in PL/Tcl function \"%s\""
+msgstr ""
+"%s\n"
+"nella funzione PL/Tcl \"%s\""
+
+#: pltcl.c:1542
+#, c-format
+msgid "trigger functions can only be called as triggers"
+msgstr "le funzioni trigger possono essere chiamate esclusivamente da trigger"
+
+#: pltcl.c:1546
+#, c-format
+msgid "PL/Tcl functions cannot return type %s"
+msgstr "le funzioni PL/Tcl non possono restituire il tipo %s"
+
+#: pltcl.c:1585
+#, c-format
+msgid "PL/Tcl functions cannot accept type %s"
+msgstr "le funzioni PL/Tcl non possono accettare il tipo %s"
+
+#: pltcl.c:1699
+#, c-format
+msgid "could not create internal procedure \"%s\": %s"
+msgstr "creazione della procedura interna \"%s\" fallita: %s"
+
+#: pltcl.c:3201
+#, c-format
+msgid "column name/value list must have even number of elements"
+msgstr "la lista nome/valore di colonne deve avere un numero di elementi pari"
+
+#: pltcl.c:3219
+#, c-format
+msgid "column name/value list contains nonexistent column name \"%s\""
+msgstr "la lista nome/valore di elementi contiene un nome di colonna inesistente \"%s\""
+
+#: pltcl.c:3226
+#, c-format
+msgid "cannot set system attribute \"%s\""
+msgstr "non è possibile impostare l'attributo di sistema \"%s\""
+
+#: pltcl.c:3232
+#, c-format
+msgid "cannot set generated column \"%s\""
+msgstr "non è possibile modificare la colonna ereditata \"%s\""
diff --git a/src/pl/tcl/po/ja.po b/src/pl/tcl/po/ja.po
new file mode 100644
index 0000000..15bd611
--- /dev/null
+++ b/src/pl/tcl/po/ja.po
@@ -0,0 +1,117 @@
+# Japanese message translation file for pltcl
+# Copyright (C) 2022 PostgreSQL Global Development Group
+# This file is distributed under the same license as the pg_archivecleanup (PostgreSQL) package.
+# KOIZUMI Satoru <koizumistr@minos.ocn.ne.jp>, 2015.
+#
+msgid ""
+msgstr ""
+"Project-Id-Version: pltcl (PostgreSQL 16)\n"
+"Report-Msgid-Bugs-To: pgsql-bugs@lists.postgresql.org\n"
+"POT-Creation-Date: 2022-07-14 10:48+0900\n"
+"PO-Revision-Date: 2019-06-11 17:26+0900\n"
+"Last-Translator: Kyotaro Horiguchi <horikyota.ntt@gmail.com>\n"
+"Language-Team: Japan PostgreSQL Users Group <jpug-doc@ml.postgresql.jp>\n"
+"Language: ja\n"
+"MIME-Version: 1.0\n"
+"Content-Type: text/plain; charset=UTF-8\n"
+"Content-Transfer-Encoding: 8bit\n"
+"Plural-Forms: nplurals=1; plural=0;\n"
+"X-Generator: Poedit 1.5.4\n"
+
+#: pltcl.c:463
+msgid "PL/Tcl function to call once when pltcl is first used."
+msgstr "pltcl が最初に使用される際に一度だけ呼び出される PL/Tcl 関数。"
+
+#: pltcl.c:470
+msgid "PL/TclU function to call once when pltclu is first used."
+msgstr "pltclu が最初に使用される際に一度だけ呼び出される PL/TclU 関数。"
+
+#: pltcl.c:637
+#, c-format
+msgid "function \"%s\" is in the wrong language"
+msgstr "関数\"%s\"は言語が異なります"
+
+#: pltcl.c:648
+#, c-format
+msgid "function \"%s\" must not be SECURITY DEFINER"
+msgstr "関数\"%s\"はSECURITY DEFINERであってはなりません"
+
+#. translator: %s is "pltcl.start_proc" or "pltclu.start_proc"
+#: pltcl.c:682
+#, c-format
+msgid "processing %s parameter"
+msgstr "%sパラメーターを処理しています"
+
+#: pltcl.c:835
+#, c-format
+msgid "set-valued function called in context that cannot accept a set"
+msgstr "このコンテキストでは、集合値の関数は集合を受け付けられません"
+
+#: pltcl.c:840
+#, c-format
+msgid "materialize mode required, but it is not allowed in this context"
+msgstr "マテリアライズモードが必要ですが、現在のコンテクストで禁止されています"
+
+#: pltcl.c:1013
+#, c-format
+msgid "function returning record called in context that cannot accept type record"
+msgstr "レコード型を受け付けられないコンテキストでレコードを返す関数が呼び出されました"
+
+#: pltcl.c:1296
+#, c-format
+msgid "could not split return value from trigger: %s"
+msgstr "トリガーからの戻り値を分割できませんでした: %s"
+
+#: pltcl.c:1377 pltcl.c:1807
+#, c-format
+msgid "%s"
+msgstr "%s"
+
+#: pltcl.c:1378
+#, c-format
+msgid ""
+"%s\n"
+"in PL/Tcl function \"%s\""
+msgstr ""
+"%s\n"
+"PL/Tcl 関数 \"%s\""
+
+#: pltcl.c:1542
+#, c-format
+msgid "trigger functions can only be called as triggers"
+msgstr "トリガー関数はトリガーとしてのみコールできます"
+
+#: pltcl.c:1546
+#, c-format
+msgid "PL/Tcl functions cannot return type %s"
+msgstr "PL/Tcl 関数は%s型の戻り値を返せません"
+
+#: pltcl.c:1585
+#, c-format
+msgid "PL/Tcl functions cannot accept type %s"
+msgstr "PL/Tcl 関数は%s型を受け付けません"
+
+#: pltcl.c:1699
+#, c-format
+msgid "could not create internal procedure \"%s\": %s"
+msgstr "内部プロシージャ\"%s\"を作成できませんでした: %s"
+
+#: pltcl.c:3201
+#, c-format
+msgid "column name/value list must have even number of elements"
+msgstr "列名/値のリストの要素は偶数個でなければなりません"
+
+#: pltcl.c:3219
+#, c-format
+msgid "column name/value list contains nonexistent column name \"%s\""
+msgstr "列名/値のリストの中に、存在しない列名\"%s\"が含まれています"
+
+#: pltcl.c:3226
+#, c-format
+msgid "cannot set system attribute \"%s\""
+msgstr "システム属性\"%s\"は設定できません"
+
+#: pltcl.c:3232
+#, c-format
+msgid "cannot set generated column \"%s\""
+msgstr "生成列\"%s\"を変更できません"
diff --git a/src/pl/tcl/po/ka.po b/src/pl/tcl/po/ka.po
new file mode 100644
index 0000000..1554015
--- /dev/null
+++ b/src/pl/tcl/po/ka.po
@@ -0,0 +1,117 @@
+# Georgian message translation file for pltcl
+# Copyright (C) 2022 PostgreSQL Global Development Group
+# This file is distributed under the same license as the pltcl (PostgreSQL) package.
+# Temuri Doghonadze <temuri.doghonadze@gmail.com>, 2022.
+#
+msgid ""
+msgstr ""
+"Project-Id-Version: pltcl (PostgreSQL) 15\n"
+"Report-Msgid-Bugs-To: pgsql-bugs@lists.postgresql.org\n"
+"POT-Creation-Date: 2022-07-06 23:08+0000\n"
+"PO-Revision-Date: 2022-07-07 06:12+0200\n"
+"Last-Translator: Temuri Doghonadze <temuri.doghonadze@gmail.com>\n"
+"Language-Team: Georgian <nothing>\n"
+"Language: ka\n"
+"MIME-Version: 1.0\n"
+"Content-Type: text/plain; charset=UTF-8\n"
+"Content-Transfer-Encoding: 8bit\n"
+"Plural-Forms: nplurals=2; plural=(n != 1);\n"
+"X-Generator: Poedit 3.1\n"
+
+#: pltcl.c:463
+msgid "PL/Tcl function to call once when pltcl is first used."
+msgstr "PL/Tcl ფუნქცია, როლის გამოძახებაც ერთხელ, pltcl-ის პირველი გამოყენებისას ხდება."
+
+#: pltcl.c:470
+msgid "PL/TclU function to call once when pltclu is first used."
+msgstr "PL/TclU ფუნქცია, როლის გამოძახებაც ერთხელ, pltclu -ის პირველი გამოყენებისას ხდება."
+
+#: pltcl.c:637
+#, c-format
+msgid "function \"%s\" is in the wrong language"
+msgstr "ფუნქცია \"%s\" არასწორ ენაზეა"
+
+#: pltcl.c:648
+#, c-format
+msgid "function \"%s\" must not be SECURITY DEFINER"
+msgstr "ფუნქცია \"%s\" არ უნდა იყოს SECURITY DEFINER"
+
+#. translator: %s is "pltcl.start_proc" or "pltclu.start_proc"
+#: pltcl.c:682
+#, c-format
+msgid "processing %s parameter"
+msgstr "პარამეტრის დამუშავება: %s"
+
+#: pltcl.c:835
+#, c-format
+msgid "set-valued function called in context that cannot accept a set"
+msgstr "სეტ-ღირებული ფუნქცია, რომელსაც ეწოდება კონტექსტში, რომელსაც არ შეუძლია მიიღოს ნაკრები"
+
+#: pltcl.c:840
+#, c-format
+msgid "materialize mode required, but it is not allowed in this context"
+msgstr "საჭიროა მატერიალიზებული რეჟიმი, მაგრამ ამ კონტექსტში ეს დაუშვებელია"
+
+#: pltcl.c:1013
+#, c-format
+msgid "function returning record called in context that cannot accept type record"
+msgstr "ფუნქცია, რომელიც ჩანაწერს აბრუნებს, გამოძახებულია კონტექსტში, რომელსაც ჩანაწერის მიღება არ შეუძლია"
+
+#: pltcl.c:1296
+#, c-format
+msgid "could not split return value from trigger: %s"
+msgstr "ტრიგერიდან დაბრუნებული მნიშვნელობის დაყოფა შეუძლებელია: %s"
+
+#: pltcl.c:1377 pltcl.c:1807
+#, c-format
+msgid "%s"
+msgstr "%s"
+
+#: pltcl.c:1378
+#, c-format
+msgid ""
+"%s\n"
+"in PL/Tcl function \"%s\""
+msgstr ""
+"%s\n"
+"PL/Tcl-ის ფუნქციაში\"%s\""
+
+#: pltcl.c:1542
+#, c-format
+msgid "trigger functions can only be called as triggers"
+msgstr "ტრიგერის ფუნქციების გამოძახება მხოლოდ ტრიგერებად შეიძლება"
+
+#: pltcl.c:1546
+#, c-format
+msgid "PL/Tcl functions cannot return type %s"
+msgstr "PL/Tcl ფუნქციას %s ტიპის დაბრუნება არ შეუძლია"
+
+#: pltcl.c:1585
+#, c-format
+msgid "PL/Tcl functions cannot accept type %s"
+msgstr "PL/Tcl ფუნქციას %s ტიპის მიღება არ შეუძლია"
+
+#: pltcl.c:1699
+#, c-format
+msgid "could not create internal procedure \"%s\": %s"
+msgstr "შიდა პროცედურის (\"%s\") შექმნის შეცდომა: %s"
+
+#: pltcl.c:3201
+#, c-format
+msgid "column name/value list must have even number of elements"
+msgstr "სვეტის სახელი/მნიშვნელობების სიას ელემენტების ლუწი რაოდენობა უნდა ჰქონდეს"
+
+#: pltcl.c:3219
+#, c-format
+msgid "column name/value list contains nonexistent column name \"%s\""
+msgstr "სვეტის სახელი/მნიშვნელობების სია შეიცავს სვეტის არარსებულ სახელს „%s“"
+
+#: pltcl.c:3226
+#, c-format
+msgid "cannot set system attribute \"%s\""
+msgstr "სისტემური ატრიბუტის დაყენების შეცდომა: \"%s\""
+
+#: pltcl.c:3232
+#, c-format
+msgid "cannot set generated column \"%s\""
+msgstr "გენერირებული სვეტის დაყენება შეუძლებელია: %s"
diff --git a/src/pl/tcl/po/ko.po b/src/pl/tcl/po/ko.po
new file mode 100644
index 0000000..1b8c5c7
--- /dev/null
+++ b/src/pl/tcl/po/ko.po
@@ -0,0 +1,118 @@
+# LANGUAGE message translation file for pltcl
+# Copyright (C) 2016 PostgreSQL Global Development Group
+# This file is distributed under the same license as the PostgreSQL package.
+# Ioseph Kim <ioseph@uri.sarang.net>, 2016.
+#
+msgid ""
+msgstr ""
+"Project-Id-Version: pltcl (PostgreSQL) 16\n"
+"Report-Msgid-Bugs-To: pgsql-bugs@lists.postgresql.org\n"
+"POT-Creation-Date: 2023-09-07 05:38+0000\n"
+"PO-Revision-Date: 2023-05-30 12:40+0900\n"
+"Last-Translator: Ioseph Kim <ioseph@uri.sarang.net>\n"
+"Language-Team: Korean Team <pgsql-kr@postgresql.kr>\n"
+"Language: ko\n"
+"MIME-Version: 1.0\n"
+"Content-Type: text/plain; charset=UTF-8\n"
+"Content-Transfer-Encoding: 8bit\n"
+"Plural-Forms: nplurals=1; plural=0;\n"
+
+#: pltcl.c:462
+msgid "PL/Tcl function to call once when pltcl is first used."
+msgstr "pltcl 언어가 처음 사용될 때 한번 호출 될 PL/Tcl 함수"
+
+#: pltcl.c:469
+msgid "PL/TclU function to call once when pltclu is first used."
+msgstr "pltclu 언어가 처음 사용될 때 한번 호출 될 PL/Tcl 함수"
+
+#: pltcl.c:636
+#, c-format
+msgid "function \"%s\" is in the wrong language"
+msgstr "\"%s\" 함수에 잘못된 언어가 있음"
+
+#: pltcl.c:647
+#, c-format
+msgid "function \"%s\" must not be SECURITY DEFINER"
+msgstr "\"%s\" 함수는 SECURITY DEFINER 속성이 없어야 합니다"
+
+#. translator: %s is "pltcl.start_proc" or "pltclu.start_proc"
+#: pltcl.c:681
+#, c-format
+msgid "processing %s parameter"
+msgstr "%s 매개 변수 처리 중"
+
+#: pltcl.c:834
+#, c-format
+msgid "set-valued function called in context that cannot accept a set"
+msgstr "집합이 값이 함수가 집합을 사용할 수 없는 구문에서 호출 되었음"
+
+#: pltcl.c:839
+#, c-format
+msgid "materialize mode required, but it is not allowed in this context"
+msgstr "materialize 모드가 필요합니다만, 이 구문에서는 허용되지 않습니다"
+
+#: pltcl.c:1012
+#, c-format
+msgid ""
+"function returning record called in context that cannot accept type record"
+msgstr ""
+"레코드를 반환하는 함수가 레코드 형을 사용할 수 없는 구문에서 호출 되었음"
+
+#: pltcl.c:1295
+#, c-format
+msgid "could not split return value from trigger: %s"
+msgstr "트리거에서 반환값을 분리할 수 없음: %s"
+
+#: pltcl.c:1376 pltcl.c:1803
+#, c-format
+msgid "%s"
+msgstr "%s"
+
+#: pltcl.c:1377
+#, c-format
+msgid ""
+"%s\n"
+"in PL/Tcl function \"%s\""
+msgstr ""
+"%s\n"
+"해당 PL/Tcl 함수: \"%s\""
+
+#: pltcl.c:1540
+#, c-format
+msgid "trigger functions can only be called as triggers"
+msgstr "트리거 함수는 트리거로만 호출될 수 있음"
+
+#: pltcl.c:1544
+#, c-format
+msgid "PL/Tcl functions cannot return type %s"
+msgstr "PL/Tcl 함수는 %s 자료형을 반환할 수 없음"
+
+#: pltcl.c:1583
+#, c-format
+msgid "PL/Tcl functions cannot accept type %s"
+msgstr "PL/Tcl 함수는 %s 자료형을 사용할 수 없음"
+
+#: pltcl.c:1695
+#, c-format
+msgid "could not create internal procedure \"%s\": %s"
+msgstr "\"%s\" 내부 프로시져를 만들 수 없음: %s"
+
+#: pltcl.c:3199
+#, c-format
+msgid "column name/value list must have even number of elements"
+msgstr "칼럼 이름/값 목록은 그 요소의 개수가 짝수여야 함"
+
+#: pltcl.c:3217
+#, c-format
+msgid "column name/value list contains nonexistent column name \"%s\""
+msgstr "칼럼 이름/값 목록에 \"%s\" 칼럼에 대한 값이 없음"
+
+#: pltcl.c:3224
+#, c-format
+msgid "cannot set system attribute \"%s\""
+msgstr "\"%s\" 시스템 속성을 지정할 수 없음"
+
+#: pltcl.c:3230
+#, c-format
+msgid "cannot set generated column \"%s\""
+msgstr "\"%s\" 계산된 칼럼을 지정할 수 없음"
diff --git a/src/pl/tcl/po/meson.build b/src/pl/tcl/po/meson.build
new file mode 100644
index 0000000..9e5c8e9
--- /dev/null
+++ b/src/pl/tcl/po/meson.build
@@ -0,0 +1,3 @@
+# Copyright (c) 2022-2023, PostgreSQL Global Development Group
+
+nls_targets += [i18n.gettext('pltcl-' + pg_version_major.to_string())]
diff --git a/src/pl/tcl/po/pl.po b/src/pl/tcl/po/pl.po
new file mode 100644
index 0000000..0a0b2bf
--- /dev/null
+++ b/src/pl/tcl/po/pl.po
@@ -0,0 +1,136 @@
+# pltcl message translation file for pltcl
+# Copyright (C) 2011 PostgreSQL Global Development Group
+# This file is distributed under the same license as the PostgreSQL package.
+# Begina Felicysym <begina.felicysym@wp.eu>, 2011.
+# grzegorz <begina.felicysym@wp.eu>, 2015, 2017.
+msgid ""
+msgstr ""
+"Project-Id-Version: pltcl (PostgreSQL 9.5)\n"
+"Report-Msgid-Bugs-To: pgsql-bugs@postgresql.org\n"
+"POT-Creation-Date: 2017-04-09 21:07+0000\n"
+"PO-Revision-Date: 2017-05-02 13:57-0400\n"
+"Last-Translator: grzegorz <begina.felicysym@wp.eu>\n"
+"Language-Team: begina.felicysym@wp.eu\n"
+"Language: pl\n"
+"MIME-Version: 1.0\n"
+"Content-Type: text/plain; charset=UTF-8\n"
+"Content-Transfer-Encoding: 8bit\n"
+"Plural-Forms: nplurals=3; plural=(n==1 ? 0 : n%10>=2 && n%10<=4 && (n%100<10 "
+"|| n%100>=20) ? 1 : 2);\n"
+"X-Generator: Virtaal 0.7.1\n"
+
+#: pltcl.c:459
+#| msgid "Perl initialization code to execute once when plperl is first used."
+msgid "PL/Tcl function to call once when pltcl is first used."
+msgstr ""
+"Funkcja PL/TCL do jednokrotnego wykonania gdy pltcl jest użyty po raz "
+"pierwszy."
+
+#: pltcl.c:466
+#| msgid "Perl initialization code to execute once when plperlu is first used."
+msgid "PL/TclU function to call once when pltclu is first used."
+msgstr ""
+"Funkcja PL/TCL do jednokrotnego wykonania gdy pltclu jest użyty po raz "
+"pierwszy."
+
+#: pltcl.c:629
+#, c-format
+#| msgid "function \"%s\" was not called by trigger manager"
+msgid "function \"%s\" is in the wrong language"
+msgstr "funkcja \"%s\" jest napisana nie w tym języku"
+
+#: pltcl.c:640
+#, c-format
+#| msgid "function \"%s\" must be fired for INSERT"
+msgid "function \"%s\" must not be SECURITY DEFINER"
+msgstr "funkcja \"%s\" nie może być SECURITY DEFINER"
+
+#. translator: %s is "pltcl.start_proc" or "pltclu.start_proc"
+#: pltcl.c:674
+#, c-format
+#| msgid "processing %s\n"
+msgid "processing %s parameter"
+msgstr "przetwarzanie parametru %s"
+
+#: pltcl.c:830
+#, c-format
+msgid "set-valued function called in context that cannot accept a set"
+msgstr ""
+"funkcja zwracająca zbiór rekordów wywołana w kontekście, w którym nie jest "
+"to dopuszczalne"
+
+#: pltcl.c:994
+#, c-format
+msgid "function returning record called in context that cannot accept type record"
+msgstr "funkcja zwracająca rekord w wywołaniu, które nie akceptuje typów złożonych"
+
+#: pltcl.c:1263
+#, c-format
+msgid "could not split return value from trigger: %s"
+msgstr "nie można podzielić wartości zwracanej przez wyzwalacz: %s"
+
+#: pltcl.c:1343 pltcl.c:1771
+#, c-format
+msgid "%s"
+msgstr "%s"
+
+#: pltcl.c:1344
+#, c-format
+msgid ""
+"%s\n"
+"in PL/Tcl function \"%s\""
+msgstr ""
+"%s\n"
+"w funkcji PL/Tcl \"%s\""
+
+#: pltcl.c:1509
+#, c-format
+msgid "trigger functions can only be called as triggers"
+msgstr "procedury wyzwalaczy mogą być wywoływane jedynie przez wyzwalacze"
+
+#: pltcl.c:1513
+#, c-format
+msgid "PL/Tcl functions cannot return type %s"
+msgstr "funkcje PL/Tcl nie mogą zwracać wartości typu %s"
+
+#: pltcl.c:1549
+#, c-format
+msgid "PL/Tcl functions cannot accept type %s"
+msgstr "funkcje PL/Tcl nie akceptują typu %s"
+
+#: pltcl.c:1663
+#, c-format
+msgid "could not create internal procedure \"%s\": %s"
+msgstr "nie można utworzyć procedury wewnętrznej \"%s\": %s"
+
+#: pltcl.c:3100
+#, c-format
+#| msgid "argument list must have even number of elements"
+msgid "column name/value list must have even number of elements"
+msgstr "lista kolumn nazwa/wartość musi mieć parzystą liczbę elementów"
+
+#: pltcl.c:3118
+#, c-format
+#| msgid "Perl hash contains nonexistent column \"%s\""
+msgid "column name/value list contains nonexistent column name \"%s\""
+msgstr "lista kolumn nazwa/wartość zawiera nieistniejącą kolumnę \"%s\""
+
+#: pltcl.c:3125
+#, c-format
+msgid "cannot set system attribute \"%s\""
+msgstr "nie można ustawić atrybutu systemowego \"%s\""
+
+#~ msgid "PL/Tcl functions cannot return composite types"
+#~ msgstr "funkcje PL/Tcl nie mogą zwracać wartości złożonych"
+
+#~ msgid "out of memory"
+#~ msgstr "brak pamięci"
+
+#~ msgid "unrecognized attribute \"%s\""
+#~ msgstr "nierozpoznany atrybut \"%s\""
+
+#~ msgid "could not load module \"unknown\": %s"
+#~ msgstr "nie można wczytać modułu \"unknown\": %s"
+
+#~ msgid "module \"unknown\" not found in pltcl_modules"
+#~ msgstr "nie znaleziono modułu \"unknown\" w pltcl_modules"
diff --git a/src/pl/tcl/po/pt_BR.po b/src/pl/tcl/po/pt_BR.po
new file mode 100644
index 0000000..39ee004
--- /dev/null
+++ b/src/pl/tcl/po/pt_BR.po
@@ -0,0 +1,117 @@
+# Brazilian Portuguese message translation file for pltcl
+#
+# Copyright (C) 2009-2022 PostgreSQL Global Development Group
+# This file is distributed under the same license as the PostgreSQL package.
+#
+# Euler Taveira <euler@eulerto.com>, 2009-2022.
+#
+msgid ""
+msgstr ""
+"Project-Id-Version: PostgreSQL 15\n"
+"Report-Msgid-Bugs-To: pgsql-bugs@lists.postgresql.org\n"
+"POT-Creation-Date: 2022-09-27 13:15-0300\n"
+"PO-Revision-Date: 2009-05-06 18:00-0300\n"
+"Last-Translator: Euler Taveira <euler@eulerto.com>\n"
+"Language-Team: Brazilian Portuguese <pgsql-translators@postgresql.org>\n"
+"Language: pt_BR\n"
+"MIME-Version: 1.0\n"
+"Content-Type: text/plain; charset=UTF-8\n"
+"Content-Transfer-Encoding: 8bit\n"
+
+#: pltcl.c:463
+msgid "PL/Tcl function to call once when pltcl is first used."
+msgstr "função PL/Tcl executada quando pltcl for utilizado pela primeira vez."
+
+#: pltcl.c:470
+msgid "PL/TclU function to call once when pltclu is first used."
+msgstr "função PL/TclU executada quando pltclu for utilizado pela primeira vez."
+
+#: pltcl.c:637
+#, c-format
+msgid "function \"%s\" is in the wrong language"
+msgstr "função \"%s\" está na linguagem incorreta"
+
+#: pltcl.c:648
+#, c-format
+msgid "function \"%s\" must not be SECURITY DEFINER"
+msgstr "função \"%s\" não deve ser SECURITY DEFINER"
+
+#. translator: %s is "pltcl.start_proc" or "pltclu.start_proc"
+#: pltcl.c:682
+#, c-format
+msgid "processing %s parameter"
+msgstr "processando parâmetro %s"
+
+#: pltcl.c:835
+#, c-format
+msgid "set-valued function called in context that cannot accept a set"
+msgstr "função que tem argumento do tipo conjunto foi chamada em um contexto que não pode aceitar um conjunto"
+
+#: pltcl.c:840
+#, c-format
+msgid "materialize mode required, but it is not allowed in this context"
+msgstr "modo de materialização é requerido, mas ele não é permitido neste contexto"
+
+#: pltcl.c:1013
+#, c-format
+msgid "function returning record called in context that cannot accept type record"
+msgstr "função que retorna record foi chamada em um contexto que não pode aceitar tipo record"
+
+#: pltcl.c:1296
+#, c-format
+msgid "could not split return value from trigger: %s"
+msgstr "não pôde dividir valor retornado do gatilho: %s"
+
+#: pltcl.c:1377 pltcl.c:1807
+#, c-format
+msgid "%s"
+msgstr "%s"
+
+#: pltcl.c:1378
+#, c-format
+msgid ""
+"%s\n"
+"in PL/Tcl function \"%s\""
+msgstr ""
+"%s\n"
+"na função PL/Tcl \"%s\""
+
+#: pltcl.c:1542
+#, c-format
+msgid "trigger functions can only be called as triggers"
+msgstr "funções de gatilho só podem ser chamadas como gatilhos"
+
+#: pltcl.c:1546
+#, c-format
+msgid "PL/Tcl functions cannot return type %s"
+msgstr "funções PL/Tcl não podem retornar tipo %s"
+
+#: pltcl.c:1585
+#, c-format
+msgid "PL/Tcl functions cannot accept type %s"
+msgstr "funções PL/Tcl não podem aceitar tipo %s"
+
+#: pltcl.c:1699
+#, c-format
+msgid "could not create internal procedure \"%s\": %s"
+msgstr "não pôde criar função interna \"%s\": %s"
+
+#: pltcl.c:3201
+#, c-format
+msgid "column name/value list must have even number of elements"
+msgstr "lista de nome/valor de colunas deve ter número par de elementos"
+
+#: pltcl.c:3219
+#, c-format
+msgid "column name/value list contains nonexistent column name \"%s\""
+msgstr "lsta de nome/valor de colunas contém nome de coluna inexistente \"%s\""
+
+#: pltcl.c:3226
+#, c-format
+msgid "cannot set system attribute \"%s\""
+msgstr "não pode definir atributo do sistema \"%s\""
+
+#: pltcl.c:3232
+#, c-format
+msgid "cannot set generated column \"%s\""
+msgstr "não pode definir coluna gerada \"%s\""
diff --git a/src/pl/tcl/po/ro.po b/src/pl/tcl/po/ro.po
new file mode 100644
index 0000000..a2928e3
--- /dev/null
+++ b/src/pl/tcl/po/ro.po
@@ -0,0 +1,56 @@
+# LANGUAGE message translation file for pltcl
+# Copyright (C) 2010 PostgreSQL Global Development Group
+# This file is distributed under the same license as the PostgreSQL package.
+# FIRST AUTHOR <EMAIL@ADDRESS>, 2010.
+#
+msgid ""
+msgstr ""
+"Project-Id-Version: PostgreSQL 9.0\n"
+"Report-Msgid-Bugs-To: pgsql-bugs@postgresql.org\n"
+"POT-Creation-Date: 2010-09-04 19:59+0000\n"
+"PO-Revision-Date: 2013-09-05 23:03-0400\n"
+"Last-Translator: Max <max@oceanline.co.uk>\n"
+"Language-Team: ROMÂNĂ <max@oceanline.co.uk>\n"
+"Language: ro\n"
+"MIME-Version: 1.0\n"
+"Content-Type: text/plain; charset=UTF-8\n"
+"Content-Transfer-Encoding: 8bit\n"
+"X-Poedit-Language: Romanian\n"
+"X-Poedit-Country: România\n"
+
+#: pltcl.c:1075
+#, c-format
+msgid "%s"
+msgstr "%s"
+
+#: pltcl.c:1076
+#, c-format
+msgid ""
+"%s\n"
+"in PL/Tcl function \"%s\""
+msgstr ""
+"%s\n"
+"în funcția PL/Tcl \"%s\""
+
+#: pltcl.c:1173
+msgid "out of memory"
+msgstr "memorie insuficientă"
+
+#: pltcl.c:1234
+msgid "trigger functions can only be called as triggers"
+msgstr "funcţiile trigger pot fi apelate doar ca triggere"
+
+#: pltcl.c:1243
+#, c-format
+msgid "PL/Tcl functions cannot return type %s"
+msgstr "funcțiile PL/Tcl nu pot returna tipul %s"
+
+#: pltcl.c:1255
+msgid "PL/Tcl functions cannot return composite types"
+msgstr "funcțiile PL/Tcl nu pot returna tipul compozit"
+
+#: pltcl.c:1294
+#, c-format
+msgid "PL/Tcl functions cannot accept type %s"
+msgstr "funcțiile PL/Tcl nu pot accepta tipul %s"
+
diff --git a/src/pl/tcl/po/ru.po b/src/pl/tcl/po/ru.po
new file mode 100644
index 0000000..8d13627
--- /dev/null
+++ b/src/pl/tcl/po/ru.po
@@ -0,0 +1,135 @@
+# Russian message translation file for pltcl
+# Copyright (C) 2012-2016 PostgreSQL Global Development Group
+# This file is distributed under the same license as the PostgreSQL package.
+# Alexander Lakhin <exclusion@gmail.com>, 2012-2017, 2019, 2022.
+msgid ""
+msgstr ""
+"Project-Id-Version: pltcl (PostgreSQL current)\n"
+"Report-Msgid-Bugs-To: pgsql-bugs@lists.postgresql.org\n"
+"POT-Creation-Date: 2023-08-28 07:59+0300\n"
+"PO-Revision-Date: 2022-09-05 13:38+0300\n"
+"Last-Translator: Alexander Lakhin <exclusion@gmail.com>\n"
+"Language-Team: Russian <pgsql-ru-general@postgresql.org>\n"
+"Language: ru\n"
+"MIME-Version: 1.0\n"
+"Content-Type: text/plain; charset=UTF-8\n"
+"Content-Transfer-Encoding: 8bit\n"
+"Plural-Forms: nplurals=3; plural=(n%10==1 && n%100!=11 ? 0 : n%10>=2 && "
+"n%10<=4 && (n%100<10 || n%100>=20) ? 1 : 2);\n"
+
+#: pltcl.c:462
+msgid "PL/Tcl function to call once when pltcl is first used."
+msgstr "Функция на PL/Tcl, вызываемая при первом использовании pltcl."
+
+#: pltcl.c:469
+msgid "PL/TclU function to call once when pltclu is first used."
+msgstr "Функция на PL/TclU, вызываемая при первом использовании pltclu."
+
+#: pltcl.c:636
+#, c-format
+msgid "function \"%s\" is in the wrong language"
+msgstr "Функция \"%s\" объявлена на другом языке"
+
+#: pltcl.c:647
+#, c-format
+msgid "function \"%s\" must not be SECURITY DEFINER"
+msgstr "функция \"%s\" не должна иметь характеристику SECURITY DEFINER"
+
+#. translator: %s is "pltcl.start_proc" or "pltclu.start_proc"
+#: pltcl.c:681
+#, c-format
+msgid "processing %s parameter"
+msgstr "обработка параметра %s"
+
+#: pltcl.c:834
+#, c-format
+msgid "set-valued function called in context that cannot accept a set"
+msgstr ""
+"функция, возвращающая множество, вызвана в контексте, где ему нет места"
+
+#: pltcl.c:839
+#, c-format
+msgid "materialize mode required, but it is not allowed in this context"
+msgstr "требуется режим материализации, но он недопустим в этом контексте"
+
+#: pltcl.c:1012
+#, c-format
+msgid ""
+"function returning record called in context that cannot accept type record"
+msgstr ""
+"функция, возвращающая запись, вызвана в контексте, не допускающем этот тип"
+
+#: pltcl.c:1295
+#, c-format
+msgid "could not split return value from trigger: %s"
+msgstr "разложить возвращаемое из триггера значение не удалось: %s"
+
+#: pltcl.c:1376 pltcl.c:1803
+#, c-format
+msgid "%s"
+msgstr "%s"
+
+#: pltcl.c:1377
+#, c-format
+msgid ""
+"%s\n"
+"in PL/Tcl function \"%s\""
+msgstr ""
+"%s\n"
+"в функции PL/Tcl \"%s\""
+
+#: pltcl.c:1540
+#, c-format
+msgid "trigger functions can only be called as triggers"
+msgstr "триггерные функции могут вызываться только в триггерах"
+
+#: pltcl.c:1544
+#, c-format
+msgid "PL/Tcl functions cannot return type %s"
+msgstr "функции PL/Tcl не могут возвращать тип %s"
+
+#: pltcl.c:1583
+#, c-format
+msgid "PL/Tcl functions cannot accept type %s"
+msgstr "функции PL/Tcl не могут принимать тип %s"
+
+#: pltcl.c:1695
+#, c-format
+msgid "could not create internal procedure \"%s\": %s"
+msgstr "не удалось создать внутреннюю процедуру \"%s\": %s"
+
+#: pltcl.c:3199
+#, c-format
+msgid "column name/value list must have even number of elements"
+msgstr "в списке имён/значений столбцов должно быть чётное число элементов"
+
+#: pltcl.c:3217
+#, c-format
+msgid "column name/value list contains nonexistent column name \"%s\""
+msgstr ""
+"список имён/значений столбцов содержит имя несуществующего столбца \"%s\""
+
+#: pltcl.c:3224
+#, c-format
+msgid "cannot set system attribute \"%s\""
+msgstr "присвоить значение системному атрибуту \"%s\" нельзя"
+
+#: pltcl.c:3230
+#, c-format
+msgid "cannot set generated column \"%s\""
+msgstr "присвоить значение генерируемому столбцу \"%s\" нельзя"
+
+#~ msgid "module \"unknown\" not found in pltcl_modules"
+#~ msgstr "модуль \"unknown\" не найден в pltcl_modules"
+
+#~ msgid "could not load module \"unknown\": %s"
+#~ msgstr "загрузить модуль \"unknown\" не удалось: %s"
+
+#~ msgid "unrecognized attribute \"%s\""
+#~ msgstr "нераспознанный атрибут \"%s\""
+
+#~ msgid "out of memory"
+#~ msgstr "нехватка памяти"
+
+#~ msgid "PL/Tcl functions cannot return composite types"
+#~ msgstr "функции PL/Tcl не могут возвращать составные типы"
diff --git a/src/pl/tcl/po/sv.po b/src/pl/tcl/po/sv.po
new file mode 100644
index 0000000..5d14044
--- /dev/null
+++ b/src/pl/tcl/po/sv.po
@@ -0,0 +1,116 @@
+# Swedish message translation file for pltcl
+# Copyright (C) 2017 PostgreSQL Global Development Group
+# This file is distributed under the same license as the PostgreSQL package.
+# Dennis Björklund <db@zigo.dhs.org>, 2017, 2018, 2019, 2020, 2021, 2022, 2023.
+#
+msgid ""
+msgstr ""
+"Project-Id-Version: PostgreSQL 15\n"
+"Report-Msgid-Bugs-To: pgsql-bugs@lists.postgresql.org\n"
+"POT-Creation-Date: 2022-04-11 13:38+0000\n"
+"PO-Revision-Date: 2023-03-09 22:42+0100\n"
+"Last-Translator: Dennis Björklund <db@zigo.dhs.org>\n"
+"Language-Team: Swedish <pgsql-translators@postgresql.org>\n"
+"Language: sv\n"
+"MIME-Version: 1.0\n"
+"Content-Type: text/plain; charset=UTF-8\n"
+"Content-Transfer-Encoding: 8bit\n"
+"Plural-Forms: nplurals=2; plural=n != 1;\n"
+
+#: pltcl.c:463
+msgid "PL/Tcl function to call once when pltcl is first used."
+msgstr "PL/Tcl-funktion att anropa en gång när pltcl först används."
+
+#: pltcl.c:470
+msgid "PL/TclU function to call once when pltclu is first used."
+msgstr "PL/TclU-funktion att anrop en gång när pltclu först används."
+
+#: pltcl.c:637
+#, c-format
+msgid "function \"%s\" is in the wrong language"
+msgstr "funktionen \"%s\" är skriven i fel språk"
+
+#: pltcl.c:648
+#, c-format
+msgid "function \"%s\" must not be SECURITY DEFINER"
+msgstr "funktionen \"%s\" får ej vara SECURITY DEFINER"
+
+#. translator: %s is "pltcl.start_proc" or "pltclu.start_proc"
+#: pltcl.c:682
+#, c-format
+msgid "processing %s parameter"
+msgstr "processar parameter %s"
+
+#: pltcl.c:835
+#, c-format
+msgid "set-valued function called in context that cannot accept a set"
+msgstr "en funktion som returnerar en mängd anropades i kontext som inte godtar en mängd"
+
+#: pltcl.c:840
+#, c-format
+msgid "materialize mode required, but it is not allowed in this context"
+msgstr "materialiserat läge krävs, men stöds inte i detta kontext"
+
+#: pltcl.c:1013
+#, c-format
+msgid "function returning record called in context that cannot accept type record"
+msgstr "en funktion med post som värde anropades i sammanhang där poster inte kan godtagas."
+
+#: pltcl.c:1297
+#, c-format
+msgid "could not split return value from trigger: %s"
+msgstr "kunde inte dela på returvärde från trigger: %s"
+
+#: pltcl.c:1378 pltcl.c:1808
+#, c-format
+msgid "%s"
+msgstr "%s"
+
+#: pltcl.c:1379
+#, c-format
+msgid ""
+"%s\n"
+"in PL/Tcl function \"%s\""
+msgstr ""
+"%s\n"
+"i PL/Tcl-funktion \"%s\""
+
+#: pltcl.c:1543
+#, c-format
+msgid "trigger functions can only be called as triggers"
+msgstr "Triggningsfunktioner kan bara anropas vid triggning."
+
+#: pltcl.c:1547
+#, c-format
+msgid "PL/Tcl functions cannot return type %s"
+msgstr "PL/Tcl-funktioner kan inte returnera typ %s"
+
+#: pltcl.c:1586
+#, c-format
+msgid "PL/Tcl functions cannot accept type %s"
+msgstr "PL/Tcl-funktioner kan inte ta emot typ %s"
+
+#: pltcl.c:1700
+#, c-format
+msgid "could not create internal procedure \"%s\": %s"
+msgstr "kunde inte skapa en intern procedur \"%s\": %s"
+
+#: pltcl.c:3202
+#, c-format
+msgid "column name/value list must have even number of elements"
+msgstr "kolumn-namn/-värde måste ha ett jämt antal element"
+
+#: pltcl.c:3220
+#, c-format
+msgid "column name/value list contains nonexistent column name \"%s\""
+msgstr "listan med kolumn-namn/-värde innehåller det icke existerande kolumnnamnet \"%s\""
+
+#: pltcl.c:3227
+#, c-format
+msgid "cannot set system attribute \"%s\""
+msgstr "kan inte sätta systemattribut \"%s\""
+
+#: pltcl.c:3233
+#, c-format
+msgid "cannot set generated column \"%s\""
+msgstr "kan inte sätta genererad kolumn \"%s\""
diff --git a/src/pl/tcl/po/tr.po b/src/pl/tcl/po/tr.po
new file mode 100644
index 0000000..ee51dfd
--- /dev/null
+++ b/src/pl/tcl/po/tr.po
@@ -0,0 +1,117 @@
+# LANGUAGE message translation file for pltcl
+# Copyright (C) 2009 PostgreSQL Global Development Group
+# This file is distributed under the same license as the PostgreSQL package.
+# FIRST AUTHOR <EMAIL@ADDRESS>, 2009.
+#
+msgid ""
+msgstr ""
+"Project-Id-Version: PostgreSQL 8.4\n"
+"Report-Msgid-Bugs-To: pgsql-bugs@lists.postgresql.org\n"
+"POT-Creation-Date: 2019-04-26 13:38+0000\n"
+"PO-Revision-Date: 2019-06-13 17:11+0300\n"
+"Last-Translator: Devrim GÜNDÜZ <devrim@commandprompt.com>\n"
+"Language-Team: TR <devrim@commandprompt.com>\n"
+"Language: tr\n"
+"MIME-Version: 1.0\n"
+"Content-Type: text/plain; charset=UTF-8\n"
+"Content-Transfer-Encoding: 8bit\n"
+"X-Generator: Poedit 1.8.7.1\n"
+
+#: pltcl.c:464
+msgid "PL/Tcl function to call once when pltcl is first used."
+msgstr "pltcl ilk sefer kullanıldığında bir kez çağrılacak PL/Tcl fonksiyonu"
+
+#: pltcl.c:471
+msgid "PL/TclU function to call once when pltclu is first used."
+msgstr "pltclu ilk sefer kullanıldığında bir kez çağrılacak PL/Tclu fonksiyonu"
+
+#: pltcl.c:636
+#, c-format
+msgid "function \"%s\" is in the wrong language"
+msgstr "\"%s\" fonksiyonu yanlış dilde"
+
+#: pltcl.c:647
+#, c-format
+msgid "function \"%s\" must not be SECURITY DEFINER"
+msgstr "\"%s\" fonksiyonu SECURITY DEFINER olmamalı"
+
+#. translator: %s is "pltcl.start_proc" or "pltclu.start_proc"
+#: pltcl.c:681
+#, c-format
+msgid "processing %s parameter"
+msgstr "%s parametresi işleniyor"
+
+#: pltcl.c:842
+#, c-format
+msgid "set-valued function called in context that cannot accept a set"
+msgstr "set değerini kabul etmediği ortamda set değeri alan fonksiyon çağırılmış"
+
+#: pltcl.c:1015
+#, c-format
+msgid "function returning record called in context that cannot accept type record"
+msgstr "tip kaydı içermeyen alanda çağırılan ve kayıt döndüren fonksiyon"
+
+#: pltcl.c:1299
+#, c-format
+msgid "could not split return value from trigger: %s"
+msgstr "sdönüş değeri tetikleyiciden (trigger) ayrılamadı: %s"
+
+#: pltcl.c:1379 pltcl.c:1809
+#, c-format
+msgid "%s"
+msgstr "%s"
+
+#: pltcl.c:1380
+#, c-format
+msgid ""
+"%s\n"
+"in PL/Tcl function \"%s\""
+msgstr ""
+"%s\n"
+"Şu PL/Tcl fonksiyonunda: \"%s\""
+
+#: pltcl.c:1544
+#, c-format
+msgid "trigger functions can only be called as triggers"
+msgstr "trigger fonksiyonları sadece trigger olarak çağırılabilirler"
+
+#: pltcl.c:1548
+#, c-format
+msgid "PL/Tcl functions cannot return type %s"
+msgstr "PL/Tcl fonksiyonları %s tipini döndüremezler"
+
+#: pltcl.c:1587
+#, c-format
+msgid "PL/Tcl functions cannot accept type %s"
+msgstr "PL/Tcl fonksiyonları %s veri tipini kabul etmezler"
+
+#: pltcl.c:1701
+#, c-format
+msgid "could not create internal procedure \"%s\": %s"
+msgstr "\"%s\" dahili yordamı oluşturulamadı: %s"
+
+#: pltcl.c:3208
+#, c-format
+msgid "column name/value list must have even number of elements"
+msgstr "sütun adı/değer listesinin çift sayıda öğesi olmalı"
+
+#: pltcl.c:3226
+#, c-format
+msgid "column name/value list contains nonexistent column name \"%s\""
+msgstr "sütun adı/değer listesi mevcut olmayan \"%s\" sütun adını içeriyor"
+
+#: pltcl.c:3233
+#, c-format
+msgid "cannot set system attribute \"%s\""
+msgstr "\"%s\" sistem niteliği ayarlanamaz"
+
+#: pltcl.c:3239
+#, c-format
+msgid "cannot set generated column \"%s\""
+msgstr "oluşturulan \"%s\" sütunu ayarlanamıyor"
+
+#~ msgid "out of memory"
+#~ msgstr "yetersiz bellek"
+
+#~ msgid "PL/Tcl functions cannot return composite types"
+#~ msgstr "PL/Tcl fonksiyonları composit tip döndüremezler"
diff --git a/src/pl/tcl/po/uk.po b/src/pl/tcl/po/uk.po
new file mode 100644
index 0000000..ceb1e78
--- /dev/null
+++ b/src/pl/tcl/po/uk.po
@@ -0,0 +1,115 @@
+msgid ""
+msgstr ""
+"Project-Id-Version: postgresql\n"
+"Report-Msgid-Bugs-To: pgsql-bugs@lists.postgresql.org\n"
+"POT-Creation-Date: 2022-08-12 10:38+0000\n"
+"PO-Revision-Date: 2022-09-13 11:52\n"
+"Last-Translator: \n"
+"Language-Team: Ukrainian\n"
+"Language: uk_UA\n"
+"MIME-Version: 1.0\n"
+"Content-Type: text/plain; charset=UTF-8\n"
+"Content-Transfer-Encoding: 8bit\n"
+"Plural-Forms: nplurals=4; plural=((n%10==1 && n%100!=11) ? 0 : ((n%10 >= 2 && n%10 <=4 && (n%100 < 12 || n%100 > 14)) ? 1 : ((n%10 == 0 || (n%10 >= 5 && n%10 <=9)) || (n%100 >= 11 && n%100 <= 14)) ? 2 : 3));\n"
+"X-Crowdin-Project: postgresql\n"
+"X-Crowdin-Project-ID: 324573\n"
+"X-Crowdin-Language: uk\n"
+"X-Crowdin-File: /REL_15_STABLE/pltcl.pot\n"
+"X-Crowdin-File-ID: 914\n"
+
+#: pltcl.c:463
+msgid "PL/Tcl function to call once when pltcl is first used."
+msgstr "Функція PL/Tcl використовується для виклику коли pltcl вперше використаний."
+
+#: pltcl.c:470
+msgid "PL/TclU function to call once when pltclu is first used."
+msgstr "Функція PL/TclU використовується для виклику коли pltclu вперше використаний."
+
+#: pltcl.c:637
+#, c-format
+msgid "function \"%s\" is in the wrong language"
+msgstr "функція «%s» написана неправильною мовою"
+
+#: pltcl.c:648
+#, c-format
+msgid "function \"%s\" must not be SECURITY DEFINER"
+msgstr "функція \"%s\" не має бути SECURITY DEFINER"
+
+#. translator: %s is "pltcl.start_proc" or "pltclu.start_proc"
+#: pltcl.c:682
+#, c-format
+msgid "processing %s parameter"
+msgstr "обробляється параметр %s"
+
+#: pltcl.c:835
+#, c-format
+msgid "set-valued function called in context that cannot accept a set"
+msgstr "функція \"set-valued\" викликана в контексті, де йому немає місця"
+
+#: pltcl.c:840
+#, c-format
+msgid "materialize mode required, but it is not allowed in this context"
+msgstr "необхідний режим матеріалізації (materialize mode), але він неприпустимий у цьому контексті"
+
+#: pltcl.c:1013
+#, c-format
+msgid "function returning record called in context that cannot accept type record"
+msgstr "функція, що повертає набір, викликана у контексті, що не приймає тип запис"
+
+#: pltcl.c:1296
+#, c-format
+msgid "could not split return value from trigger: %s"
+msgstr "не вдалося розділити повернене значення з тригера: %s"
+
+#: pltcl.c:1377 pltcl.c:1807
+#, c-format
+msgid "%s"
+msgstr "%s"
+
+#: pltcl.c:1378
+#, c-format
+msgid "%s\n"
+"in PL/Tcl function \"%s\""
+msgstr "%s\n"
+"у функції PL/Tcl \"%s\""
+
+#: pltcl.c:1542
+#, c-format
+msgid "trigger functions can only be called as triggers"
+msgstr "тригер-функція може викликатися лише як тригер"
+
+#: pltcl.c:1546
+#, c-format
+msgid "PL/Tcl functions cannot return type %s"
+msgstr "Функції PL/Tcl не можуть повертати тип %s"
+
+#: pltcl.c:1585
+#, c-format
+msgid "PL/Tcl functions cannot accept type %s"
+msgstr "Функції PL/Tcl не можуть приймати тип %s"
+
+#: pltcl.c:1699
+#, c-format
+msgid "could not create internal procedure \"%s\": %s"
+msgstr "не вдалося створити внутрішню процедуру \"%s\": %s"
+
+#: pltcl.c:3201
+#, c-format
+msgid "column name/value list must have even number of elements"
+msgstr "список імен і значень стовпців повинен мати парну кількість елементів"
+
+#: pltcl.c:3219
+#, c-format
+msgid "column name/value list contains nonexistent column name \"%s\""
+msgstr "список імен і значень стовпців містить неіснуєче ім'я стовпця \"%s\""
+
+#: pltcl.c:3226
+#, c-format
+msgid "cannot set system attribute \"%s\""
+msgstr "не вдалося встановити системний атрибут \"%s\""
+
+#: pltcl.c:3232
+#, c-format
+msgid "cannot set generated column \"%s\""
+msgstr "неможливо оновити згенерований стовпець \"%s\""
+
diff --git a/src/pl/tcl/po/vi.po b/src/pl/tcl/po/vi.po
new file mode 100644
index 0000000..7224bf1
--- /dev/null
+++ b/src/pl/tcl/po/vi.po
@@ -0,0 +1,107 @@
+# LANGUAGE message translation file for pltcl
+# Copyright (C) 2018 PostgreSQL Global Development Group
+# This file is distributed under the same license as the pltcl (PostgreSQL) package.
+# FIRST AUTHOR <kakalot49@gmail.com>, 2018.
+#
+msgid ""
+msgstr ""
+"Project-Id-Version: pltcl (PostgreSQL) 11\n"
+"Report-Msgid-Bugs-To: pgsql-bugs@postgresql.org\n"
+"POT-Creation-Date: 2018-04-22 12:08+0000\n"
+"PO-Revision-Date: 2018-04-29 22:56+0900\n"
+"Language-Team: <pgvn_translators@postgresql.vn>\n"
+"MIME-Version: 1.0\n"
+"Content-Type: text/plain; charset=UTF-8\n"
+"Content-Transfer-Encoding: 8bit\n"
+"X-Generator: Poedit 2.0.6\n"
+"Last-Translator: Dang Minh Huong <kakalot49@gmail.com>\n"
+"Plural-Forms: nplurals=1; plural=0;\n"
+"Language: vi_VN\n"
+
+#: pltcl.c:466
+msgid "PL/Tcl function to call once when pltcl is first used."
+msgstr "Chỉ định hàm PL/Tcl được gọi một lần khi pltcl sử dụng lần đầu tiên."
+
+#: pltcl.c:473
+msgid "PL/TclU function to call once when pltclu is first used."
+msgstr "Chỉ định hàm PL/TclU được gọi một lần khi pltclu sử dụng lần đầu tiên."
+
+#: pltcl.c:640
+#, c-format
+msgid "function \"%s\" is in the wrong language"
+msgstr "hàm \"%s\" không đúng ngôn ngữ"
+
+#: pltcl.c:651
+#, c-format
+msgid "function \"%s\" must not be SECURITY DEFINER"
+msgstr "hàm \"%s\" không được là SECURITY DEFINER"
+
+#. translator: %s is "pltcl.start_proc" or "pltclu.start_proc"
+#: pltcl.c:685
+#, c-format
+msgid "processing %s parameter"
+msgstr "xử lý tham số %s"
+
+#: pltcl.c:846
+#, c-format
+msgid "set-valued function called in context that cannot accept a set"
+msgstr "hàm thiết lập giá trị được gọi trong ngữ cảnh không thể chấp nhận một tập hợp"
+
+#: pltcl.c:1019
+#, c-format
+msgid "function returning record called in context that cannot accept type record"
+msgstr "hàm trả về bản ghi được gọi trong ngữ cảnh không thể chấp nhận kiểu bản ghi"
+
+#: pltcl.c:1296
+#, c-format
+msgid "could not split return value from trigger: %s"
+msgstr "không thể tách giá trị trả về khỏi trigger: %s"
+
+#: pltcl.c:1376 pltcl.c:1806
+#, c-format
+msgid "%s"
+msgstr "%s"
+
+#: pltcl.c:1377
+#, c-format
+msgid ""
+"%s\n"
+"in PL/Tcl function \"%s\""
+msgstr ""
+"%s\n"
+"trong hàm PL/Tcl \"%s\""
+
+#: pltcl.c:1541
+#, c-format
+msgid "trigger functions can only be called as triggers"
+msgstr "hàm trigger chỉ có thể được goi như những triggers."
+
+#: pltcl.c:1545
+#, c-format
+msgid "PL/Tcl functions cannot return type %s"
+msgstr "Hàm PL/Tcl không thể trả về kiểu %s"
+
+#: pltcl.c:1584
+#, c-format
+msgid "PL/Tcl functions cannot accept type %s"
+msgstr "Hàm PL/Tcl không thể chấp nhận kiểu %s"
+
+#: pltcl.c:1698
+#, c-format
+msgid "could not create internal procedure \"%s\": %s"
+msgstr "không thể tạo procedure nội bộ \"%s\": %s"
+
+#: pltcl.c:3219
+#, c-format
+msgid "column name/value list must have even number of elements"
+msgstr "danh sách cột tên/giá trị phải có giá trị chẵn cho số phần tử"
+
+#: pltcl.c:3237
+#, c-format
+msgid "column name/value list contains nonexistent column name \"%s\""
+msgstr "danh sách cột tên/giá trị chứa tên cột không tồn tại \"%s\""
+
+#: pltcl.c:3244
+#, c-format
+msgid "cannot set system attribute \"%s\""
+msgstr "không thể thiết lập attribute hệ thống \"%s\""
diff --git a/src/pl/tcl/po/zh_CN.po b/src/pl/tcl/po/zh_CN.po
new file mode 100644
index 0000000..d9e49a7
--- /dev/null
+++ b/src/pl/tcl/po/zh_CN.po
@@ -0,0 +1,111 @@
+# LANGUAGE message translation file for pltcl
+# Copyright (C) 2019 PostgreSQL Global Development Group
+# This file is distributed under the same license as the pltcl (PostgreSQL) package.
+# FIRST AUTHOR <EMAIL@ADDRESS>, 2019.
+#
+msgid ""
+msgstr ""
+"Project-Id-Version: pltcl (PostgreSQL) 14\n"
+"Report-Msgid-Bugs-To: pgsql-bugs@lists.postgresql.org\n"
+"POT-Creation-Date: 2021-08-14 05:38+0000\n"
+"PO-Revision-Date: 2021-08-16 18:00+0800\n"
+"Last-Translator: Jie Zhang <zhangjie2@fujitsu.com>\n"
+"Language-Team: Chinese (Simplified) <zhangjie2@fujitsu.com>\n"
+"Language: zh_CN\n"
+"MIME-Version: 1.0\n"
+"Content-Type: text/plain; charset=UTF-8\n"
+"Content-Transfer-Encoding: 8bit\n"
+"X-Generator: Poedit 1.5.7\n"
+
+#: pltcl.c:463
+msgid "PL/Tcl function to call once when pltcl is first used."
+msgstr "PL/Tcl函数在首次使用pltcl时调用一次."
+
+#: pltcl.c:470
+msgid "PL/TclU function to call once when pltclu is first used."
+msgstr "PL/TclU函数在首次使用pltcl时调用一次."
+
+#: pltcl.c:634
+#, c-format
+msgid "function \"%s\" is in the wrong language"
+msgstr "函数\"%s\"的语言错误"
+
+#: pltcl.c:645
+#, c-format
+msgid "function \"%s\" must not be SECURITY DEFINER"
+msgstr "函数\"%s\"不能是安全定义者"
+
+#. translator: %s is "pltcl.start_proc" or "pltclu.start_proc"
+#: pltcl.c:679
+#, c-format
+msgid "processing %s parameter"
+msgstr "正在处理%s参数"
+
+#: pltcl.c:833
+#, c-format
+msgid "set-valued function called in context that cannot accept a set"
+msgstr "在不能接受使用集合的环境中调用set-valued函数"
+
+#: pltcl.c:1006
+#, c-format
+msgid "function returning record called in context that cannot accept type record"
+msgstr "返回值类型是记录的函数在不接受使用记录类型的环境中调用"
+
+#: pltcl.c:1290
+#, c-format
+msgid "could not split return value from trigger: %s"
+msgstr "无法分离来自触发器的返回值:%s"
+
+#: pltcl.c:1371 pltcl.c:1801
+#, c-format
+msgid "%s"
+msgstr "%s"
+
+#: pltcl.c:1372
+#, c-format
+msgid ""
+"%s\n"
+"in PL/Tcl function \"%s\""
+msgstr ""
+"%s\n"
+"在PL/Tcl函数\"%s\"中"
+
+#: pltcl.c:1536
+#, c-format
+msgid "trigger functions can only be called as triggers"
+msgstr "触发器函数只能以触发器的形式调用"
+
+#: pltcl.c:1540
+#, c-format
+msgid "PL/Tcl functions cannot return type %s"
+msgstr "PL/Tcl函数不能返回类型%s"
+
+#: pltcl.c:1579
+#, c-format
+msgid "PL/Tcl functions cannot accept type %s"
+msgstr "PL/Tcl函数不能使用类型 %s"
+
+#: pltcl.c:1693
+#, c-format
+msgid "could not create internal procedure \"%s\": %s"
+msgstr "无法创建内部过程\"%s\":%s"
+
+#: pltcl.c:3197
+#, c-format
+msgid "column name/value list must have even number of elements"
+msgstr "列名/值列表必须具有偶数个元素"
+
+#: pltcl.c:3215
+#, c-format
+msgid "column name/value list contains nonexistent column name \"%s\""
+msgstr "列名/值列表包含不存在的列名\"%s\""
+
+#: pltcl.c:3222
+#, c-format
+msgid "cannot set system attribute \"%s\""
+msgstr "不能设置系统属性\"%s\""
+
+#: pltcl.c:3228
+#, c-format
+msgid "cannot set generated column \"%s\""
+msgstr "无法设置生成的列 \"%s\""
diff --git a/src/pl/tcl/po/zh_TW.po b/src/pl/tcl/po/zh_TW.po
new file mode 100644
index 0000000..f484eda
--- /dev/null
+++ b/src/pl/tcl/po/zh_TW.po
@@ -0,0 +1,135 @@
+# Traditional Chinese message translation file for pltcl
+# Copyright (C) 2023 PostgreSQL Global Development Group
+# This file is distributed under the same license as the pltcl (PostgreSQL) package.
+# Zhenbang Wei <znbang@gmail.com>, 2011.
+#
+msgid ""
+msgstr ""
+"Project-Id-Version: pltcl (PostgreSQL) 16\n"
+"Report-Msgid-Bugs-To: pgsql-bugs@lists.postgresql.org\n"
+"POT-Creation-Date: 2023-09-11 20:38+0000\n"
+"PO-Revision-Date: 2023-11-06 08:50+0800\n"
+"Last-Translator: Zhenbang Wei <znbang@gmail.com>\n"
+"Language-Team: \n"
+"Language: zh_TW\n"
+"MIME-Version: 1.0\n"
+"Content-Type: text/plain; charset=UTF-8\n"
+"Content-Transfer-Encoding: 8bit\n"
+"X-Generator: Poedit 3.4.1\n"
+
+#: pltcl.c:462
+msgid "PL/Tcl function to call once when pltcl is first used."
+msgstr "初次使用 pltcl 時執行的 PL/Tcl 函數。"
+
+#: pltcl.c:469
+msgid "PL/TclU function to call once when pltclu is first used."
+msgstr "初次使用 pltclu 時執行的 PL/TclU 函數。"
+
+# utils/adt/ri_triggers.c:2921
+#: pltcl.c:636
+#, c-format
+msgid "function \"%s\" is in the wrong language"
+msgstr "函數 \"%s\" 使用錯誤的語言"
+
+# utils/adt/ri_triggers.c:2938
+#: pltcl.c:647
+#, c-format
+msgid "function \"%s\" must not be SECURITY DEFINER"
+msgstr "函數 \"%s\" 不得設為 SECURITY DEFINER"
+
+#. translator: %s is "pltcl.start_proc" or "pltclu.start_proc"
+#: pltcl.c:681
+#, c-format
+msgid "processing %s parameter"
+msgstr "處理 %s 參數"
+
+# executor/execQual.c:866 executor/execQual.c:910 executor/execQual.c:1086
+# executor/execQual.c:1211 executor/execQual.c:3445 executor/functions.c:666
+# executor/functions.c:705 utils/fmgr/funcapi.c:39
+#: pltcl.c:834
+#, c-format
+msgid "set-valued function called in context that cannot accept a set"
+msgstr "在無法接受集合的情況下呼叫了回傳集合的函數"
+
+#: pltcl.c:839
+#, c-format
+msgid "materialize mode required, but it is not allowed in this context"
+msgstr "需要實體化模式,但在這個情況下是不允許的"
+
+#: pltcl.c:1012
+#, c-format
+msgid "function returning record called in context that cannot accept type record"
+msgstr "在不接受記錄型別的清況下呼叫回傳記錄的函數"
+
+# fe-exec.c:2204
+#: pltcl.c:1295
+#, c-format
+msgid "could not split return value from trigger: %s"
+msgstr "無法拆分觸發程序的回傳值: %s"
+
+# commands/vacuum.c:2258 commands/vacuumlazy.c:489 commands/vacuumlazy.c:770
+# nodes/print.c:86 storage/lmgr/deadlock.c:888 tcop/postgres.c:3285
+#: pltcl.c:1376 pltcl.c:1803
+#, c-format
+msgid "%s"
+msgstr "%s"
+
+#: pltcl.c:1377
+#, c-format
+msgid ""
+"%s\n"
+"in PL/Tcl function \"%s\""
+msgstr ""
+"%s\n"
+"於 PL/Tcl 函數 \"%s\""
+
+#: pltcl.c:1540
+#, c-format
+msgid "trigger functions can only be called as triggers"
+msgstr "觸發函數只能被當作觸發程序來呼叫"
+
+#: pltcl.c:1544
+#, c-format
+msgid "PL/Tcl functions cannot return type %s"
+msgstr "PL/Tcl 函數不能回傳型別 %s"
+
+#: pltcl.c:1583
+#, c-format
+msgid "PL/Tcl functions cannot accept type %s"
+msgstr "PL/Tcl 函數不能接受型別 %s"
+
+# utils/init/miscinit.c:519
+#: pltcl.c:1695
+#, c-format
+msgid "could not create internal procedure \"%s\": %s"
+msgstr "無法建立內部程序 \"%s\": %s"
+
+# parser/analyze.c:2210
+#: pltcl.c:3199
+#, c-format
+msgid "column name/value list must have even number of elements"
+msgstr "欄位名稱/值清單須有偶數個元素"
+
+#: pltcl.c:3217
+#, c-format
+msgid "column name/value list contains nonexistent column name \"%s\""
+msgstr "欄位名稱/值清單包含不存在的欄位名稱 \"%s\""
+
+# commands/tablecmds.c:5425
+#: pltcl.c:3224
+#, c-format
+msgid "cannot set system attribute \"%s\""
+msgstr "無法設定系統屬性 \"%s\""
+
+# commands/tablecmds.c:4580
+#: pltcl.c:3230
+#, c-format
+msgid "cannot set generated column \"%s\""
+msgstr "無法設定被產生的欄位 \"%s\""
+
+#~ msgid "PL/Tcl functions cannot return composite types"
+#~ msgstr "PL/Tcl 函式不能傳回複合型別"
+
+# common.c:123
+#~ msgid "out of memory"
+#~ msgstr "記憶體用盡"
diff --git a/src/pl/tcl/sql/pltcl_call.sql b/src/pl/tcl/sql/pltcl_call.sql
new file mode 100644
index 0000000..37efbde
--- /dev/null
+++ b/src/pl/tcl/sql/pltcl_call.sql
@@ -0,0 +1,78 @@
+CREATE PROCEDURE test_proc1()
+LANGUAGE pltcl
+AS $$
+unset
+$$;
+
+CALL test_proc1();
+
+
+CREATE PROCEDURE test_proc2()
+LANGUAGE pltcl
+AS $$
+return 5
+$$;
+
+CALL test_proc2();
+
+
+CREATE TABLE test1 (a int);
+
+CREATE PROCEDURE test_proc3(x int)
+LANGUAGE pltcl
+AS $$
+spi_exec "INSERT INTO test1 VALUES ($1)"
+$$;
+
+CALL test_proc3(55);
+
+SELECT * FROM test1;
+
+
+-- output arguments
+
+CREATE PROCEDURE test_proc5(INOUT a text)
+LANGUAGE pltcl
+AS $$
+set aa [concat $1 "+" $1]
+return [list a $aa]
+$$;
+
+CALL test_proc5('abc');
+
+
+CREATE PROCEDURE test_proc6(a int, INOUT b int, INOUT c int)
+LANGUAGE pltcl
+AS $$
+set bb [expr $2 * $1]
+set cc [expr $3 * $1]
+return [list b $bb c $cc]
+$$;
+
+CALL test_proc6(2, 3, 4);
+
+
+-- OUT parameters
+
+CREATE PROCEDURE test_proc9(IN a int, OUT b int)
+LANGUAGE pltcl
+AS $$
+elog NOTICE "a: $1"
+return [list b [expr {$1 * 2}]]
+$$;
+
+DO $$
+DECLARE _a int; _b int;
+BEGIN
+ _a := 10; _b := 30;
+ CALL test_proc9(_a, _b);
+ RAISE NOTICE '_a: %, _b: %', _a, _b;
+END
+$$;
+
+
+DROP PROCEDURE test_proc1;
+DROP PROCEDURE test_proc2;
+DROP PROCEDURE test_proc3;
+
+DROP TABLE test1;
diff --git a/src/pl/tcl/sql/pltcl_queries.sql b/src/pl/tcl/sql/pltcl_queries.sql
new file mode 100644
index 0000000..bbd2d97
--- /dev/null
+++ b/src/pl/tcl/sql/pltcl_queries.sql
@@ -0,0 +1,166 @@
+-- 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'));
+
+-- More tests for composite argument/result types
+
+create domain d_comp1 as T_comp1 check ((value).ref1 > 0);
+
+create function tcl_record_arg(record, fldname text) returns int as '
+ return $1($2)
+' language pltcl;
+
+select tcl_record_arg(row('tkey', 42, 'ref2')::T_comp1, 'ref1');
+select tcl_record_arg(row('tkey', 42, 'ref2')::d_comp1, 'ref1');
+select tcl_record_arg(row(2,4), 'f2');
+
+create function tcl_cdomain_arg(d_comp1) returns int as '
+ return $1(ref1)
+' language pltcl;
+
+select tcl_cdomain_arg(row('tkey', 42, 'ref2'));
+select tcl_cdomain_arg(row('tkey', 42, 'ref2')::T_comp1);
+select tcl_cdomain_arg(row('tkey', -1, 'ref2')); -- fail
+
+-- Test argisnull primitive
+select tcl_argisnull('foo');
+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;
+select tcl_error();
+
+create function bad_record(out a text, out b text) as $$return [list a]$$ language pltcl;
+select bad_record();
+
+create function bad_field(out a text, out b text) as $$return [list a 1 b 2 cow 3]$$ language pltcl;
+select bad_field();
+
+-- test compound return
+select * from tcl_test_cube_squared(5);
+
+-- test SRF
+select * from tcl_test_squared_rows(0,5);
+
+select * from tcl_test_sequence(0,5) as a;
+
+select 1, tcl_test_sequence(0,5);
+
+create function non_srf() returns int as $$return_next 1$$ language pltcl;
+select 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();
+
+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();
+
+-- 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]
+$$ language pltcl;
+select tcl_composite_result(1001);
+select * from tcl_composite_result(1002);
+
+create function tcl_dcomposite_result(int) returns d_comp1 as $$
+return [list tkey tkey2 ref1 $1 ref2 ref42]
+$$ language pltcl;
+select tcl_dcomposite_result(1001);
+select * from tcl_dcomposite_result(1002);
+select * from tcl_dcomposite_result(-1); -- fail
+
+create function tcl_record_result(int) returns record as $$
+return [list q1 sometext q2 $1 q3 moretext]
+$$ language pltcl;
+select tcl_record_result(42); -- fail
+select * from tcl_record_result(42); -- fail
+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, q4 int);
+select * from tcl_record_result(42) as (q1 text, q2 int, q4 int); -- fail
+
+-- test quote
+select tcl_eval('quote foo bar');
+select tcl_eval('quote [format %c 39]');
+select tcl_eval('quote [format %c 92]');
+
+-- Test argisnull
+select tcl_eval('argisnull');
+select tcl_eval('argisnull 14');
+select tcl_eval('argisnull abc');
+
+-- Test return_null
+select tcl_eval('return_null 14');
+
+-- Test spi_exec
+select tcl_eval('spi_exec');
+select tcl_eval('spi_exec -count');
+select tcl_eval('spi_exec -array');
+select tcl_eval('spi_exec -count abc');
+select tcl_eval('spi_exec query loop body toomuch');
+select tcl_eval('spi_exec "begin; rollback;"');
+
+-- Test spi_execp
+select tcl_eval('spi_execp');
+select tcl_eval('spi_execp -count');
+select tcl_eval('spi_execp -array');
+select tcl_eval('spi_execp -count abc');
+select tcl_eval('spi_execp -nulls');
+select tcl_eval('spi_execp ""');
+
+-- test spi_prepare
+select tcl_eval('spi_prepare');
+select tcl_eval('spi_prepare a b');
+select tcl_eval('spi_prepare a "b {"');
+select tcl_error_handling_test($tcl$spi_prepare "select moo" []$tcl$);
+
+-- test full error text
+select tcl_error_handling_test($tcl$
+spi_exec "DO $$
+BEGIN
+RAISE 'my message'
+ USING HINT = 'my hint'
+ , DETAIL = 'my detail'
+ , SCHEMA = 'my schema'
+ , TABLE = 'my table'
+ , COLUMN = 'my column'
+ , CONSTRAINT = 'my constraint'
+ , DATATYPE = 'my datatype'
+;
+END$$;"
+$tcl$);
+
+-- verify tcl_error_handling_test() properly reports non-postgres errors
+select tcl_error_handling_test('moo');
+
+-- test elog
+select tcl_eval('elog');
+select tcl_eval('elog foo bar');
+
+-- test forced error
+select tcl_eval('error "forced error"');
+
+-- test loop control in spi_exec[p]
+select tcl_spi_exec(true, 'break');
+select tcl_spi_exec(true, 'continue');
+select tcl_spi_exec(true, 'error');
+select tcl_spi_exec(true, 'return');
+select tcl_spi_exec(false, 'break');
+select tcl_spi_exec(false, 'continue');
+select tcl_spi_exec(false, 'error');
+select tcl_spi_exec(false, 'return');
+
+-- 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($$
+ unset -nocomplain ::tcl_vwait
+ after 100 {set ::tcl_vwait 1}
+ vwait ::tcl_vwait
+ unset -nocomplain ::tcl_vwait$$);
diff --git a/src/pl/tcl/sql/pltcl_setup.sql b/src/pl/tcl/sql/pltcl_setup.sql
new file mode 100644
index 0000000..b9892ea
--- /dev/null
+++ b/src/pl/tcl/sql/pltcl_setup.sql
@@ -0,0 +1,278 @@
+create table T_comp1 (
+ tkey char(10),
+ ref1 int4,
+ ref2 char(20)
+);
+
+create function tcl_composite_arg_ref1(T_comp1) returns int as '
+ return $1(ref1)
+' language pltcl;
+
+create function tcl_composite_arg_ref2(T_comp1) returns text as '
+ return $1(ref2)
+' language pltcl;
+
+create function tcl_argisnull(text) returns bool as '
+ argisnull 1
+' language pltcl;
+
+
+create function tcl_int4add(int4,int4) returns int4 as '
+ return [expr $1 + $2]
+' language pltcl;
+
+-- We use split(n) as a quick-and-dirty way of parsing the input array
+-- value, which comes in as a string like '{1,2}'. There are better ways...
+
+create function tcl_int4_accum(int4[], int4) returns int4[] as '
+ set state [split $1 "{,}"]
+ set newsum [expr {[lindex $state 1] + $2}]
+ set newcnt [expr {[lindex $state 2] + 1}]
+ return "{$newsum,$newcnt}"
+' language pltcl;
+
+create function tcl_int4_avg(int4[]) returns int4 as '
+ set state [split $1 "{,}"]
+ if {[lindex $state 2] == 0} { return_null }
+ return [expr {[lindex $state 1] / [lindex $state 2]}]
+' language pltcl;
+
+create aggregate tcl_avg (
+ sfunc = tcl_int4_accum,
+ basetype = int4,
+ stype = int4[],
+ finalfunc = tcl_int4_avg,
+ initcond = '{0,0}'
+ );
+
+create aggregate tcl_sum (
+ sfunc = tcl_int4add,
+ basetype = int4,
+ stype = int4,
+ initcond1 = 0
+ );
+
+create function tcl_int4lt(int4,int4) returns bool as '
+ if {$1 < $2} {
+ return t
+ }
+ return f
+' language pltcl;
+
+create function tcl_int4le(int4,int4) returns bool as '
+ if {$1 <= $2} {
+ return t
+ }
+ return f
+' language pltcl;
+
+create function tcl_int4eq(int4,int4) returns bool as '
+ if {$1 == $2} {
+ return t
+ }
+ return f
+' language pltcl;
+
+create function tcl_int4ge(int4,int4) returns bool as '
+ if {$1 >= $2} {
+ return t
+ }
+ return f
+' language pltcl;
+
+create function tcl_int4gt(int4,int4) returns bool as '
+ if {$1 > $2} {
+ return t
+ }
+ return f
+' language pltcl;
+
+create operator @< (
+ leftarg = int4,
+ rightarg = int4,
+ procedure = tcl_int4lt
+ );
+
+create operator @<= (
+ leftarg = int4,
+ rightarg = int4,
+ procedure = tcl_int4le
+ );
+
+create operator @= (
+ leftarg = int4,
+ rightarg = int4,
+ procedure = tcl_int4eq
+ );
+
+create operator @>= (
+ leftarg = int4,
+ rightarg = int4,
+ procedure = tcl_int4ge
+ );
+
+create operator @> (
+ leftarg = int4,
+ rightarg = int4,
+ procedure = tcl_int4gt
+ );
+
+create function tcl_int4cmp(int4,int4) returns int4 as '
+ if {$1 < $2} {
+ return -1
+ }
+ if {$1 > $2} {
+ return 1
+ }
+ return 0
+' language pltcl;
+
+CREATE OPERATOR CLASS tcl_int4_ops
+ FOR TYPE int4 USING btree AS
+ OPERATOR 1 @<,
+ OPERATOR 2 @<=,
+ OPERATOR 3 @=,
+ OPERATOR 4 @>=,
+ OPERATOR 5 @>,
+ FUNCTION 1 tcl_int4cmp(int4,int4) ;
+
+--
+-- Test usage of Tcl's "clock" command. In recent Tcl versions this
+-- command fails without working "unknown" support, so it's a good canary
+-- for initialization problems.
+--
+create function tcl_date_week(int4,int4,int4) returns text as $$
+ return [clock format [clock scan "$2/$3/$1" -gmt 1] -format "%U" -gmt 1]
+$$ language pltcl immutable;
+
+select tcl_date_week(2010,1,26);
+select tcl_date_week(2001,10,24);
+
+-- test pltcl event triggers
+create function tclsnitch() returns event_trigger language pltcl as $$
+ elog NOTICE "tclsnitch: $TG_event $TG_tag"
+$$;
+
+create event trigger tcl_a_snitch on ddl_command_start execute procedure tclsnitch();
+create event trigger tcl_b_snitch on ddl_command_end execute procedure tclsnitch();
+
+create function foobar() returns int language sql as $$select 1;$$;
+alter function foobar() cost 77;
+drop function foobar();
+
+create table foo();
+drop table foo;
+
+drop event trigger tcl_a_snitch;
+drop event trigger tcl_b_snitch;
+
+create function tcl_test_cube_squared(in int, out squared int, out cubed int) as $$
+ return [list squared [expr {$1 * $1}] cubed [expr {$1 * $1 * $1}]]
+$$ language pltcl;
+
+create function tcl_test_squared_rows(int,int) returns table (x int, y int) as $$
+ for {set i $1} {$i < $2} {incr i} {
+ return_next [list y [expr {$i * $i}] x $i]
+ }
+$$ language pltcl;
+
+create function tcl_test_sequence(int,int) returns setof int as $$
+ for {set i $1} {$i < $2} {incr i} {
+ return_next $i
+ }
+$$ language pltcl;
+
+create function tcl_eval(string text) returns text as $$
+ eval $1
+$$ language pltcl;
+
+-- test use of errorCode in error handling
+create function tcl_error_handling_test(text) returns text
+language pltcl
+as $function$
+ if {[catch $1 err]} {
+ # If not a Postgres error, just return the basic error message
+ if {[lindex $::errorCode 0] != "POSTGRES"} {
+ return $err
+ }
+
+ # Get rid of keys that can't be expected to remain constant
+ array set myArray $::errorCode
+ unset myArray(POSTGRES)
+ unset -nocomplain myArray(funcname)
+ unset -nocomplain myArray(filename)
+ unset -nocomplain myArray(lineno)
+
+ # Format into something nicer
+ set vals []
+ foreach {key} [lsort [array names myArray]] {
+ set value [string map {"\n" "\n\t"} $myArray($key)]
+ lappend vals "$key: $value"
+ }
+ return [join $vals "\n"]
+ } else {
+ return "no error"
+ }
+$function$;
+
+-- test spi_exec and spi_execp with -array
+create function tcl_spi_exec(
+ prepare boolean,
+ action text
+)
+returns void language pltcl AS $function$
+set query "select * from (values (1,'foo'),(2,'bar'),(3,'baz')) v(col1,col2)"
+if {$1 == "t"} {
+ set prep [spi_prepare $query {}]
+ spi_execp -array A $prep {
+ elog NOTICE "col1 $A(col1), col2 $A(col2)"
+
+ switch $A(col1) {
+ 2 {
+ elog NOTICE "action: $2"
+ switch $2 {
+ break {
+ break
+ }
+ continue {
+ continue
+ }
+ return {
+ return
+ }
+ error {
+ error "error message"
+ }
+ }
+ error "should not get here"
+ }
+ }
+ }
+} else {
+ spi_exec -array A $query {
+ elog NOTICE "col1 $A(col1), col2 $A(col2)"
+
+ switch $A(col1) {
+ 2 {
+ elog NOTICE "action: $2"
+ switch $2 {
+ break {
+ break
+ }
+ continue {
+ continue
+ }
+ return {
+ return
+ }
+ error {
+ error "error message"
+ }
+ }
+ error "should not get here"
+ }
+ }
+ }
+}
+elog NOTICE "end of function"
+$function$;
diff --git a/src/pl/tcl/sql/pltcl_start_proc.sql b/src/pl/tcl/sql/pltcl_start_proc.sql
new file mode 100644
index 0000000..7a8e68e
--- /dev/null
+++ b/src/pl/tcl/sql/pltcl_start_proc.sql
@@ -0,0 +1,21 @@
+--
+-- Test start_proc execution
+--
+
+SET pltcl.start_proc = 'no_such_function';
+
+select tcl_int4add(1, 2);
+select tcl_int4add(1, 2);
+
+create function tcl_initialize() returns void as
+$$ elog NOTICE "in tcl_initialize" $$ language pltcl SECURITY DEFINER;
+
+SET pltcl.start_proc = 'public.tcl_initialize';
+
+select tcl_int4add(1, 2); -- fail
+
+create or replace function tcl_initialize() returns void as
+$$ elog NOTICE "in tcl_initialize" $$ language pltcl;
+
+select tcl_int4add(1, 2);
+select tcl_int4add(1, 2);
diff --git a/src/pl/tcl/sql/pltcl_subxact.sql b/src/pl/tcl/sql/pltcl_subxact.sql
new file mode 100644
index 0000000..0625736
--- /dev/null
+++ b/src/pl/tcl/sql/pltcl_subxact.sql
@@ -0,0 +1,95 @@
+--
+-- Test explicit subtransactions
+--
+
+CREATE TABLE subtransaction_tbl (
+ i integer
+);
+
+--
+-- We use this wrapper to catch errors and return errormsg only,
+-- because values of $::errorinfo variable contain procedure name which
+-- includes OID, so it's not stable
+--
+CREATE FUNCTION pltcl_wrapper(statement text) RETURNS text
+AS $$
+ if [catch {spi_exec $1} msg] {
+ return "ERROR: $msg"
+ } else {
+ return "SUCCESS: $msg"
+ }
+$$ LANGUAGE pltcl;
+
+-- Test subtransaction successfully committed
+
+CREATE FUNCTION subtransaction_ctx_success() RETURNS void
+AS $$
+ spi_exec "INSERT INTO subtransaction_tbl VALUES(1)"
+ subtransaction {
+ spi_exec "INSERT INTO subtransaction_tbl VALUES(2)"
+ }
+$$ LANGUAGE pltcl;
+
+BEGIN;
+INSERT INTO subtransaction_tbl VALUES(0);
+SELECT subtransaction_ctx_success();
+COMMIT;
+SELECT * FROM subtransaction_tbl;
+TRUNCATE subtransaction_tbl;
+
+-- Test subtransaction rollback
+
+CREATE FUNCTION subtransaction_ctx_test(what_error text = NULL) RETURNS void
+AS $$
+ spi_exec "INSERT INTO subtransaction_tbl VALUES (1)"
+ subtransaction {
+ spi_exec "INSERT INTO subtransaction_tbl VALUES (2)"
+ if {$1 == "SPI"} {
+ spi_exec "INSERT INTO subtransaction_tbl VALUES ('oops')"
+ } elseif { $1 == "Tcl"} {
+ elog ERROR "Tcl error"
+ }
+ }
+$$ LANGUAGE pltcl;
+
+SELECT pltcl_wrapper('SELECT subtransaction_ctx_test()');
+SELECT * FROM subtransaction_tbl;
+TRUNCATE subtransaction_tbl;
+
+SELECT pltcl_wrapper('SELECT subtransaction_ctx_test(''SPI'')');
+SELECT * FROM subtransaction_tbl;
+TRUNCATE subtransaction_tbl;
+
+SELECT pltcl_wrapper('SELECT subtransaction_ctx_test(''Tcl'')');
+SELECT * FROM subtransaction_tbl;
+TRUNCATE subtransaction_tbl;
+
+-- Nested subtransactions
+
+CREATE FUNCTION subtransaction_nested_test(swallow boolean = 'f') RETURNS text
+AS $$
+spi_exec "INSERT INTO subtransaction_tbl VALUES (1)"
+subtransaction {
+ spi_exec "INSERT INTO subtransaction_tbl VALUES (2)"
+ if [catch {
+ subtransaction {
+ spi_exec "INSERT INTO subtransaction_tbl VALUES (3)"
+ spi_exec "error"
+ }
+ } errormsg] {
+ if {$1 != "t"} {
+ error $errormsg $::errorInfo $::errorCode
+ }
+ elog NOTICE "Swallowed $errormsg"
+ }
+}
+return "ok"
+$$ LANGUAGE pltcl;
+
+SELECT pltcl_wrapper('SELECT subtransaction_nested_test()');
+SELECT * FROM subtransaction_tbl;
+TRUNCATE subtransaction_tbl;
+
+SELECT pltcl_wrapper('SELECT subtransaction_nested_test(''t'')');
+SELECT * FROM subtransaction_tbl;
+TRUNCATE subtransaction_tbl;
diff --git a/src/pl/tcl/sql/pltcl_transaction.sql b/src/pl/tcl/sql/pltcl_transaction.sql
new file mode 100644
index 0000000..bd75985
--- /dev/null
+++ b/src/pl/tcl/sql/pltcl_transaction.sql
@@ -0,0 +1,135 @@
+-- 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
+AS $$
+for {set i 0} {$i < 10} {incr i} {
+ spi_exec "INSERT INTO test1 (a) VALUES ($i)"
+ if {$i % 2 == 0} {
+ commit
+ } else {
+ rollback
+ }
+}
+$$;
+
+CALL transaction_test1();
+
+SELECT * FROM test1;
+
+
+TRUNCATE test1;
+
+-- not allowed in a function
+CREATE FUNCTION transaction_test2() RETURNS int
+LANGUAGE pltcl
+AS $$
+for {set i 0} {$i < 10} {incr i} {
+ spi_exec "INSERT INTO test1 (a) VALUES ($i)"
+ if {$i % 2 == 0} {
+ commit
+ } else {
+ rollback
+ }
+}
+return 1
+$$;
+
+SELECT transaction_test2();
+
+SELECT * FROM test1;
+
+
+-- also not allowed if procedure is called from a function
+CREATE FUNCTION transaction_test3() RETURNS int
+LANGUAGE pltcl
+AS $$
+spi_exec "CALL transaction_test1()"
+return 1
+$$;
+
+SELECT transaction_test3();
+
+SELECT * FROM test1;
+
+
+-- commit inside cursor loop
+CREATE TABLE test2 (x int);
+INSERT INTO test2 VALUES (0), (1), (2), (3), (4);
+
+TRUNCATE test1;
+
+CREATE PROCEDURE transaction_test4a()
+LANGUAGE pltcl
+AS $$
+spi_exec -array row "SELECT * FROM test2 ORDER BY x" {
+ spi_exec "INSERT INTO test1 (a) VALUES ($row(x))"
+ commit
+}
+$$;
+
+CALL transaction_test4a();
+
+SELECT * FROM test1;
+
+
+-- rollback inside cursor loop
+TRUNCATE test1;
+
+CREATE PROCEDURE transaction_test4b()
+LANGUAGE pltcl
+AS $$
+spi_exec -array row "SELECT * FROM test2 ORDER BY x" {
+ spi_exec "INSERT INTO test1 (a) VALUES ($row(x))"
+ rollback
+}
+$$;
+
+CALL transaction_test4b();
+
+SELECT * FROM test1;
+
+
+-- check handling of an error during COMMIT
+CREATE TABLE testpk (id int PRIMARY KEY);
+CREATE TABLE testfk(f1 int REFERENCES testpk DEFERRABLE INITIALLY DEFERRED);
+
+CREATE PROCEDURE transaction_testfk()
+LANGUAGE pltcl
+AS $$
+# this insert will fail during commit:
+spi_exec "INSERT INTO testfk VALUES (0)"
+commit
+elog WARNING "should not get here"
+$$;
+
+CALL transaction_testfk();
+
+SELECT * FROM testpk;
+SELECT * FROM testfk;
+
+CREATE OR REPLACE PROCEDURE transaction_testfk()
+LANGUAGE pltcl
+AS $$
+# this insert will fail during commit:
+spi_exec "INSERT INTO testfk VALUES (0)"
+if [catch {commit} msg] {
+ elog INFO $msg
+}
+# these inserts should work:
+spi_exec "INSERT INTO testpk VALUES (1)"
+spi_exec "INSERT INTO testfk VALUES (1)"
+$$;
+
+CALL transaction_testfk();
+
+SELECT * FROM testpk;
+SELECT * FROM testfk;
+
+
+DROP TABLE test1;
+DROP TABLE test2;
diff --git a/src/pl/tcl/sql/pltcl_trigger.sql b/src/pl/tcl/sql/pltcl_trigger.sql
new file mode 100644
index 0000000..2db75a3
--- /dev/null
+++ b/src/pl/tcl/sql/pltcl_trigger.sql
@@ -0,0 +1,603 @@
+-- suppress CONTEXT so that function OIDs aren't in output
+\set VERBOSITY terse
+
+--
+-- Create the tables used in the test queries
+--
+-- T_pkey1 is the primary key table for T_dta1. Entries from T_pkey1
+-- Cannot be changed or deleted if they are referenced from T_dta1.
+--
+-- T_pkey2 is the primary key table for T_dta2. If the key values in
+-- T_pkey2 are changed, the references in T_dta2 follow. If entries
+-- are deleted, the referencing entries from T_dta2 are deleted too.
+-- The values for field key2 in T_pkey2 are silently converted to
+-- upper case on insert/update.
+--
+create table T_pkey1 (
+ key1 int4,
+ key2 char(20),
+ txt char(40)
+);
+
+create table T_pkey2 (
+ key1 int4,
+ key2 char(20),
+ txt char(40)
+);
+
+create table T_dta1 (
+ tkey char(10),
+ ref1 int4,
+ ref2 char(20)
+);
+
+create table T_dta2 (
+ tkey char(10),
+ ref1 int4,
+ ref2 char(20)
+);
+
+
+--
+-- Function to check key existence in T_pkey1
+--
+create function check_pkey1_exists(int4, bpchar) returns bool as E'
+ if {![info exists GD]} {
+ set GD(plan) [spi_prepare \\
+ "select 1 from T_pkey1 \\
+ where key1 = \\$1 and key2 = \\$2" \\
+ {int4 bpchar}]
+ }
+
+ set n [spi_execp -count 1 $GD(plan) [list $1 $2]]
+
+ if {$n > 0} {
+ return "t"
+ }
+ return "f"
+' language pltcl;
+
+
+-- dump trigger data
+
+CREATE TABLE trigger_test (
+ i int,
+ v text,
+ dropme text,
+ test_skip boolean DEFAULT false,
+ test_return_null boolean DEFAULT false,
+ test_argisnull boolean DEFAULT false
+);
+-- Make certain dropped attributes are handled correctly
+ALTER TABLE trigger_test DROP dropme;
+
+CREATE TABLE trigger_test_generated (
+ i int,
+ j int GENERATED ALWAYS AS (i * 2) STORED
+);
+
+CREATE VIEW trigger_test_view AS SELECT i, v FROM trigger_test;
+
+CREATE FUNCTION trigger_data() returns trigger language pltcl as $_$
+ if {$TG_table_name eq "trigger_test" && $TG_level eq "ROW" && $TG_op ne "DELETE"} {
+ # Special case tests
+ if {$NEW(test_return_null) eq "t" } {
+ return_null
+ }
+ if {$NEW(test_argisnull) eq "t" } {
+ set should_error [argisnull 1]
+ }
+ if {$NEW(test_skip) eq "t" } {
+ elog NOTICE "SKIPPING OPERATION $TG_op"
+ return SKIP
+ }
+ }
+
+ if { [info exists TG_relid] } {
+ set TG_relid "bogus:12345"
+ }
+
+ set dnames [info locals {[a-zA-Z]*} ]
+
+ foreach key [lsort $dnames] {
+
+ if { [array exists $key] } {
+ set str "{"
+ foreach akey [lsort [ array names $key ] ] {
+ if {[string length $str] > 1} { set str "$str, " }
+ set cmd "($akey)"
+ set cmd "set val \$$key$cmd"
+ eval $cmd
+ set str "$str$akey: $val"
+ }
+ set str "$str}"
+ elog NOTICE "$key: $str"
+ } else {
+ set val [eval list "\$$key" ]
+ elog NOTICE "$key: $val"
+ }
+ }
+
+
+ return OK
+
+$_$;
+
+CREATE TRIGGER show_trigger_data_trig
+BEFORE INSERT OR UPDATE OR DELETE ON trigger_test
+FOR EACH ROW EXECUTE PROCEDURE trigger_data(23,'skidoo');
+CREATE TRIGGER statement_trigger
+BEFORE INSERT OR UPDATE OR DELETE OR TRUNCATE ON trigger_test
+FOR EACH STATEMENT EXECUTE PROCEDURE trigger_data(42,'statement trigger');
+
+CREATE TRIGGER show_trigger_data_trig_before
+BEFORE INSERT OR UPDATE OR DELETE ON trigger_test_generated
+FOR EACH ROW EXECUTE PROCEDURE trigger_data();
+CREATE TRIGGER show_trigger_data_trig_after
+AFTER INSERT OR UPDATE OR DELETE ON trigger_test_generated
+FOR EACH ROW EXECUTE PROCEDURE trigger_data();
+
+CREATE TRIGGER show_trigger_data_view_trig
+INSTEAD OF INSERT OR UPDATE OR DELETE ON trigger_test_view
+FOR EACH ROW EXECUTE PROCEDURE trigger_data(24,'skidoo view');
+
+--
+-- Trigger function on every change to T_pkey1
+--
+create function trig_pkey1_before() returns trigger as E'
+ #
+ # Create prepared plans on the first call
+ #
+ if {![info exists GD]} {
+ #
+ # Plan to check for duplicate key in T_pkey1
+ #
+ set GD(plan_pkey1) [spi_prepare \\
+ "select check_pkey1_exists(\\$1, \\$2) as ret" \\
+ {int4 bpchar}]
+ #
+ # Plan to check for references from T_dta1
+ #
+ set GD(plan_dta1) [spi_prepare \\
+ "select 1 from T_dta1 \\
+ where ref1 = \\$1 and ref2 = \\$2" \\
+ {int4 bpchar}]
+ }
+
+ #
+ # Initialize flags
+ #
+ set check_old_ref 0
+ set check_new_dup 0
+
+ switch $TG_op {
+ INSERT {
+ #
+ # Must check for duplicate key on INSERT
+ #
+ set check_new_dup 1
+ }
+ UPDATE {
+ #
+ # Must check for duplicate key on UPDATE only if
+ # the key changes. In that case we must check for
+ # references to OLD values too.
+ #
+ if {[string compare $NEW(key1) $OLD(key1)] != 0} {
+ set check_old_ref 1
+ set check_new_dup 1
+ }
+ if {[string compare $NEW(key2) $OLD(key2)] != 0} {
+ set check_old_ref 1
+ set check_new_dup 1
+ }
+ }
+ DELETE {
+ #
+ # Must only check for references to OLD on DELETE
+ #
+ set check_old_ref 1
+ }
+ }
+
+ if {$check_new_dup} {
+ #
+ # Check for duplicate key
+ #
+ spi_execp -count 1 $GD(plan_pkey1) [list $NEW(key1) $NEW(key2)]
+ if {$ret == "t"} {
+ elog ERROR \\
+ "duplicate key ''$NEW(key1)'', ''$NEW(key2)'' for T_pkey1"
+ }
+ }
+
+ if {$check_old_ref} {
+ #
+ # Check for references to OLD
+ #
+ set n [spi_execp -count 1 $GD(plan_dta1) [list $OLD(key1) $OLD(key2)]]
+ if {$n > 0} {
+ elog ERROR \\
+ "key ''$OLD(key1)'', ''$OLD(key2)'' referenced by T_dta1"
+ }
+ }
+
+ #
+ # Anything is fine - let operation pass through
+ #
+ return OK
+' language pltcl;
+
+
+create trigger pkey1_before before insert or update or delete on T_pkey1
+ for each row execute procedure
+ trig_pkey1_before();
+
+
+--
+-- Trigger function to check for duplicate keys in T_pkey2
+-- and to force key2 to be upper case only without leading whitespaces
+--
+create function trig_pkey2_before() returns trigger as E'
+ #
+ # Prepare plan on first call
+ #
+ if {![info exists GD]} {
+ set GD(plan_pkey2) [spi_prepare \\
+ "select 1 from T_pkey2 \\
+ where key1 = \\$1 and key2 = \\$2" \\
+ {int4 bpchar}]
+ }
+
+ #
+ # Convert key2 value
+ #
+ set NEW(key2) [string toupper [string trim $NEW(key2)]]
+
+ #
+ # Check for duplicate key
+ #
+ set n [spi_execp -count 1 $GD(plan_pkey2) [list $NEW(key1) $NEW(key2)]]
+ if {$n > 0} {
+ elog ERROR \\
+ "duplicate key ''$NEW(key1)'', ''$NEW(key2)'' for T_pkey2"
+ }
+
+ #
+ # Return modified tuple in NEW
+ #
+ return [array get NEW]
+' language pltcl;
+
+
+create trigger pkey2_before before insert or update on T_pkey2
+ for each row execute procedure
+ trig_pkey2_before();
+
+
+--
+-- Trigger function to force references from T_dta2 follow changes
+-- in T_pkey2 or be deleted too. This must be done AFTER the changes
+-- in T_pkey2 are done so the trigger for primkey check on T_dta2
+-- fired on our updates will see the new key values in T_pkey2.
+--
+create function trig_pkey2_after() returns trigger as E'
+ #
+ # Prepare plans on first call
+ #
+ if {![info exists GD]} {
+ #
+ # Plan to update references from T_dta2
+ #
+ set GD(plan_dta2_upd) [spi_prepare \\
+ "update T_dta2 set ref1 = \\$3, ref2 = \\$4 \\
+ where ref1 = \\$1 and ref2 = \\$2" \\
+ {int4 bpchar int4 bpchar}]
+ #
+ # Plan to delete references from T_dta2
+ #
+ set GD(plan_dta2_del) [spi_prepare \\
+ "delete from T_dta2 \\
+ where ref1 = \\$1 and ref2 = \\$2" \\
+ {int4 bpchar}]
+ }
+
+ #
+ # Initialize flags
+ #
+ set old_ref_follow 0
+ set old_ref_delete 0
+
+ switch $TG_op {
+ UPDATE {
+ #
+ # On update we must let old references follow
+ #
+ set NEW(key2) [string toupper $NEW(key2)]
+
+ if {[string compare $NEW(key1) $OLD(key1)] != 0} {
+ set old_ref_follow 1
+ }
+ if {[string compare $NEW(key2) $OLD(key2)] != 0} {
+ set old_ref_follow 1
+ }
+ }
+ DELETE {
+ #
+ # On delete we must delete references too
+ #
+ set old_ref_delete 1
+ }
+ }
+
+ if {$old_ref_follow} {
+ #
+ # Let old references follow and fire NOTICE message if
+ # there where some
+ #
+ set n [spi_execp $GD(plan_dta2_upd) \\
+ [list $OLD(key1) $OLD(key2) $NEW(key1) $NEW(key2)]]
+ if {$n > 0} {
+ elog NOTICE \\
+ "updated $n entries in T_dta2 for new key in T_pkey2"
+ }
+ }
+
+ if {$old_ref_delete} {
+ #
+ # delete references and fire NOTICE message if
+ # there where some
+ #
+ set n [spi_execp $GD(plan_dta2_del) \\
+ [list $OLD(key1) $OLD(key2)]]
+ if {$n > 0} {
+ elog NOTICE \\
+ "deleted $n entries from T_dta2"
+ }
+ }
+
+ return OK
+' language pltcl;
+
+
+create trigger pkey2_after after update or delete on T_pkey2
+ for each row execute procedure
+ trig_pkey2_after();
+
+
+--
+-- Generic trigger function to check references in T_dta1 and T_dta2
+--
+create function check_primkey() returns trigger as E'
+ #
+ # For every trigger/relation pair we create
+ # a saved plan and hold them in GD
+ #
+ set plankey [list "plan" $TG_name $TG_relid]
+ set planrel [list "relname" $TG_relid]
+
+ #
+ # Extract the pkey relation name
+ #
+ set keyidx [expr [llength $args] / 2]
+ set keyrel [string tolower [lindex $args $keyidx]]
+
+ if {![info exists GD($plankey)]} {
+ #
+ # We must prepare a new plan. Build up a query string
+ # for the primary key check.
+ #
+ set keylist [lrange $args [expr $keyidx + 1] end]
+
+ set query "select 1 from $keyrel"
+ set qual " where"
+ set typlist ""
+ set idx 1
+ foreach key $keylist {
+ set key [string tolower $key]
+ #
+ # Add the qual part to the query string
+ #
+ append query "$qual $key = \\$$idx"
+ set qual " and"
+
+ #
+ # Lookup the fields type in pg_attribute
+ #
+ set n [spi_exec "select T.typname \\
+ from pg_catalog.pg_type T, pg_catalog.pg_attribute A, pg_catalog.pg_class C \\
+ where C.relname = ''[quote $keyrel]'' \\
+ and C.oid = A.attrelid \\
+ and A.attname = ''[quote $key]'' \\
+ and A.atttypid = T.oid"]
+ if {$n != 1} {
+ elog ERROR "table $keyrel doesn''t have a field named $key"
+ }
+
+ #
+ # Append the fields type to the argument type list
+ #
+ lappend typlist $typname
+ incr idx
+ }
+
+ #
+ # Prepare the plan
+ #
+ set GD($plankey) [spi_prepare $query $typlist]
+
+ #
+ # Lookup and remember the table name for later error messages
+ #
+ spi_exec "select relname from pg_catalog.pg_class \\
+ where oid = ''$TG_relid''::oid"
+ set GD($planrel) $relname
+ }
+
+ #
+ # Build the argument list from the NEW row
+ #
+ incr keyidx -1
+ set arglist ""
+ foreach arg [lrange $args 0 $keyidx] {
+ lappend arglist $NEW($arg)
+ }
+
+ #
+ # Check for the primary key
+ #
+ set n [spi_execp -count 1 $GD($plankey) $arglist]
+ if {$n <= 0} {
+ elog ERROR "key for $GD($planrel) not in $keyrel"
+ }
+
+ #
+ # Anything is fine
+ #
+ return OK
+' language pltcl;
+
+
+create trigger dta1_before before insert or update on T_dta1
+ for each row execute procedure
+ check_primkey('ref1', 'ref2', 'T_pkey1', 'key1', 'key2');
+
+
+create trigger dta2_before before insert or update on T_dta2
+ for each row execute procedure
+ check_primkey('ref1', 'ref2', 'T_pkey2', 'key1', 'key2');
+
+
+insert into T_pkey1 values (1, 'key1-1', 'test key');
+insert into T_pkey1 values (1, 'key1-2', 'test key');
+insert into T_pkey1 values (1, 'key1-3', 'test key');
+insert into T_pkey1 values (2, 'key2-1', 'test key');
+insert into T_pkey1 values (2, 'key2-2', 'test key');
+insert into T_pkey1 values (2, 'key2-3', 'test key');
+
+insert into T_pkey2 values (1, 'key1-1', 'test key');
+insert into T_pkey2 values (1, 'key1-2', 'test key');
+insert into T_pkey2 values (1, 'key1-3', 'test key');
+insert into T_pkey2 values (2, 'key2-1', 'test key');
+insert into T_pkey2 values (2, 'key2-2', 'test key');
+insert into T_pkey2 values (2, 'key2-3', 'test key');
+
+select * from T_pkey1;
+
+-- key2 in T_pkey2 should have upper case only
+select * from T_pkey2;
+
+insert into T_pkey1 values (1, 'KEY1-3', 'should work');
+
+-- Due to the upper case translation in trigger this must fail
+insert into T_pkey2 values (1, 'KEY1-3', 'should fail');
+
+insert into T_dta1 values ('trec 1', 1, 'key1-1');
+insert into T_dta1 values ('trec 2', 1, 'key1-2');
+insert into T_dta1 values ('trec 3', 1, 'key1-3');
+
+-- Must fail due to unknown key in T_pkey1
+insert into T_dta1 values ('trec 4', 1, 'key1-4');
+
+insert into T_dta2 values ('trec 1', 1, 'KEY1-1');
+insert into T_dta2 values ('trec 2', 1, 'KEY1-2');
+insert into T_dta2 values ('trec 3', 1, 'KEY1-3');
+
+-- Must fail due to unknown key in T_pkey2
+insert into T_dta2 values ('trec 4', 1, 'KEY1-4');
+
+select * from T_dta1;
+
+select * from T_dta2;
+
+update T_pkey1 set key2 = 'key2-9' where key1 = 2 and key2 = 'key2-1';
+update T_pkey1 set key2 = 'key1-9' where key1 = 1 and key2 = 'key1-1';
+delete from T_pkey1 where key1 = 2 and key2 = 'key2-2';
+delete from T_pkey1 where key1 = 1 and key2 = 'key1-2';
+
+update T_pkey2 set key2 = 'KEY2-9' where key1 = 2 and key2 = 'KEY2-1';
+update T_pkey2 set key2 = 'KEY1-9' where key1 = 1 and key2 = 'KEY1-1';
+delete from T_pkey2 where key1 = 2 and key2 = 'KEY2-2';
+delete from T_pkey2 where key1 = 1 and key2 = 'KEY1-2';
+
+select * from T_pkey1;
+select * from T_pkey2;
+select * from T_dta1;
+select * from T_dta2;
+
+select tcl_avg(key1) from T_pkey1;
+select tcl_sum(key1) from T_pkey1;
+select tcl_avg(key1) from T_pkey2;
+select tcl_sum(key1) from T_pkey2;
+
+-- The following should return NULL instead of 0
+select tcl_avg(key1) from T_pkey1 where key1 = 99;
+select tcl_sum(key1) from T_pkey1 where key1 = 99;
+
+select 1 @< 2;
+select 100 @< 4;
+
+select * from T_pkey1 order by key1 using @<, key2 collate "C";
+select * from T_pkey2 order by key1 using @<, key2 collate "C";
+
+-- show dump of trigger data
+insert into trigger_test values(1,'insert');
+
+insert into trigger_test_generated (i) values (1);
+update trigger_test_generated set i = 11 where i = 1;
+delete from trigger_test_generated;
+
+insert into trigger_test_view values(2,'insert');
+update trigger_test_view set v = 'update' where i=1;
+delete from trigger_test_view;
+
+update trigger_test set v = 'update', test_skip=true where i = 1;
+update trigger_test set v = 'update' where i = 1;
+delete from trigger_test;
+truncate trigger_test;
+
+DROP TRIGGER show_trigger_data_trig_before ON trigger_test_generated;
+DROP TRIGGER show_trigger_data_trig_after ON trigger_test_generated;
+
+-- should error
+insert into trigger_test(test_argisnull) values(true);
+
+-- should error
+insert into trigger_test(test_return_null) values(true);
+
+-- test transition table visibility
+create table transition_table_test (id int, name text);
+insert into transition_table_test values (1, 'a');
+create function transition_table_test_f() returns trigger language pltcl as
+$$
+ spi_exec -array C "SELECT id, name FROM old_table" {
+ elog INFO "old: $C(id) -> $C(name)"
+ }
+ spi_exec -array C "SELECT id, name FROM new_table" {
+ elog INFO "new: $C(id) -> $C(name)"
+ }
+ return OK
+$$;
+CREATE TRIGGER a_t AFTER UPDATE ON transition_table_test
+ REFERENCING OLD TABLE AS old_table NEW TABLE AS new_table
+ FOR EACH STATEMENT EXECUTE PROCEDURE transition_table_test_f();
+update transition_table_test set name = 'b';
+drop table transition_table_test;
+drop function transition_table_test_f();
+
+-- dealing with generated columns
+
+CREATE FUNCTION generated_test_func1() RETURNS trigger
+LANGUAGE pltcl
+AS $$
+# not allowed
+set NEW(j) 5
+return [array get NEW]
+$$;
+
+CREATE TRIGGER generated_test_trigger1 BEFORE INSERT ON trigger_test_generated
+FOR EACH ROW EXECUTE PROCEDURE generated_test_func1();
+
+TRUNCATE trigger_test_generated;
+INSERT INTO trigger_test_generated (i) VALUES (1);
+SELECT * FROM trigger_test_generated;
diff --git a/src/pl/tcl/sql/pltcl_unicode.sql b/src/pl/tcl/sql/pltcl_unicode.sql
new file mode 100644
index 0000000..f000604
--- /dev/null
+++ b/src/pl/tcl/sql/pltcl_unicode.sql
@@ -0,0 +1,38 @@
+--
+-- Unicode handling
+--
+-- Note: this test case is known to fail if the database encoding is
+-- EUC_CN, EUC_JP, EUC_KR, or EUC_TW, for lack of any equivalent to
+-- U+00A0 (no-break space) in those encodings. However, testing with
+-- plain ASCII data would be rather useless, so we must live with that.
+--
+
+SET client_encoding TO UTF8;
+
+CREATE TABLE unicode_test (
+ testvalue text NOT NULL
+);
+
+CREATE FUNCTION unicode_return() RETURNS text AS $$
+ return "\xA0"
+$$ LANGUAGE pltcl;
+
+CREATE FUNCTION unicode_trigger() RETURNS trigger AS $$
+ set NEW(testvalue) "\xA0"
+ return [array get NEW]
+$$ LANGUAGE pltcl;
+
+CREATE TRIGGER unicode_test_bi BEFORE INSERT ON unicode_test
+ FOR EACH ROW EXECUTE PROCEDURE unicode_trigger();
+
+CREATE FUNCTION unicode_plan1() RETURNS text AS $$
+ set plan [ spi_prepare {SELECT $1 AS testvalue} [ list "text" ] ]
+ spi_execp $plan [ list "\xA0" ]
+ return $testvalue
+$$ LANGUAGE pltcl;
+
+
+SELECT unicode_return();
+INSERT INTO unicode_test (testvalue) VALUES ('test');
+SELECT * FROM unicode_test;
+SELECT unicode_plan1();