├── po ├── cs.mo ├── de.mo ├── es.mo ├── fr.mo ├── fr.po ├── it.mo ├── ja.mo ├── ko.mo ├── pl.mo ├── ro.mo ├── ru.mo ├── tr.mo ├── pt_BR.mo ├── zh_CN.mo ├── zh_TW.mo ├── tr.po ├── ro.po ├── zh_TW.po ├── cs.po ├── ko.po ├── ja.po ├── de.po ├── pt_BR.po ├── zh_CN.po ├── es.po ├── pl.po ├── ru.po └── it.po ├── pltcl.control ├── pltclu.control ├── nls.mk ├── pltcl--unpackaged--1.0.sql ├── pltclu--unpackaged--1.0.sql ├── pltcl--1.0.sql ├── pltclu--1.0.sql ├── .gitignore ├── generate-pltclerrcodes.pl ├── sql ├── pltcl_unicode.sql ├── pltcl_queries.sql └── pltcl_setup.sql ├── expected ├── pltcl_unicode.out ├── pltcl_queries.out └── pltcl_setup.out ├── stand-alone.mk ├── README.md ├── Makefile └── pltcl.c /po/cs.mo: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/flightaware/pltcl96/master/po/cs.mo -------------------------------------------------------------------------------- /po/de.mo: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/flightaware/pltcl96/master/po/de.mo -------------------------------------------------------------------------------- /po/es.mo: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/flightaware/pltcl96/master/po/es.mo -------------------------------------------------------------------------------- /po/fr.mo: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/flightaware/pltcl96/master/po/fr.mo -------------------------------------------------------------------------------- /po/fr.po: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/flightaware/pltcl96/master/po/fr.po -------------------------------------------------------------------------------- /po/it.mo: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/flightaware/pltcl96/master/po/it.mo -------------------------------------------------------------------------------- /po/ja.mo: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/flightaware/pltcl96/master/po/ja.mo -------------------------------------------------------------------------------- /po/ko.mo: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/flightaware/pltcl96/master/po/ko.mo -------------------------------------------------------------------------------- /po/pl.mo: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/flightaware/pltcl96/master/po/pl.mo -------------------------------------------------------------------------------- /po/ro.mo: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/flightaware/pltcl96/master/po/ro.mo -------------------------------------------------------------------------------- /po/ru.mo: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/flightaware/pltcl96/master/po/ru.mo -------------------------------------------------------------------------------- /po/tr.mo: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/flightaware/pltcl96/master/po/tr.mo -------------------------------------------------------------------------------- /po/pt_BR.mo: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/flightaware/pltcl96/master/po/pt_BR.mo -------------------------------------------------------------------------------- /po/zh_CN.mo: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/flightaware/pltcl96/master/po/zh_CN.mo -------------------------------------------------------------------------------- /po/zh_TW.mo: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/flightaware/pltcl96/master/po/zh_TW.mo -------------------------------------------------------------------------------- /pltcl.control: -------------------------------------------------------------------------------- 1 | # pltcl extension 2 | comment = 'PL/Tcl procedural language' 3 | default_version = '1.0' 4 | module_pathname = '$libdir/pltcl' 5 | relocatable = false 6 | schema = pg_catalog 7 | superuser = false 8 | -------------------------------------------------------------------------------- /pltclu.control: -------------------------------------------------------------------------------- 1 | # pltclu extension 2 | comment = 'PL/TclU untrusted procedural language' 3 | default_version = '1.0' 4 | module_pathname = '$libdir/pltcl' 5 | relocatable = false 6 | schema = pg_catalog 7 | superuser = true 8 | -------------------------------------------------------------------------------- /nls.mk: -------------------------------------------------------------------------------- 1 | # src/pl/tcl/nls.mk 2 | CATALOG_NAME = pltcl 3 | AVAIL_LANGUAGES = cs de es fr it ja ko pl pt_BR ro ru tr zh_CN zh_TW 4 | GETTEXT_FILES = pltcl.c 5 | GETTEXT_TRIGGERS = $(BACKEND_COMMON_GETTEXT_TRIGGERS) 6 | GETTEXT_FLAGS = $(BACKEND_COMMON_GETTEXT_FLAGS) 7 | -------------------------------------------------------------------------------- /pltcl--unpackaged--1.0.sql: -------------------------------------------------------------------------------- 1 | /* src/pl/tcl/pltcl--unpackaged--1.0.sql */ 2 | 3 | ALTER EXTENSION pltcl ADD PROCEDURAL LANGUAGE pltcl; 4 | -- ALTER ADD LANGUAGE doesn't pick up the support functions, so we have to. 5 | ALTER EXTENSION pltcl ADD FUNCTION pltcl_call_handler(); 6 | -------------------------------------------------------------------------------- /pltclu--unpackaged--1.0.sql: -------------------------------------------------------------------------------- 1 | /* src/pl/tcl/pltclu--unpackaged--1.0.sql */ 2 | 3 | ALTER EXTENSION pltclu ADD PROCEDURAL LANGUAGE pltclu; 4 | -- ALTER ADD LANGUAGE doesn't pick up the support functions, so we have to. 5 | ALTER EXTENSION pltclu ADD FUNCTION pltclu_call_handler(); 6 | -------------------------------------------------------------------------------- /pltcl--1.0.sql: -------------------------------------------------------------------------------- 1 | /* src/pl/tcl/pltcl--1.0.sql */ 2 | 3 | /* 4 | * Currently, all the interesting stuff is done by CREATE LANGUAGE. 5 | * Later we will probably "dumb down" that command and put more of the 6 | * knowledge into this script. 7 | */ 8 | 9 | CREATE PROCEDURAL LANGUAGE pltcl; 10 | 11 | COMMENT ON PROCEDURAL LANGUAGE pltcl IS 'PL/Tcl procedural language'; 12 | -------------------------------------------------------------------------------- /pltclu--1.0.sql: -------------------------------------------------------------------------------- 1 | /* src/pl/tcl/pltclu--1.0.sql */ 2 | 3 | /* 4 | * Currently, all the interesting stuff is done by CREATE LANGUAGE. 5 | * Later we will probably "dumb down" that command and put more of the 6 | * knowledge into this script. 7 | */ 8 | 9 | CREATE PROCEDURAL LANGUAGE pltclu; 10 | 11 | COMMENT ON PROCEDURAL LANGUAGE pltclu IS 'PL/TclU untrusted procedural language'; 12 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # ORIGINAL EXCLUDES 2 | # 3 | # Global excludes across all subdirectories 4 | *.o 5 | *.obj 6 | *.so 7 | *.so.[0-9] 8 | *.so.[0-9].[0-9] 9 | *.so.[0-9].[0-9][0-9] 10 | *.sl 11 | *.sl.[0-9] 12 | *.sl.[0-9].[0-9] 13 | *.sl.[0-9].[0-9][0-9] 14 | *.dylib 15 | *.dll 16 | *.exp 17 | *.a 18 | *.mo 19 | *.pot 20 | objfiles.txt 21 | .deps/ 22 | *.gcno 23 | *.gcda 24 | *.gcov 25 | *.gcov.out 26 | lcov.info 27 | coverage/ 28 | *.vcproj 29 | *.vcxproj 30 | win32ver.rc 31 | *.exe 32 | lib*dll.def 33 | lib*.pc 34 | 35 | # Local excludes in root directory HAVE BEEN REMOVED 36 | 37 | # Excludes from original src/pl/tcl/.gitignore 38 | /pltclerrcodes.h 39 | 40 | # Generated subdirectories 41 | /log/ 42 | /results/ 43 | /tmp_check/ 44 | 45 | # 46 | # Additional stand-alone excludes 47 | # 48 | 49 | # vi .sw? files 50 | .*.sw? 51 | -------------------------------------------------------------------------------- /generate-pltclerrcodes.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | # 3 | # Generate the pltclerrcodes.h header from errcodes.txt 4 | # Copyright (c) 2000-2016, PostgreSQL Global Development Group 5 | 6 | use warnings; 7 | use strict; 8 | 9 | print 10 | "/* autogenerated from src/backend/utils/errcodes.txt, do not edit */\n"; 11 | print "/* there is deliberately not an #ifndef PLTCLERRCODES_H here */\n"; 12 | 13 | open my $errcodes, $ARGV[0] or die; 14 | 15 | while (<$errcodes>) 16 | { 17 | chomp; 18 | 19 | # Skip comments 20 | next if /^#/; 21 | next if /^\s*$/; 22 | 23 | # Skip section headers 24 | next if /^Section:/; 25 | 26 | die unless /^([^\s]{5})\s+([EWS])\s+([^\s]+)(?:\s+)?([^\s]+)?/; 27 | 28 | (my $sqlstate, my $type, my $errcode_macro, my $condition_name) = 29 | ($1, $2, $3, $4); 30 | 31 | # Skip non-errors 32 | next unless $type eq 'E'; 33 | 34 | # Skip lines without PL/pgSQL condition names 35 | next unless defined($condition_name); 36 | 37 | print "{\n\t\"$condition_name\", $errcode_macro\n},\n\n"; 38 | } 39 | 40 | close $errcodes; 41 | -------------------------------------------------------------------------------- /sql/pltcl_unicode.sql: -------------------------------------------------------------------------------- 1 | -- 2 | -- Unicode handling 3 | -- 4 | -- Note: this test case is known to fail if the database encoding is 5 | -- EUC_CN, EUC_JP, EUC_KR, or EUC_TW, for lack of any equivalent to 6 | -- U+00A0 (no-break space) in those encodings. However, testing with 7 | -- plain ASCII data would be rather useless, so we must live with that. 8 | -- 9 | 10 | SET client_encoding TO UTF8; 11 | 12 | CREATE TABLE unicode_test ( 13 | testvalue text NOT NULL 14 | ); 15 | 16 | CREATE FUNCTION unicode_return() RETURNS text AS $$ 17 | return "\xA0" 18 | $$ LANGUAGE pltcl; 19 | 20 | CREATE FUNCTION unicode_trigger() RETURNS trigger AS $$ 21 | set NEW(testvalue) "\xA0" 22 | return [array get NEW] 23 | $$ LANGUAGE pltcl; 24 | 25 | CREATE TRIGGER unicode_test_bi BEFORE INSERT ON unicode_test 26 | FOR EACH ROW EXECUTE PROCEDURE unicode_trigger(); 27 | 28 | CREATE FUNCTION unicode_plan1() RETURNS text AS $$ 29 | set plan [ spi_prepare {SELECT $1 AS testvalue} [ list "text" ] ] 30 | spi_execp $plan [ list "\xA0" ] 31 | return $testvalue 32 | $$ LANGUAGE pltcl; 33 | 34 | 35 | SELECT unicode_return(); 36 | INSERT INTO unicode_test (testvalue) VALUES ('test'); 37 | SELECT * FROM unicode_test; 38 | SELECT unicode_plan1(); 39 | -------------------------------------------------------------------------------- /expected/pltcl_unicode.out: -------------------------------------------------------------------------------- 1 | -- 2 | -- Unicode handling 3 | -- 4 | -- Note: this test case is known to fail if the database encoding is 5 | -- EUC_CN, EUC_JP, EUC_KR, or EUC_TW, for lack of any equivalent to 6 | -- U+00A0 (no-break space) in those encodings. However, testing with 7 | -- plain ASCII data would be rather useless, so we must live with that. 8 | -- 9 | SET client_encoding TO UTF8; 10 | CREATE TABLE unicode_test ( 11 | testvalue text NOT NULL 12 | ); 13 | CREATE FUNCTION unicode_return() RETURNS text AS $$ 14 | return "\xA0" 15 | $$ LANGUAGE pltcl; 16 | CREATE FUNCTION unicode_trigger() RETURNS trigger AS $$ 17 | set NEW(testvalue) "\xA0" 18 | return [array get NEW] 19 | $$ LANGUAGE pltcl; 20 | CREATE TRIGGER unicode_test_bi BEFORE INSERT ON unicode_test 21 | FOR EACH ROW EXECUTE PROCEDURE unicode_trigger(); 22 | CREATE FUNCTION unicode_plan1() RETURNS text AS $$ 23 | set plan [ spi_prepare {SELECT $1 AS testvalue} [ list "text" ] ] 24 | spi_execp $plan [ list "\xA0" ] 25 | return $testvalue 26 | $$ LANGUAGE pltcl; 27 | SELECT unicode_return(); 28 | unicode_return 29 | ---------------- 30 |   31 | (1 row) 32 | 33 | INSERT INTO unicode_test (testvalue) VALUES ('test'); 34 | SELECT * FROM unicode_test; 35 | testvalue 36 | ----------- 37 |   38 | (1 row) 39 | 40 | SELECT unicode_plan1(); 41 | unicode_plan1 42 | --------------- 43 |   44 | (1 row) 45 | 46 | -------------------------------------------------------------------------------- /stand-alone.mk: -------------------------------------------------------------------------------- 1 | # Because this is a stand-alone build, top_builddir must be set manually! 2 | # 3 | #top_builddir = ../../.. 4 | # 5 | ifndef top_builddir 6 | $(error top_builddir is not set) 7 | endif 8 | # 9 | # 10 | # We also need to over-ride the main build system's idea of where we're located. 11 | subdir = $(shell pwd) 12 | # 13 | # 14 | # Similar to PGXS, make check is also not supported. Define a dependency that 15 | # will trigger a failure. 16 | # 17 | # However, by default Gnumake runs the first rule that's defined, so make sure 18 | # that 'all' is the first rule. (presumably we could get around this by 19 | # splitting up the modifications). 20 | all: 21 | 22 | check: check-fail 23 | 24 | .PHONY: check-fail 25 | check-fail: 26 | @echo 27 | @echo 28 | @echo '"$(MAKE) check" is not supported.' 29 | @echo 'Do "$(MAKE) install", then "$(MAKE) installcheck" instead.' 30 | @exit 1 31 | 32 | # Add a convenience test target. Stolen from pgxntool. 33 | # 34 | # make test: run any test dependencies, then do a `make install installcheck`. 35 | # If regressions are found, it will output them. 36 | # 37 | # This used to depend on clean as well, but that causes problems with 38 | # watch-make if you're generating intermediate files. If tests end up needing 39 | # clean it's an indication of a missing dependency anyway. 40 | .PHONY: test 41 | test: install installcheck 42 | @if [ -r regression.diffs ]; then cat regression.diffs; fi 43 | -------------------------------------------------------------------------------- /po/tr.po: -------------------------------------------------------------------------------- 1 | # LANGUAGE message translation file for pltcl 2 | # Copyright (C) 2009 PostgreSQL Global Development Group 3 | # This file is distributed under the same license as the PostgreSQL package. 4 | # FIRST AUTHOR , 2009. 5 | # 6 | msgid "" 7 | msgstr "" 8 | "Project-Id-Version: PostgreSQL 8.4\n" 9 | "Report-Msgid-Bugs-To: pgsql-bugs@postgresql.org\n" 10 | "POT-Creation-Date: 2009-04-29 07:08+0000\n" 11 | "PO-Revision-Date: 2013-09-04 20:50-0400\n" 12 | "Last-Translator: Devrim GÜNDÜZ \n" 13 | "Language-Team: TR >\n" 14 | "Language: tr\n" 15 | "MIME-Version: 1.0\n" 16 | "Content-Type: text/plain; charset=UTF-8\n" 17 | "Content-Transfer-Encoding: 8bit\n" 18 | 19 | #: pltcl.c:1027 20 | #, c-format 21 | msgid "%s" 22 | msgstr "%s" 23 | 24 | #: pltcl.c:1028 25 | #, c-format 26 | msgid "" 27 | "%s\n" 28 | "in PL/Tcl function \"%s\"" 29 | msgstr "" 30 | "%s\n" 31 | "Şu PL/Tcl fonksiyonunda: \"%s\"" 32 | 33 | #: pltcl.c:1127 34 | msgid "out of memory" 35 | msgstr "yetersiz bellek" 36 | 37 | #: pltcl.c:1192 38 | msgid "trigger functions can only be called as triggers" 39 | msgstr "trigger fonksiyonları sadece trigger olarak çağırılabilirler" 40 | 41 | #: pltcl.c:1201 42 | #, c-format 43 | msgid "PL/Tcl functions cannot return type %s" 44 | msgstr "PL/Tcl fonksiyonları %s tipini döndüremezler" 45 | 46 | #: pltcl.c:1213 47 | msgid "PL/Tcl functions cannot return composite types" 48 | msgstr "PL/Tcl fonksiyonları composit tip döndüremezler" 49 | 50 | #: pltcl.c:1253 51 | #, c-format 52 | msgid "PL/Tcl functions cannot accept type %s" 53 | msgstr "PL/Tcl fonksiyonları %s veri tipini kabul etmezler" 54 | 55 | -------------------------------------------------------------------------------- /po/ro.po: -------------------------------------------------------------------------------- 1 | # LANGUAGE message translation file for pltcl 2 | # Copyright (C) 2010 PostgreSQL Global Development Group 3 | # This file is distributed under the same license as the PostgreSQL package. 4 | # FIRST AUTHOR , 2010. 5 | # 6 | msgid "" 7 | msgstr "" 8 | "Project-Id-Version: PostgreSQL 9.0\n" 9 | "Report-Msgid-Bugs-To: pgsql-bugs@postgresql.org\n" 10 | "POT-Creation-Date: 2010-09-04 19:59+0000\n" 11 | "PO-Revision-Date: 2013-09-05 23:03-0400\n" 12 | "Last-Translator: Max \n" 13 | "Language-Team: ROMÂNĂ \n" 14 | "Language: ro\n" 15 | "MIME-Version: 1.0\n" 16 | "Content-Type: text/plain; charset=UTF-8\n" 17 | "Content-Transfer-Encoding: 8bit\n" 18 | "X-Poedit-Language: Romanian\n" 19 | "X-Poedit-Country: România\n" 20 | 21 | #: pltcl.c:1075 22 | #, c-format 23 | msgid "%s" 24 | msgstr "%s" 25 | 26 | #: pltcl.c:1076 27 | #, c-format 28 | msgid "" 29 | "%s\n" 30 | "in PL/Tcl function \"%s\"" 31 | msgstr "" 32 | "%s\n" 33 | "în funcția PL/Tcl \"%s\"" 34 | 35 | #: pltcl.c:1173 36 | msgid "out of memory" 37 | msgstr "memorie insuficientă" 38 | 39 | #: pltcl.c:1234 40 | msgid "trigger functions can only be called as triggers" 41 | msgstr "funcţiile trigger pot fi apelate doar ca triggere" 42 | 43 | #: pltcl.c:1243 44 | #, c-format 45 | msgid "PL/Tcl functions cannot return type %s" 46 | msgstr "funcțiile PL/Tcl nu pot returna tipul %s" 47 | 48 | #: pltcl.c:1255 49 | msgid "PL/Tcl functions cannot return composite types" 50 | msgstr "funcțiile PL/Tcl nu pot returna tipul compozit" 51 | 52 | #: pltcl.c:1294 53 | #, c-format 54 | msgid "PL/Tcl functions cannot accept type %s" 55 | msgstr "funcțiile PL/Tcl nu pot accepta tipul %s" 56 | 57 | -------------------------------------------------------------------------------- /po/zh_TW.po: -------------------------------------------------------------------------------- 1 | # Traditional Chinese message translation file for pltcl 2 | # Copyright (C) 2011 PostgreSQL Global Development Group 3 | # This file is distributed under the same license as the PostgreSQL package. 4 | # Zhenbang Wei , 2011. 5 | # 6 | msgid "" 7 | msgstr "" 8 | "Project-Id-Version: PostgreSQL 9.1\n" 9 | "Report-Msgid-Bugs-To: pgsql-bugs@postgresql.org\n" 10 | "POT-Creation-Date: 2011-05-13 20:39+0000\n" 11 | "PO-Revision-Date: 2013-09-03 23:24-0400\n" 12 | "Last-Translator: Zhenbang Wei \n" 13 | "Language-Team: Traditional Chinese\n" 14 | "Language: zh_TW\n" 15 | "MIME-Version: 1.0\n" 16 | "Content-Type: text/plain; charset=UTF-8\n" 17 | "Content-Transfer-Encoding: 8bit\n" 18 | 19 | # commands/vacuum.c:2258 commands/vacuumlazy.c:489 commands/vacuumlazy.c:770 20 | # nodes/print.c:86 storage/lmgr/deadlock.c:888 tcop/postgres.c:3285 21 | #: pltcl.c:1149 22 | #, c-format 23 | msgid "%s" 24 | msgstr "%s" 25 | 26 | #: pltcl.c:1150 27 | #, c-format 28 | msgid "" 29 | "%s\n" 30 | "in PL/Tcl function \"%s\"" 31 | msgstr "" 32 | "%s\n" 33 | "於 PL/Tcl 函式 \"%s\"" 34 | 35 | # common.c:123 36 | #: pltcl.c:1254 pltcl.c:1261 37 | msgid "out of memory" 38 | msgstr "記憶體用盡" 39 | 40 | #: pltcl.c:1308 41 | msgid "trigger functions can only be called as triggers" 42 | msgstr "觸發函式只能當做觸發程序呼叫" 43 | 44 | #: pltcl.c:1317 45 | #, c-format 46 | msgid "PL/Tcl functions cannot return type %s" 47 | msgstr "PL/Tcl 函式不能傳回型別 %s" 48 | 49 | #: pltcl.c:1329 50 | msgid "PL/Tcl functions cannot return composite types" 51 | msgstr "PL/Tcl 函式不能傳回複合型別" 52 | 53 | #: pltcl.c:1368 54 | #, c-format 55 | msgid "PL/Tcl functions cannot accept type %s" 56 | msgstr "PL/Tcl 函式不能接受型別 %s" 57 | -------------------------------------------------------------------------------- /po/cs.po: -------------------------------------------------------------------------------- 1 | # Czech message translation file for pltcl 2 | # Copyright (C) 2012 PostgreSQL Global Development Group 3 | # This file is distributed under the same license as the PostgreSQL package. 4 | # 5 | # Tomáš Vondra , 2012, 2013. 6 | 7 | msgid "" 8 | msgstr "" 9 | "Project-Id-Version: pltcl-cs (PostgreSQL 9.3)\n" 10 | "Report-Msgid-Bugs-To: pgsql-bugs@postgresql.org\n" 11 | "POT-Creation-Date: 2012-04-07 18:18+0200\n" 12 | "PO-Revision-Date: 2012-MO-DA HO:MI+ZONE\n" 13 | "Last-Translator: Tomas Vondra \n" 14 | "Language-Team: Czech \n" 15 | "Language: cs\n" 16 | "MIME-Version: 1.0\n" 17 | "Content-Type: text/plain; charset=UTF-8\n" 18 | "Content-Transfer-Encoding: 8bit\n" 19 | 20 | #: pltcl.c:1150 21 | #, c-format 22 | msgid "%s" 23 | msgstr "%s" 24 | 25 | #: pltcl.c:1151 26 | #, c-format 27 | msgid "" 28 | "%s\n" 29 | "in PL/Tcl function \"%s\"" 30 | msgstr "" 31 | "%s\n" 32 | "v PL/Tcl funkci \"%s\"" 33 | 34 | #: pltcl.c:1255 pltcl.c:1262 35 | #, c-format 36 | msgid "out of memory" 37 | msgstr "paměť vyčerpána" 38 | 39 | #: pltcl.c:1309 40 | #, c-format 41 | msgid "trigger functions can only be called as triggers" 42 | msgstr "funkce pro obsluhu triggerů mohou být volané pouze prostřednictvím triggerů" 43 | 44 | #: pltcl.c:1318 45 | #, c-format 46 | msgid "PL/Tcl functions cannot return type %s" 47 | msgstr "PL/Tcl funkce nemohou vracet datový typ %s" 48 | 49 | #: pltcl.c:1330 50 | #, c-format 51 | msgid "PL/Tcl functions cannot return composite types" 52 | msgstr "PL/Tcl funkce nemohou vracet složené datové typy" 53 | 54 | #: pltcl.c:1369 55 | #, c-format 56 | msgid "PL/Tcl functions cannot accept type %s" 57 | msgstr "PL/Tcl funkce nemohou přijímat datový typ %s" 58 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Stand-alone version of Postgres pl/tcl 2 | 3 | This repository is meant to facilitate development and potential release of pl/tcl 4 | features outside of the normal Postgres release process. 5 | 6 | # Building 7 | In order to build from this repository, you must have a checkout of the full Postgres 8 | source code. In that checkout, make certain that you can build and run pl/tcl. IE: 9 | 10 | ``` 11 | cd src/pl/tcl 12 | make install installcheck 13 | ``` 14 | 15 | Once you're satisfied that mainline pltcl works, switch to a checkout of this repository. 16 | You will need to set the `top_builddir` environment variable, and then you can run make. 17 | Unlike mainline pl/tcl, `make check` is not supported; use the installcheck target instead: 18 | 19 | ``` 20 | top_builddir=$HOME/pgsql/HEAD make installcheck 21 | ``` 22 | 23 | # Accidental use of mainline pl/tcl 24 | Because this repository depends on the main Postgres source, it's possible to accidentally 25 | be working with the mainline pl/tcl without realizing it. The simplest way to verify that 26 | installcheck is running the right code is to temporarily move the original pl/tcl somewhere 27 | else: 28 | 29 | ``` 30 | top_builddir=$HOME/pgsql/HEAD mv "$top_builddir"/src/pl/tcl ${TEMP:-/tmp} 31 | ``` 32 | 33 | NOTE: even if the mainline pltcl is accidentally being used, `make` will probably still be 34 | working within this repository. Just because make works don't assume you have the correct 35 | pl/tcl! 36 | 37 | NOTE from Peter: This repo is restarting with Decibel's changes to pltcl from version 10, 38 | applied to pltcl from version 9.6... it does not include the postgresql commit history in 39 | https://github.com/decibel/pltcl because of my lack of git chops. 40 | -------------------------------------------------------------------------------- /po/ko.po: -------------------------------------------------------------------------------- 1 | # LANGUAGE message translation file for pltcl 2 | # Copyright (C) 2016 PostgreSQL Global Development Group 3 | # This file is distributed under the same license as the PostgreSQL package. 4 | # Ioseph Kim , 2016. 5 | # 6 | msgid "" 7 | msgstr "" 8 | "Project-Id-Version: pltcl (PostgreSQL) 9.5\n" 9 | "Report-Msgid-Bugs-To: pgsql-bugs@postgresql.org\n" 10 | "POT-Creation-Date: 2016-02-01 11:24+0900\n" 11 | "PO-Revision-Date: 2016-02-01 11:47+0900\n" 12 | "Last-Translator: Ioseph Kim \n" 13 | "Language-Team: Korean Team \n" 14 | "MIME-Version: 1.0\n" 15 | "Content-Type: text/plain; charset=UTF-8\n" 16 | "Content-Transfer-Encoding: 8bit\n" 17 | "Language: ko\n" 18 | 19 | #: pltcl.c:555 20 | #, c-format 21 | msgid "module \"unknown\" not found in pltcl_modules" 22 | msgstr "pltcl_modules 안에 \"unknown\" 모듈을 찾을 수 없음" 23 | 24 | #: pltcl.c:591 25 | #, c-format 26 | msgid "could not load module \"unknown\": %s" 27 | msgstr "\"unknown\" 모듈을 불러올 수 없음: %s" 28 | 29 | #: pltcl.c:1047 30 | #, c-format 31 | msgid "could not split return value from trigger: %s" 32 | msgstr "트리거에서 반환값을 분리할 수 없음: %s" 33 | 34 | #: pltcl.c:1058 35 | #, c-format 36 | msgid "trigger's return list must have even number of elements" 37 | msgstr "트리거 반환 목록은 그 요소의 개수가 짝수여야 함" 38 | 39 | #: pltcl.c:1094 40 | #, c-format 41 | msgid "unrecognized attribute \"%s\"" 42 | msgstr "\"%s\" 속성을 알 수 없음" 43 | 44 | #: pltcl.c:1099 45 | #, c-format 46 | msgid "cannot set system attribute \"%s\"" 47 | msgstr "\"%s\" 시스템 속성을 지정할 수 없음" 48 | 49 | #: pltcl.c:1222 pltcl.c:1648 50 | #, c-format 51 | msgid "%s" 52 | msgstr "%s" 53 | 54 | #: pltcl.c:1223 55 | #, c-format 56 | msgid "" 57 | "%s\n" 58 | "in PL/Tcl function \"%s\"" 59 | msgstr "" 60 | "%s\n" 61 | "해당 PL/Tcl 함수: \"%s\"" 62 | 63 | #: pltcl.c:1331 pltcl.c:1338 64 | #, c-format 65 | msgid "out of memory" 66 | msgstr "메모리 부족" 67 | 68 | #: pltcl.c:1386 69 | #, c-format 70 | msgid "trigger functions can only be called as triggers" 71 | msgstr "트리거 함수는 트리거로만 호출될 수 있음" 72 | 73 | #: pltcl.c:1395 74 | #, c-format 75 | msgid "PL/Tcl functions cannot return type %s" 76 | msgstr "PL/Tcl 함수는 %s 자료형을 반환할 수 없음" 77 | 78 | #: pltcl.c:1407 79 | #, c-format 80 | msgid "PL/Tcl functions cannot return composite types" 81 | msgstr "PL/Tcl 함수는 복합 자료형을 반환할 수 없음" 82 | 83 | #: pltcl.c:1446 84 | #, c-format 85 | msgid "PL/Tcl functions cannot accept type %s" 86 | msgstr "PL/Tcl 함수는 %s 자료형을 사용할 수 없음" 87 | 88 | #: pltcl.c:1564 89 | #, c-format 90 | msgid "could not create internal procedure \"%s\": %s" 91 | msgstr "\"%s\" 내부 프로시져를 만들 수 없음: %s" 92 | -------------------------------------------------------------------------------- /po/ja.po: -------------------------------------------------------------------------------- 1 | # LANGUAGE message translation file for pltcl 2 | # Copyright (C) 2009 PostgreSQL Global Development Group 3 | # This file is distributed under the same license as the PostgreSQL package. 4 | # FIRST AUTHOR , 2009. 5 | # 6 | msgid "" 7 | msgstr "" 8 | "Project-Id-Version: pltcl (PostgreSQL) 9.5\n" 9 | "Report-Msgid-Bugs-To: pgsql-bugs@postgresql.org\n" 10 | "POT-Creation-Date: 2015-09-21 01:07+0000\n" 11 | "PO-Revision-Date: 2015-10-04 18:15+0900\n" 12 | "Last-Translator: KOIZUMI Satoru \n" 13 | "Language-Team: Japan PostgreSQL Users Group \n" 14 | "Language: ja\n" 15 | "MIME-Version: 1.0\n" 16 | "Content-Type: text/plain; charset=UTF-8\n" 17 | "Content-Transfer-Encoding: 8bit\n" 18 | "Plural-Forms: nplurals=1; plural=0;\n" 19 | 20 | #: pltcl.c:555 21 | #, c-format 22 | msgid "module \"unknown\" not found in pltcl_modules" 23 | msgstr "pltcl_modulesにモジュール\"unknown\"が見つかりません" 24 | 25 | #: pltcl.c:591 26 | #, c-format 27 | msgid "could not load module \"unknown\": %s" 28 | msgstr "モジュール\"unknown\"をロードできませんでした: %s" 29 | 30 | #: pltcl.c:1047 31 | #, c-format 32 | msgid "could not split return value from trigger: %s" 33 | msgstr "トリガからの戻り値を分割できませんでした: %s" 34 | 35 | #: pltcl.c:1058 36 | #, c-format 37 | msgid "trigger's return list must have even number of elements" 38 | msgstr "トリガが返すリストの要素は偶数個でなければなりません" 39 | 40 | #: pltcl.c:1094 41 | #, c-format 42 | msgid "unrecognized attribute \"%s\"" 43 | msgstr "未知の属性 \"%s\"" 44 | 45 | #: pltcl.c:1099 46 | #, c-format 47 | msgid "cannot set system attribute \"%s\"" 48 | msgstr "システム属性\"%s\"を設定できません" 49 | 50 | #: pltcl.c:1222 pltcl.c:1648 51 | #, c-format 52 | msgid "%s" 53 | msgstr "%s" 54 | 55 | #: pltcl.c:1223 56 | #, c-format 57 | msgid "" 58 | "%s\n" 59 | "in PL/Tcl function \"%s\"" 60 | msgstr "" 61 | "%s\n" 62 | "PL/Tcl 関数 \"%s\"" 63 | 64 | #: pltcl.c:1331 pltcl.c:1338 65 | #, c-format 66 | msgid "out of memory" 67 | msgstr "メモリ不足です" 68 | 69 | #: pltcl.c:1386 70 | #, c-format 71 | msgid "trigger functions can only be called as triggers" 72 | msgstr "トリガ関数はトリガとしてのみコールできます" 73 | 74 | #: pltcl.c:1395 75 | #, c-format 76 | msgid "PL/Tcl functions cannot return type %s" 77 | msgstr "PL/Tcl 関数は戻り値の型 %s を返せません" 78 | 79 | #: pltcl.c:1407 80 | #, c-format 81 | msgid "PL/Tcl functions cannot return composite types" 82 | msgstr "PL/Tcl 関数は戻り値の型として複合型を返せません" 83 | 84 | #: pltcl.c:1446 85 | #, c-format 86 | msgid "PL/Tcl functions cannot accept type %s" 87 | msgstr "PL/Tcl 関数は型 %s を受け付けません" 88 | 89 | #: pltcl.c:1564 90 | #, c-format 91 | msgid "could not create internal procedure \"%s\": %s" 92 | msgstr "内部プロシージャ \"%s\" を作成できませんでした: %s" 93 | -------------------------------------------------------------------------------- /po/de.po: -------------------------------------------------------------------------------- 1 | # German message translation file for PL/Tcl 2 | # Peter Eisentraut , 2009 - 2015. 3 | # 4 | # Use these quotes: »%s« 5 | # 6 | msgid "" 7 | msgstr "" 8 | "Project-Id-Version: PostgreSQL 9.5\n" 9 | "Report-Msgid-Bugs-To: pgsql-bugs@postgresql.org\n" 10 | "POT-Creation-Date: 2015-09-22 15:07+0000\n" 11 | "PO-Revision-Date: 2015-09-22 20:29-0400\n" 12 | "Last-Translator: Peter Eisentraut \n" 13 | "Language-Team: German \n" 14 | "Language: de\n" 15 | "MIME-Version: 1.0\n" 16 | "Content-Type: text/plain; charset=UTF-8\n" 17 | "Content-Transfer-Encoding: 8bit\n" 18 | 19 | #: pltcl.c:555 20 | #, c-format 21 | msgid "module \"unknown\" not found in pltcl_modules" 22 | msgstr "Modul »unknown« nicht in pltcl_modules gefunden" 23 | 24 | #: pltcl.c:591 25 | #, c-format 26 | msgid "could not load module \"unknown\": %s" 27 | msgstr "konnte Modul »unknown« nicht laden: %s" 28 | 29 | #: pltcl.c:1047 30 | #, c-format 31 | msgid "could not split return value from trigger: %s" 32 | msgstr "konnte Rückgabewert des Triggers nicht splitten: %s" 33 | 34 | #: pltcl.c:1058 35 | #, c-format 36 | msgid "trigger's return list must have even number of elements" 37 | msgstr "Rückgabeliste des Triggers muss gerade Anzahl Elemente haben" 38 | 39 | #: pltcl.c:1094 40 | #, c-format 41 | msgid "unrecognized attribute \"%s\"" 42 | msgstr "unbekanntes Attribute »%s«" 43 | 44 | #: pltcl.c:1099 45 | #, c-format 46 | msgid "cannot set system attribute \"%s\"" 47 | msgstr "Systemattribut »%s« kann nicht gesetzt werden" 48 | 49 | #: pltcl.c:1222 pltcl.c:1648 50 | #, c-format 51 | msgid "%s" 52 | msgstr "%s" 53 | 54 | #: pltcl.c:1223 55 | #, c-format 56 | msgid "" 57 | "%s\n" 58 | "in PL/Tcl function \"%s\"" 59 | msgstr "" 60 | "%s\n" 61 | "in PL/Tcl-Funktion »%s«" 62 | 63 | #: pltcl.c:1331 pltcl.c:1338 64 | #, c-format 65 | msgid "out of memory" 66 | msgstr "Speicher aufgebraucht" 67 | 68 | #: pltcl.c:1386 69 | #, c-format 70 | msgid "trigger functions can only be called as triggers" 71 | msgstr "Triggerfunktionen können nur als Trigger aufgerufen werden" 72 | 73 | #: pltcl.c:1395 74 | #, c-format 75 | msgid "PL/Tcl functions cannot return type %s" 76 | msgstr "PL/Tcl-Funktionen können keinen Rückgabetyp %s haben" 77 | 78 | #: pltcl.c:1407 79 | #, c-format 80 | msgid "PL/Tcl functions cannot return composite types" 81 | msgstr "PL/Tcl-Funktion können keine zusammengesetzten Typen zurückgeben" 82 | 83 | #: pltcl.c:1446 84 | #, c-format 85 | msgid "PL/Tcl functions cannot accept type %s" 86 | msgstr "PL/Tcl-Funktionen können Typ %s nicht annehmen" 87 | 88 | #: pltcl.c:1564 89 | #, c-format 90 | msgid "could not create internal procedure \"%s\": %s" 91 | msgstr "konnte interne Prozedur »%s« nicht erzeugen: %s" 92 | -------------------------------------------------------------------------------- /po/pt_BR.po: -------------------------------------------------------------------------------- 1 | # Brazilian Portuguese message translation file for pltcl 2 | # Copyright (C) 2009 PostgreSQL Global Development Group 3 | # This file is distributed under the same license as the PostgreSQL package. 4 | # Euler Taveira de Oliveira , 2009-2015. 5 | # 6 | msgid "" 7 | msgstr "" 8 | "Project-Id-Version: PostgreSQL 9.5\n" 9 | "Report-Msgid-Bugs-To: pgsql-bugs@postgresql.org\n" 10 | "POT-Creation-Date: 2015-09-17 22:32-0300\n" 11 | "PO-Revision-Date: 2009-05-06 18:00-0300\n" 12 | "Last-Translator: Euler Taveira de Oliveira \n" 13 | "Language-Team: Brazilian Portuguese \n" 14 | "Language: pt_BR\n" 15 | "MIME-Version: 1.0\n" 16 | "Content-Type: text/plain; charset=UTF-8\n" 17 | "Content-Transfer-Encoding: 8bit\n" 18 | 19 | #: pltcl.c:555 20 | #, c-format 21 | msgid "module \"unknown\" not found in pltcl_modules" 22 | msgstr "módulo \"unknown\" não foi encontrado em pltcl_modules" 23 | 24 | #: pltcl.c:591 25 | #, c-format 26 | msgid "could not load module \"unknown\": %s" 27 | msgstr "não pôde carregar módulo \"unknown\": %s" 28 | 29 | #: pltcl.c:1047 30 | #, c-format 31 | msgid "could not split return value from trigger: %s" 32 | msgstr "não pôde dividir valor retornado do gatilho: %s" 33 | 34 | #: pltcl.c:1058 35 | #, c-format 36 | msgid "trigger's return list must have even number of elements" 37 | msgstr "lista de retorno do gatilho deve ter número par de elementos" 38 | 39 | #: pltcl.c:1094 40 | #, c-format 41 | msgid "unrecognized attribute \"%s\"" 42 | msgstr "atributo \"%s\" desconhecido" 43 | 44 | #: pltcl.c:1099 45 | #, c-format 46 | msgid "cannot set system attribute \"%s\"" 47 | msgstr "não pode definir atributo do sistema \"%s\"" 48 | 49 | #: pltcl.c:1222 pltcl.c:1648 50 | #, c-format 51 | msgid "%s" 52 | msgstr "%s" 53 | 54 | #: pltcl.c:1223 55 | #, c-format 56 | msgid "" 57 | "%s\n" 58 | "in PL/Tcl function \"%s\"" 59 | msgstr "" 60 | "%s\n" 61 | "na função PL/Tcl \"%s\"" 62 | 63 | #: pltcl.c:1331 pltcl.c:1338 64 | #, c-format 65 | msgid "out of memory" 66 | msgstr "sem memória" 67 | 68 | #: pltcl.c:1386 69 | #, c-format 70 | msgid "trigger functions can only be called as triggers" 71 | msgstr "funções de gatilho só podem ser chamadas como gatilhos" 72 | 73 | #: pltcl.c:1395 74 | #, c-format 75 | msgid "PL/Tcl functions cannot return type %s" 76 | msgstr "funções PL/Tcl não podem retornar tipo %s" 77 | 78 | #: pltcl.c:1407 79 | #, c-format 80 | msgid "PL/Tcl functions cannot return composite types" 81 | msgstr "funções PL/Tcl não podem retornar tipos compostos" 82 | 83 | #: pltcl.c:1446 84 | #, c-format 85 | msgid "PL/Tcl functions cannot accept type %s" 86 | msgstr "funções PL/Tcl não podem aceitar tipo %s" 87 | 88 | #: pltcl.c:1564 89 | #, c-format 90 | msgid "could not create internal procedure \"%s\": %s" 91 | msgstr "não pôde criar função interna \"%s\": %s" 92 | -------------------------------------------------------------------------------- /po/zh_CN.po: -------------------------------------------------------------------------------- 1 | # LANGUAGE message translation file for pltcl 2 | # Copyright (C) 2010 PostgreSQL Global Development Group 3 | # This file is distributed under the same license as the PostgreSQL package. 4 | # FIRST AUTHOR , 2010. 5 | # 6 | msgid "" 7 | msgstr "" 8 | "Project-Id-Version: PostgreSQL 9.0\n" 9 | "Report-Msgid-Bugs-To: pgsql-bugs@postgresql.org\n" 10 | "POT-Creation-Date: 2015-11-26 18:37+0000\n" 11 | "PO-Revision-Date: 2015-12-02 14:52+0800\n" 12 | "Last-Translator: Yuwei Peng \n" 13 | "Language-Team: Weibin \n" 14 | "Language: zh_CN\n" 15 | "MIME-Version: 1.0\n" 16 | "Content-Type: text/plain; charset=UTF-8\n" 17 | "Content-Transfer-Encoding: 8bit\n" 18 | "X-Generator: Poedit 1.5.7\n" 19 | 20 | #: pltcl.c:555 21 | #, c-format 22 | msgid "module \"unknown\" not found in pltcl_modules" 23 | msgstr "在pltcl_modules中没有找到模块\"unknown\"" 24 | 25 | #: pltcl.c:591 26 | #, c-format 27 | #| msgid "could not load library \"%s\": %s" 28 | msgid "could not load module \"unknown\": %s" 29 | msgstr "无法载入模块\"unknown\"：%s" 30 | 31 | # fe-exec.c:2325 32 | #: pltcl.c:1047 33 | #, c-format 34 | #| msgid "could not interpret result from server: %s" 35 | msgid "could not split return value from trigger: %s" 36 | msgstr "无法分离来自触发器的返回值：%s" 37 | 38 | #: pltcl.c:1058 39 | #, c-format 40 | #| msgid "argument list must have even number of elements" 41 | msgid "trigger's return list must have even number of elements" 42 | msgstr "触发器的返回列表必须具有偶数个元素" 43 | 44 | #: pltcl.c:1094 45 | #, c-format 46 | #| msgid "unrecognized parameter \"%s\"" 47 | msgid "unrecognized attribute \"%s\"" 48 | msgstr "未识别的属性\"%s\"" 49 | 50 | #: pltcl.c:1099 51 | #, c-format 52 | #| msgid "cannot move system relation \"%s\"" 53 | msgid "cannot set system attribute \"%s\"" 54 | msgstr "不能设置系统属性\"%s\"" 55 | 56 | #: pltcl.c:1222 pltcl.c:1648 57 | #, c-format 58 | msgid "%s" 59 | msgstr "%s" 60 | 61 | #: pltcl.c:1223 62 | #, c-format 63 | msgid "" 64 | "%s\n" 65 | "in PL/Tcl function \"%s\"" 66 | msgstr "" 67 | "%s\n" 68 | "在PL/Tcl函数\"%s\"中" 69 | 70 | #: pltcl.c:1331 pltcl.c:1338 71 | #, c-format 72 | msgid "out of memory" 73 | msgstr "内存用尽" 74 | 75 | #: pltcl.c:1386 76 | #, c-format 77 | msgid "trigger functions can only be called as triggers" 78 | msgstr "触发器函数只能以触发器的形式调用" 79 | 80 | #: pltcl.c:1395 81 | #, c-format 82 | msgid "PL/Tcl functions cannot return type %s" 83 | msgstr "PL/Tcl函数不能返回类型%s" 84 | 85 | #: pltcl.c:1407 86 | #, c-format 87 | msgid "PL/Tcl functions cannot return composite types" 88 | msgstr "PL/Tcl 函数不能返回组合类型" 89 | 90 | #: pltcl.c:1446 91 | #, c-format 92 | msgid "PL/Tcl functions cannot accept type %s" 93 | msgstr "PL/Tcl行数不能使用类型 %s" 94 | 95 | #: pltcl.c:1564 96 | #, c-format 97 | #| msgid "could not create locale \"%s\": %m" 98 | msgid "could not create internal procedure \"%s\": %s" 99 | msgstr "无法创建内部过程\"%s\"：%s" 100 | -------------------------------------------------------------------------------- /po/es.po: -------------------------------------------------------------------------------- 1 | # Spanish translation file for pltcl 2 | # 3 | # Copyright (C) 2009-2012 PostgreSQL Global Development Group 4 | # This file is distributed under the same license as the PostgreSQL package. 5 | # 6 | # Emanuel Calvo Franco , 2009. 7 | # Alvaro Herrera , 2009-2012, 2015 8 | # 9 | msgid "" 10 | msgstr "" 11 | "Project-Id-Version: pltcl (PostgreSQL 9.6)\n" 12 | "Report-Msgid-Bugs-To: pgsql-bugs@postgresql.org\n" 13 | "POT-Creation-Date: 2016-05-02 20:07+0000\n" 14 | "PO-Revision-Date: 2016-05-03 12:17-0300\n" 15 | "Last-Translator: Álvaro Herrera \n" 16 | "Language-Team: PgSQL-es-Ayuda \n" 17 | "Language: es\n" 18 | "MIME-Version: 1.0\n" 19 | "Content-Type: text/plain; charset=UTF-8\n" 20 | "Content-Transfer-Encoding: 8bit\n" 21 | 22 | #: pltcl.c:559 23 | #, c-format 24 | msgid "module \"unknown\" not found in pltcl_modules" 25 | msgstr "módulo «unknown» no encontrado en pltcl_modules" 26 | 27 | #: pltcl.c:597 28 | #, c-format 29 | msgid "could not load module \"unknown\": %s" 30 | msgstr "no se pudo carga módulo «unknown»: %s" 31 | 32 | #: pltcl.c:1065 33 | #, c-format 34 | msgid "could not split return value from trigger: %s" 35 | msgstr "no se pudo separar el valor de retorno del disparador: %s" 36 | 37 | #: pltcl.c:1074 38 | #, c-format 39 | msgid "trigger's return list must have even number of elements" 40 | msgstr "la lista de retorno del disparador debe tener un número par de elementos" 41 | 42 | #: pltcl.c:1109 43 | #, c-format 44 | msgid "unrecognized attribute \"%s\"" 45 | msgstr "atributo «%s» no reconocido" 46 | 47 | #: pltcl.c:1114 48 | #, c-format 49 | msgid "cannot set system attribute \"%s\"" 50 | msgstr "no se puede definir el atributo de sistema «%s»" 51 | 52 | #: pltcl.c:1230 pltcl.c:1655 53 | #, c-format 54 | msgid "%s" 55 | msgstr "%s" 56 | 57 | #: pltcl.c:1231 58 | #, c-format 59 | msgid "" 60 | "%s\n" 61 | "in PL/Tcl function \"%s\"" 62 | msgstr "" 63 | "%s\n" 64 | "en función PL/Tcl \"%s\"" 65 | 66 | #: pltcl.c:1338 pltcl.c:1345 67 | #, c-format 68 | msgid "out of memory" 69 | msgstr "memoria agotada" 70 | 71 | #: pltcl.c:1393 72 | #, c-format 73 | msgid "trigger functions can only be called as triggers" 74 | msgstr "las funciones disparadoras sólo pueden ser invocadas como disparadores" 75 | 76 | #: pltcl.c:1402 77 | #, c-format 78 | msgid "PL/Tcl functions cannot return type %s" 79 | msgstr "las funciones PL/Tcl no pueden retornar tipo %s" 80 | 81 | #: pltcl.c:1414 82 | #, c-format 83 | msgid "PL/Tcl functions cannot return composite types" 84 | msgstr "las funciones PL/Tcl no pueden retornar tipos compuestos" 85 | 86 | #: pltcl.c:1453 87 | #, c-format 88 | msgid "PL/Tcl functions cannot accept type %s" 89 | msgstr "las funciones PL/Tcl no pueden aceptar el tipog%s" 90 | 91 | #: pltcl.c:1576 92 | #, c-format 93 | msgid "could not create internal procedure \"%s\": %s" 94 | msgstr "no se pudo crear procedimiento interno «%s»: %s" 95 | -------------------------------------------------------------------------------- /po/pl.po: -------------------------------------------------------------------------------- 1 | # pltcl message translation file for pltcl 2 | # Copyright (C) 2011 PostgreSQL Global Development Group 3 | # This file is distributed under the same license as the PostgreSQL package. 4 | # Begina Felicysym , 2011. 5 | # grzegorz , 2015. 6 | msgid "" 7 | msgstr "" 8 | "Project-Id-Version: pltcl (PostgreSQL 9.5)\n" 9 | "Report-Msgid-Bugs-To: pgsql-bugs@postgresql.org\n" 10 | "POT-Creation-Date: 2015-10-29 01:37+0000\n" 11 | "PO-Revision-Date: 2015-12-22 21:19-0500\n" 12 | "Last-Translator: grzegorz \n" 13 | "Language-Team: begina.felicysym@wp.eu\n" 14 | "Language: pl\n" 15 | "MIME-Version: 1.0\n" 16 | "Content-Type: text/plain; charset=UTF-8\n" 17 | "Content-Transfer-Encoding: 8bit\n" 18 | "Plural-Forms: nplurals=3; plural=(n==1 ? 0 : n%10>=2 && n%10<=4 && (n%100<10 || n%100>=20) ? 1 : 2);\n" 19 | "X-Generator: Virtaal 0.7.1\n" 20 | 21 | #: pltcl.c:555 22 | #, c-format 23 | msgid "module \"unknown\" not found in pltcl_modules" 24 | msgstr "nie znaleziono modułu \"unknown\" w pltcl_modules" 25 | 26 | #: pltcl.c:591 27 | #, c-format 28 | msgid "could not load module \"unknown\": %s" 29 | msgstr "nie można wczytać modułu \"unknown\": %s" 30 | 31 | #: pltcl.c:1047 32 | #, c-format 33 | msgid "could not split return value from trigger: %s" 34 | msgstr "nie można podzielić wartości zwracanej przez wyzwalacz: %s" 35 | 36 | #: pltcl.c:1058 37 | #, c-format 38 | #| msgid "argument list must have even number of elements" 39 | msgid "trigger's return list must have even number of elements" 40 | msgstr "lista zwracana przez wyzwalacz musi mieć parzystą liczbę elementów" 41 | 42 | #: pltcl.c:1094 43 | #, c-format 44 | msgid "unrecognized attribute \"%s\"" 45 | msgstr "nierozpoznany atrybut \"%s\"" 46 | 47 | #: pltcl.c:1099 48 | #, c-format 49 | msgid "cannot set system attribute \"%s\"" 50 | msgstr "nie można ustawić atrybutu systemowego \"%s\"" 51 | 52 | #: pltcl.c:1222 pltcl.c:1648 53 | #, c-format 54 | msgid "%s" 55 | msgstr "%s" 56 | 57 | #: pltcl.c:1223 58 | #, c-format 59 | msgid "" 60 | "%s\n" 61 | "in PL/Tcl function \"%s\"" 62 | msgstr "" 63 | "%s\n" 64 | "w funkcji PL/Tcl \"%s\"" 65 | 66 | #: pltcl.c:1331 pltcl.c:1338 67 | #, c-format 68 | msgid "out of memory" 69 | msgstr "brak pamięci" 70 | 71 | #: pltcl.c:1386 72 | #, c-format 73 | msgid "trigger functions can only be called as triggers" 74 | msgstr "procedury wyzwalaczy mogą być wywoływane jedynie przez wyzwalacze" 75 | 76 | #: pltcl.c:1395 77 | #, c-format 78 | msgid "PL/Tcl functions cannot return type %s" 79 | msgstr "funkcje PL/Tcl nie mogą zwracać wartości typu %s" 80 | 81 | #: pltcl.c:1407 82 | #, c-format 83 | msgid "PL/Tcl functions cannot return composite types" 84 | msgstr "funkcje PL/Tcl nie mogą zwracać wartości złożonych" 85 | 86 | #: pltcl.c:1446 87 | #, c-format 88 | msgid "PL/Tcl functions cannot accept type %s" 89 | msgstr "funkcje PL/Tcl nie akceptują typu %s" 90 | 91 | #: pltcl.c:1564 92 | #, c-format 93 | msgid "could not create internal procedure \"%s\": %s" 94 | msgstr "nie można utworzyć procedury wewnętrznej \"%s\": %s" 95 | -------------------------------------------------------------------------------- /po/ru.po: -------------------------------------------------------------------------------- 1 | # Russian message translation file for pltcl 2 | # Copyright (C) 2012 PostgreSQL Global Development Group 3 | # This file is distributed under the same license as the PostgreSQL package. 4 | # Alexander Lakhin , 2012. 5 | # 6 | # ChangeLog: 7 | # - February 18, 2012: Complete translation for 9.1. Alexander Lakhin . 8 | msgid "" 9 | msgstr "" 10 | "Project-Id-Version: PostgreSQL 9.2\n" 11 | "Report-Msgid-Bugs-To: pgsql-bugs@postgresql.org\n" 12 | "POT-Creation-Date: 2015-09-19 03:07+0000\n" 13 | "PO-Revision-Date: 2015-10-16 21:38+0400\n" 14 | "Last-Translator: Alexander Lakhin \n" 15 | "Language-Team: Russian \n" 16 | "Language: ru\n" 17 | "MIME-Version: 1.0\n" 18 | "Content-Type: text/plain; charset=UTF-8\n" 19 | "Content-Transfer-Encoding: 8bit\n" 20 | "Plural-Forms: nplurals=3; plural=(n%10==1 && n%100!=11 ? 0 : n%10>=2 && n" 21 | "%10<=4 && (n%100<10 || n%100>=20) ? 1 : 2);\n" 22 | "X-Generator: Lokalize 2.0\n" 23 | 24 | #: pltcl.c:555 25 | #, c-format 26 | msgid "module \"unknown\" not found in pltcl_modules" 27 | msgstr "модуль \"unknown\" не найден в pltcl_modules" 28 | 29 | #: pltcl.c:591 30 | #, c-format 31 | msgid "could not load module \"unknown\": %s" 32 | msgstr "загрузить модуль \"unknown\" не удалось: %s" 33 | 34 | #: pltcl.c:1047 35 | #, c-format 36 | msgid "could not split return value from trigger: %s" 37 | msgstr "разложить возвращаемое из триггера значение не удалось: %s" 38 | 39 | #: pltcl.c:1058 40 | #, c-format 41 | msgid "trigger's return list must have even number of elements" 42 | msgstr "в возвращаемом триггером списке должно быть чётное число элементов" 43 | 44 | #: pltcl.c:1094 45 | #, c-format 46 | msgid "unrecognized attribute \"%s\"" 47 | msgstr "нераспознанный атрибут \"%s\"" 48 | 49 | #: pltcl.c:1099 50 | #, c-format 51 | msgid "cannot set system attribute \"%s\"" 52 | msgstr "установить системный атрибут \"%s\" нельзя" 53 | 54 | #: pltcl.c:1222 pltcl.c:1648 55 | #, c-format 56 | msgid "%s" 57 | msgstr "%s" 58 | 59 | #: pltcl.c:1223 60 | #, c-format 61 | msgid "" 62 | "%s\n" 63 | "in PL/Tcl function \"%s\"" 64 | msgstr "" 65 | "%s\n" 66 | "в функции PL/Tcl \"%s\"" 67 | 68 | #: pltcl.c:1331 pltcl.c:1338 69 | #, c-format 70 | msgid "out of memory" 71 | msgstr "нехватка памяти" 72 | 73 | #: pltcl.c:1386 74 | #, c-format 75 | msgid "trigger functions can only be called as triggers" 76 | msgstr "триггерные функции могут вызываться только в триггерах" 77 | 78 | #: pltcl.c:1395 79 | #, c-format 80 | msgid "PL/Tcl functions cannot return type %s" 81 | msgstr "функции PL/Tcl не могут возвращать тип %s" 82 | 83 | #: pltcl.c:1407 84 | #, c-format 85 | msgid "PL/Tcl functions cannot return composite types" 86 | msgstr "функции PL/Tcl не могут возвращать составные типы" 87 | 88 | #: pltcl.c:1446 89 | #, c-format 90 | msgid "PL/Tcl functions cannot accept type %s" 91 | msgstr "функции PL/Tcl не могут принимать тип %s" 92 | 93 | #: pltcl.c:1564 94 | #, c-format 95 | msgid "could not create internal procedure \"%s\": %s" 96 | msgstr "не удалось создать внутреннюю процедуру \"%s\": %s" 97 | -------------------------------------------------------------------------------- /po/it.po: -------------------------------------------------------------------------------- 1 | # 2 | # Translation of pltcl to Italian 3 | # PostgreSQL Project 4 | # 5 | # Associazione Culturale ITPUG - Italian PostgreSQL Users Group 6 | # http://www.itpug.org/ - info@itpug.org 7 | # 8 | # Traduttori: 9 | # * Flavio Spada 10 | # 11 | # Revisori: 12 | # * Gabriele Bartolini 13 | # 14 | # Copyright (c) 2010, Associazione Culturale ITPUG 15 | # Distributed under the same license of the PostgreSQL project 16 | # 17 | msgid "" 18 | msgstr "" 19 | "Project-Id-Version: pltcl (PostgreSQL) 9.6\n" 20 | "Report-Msgid-Bugs-To: pgsql-bugs@postgresql.org\n" 21 | "POT-Creation-Date: 2016-04-17 00:07+0000\n" 22 | "PO-Revision-Date: 2016-04-17 03:40+0100\n" 23 | "Last-Translator: Daniele Varrazzo \n" 24 | "Language-Team: Gruppo traduzioni ITPUG \n" 25 | "Language: it\n" 26 | "MIME-Version: 1.0\n" 27 | "Content-Type: text/plain; charset=UTF-8\n" 28 | "Content-Transfer-Encoding: 8bit\n" 29 | "Plural-Forms: nplurals=2; plural=n != 1;\n" 30 | "X-Generator: Poedit 1.5.4\n" 31 | 32 | #: pltcl.c:559 33 | #, c-format 34 | msgid "module \"unknown\" not found in pltcl_modules" 35 | msgstr "modulo \"unknown\" not trovato nei moduli pltcl" 36 | 37 | #: pltcl.c:597 38 | #, c-format 39 | msgid "could not load module \"unknown\": %s" 40 | msgstr "caricamento del modulo \"unknown\" fallito: %s" 41 | 42 | #: pltcl.c:1065 43 | #, c-format 44 | msgid "could not split return value from trigger: %s" 45 | msgstr "divisione del valore di ritorno del trigger fallita: %s" 46 | 47 | #: pltcl.c:1074 48 | #, c-format 49 | msgid "trigger's return list must have even number of elements" 50 | msgstr "la lista restituita dal trigger deve avere un numero pari di elementi" 51 | 52 | #: pltcl.c:1109 53 | #, c-format 54 | msgid "unrecognized attribute \"%s\"" 55 | msgstr "attributo \"%s\" non riconosciuto" 56 | 57 | #: pltcl.c:1114 58 | #, c-format 59 | msgid "cannot set system attribute \"%s\"" 60 | msgstr "non è possibile impostare l'attributo di sistema \"%s\"" 61 | 62 | #: pltcl.c:1230 pltcl.c:1655 63 | #, c-format 64 | msgid "%s" 65 | msgstr "%s" 66 | 67 | #: pltcl.c:1231 68 | #, c-format 69 | msgid "" 70 | "%s\n" 71 | "in PL/Tcl function \"%s\"" 72 | msgstr "" 73 | "%s\n" 74 | "nella funzione PL/Tcl \"%s\"" 75 | 76 | #: pltcl.c:1338 pltcl.c:1345 77 | #, c-format 78 | msgid "out of memory" 79 | msgstr "memoria esaurita" 80 | 81 | #: pltcl.c:1393 82 | #, c-format 83 | msgid "trigger functions can only be called as triggers" 84 | msgstr "le funzioni trigger possono essere chiamate esclusivamente da trigger" 85 | 86 | #: pltcl.c:1402 87 | #, c-format 88 | msgid "PL/Tcl functions cannot return type %s" 89 | msgstr "le funzioni PL/Tcl non possono restituire il tipo %s" 90 | 91 | #: pltcl.c:1414 92 | #, c-format 93 | msgid "PL/Tcl functions cannot return composite types" 94 | msgstr "le funzioni PL/Tcl non possono restituire tipi compositi" 95 | 96 | #: pltcl.c:1453 97 | #, c-format 98 | msgid "PL/Tcl functions cannot accept type %s" 99 | msgstr "le funzioni PL/Tcl non possono accettare il tipo %s" 100 | 101 | #: pltcl.c:1576 102 | #, c-format 103 | msgid "could not create internal procedure \"%s\": %s" 104 | msgstr "creazione della procedura interna \"%s\" fallita: %s" 105 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | #------------------------------------------------------------------------- 2 | # 3 | # Makefile for the pl/tcl procedural language 4 | # 5 | # src/pl/tcl/Makefile 6 | # 7 | #------------------------------------------------------------------------- 8 | 9 | subdir = src/pl/tcl 10 | 11 | ################################################# 12 | # 13 | # CHANGES FOR STAND-ALONE REPOSITORY 14 | # 15 | # All the real changes are in stand-alone.mk, which we include. BUT, we need to 16 | # ensure that the user has set top_builddir, so we must comment it here! This 17 | # is the only modification to the original Makefile; please try to keep it that 18 | # way! 19 | # 20 | # COMMENTED OUT: top_builddir = ../../.. 21 | 22 | # NOTE: This over-rides subdir! (set above) 23 | include stand-alone.mk 24 | 25 | # 26 | # END CHANGES 27 | # 28 | ################################################# 29 | 30 | include $(top_builddir)/src/Makefile.global 31 | 32 | 33 | override CPPFLAGS := -I. -I$(srcdir) $(TCL_INCLUDE_SPEC) $(CPPFLAGS) 34 | 35 | # On Windows, we don't link directly with the Tcl library; see below 36 | ifneq ($(PORTNAME), win32) 37 | SHLIB_LINK = $(TCL_LIB_SPEC) $(TCL_LIBS) -lc 38 | endif 39 | 40 | PGFILEDESC = "PL/Tcl - procedural language" 41 | 42 | NAME = pltcl 43 | 44 | OBJS = pltcl.o $(WIN32RES) 45 | 46 | DATA = pltcl.control pltcl--1.0.sql pltcl--unpackaged--1.0.sql \ 47 | pltclu.control pltclu--1.0.sql pltclu--unpackaged--1.0.sql 48 | 49 | REGRESS_OPTS = --dbname=$(PL_TESTDB) --load-extension=pltcl 50 | REGRESS = pltcl_setup pltcl_queries pltcl_unicode 51 | 52 | # Tcl on win32 ships with import libraries only for Microsoft Visual C++, 53 | # which are not compatible with mingw gcc. Therefore we need to build a 54 | # new import library to link with. 55 | ifeq ($(PORTNAME), win32) 56 | 57 | tclwithver = $(subst -l,,$(filter -l%, $(TCL_LIB_SPEC))) 58 | TCLDLL = $(dir $(TCLSH))/$(tclwithver).dll 59 | 60 | OBJS += lib$(tclwithver).a 61 | 62 | lib$(tclwithver).a: $(tclwithver).def 63 | dlltool --dllname $(tclwithver).dll --def $(tclwithver).def --output-lib lib$(tclwithver).a 64 | 65 | $(tclwithver).def: $(TCLDLL) 66 | pexports $^ > $@ 67 | 68 | endif # win32 69 | 70 | 71 | include $(top_srcdir)/src/Makefile.shlib 72 | 73 | 74 | all: all-lib 75 | 76 | # Force this dependency to be known even without dependency info built: 77 | pltcl.o: pltclerrcodes.h 78 | 79 | # generate pltclerrcodes.h from src/backend/utils/errcodes.txt 80 | pltclerrcodes.h: $(top_srcdir)/src/backend/utils/errcodes.txt generate-pltclerrcodes.pl 81 | $(PERL) $(srcdir)/generate-pltclerrcodes.pl $< > $@ 82 | 83 | distprep: pltclerrcodes.h 84 | 85 | install: all install-lib install-data 86 | 87 | installdirs: installdirs-lib 88 | $(MKDIR_P) '$(DESTDIR)$(datadir)/extension' 89 | 90 | uninstall: uninstall-lib uninstall-data 91 | 92 | install-data: installdirs 93 | $(INSTALL_DATA) $(addprefix $(srcdir)/, $(DATA)) '$(DESTDIR)$(datadir)/extension/' 94 | 95 | uninstall-data: 96 | rm -f $(addprefix '$(DESTDIR)$(datadir)/extension'/, $(notdir $(DATA))) 97 | 98 | .PHONY: install-data uninstall-data 99 | 100 | 101 | check: submake 102 | $(pg_regress_check) $(REGRESS_OPTS) $(REGRESS) 103 | 104 | installcheck: submake 105 | $(pg_regress_installcheck) $(REGRESS_OPTS) $(REGRESS) 106 | 107 | .PHONY: submake 108 | submake: 109 | $(MAKE) -C $(top_builddir)/src/test/regress pg_regress$(X) 110 | 111 | # pltclerrcodes.h is in the distribution tarball, so don't clean it here. 112 | clean distclean: clean-lib 113 | rm -f $(OBJS) 114 | rm -rf $(pg_regress_clean_files) 115 | ifeq ($(PORTNAME), win32) 116 | rm -f $(tclwithver).def 117 | endif 118 | 119 | maintainer-clean: distclean 120 | rm -f pltclerrcodes.h 121 | -------------------------------------------------------------------------------- /sql/pltcl_queries.sql: -------------------------------------------------------------------------------- 1 | -- suppress CONTEXT so that function OIDs aren't in output 2 | \set VERBOSITY terse 3 | 4 | insert into T_pkey1 values (1, 'key1-1', 'test key'); 5 | insert into T_pkey1 values (1, 'key1-2', 'test key'); 6 | insert into T_pkey1 values (1, 'key1-3', 'test key'); 7 | insert into T_pkey1 values (2, 'key2-1', 'test key'); 8 | insert into T_pkey1 values (2, 'key2-2', 'test key'); 9 | insert into T_pkey1 values (2, 'key2-3', 'test key'); 10 | 11 | insert into T_pkey2 values (1, 'key1-1', 'test key'); 12 | insert into T_pkey2 values (1, 'key1-2', 'test key'); 13 | insert into T_pkey2 values (1, 'key1-3', 'test key'); 14 | insert into T_pkey2 values (2, 'key2-1', 'test key'); 15 | insert into T_pkey2 values (2, 'key2-2', 'test key'); 16 | insert into T_pkey2 values (2, 'key2-3', 'test key'); 17 | 18 | select * from T_pkey1; 19 | 20 | -- key2 in T_pkey2 should have upper case only 21 | select * from T_pkey2; 22 | 23 | insert into T_pkey1 values (1, 'KEY1-3', 'should work'); 24 | 25 | -- Due to the upper case translation in trigger this must fail 26 | insert into T_pkey2 values (1, 'KEY1-3', 'should fail'); 27 | 28 | insert into T_dta1 values ('trec 1', 1, 'key1-1'); 29 | insert into T_dta1 values ('trec 2', 1, 'key1-2'); 30 | insert into T_dta1 values ('trec 3', 1, 'key1-3'); 31 | 32 | -- Must fail due to unknown key in T_pkey1 33 | insert into T_dta1 values ('trec 4', 1, 'key1-4'); 34 | 35 | insert into T_dta2 values ('trec 1', 1, 'KEY1-1'); 36 | insert into T_dta2 values ('trec 2', 1, 'KEY1-2'); 37 | insert into T_dta2 values ('trec 3', 1, 'KEY1-3'); 38 | 39 | -- Must fail due to unknown key in T_pkey2 40 | insert into T_dta2 values ('trec 4', 1, 'KEY1-4'); 41 | 42 | select * from T_dta1; 43 | 44 | select * from T_dta2; 45 | 46 | update T_pkey1 set key2 = 'key2-9' where key1 = 2 and key2 = 'key2-1'; 47 | update T_pkey1 set key2 = 'key1-9' where key1 = 1 and key2 = 'key1-1'; 48 | delete from T_pkey1 where key1 = 2 and key2 = 'key2-2'; 49 | delete from T_pkey1 where key1 = 1 and key2 = 'key1-2'; 50 | 51 | update T_pkey2 set key2 = 'KEY2-9' where key1 = 2 and key2 = 'KEY2-1'; 52 | update T_pkey2 set key2 = 'KEY1-9' where key1 = 1 and key2 = 'KEY1-1'; 53 | delete from T_pkey2 where key1 = 2 and key2 = 'KEY2-2'; 54 | delete from T_pkey2 where key1 = 1 and key2 = 'KEY1-2'; 55 | 56 | select * from T_pkey1; 57 | select * from T_pkey2; 58 | select * from T_dta1; 59 | select * from T_dta2; 60 | 61 | select tcl_avg(key1) from T_pkey1; 62 | select tcl_sum(key1) from T_pkey1; 63 | select tcl_avg(key1) from T_pkey2; 64 | select tcl_sum(key1) from T_pkey2; 65 | 66 | -- The following should return NULL instead of 0 67 | select tcl_avg(key1) from T_pkey1 where key1 = 99; 68 | select tcl_sum(key1) from T_pkey1 where key1 = 99; 69 | 70 | select 1 @< 2; 71 | select 100 @< 4; 72 | 73 | select * from T_pkey1 order by key1 using @<, key2 collate "C"; 74 | select * from T_pkey2 order by key1 using @<, key2 collate "C"; 75 | 76 | -- show dump of trigger data 77 | insert into trigger_test values(1,'insert'); 78 | 79 | insert into trigger_test_view values(2,'insert'); 80 | update trigger_test_view set v = 'update' where i=1; 81 | delete from trigger_test_view; 82 | 83 | update trigger_test set v = 'update' where i = 1; 84 | delete from trigger_test; 85 | 86 | -- Test composite-type arguments 87 | select tcl_composite_arg_ref1(row('tkey', 42, 'ref2')); 88 | select tcl_composite_arg_ref2(row('tkey', 42, 'ref2')); 89 | 90 | -- Test argisnull primitive 91 | select tcl_argisnull('foo'); 92 | select tcl_argisnull(''); 93 | select tcl_argisnull(null); 94 | 95 | -- Test spi_lastoid primitive 96 | create temp table t1 (f1 int); 97 | select tcl_lastoid('t1'); 98 | create temp table t2 (f1 int) with oids; 99 | select tcl_lastoid('t2') > 0; 100 | -------------------------------------------------------------------------------- /expected/pltcl_queries.out: -------------------------------------------------------------------------------- 1 | -- suppress CONTEXT so that function OIDs aren't in output 2 | \set VERBOSITY terse 3 | insert into T_pkey1 values (1, 'key1-1', 'test key'); 4 | insert into T_pkey1 values (1, 'key1-2', 'test key'); 5 | insert into T_pkey1 values (1, 'key1-3', 'test key'); 6 | insert into T_pkey1 values (2, 'key2-1', 'test key'); 7 | insert into T_pkey1 values (2, 'key2-2', 'test key'); 8 | insert into T_pkey1 values (2, 'key2-3', 'test key'); 9 | insert into T_pkey2 values (1, 'key1-1', 'test key'); 10 | insert into T_pkey2 values (1, 'key1-2', 'test key'); 11 | insert into T_pkey2 values (1, 'key1-3', 'test key'); 12 | insert into T_pkey2 values (2, 'key2-1', 'test key'); 13 | insert into T_pkey2 values (2, 'key2-2', 'test key'); 14 | insert into T_pkey2 values (2, 'key2-3', 'test key'); 15 | select * from T_pkey1; 16 | key1 | key2 | txt 17 | ------+----------------------+------------------------------------------ 18 | 1 | key1-1 | test key 19 | 1 | key1-2 | test key 20 | 1 | key1-3 | test key 21 | 2 | key2-1 | test key 22 | 2 | key2-2 | test key 23 | 2 | key2-3 | test key 24 | (6 rows) 25 | 26 | -- key2 in T_pkey2 should have upper case only 27 | select * from T_pkey2; 28 | key1 | key2 | txt 29 | ------+----------------------+------------------------------------------ 30 | 1 | KEY1-1 | test key 31 | 1 | KEY1-2 | test key 32 | 1 | KEY1-3 | test key 33 | 2 | KEY2-1 | test key 34 | 2 | KEY2-2 | test key 35 | 2 | KEY2-3 | test key 36 | (6 rows) 37 | 38 | insert into T_pkey1 values (1, 'KEY1-3', 'should work'); 39 | -- Due to the upper case translation in trigger this must fail 40 | insert into T_pkey2 values (1, 'KEY1-3', 'should fail'); 41 | ERROR: duplicate key '1', 'KEY1-3' for T_pkey2 42 | insert into T_dta1 values ('trec 1', 1, 'key1-1'); 43 | insert into T_dta1 values ('trec 2', 1, 'key1-2'); 44 | insert into T_dta1 values ('trec 3', 1, 'key1-3'); 45 | -- Must fail due to unknown key in T_pkey1 46 | insert into T_dta1 values ('trec 4', 1, 'key1-4'); 47 | ERROR: key for t_dta1 not in t_pkey1 48 | insert into T_dta2 values ('trec 1', 1, 'KEY1-1'); 49 | insert into T_dta2 values ('trec 2', 1, 'KEY1-2'); 50 | insert into T_dta2 values ('trec 3', 1, 'KEY1-3'); 51 | -- Must fail due to unknown key in T_pkey2 52 | insert into T_dta2 values ('trec 4', 1, 'KEY1-4'); 53 | ERROR: key for t_dta2 not in t_pkey2 54 | select * from T_dta1; 55 | tkey | ref1 | ref2 56 | ------------+------+---------------------- 57 | trec 1 | 1 | key1-1 58 | trec 2 | 1 | key1-2 59 | trec 3 | 1 | key1-3 60 | (3 rows) 61 | 62 | select * from T_dta2; 63 | tkey | ref1 | ref2 64 | ------------+------+---------------------- 65 | trec 1 | 1 | KEY1-1 66 | trec 2 | 1 | KEY1-2 67 | trec 3 | 1 | KEY1-3 68 | (3 rows) 69 | 70 | update T_pkey1 set key2 = 'key2-9' where key1 = 2 and key2 = 'key2-1'; 71 | update T_pkey1 set key2 = 'key1-9' where key1 = 1 and key2 = 'key1-1'; 72 | ERROR: key '1', 'key1-1 ' referenced by T_dta1 73 | delete from T_pkey1 where key1 = 2 and key2 = 'key2-2'; 74 | delete from T_pkey1 where key1 = 1 and key2 = 'key1-2'; 75 | ERROR: key '1', 'key1-2 ' referenced by T_dta1 76 | update T_pkey2 set key2 = 'KEY2-9' where key1 = 2 and key2 = 'KEY2-1'; 77 | update T_pkey2 set key2 = 'KEY1-9' where key1 = 1 and key2 = 'KEY1-1'; 78 | NOTICE: updated 1 entries in T_dta2 for new key in T_pkey2 79 | delete from T_pkey2 where key1 = 2 and key2 = 'KEY2-2'; 80 | delete from T_pkey2 where key1 = 1 and key2 = 'KEY1-2'; 81 | NOTICE: deleted 1 entries from T_dta2 82 | select * from T_pkey1; 83 | key1 | key2 | txt 84 | ------+----------------------+------------------------------------------ 85 | 1 | key1-1 | test key 86 | 1 | key1-2 | test key 87 | 1 | key1-3 | test key 88 | 2 | key2-3 | test key 89 | 1 | KEY1-3 | should work 90 | 2 | key2-9 | test key 91 | (6 rows) 92 | 93 | select * from T_pkey2; 94 | key1 | key2 | txt 95 | ------+----------------------+------------------------------------------ 96 | 1 | KEY1-3 | test key 97 | 2 | KEY2-3 | test key 98 | 2 | KEY2-9 | test key 99 | 1 | KEY1-9 | test key 100 | (4 rows) 101 | 102 | select * from T_dta1; 103 | tkey | ref1 | ref2 104 | ------------+------+---------------------- 105 | trec 1 | 1 | key1-1 106 | trec 2 | 1 | key1-2 107 | trec 3 | 1 | key1-3 108 | (3 rows) 109 | 110 | select * from T_dta2; 111 | tkey | ref1 | ref2 112 | ------------+------+---------------------- 113 | trec 3 | 1 | KEY1-3 114 | trec 1 | 1 | KEY1-9 115 | (2 rows) 116 | 117 | select tcl_avg(key1) from T_pkey1; 118 | tcl_avg 119 | --------- 120 | 1 121 | (1 row) 122 | 123 | select tcl_sum(key1) from T_pkey1; 124 | tcl_sum 125 | --------- 126 | 8 127 | (1 row) 128 | 129 | select tcl_avg(key1) from T_pkey2; 130 | tcl_avg 131 | --------- 132 | 1 133 | (1 row) 134 | 135 | select tcl_sum(key1) from T_pkey2; 136 | tcl_sum 137 | --------- 138 | 6 139 | (1 row) 140 | 141 | -- The following should return NULL instead of 0 142 | select tcl_avg(key1) from T_pkey1 where key1 = 99; 143 | tcl_avg 144 | --------- 145 | 146 | (1 row) 147 | 148 | select tcl_sum(key1) from T_pkey1 where key1 = 99; 149 | tcl_sum 150 | --------- 151 | 0 152 | (1 row) 153 | 154 | select 1 @< 2; 155 | ?column? 156 | ---------- 157 | t 158 | (1 row) 159 | 160 | select 100 @< 4; 161 | ?column? 162 | ---------- 163 | f 164 | (1 row) 165 | 166 | select * from T_pkey1 order by key1 using @<, key2 collate "C"; 167 | key1 | key2 | txt 168 | ------+----------------------+------------------------------------------ 169 | 1 | KEY1-3 | should work 170 | 1 | key1-1 | test key 171 | 1 | key1-2 | test key 172 | 1 | key1-3 | test key 173 | 2 | key2-3 | test key 174 | 2 | key2-9 | test key 175 | (6 rows) 176 | 177 | select * from T_pkey2 order by key1 using @<, key2 collate "C"; 178 | key1 | key2 | txt 179 | ------+----------------------+------------------------------------------ 180 | 1 | KEY1-3 | test key 181 | 1 | KEY1-9 | test key 182 | 2 | KEY2-3 | test key 183 | 2 | KEY2-9 | test key 184 | (4 rows) 185 | 186 | -- show dump of trigger data 187 | insert into trigger_test values(1,'insert'); 188 | NOTICE: NEW: {i: 1, v: insert} 189 | NOTICE: OLD: {} 190 | NOTICE: TG_level: ROW 191 | NOTICE: TG_name: show_trigger_data_trig 192 | NOTICE: TG_op: INSERT 193 | NOTICE: TG_relatts: {{} i v} 194 | NOTICE: TG_relid: bogus:12345 195 | NOTICE: TG_table_name: trigger_test 196 | NOTICE: TG_table_schema: public 197 | NOTICE: TG_when: BEFORE 198 | NOTICE: args: {23 skidoo} 199 | insert into trigger_test_view values(2,'insert'); 200 | NOTICE: NEW: {i: 2, v: insert} 201 | NOTICE: OLD: {} 202 | NOTICE: TG_level: ROW 203 | NOTICE: TG_name: show_trigger_data_view_trig 204 | NOTICE: TG_op: INSERT 205 | NOTICE: TG_relatts: {{} i v} 206 | NOTICE: TG_relid: bogus:12345 207 | NOTICE: TG_table_name: trigger_test_view 208 | NOTICE: TG_table_schema: public 209 | NOTICE: TG_when: {INSTEAD OF} 210 | NOTICE: args: {24 {skidoo view}} 211 | update trigger_test_view set v = 'update' where i=1; 212 | NOTICE: NEW: {i: 1, v: update} 213 | NOTICE: OLD: {i: 1, v: insert} 214 | NOTICE: TG_level: ROW 215 | NOTICE: TG_name: show_trigger_data_view_trig 216 | NOTICE: TG_op: UPDATE 217 | NOTICE: TG_relatts: {{} i v} 218 | NOTICE: TG_relid: bogus:12345 219 | NOTICE: TG_table_name: trigger_test_view 220 | NOTICE: TG_table_schema: public 221 | NOTICE: TG_when: {INSTEAD OF} 222 | NOTICE: args: {24 {skidoo view}} 223 | delete from trigger_test_view; 224 | NOTICE: NEW: {} 225 | NOTICE: OLD: {i: 1, v: insert} 226 | NOTICE: TG_level: ROW 227 | NOTICE: TG_name: show_trigger_data_view_trig 228 | NOTICE: TG_op: DELETE 229 | NOTICE: TG_relatts: {{} i v} 230 | NOTICE: TG_relid: bogus:12345 231 | NOTICE: TG_table_name: trigger_test_view 232 | NOTICE: TG_table_schema: public 233 | NOTICE: TG_when: {INSTEAD OF} 234 | NOTICE: args: {24 {skidoo view}} 235 | update trigger_test set v = 'update' where i = 1; 236 | NOTICE: NEW: {i: 1, v: update} 237 | NOTICE: OLD: {i: 1, v: insert} 238 | NOTICE: TG_level: ROW 239 | NOTICE: TG_name: show_trigger_data_trig 240 | NOTICE: TG_op: UPDATE 241 | NOTICE: TG_relatts: {{} i v} 242 | NOTICE: TG_relid: bogus:12345 243 | NOTICE: TG_table_name: trigger_test 244 | NOTICE: TG_table_schema: public 245 | NOTICE: TG_when: BEFORE 246 | NOTICE: args: {23 skidoo} 247 | delete from trigger_test; 248 | NOTICE: NEW: {} 249 | NOTICE: OLD: {i: 1, v: update} 250 | NOTICE: TG_level: ROW 251 | NOTICE: TG_name: show_trigger_data_trig 252 | NOTICE: TG_op: DELETE 253 | NOTICE: TG_relatts: {{} i v} 254 | NOTICE: TG_relid: bogus:12345 255 | NOTICE: TG_table_name: trigger_test 256 | NOTICE: TG_table_schema: public 257 | NOTICE: TG_when: BEFORE 258 | NOTICE: args: {23 skidoo} 259 | -- Test composite-type arguments 260 | select tcl_composite_arg_ref1(row('tkey', 42, 'ref2')); 261 | tcl_composite_arg_ref1 262 | ------------------------ 263 | 42 264 | (1 row) 265 | 266 | select tcl_composite_arg_ref2(row('tkey', 42, 'ref2')); 267 | tcl_composite_arg_ref2 268 | ------------------------ 269 | ref2 270 | (1 row) 271 | 272 | -- Test argisnull primitive 273 | select tcl_argisnull('foo'); 274 | tcl_argisnull 275 | --------------- 276 | f 277 | (1 row) 278 | 279 | select tcl_argisnull(''); 280 | tcl_argisnull 281 | --------------- 282 | f 283 | (1 row) 284 | 285 | select tcl_argisnull(null); 286 | tcl_argisnull 287 | --------------- 288 | t 289 | (1 row) 290 | 291 | -- Test spi_lastoid primitive 292 | create temp table t1 (f1 int); 293 | select tcl_lastoid('t1'); 294 | tcl_lastoid 295 | ------------- 296 | 0 297 | (1 row) 298 | 299 | create temp table t2 (f1 int) with oids; 300 | select tcl_lastoid('t2') > 0; 301 | ?column? 302 | ---------- 303 | t 304 | (1 row) 305 | 306 | -------------------------------------------------------------------------------- /sql/pltcl_setup.sql: -------------------------------------------------------------------------------- 1 | -- 2 | -- Create the tables used in the test queries 3 | -- 4 | -- T_pkey1 is the primary key table for T_dta1. Entries from T_pkey1 5 | -- Cannot be changed or deleted if they are referenced from T_dta1. 6 | -- 7 | -- T_pkey2 is the primary key table for T_dta2. If the key values in 8 | -- T_pkey2 are changed, the references in T_dta2 follow. If entries 9 | -- are deleted, the referencing entries from T_dta2 are deleted too. 10 | -- The values for field key2 in T_pkey2 are silently converted to 11 | -- upper case on insert/update. 12 | -- 13 | create table T_pkey1 ( 14 | key1 int4, 15 | key2 char(20), 16 | txt char(40) 17 | ); 18 | 19 | create table T_pkey2 ( 20 | key1 int4, 21 | key2 char(20), 22 | txt char(40) 23 | ); 24 | 25 | create table T_dta1 ( 26 | tkey char(10), 27 | ref1 int4, 28 | ref2 char(20) 29 | ); 30 | 31 | create table T_dta2 ( 32 | tkey char(10), 33 | ref1 int4, 34 | ref2 char(20) 35 | ); 36 | 37 | 38 | -- 39 | -- Function to check key existence in T_pkey1 40 | -- 41 | create function check_pkey1_exists(int4, bpchar) returns bool as E' 42 | if {![info exists GD]} { 43 | set GD(plan) [spi_prepare \\ 44 | "select 1 from T_pkey1 \\ 45 | where key1 = \\$1 and key2 = \\$2" \\ 46 | {int4 bpchar}] 47 | } 48 | 49 | set n [spi_execp -count 1 $GD(plan) [list $1 $2]] 50 | 51 | if {$n > 0} { 52 | return "t" 53 | } 54 | return "f" 55 | ' language pltcl; 56 | 57 | 58 | -- dump trigger data 59 | 60 | CREATE TABLE trigger_test 61 | (i int, v text ); 62 | 63 | CREATE VIEW trigger_test_view AS SELECT * FROM trigger_test; 64 | 65 | CREATE FUNCTION trigger_data() returns trigger language pltcl as $_$ 66 | 67 | if { [info exists TG_relid] } { 68 | set TG_relid "bogus:12345" 69 | } 70 | 71 | set dnames [info locals {[a-zA-Z]*} ] 72 | 73 | foreach key [lsort $dnames] { 74 | 75 | if { [array exists $key] } { 76 | set str "{" 77 | foreach akey [lsort [ array names $key ] ] { 78 | if {[string length $str] > 1} { set str "$str, " } 79 | set cmd "($akey)" 80 | set cmd "set val \$$key$cmd" 81 | eval $cmd 82 | set str "$str$akey: $val" 83 | } 84 | set str "$str}" 85 | elog NOTICE "$key: $str" 86 | } else { 87 | set val [eval list "\$$key" ] 88 | elog NOTICE "$key: $val" 89 | } 90 | } 91 | 92 | 93 | return OK 94 | 95 | $_$; 96 | 97 | CREATE TRIGGER show_trigger_data_trig 98 | BEFORE INSERT OR UPDATE OR DELETE ON trigger_test 99 | FOR EACH ROW EXECUTE PROCEDURE trigger_data(23,'skidoo'); 100 | 101 | CREATE TRIGGER show_trigger_data_view_trig 102 | INSTEAD OF INSERT OR UPDATE OR DELETE ON trigger_test_view 103 | FOR EACH ROW EXECUTE PROCEDURE trigger_data(24,'skidoo view'); 104 | 105 | -- 106 | -- Trigger function on every change to T_pkey1 107 | -- 108 | create function trig_pkey1_before() returns trigger as E' 109 | # 110 | # Create prepared plans on the first call 111 | # 112 | if {![info exists GD]} { 113 | # 114 | # Plan to check for duplicate key in T_pkey1 115 | # 116 | set GD(plan_pkey1) [spi_prepare \\ 117 | "select check_pkey1_exists(\\$1, \\$2) as ret" \\ 118 | {int4 bpchar}] 119 | # 120 | # Plan to check for references from T_dta1 121 | # 122 | set GD(plan_dta1) [spi_prepare \\ 123 | "select 1 from T_dta1 \\ 124 | where ref1 = \\$1 and ref2 = \\$2" \\ 125 | {int4 bpchar}] 126 | } 127 | 128 | # 129 | # Initialize flags 130 | # 131 | set check_old_ref 0 132 | set check_new_dup 0 133 | 134 | switch $TG_op { 135 | INSERT { 136 | # 137 | # Must check for duplicate key on INSERT 138 | # 139 | set check_new_dup 1 140 | } 141 | UPDATE { 142 | # 143 | # Must check for duplicate key on UPDATE only if 144 | # the key changes. In that case we must check for 145 | # references to OLD values too. 146 | # 147 | if {[string compare $NEW(key1) $OLD(key1)] != 0} { 148 | set check_old_ref 1 149 | set check_new_dup 1 150 | } 151 | if {[string compare $NEW(key2) $OLD(key2)] != 0} { 152 | set check_old_ref 1 153 | set check_new_dup 1 154 | } 155 | } 156 | DELETE { 157 | # 158 | # Must only check for references to OLD on DELETE 159 | # 160 | set check_old_ref 1 161 | } 162 | } 163 | 164 | if {$check_new_dup} { 165 | # 166 | # Check for duplicate key 167 | # 168 | spi_execp -count 1 $GD(plan_pkey1) [list $NEW(key1) $NEW(key2)] 169 | if {$ret == "t"} { 170 | elog ERROR \\ 171 | "duplicate key ''$NEW(key1)'', ''$NEW(key2)'' for T_pkey1" 172 | } 173 | } 174 | 175 | if {$check_old_ref} { 176 | # 177 | # Check for references to OLD 178 | # 179 | set n [spi_execp -count 1 $GD(plan_dta1) [list $OLD(key1) $OLD(key2)]] 180 | if {$n > 0} { 181 | elog ERROR \\ 182 | "key ''$OLD(key1)'', ''$OLD(key2)'' referenced by T_dta1" 183 | } 184 | } 185 | 186 | # 187 | # Anything is fine - let operation pass through 188 | # 189 | return OK 190 | ' language pltcl; 191 | 192 | 193 | create trigger pkey1_before before insert or update or delete on T_pkey1 194 | for each row execute procedure 195 | trig_pkey1_before(); 196 | 197 | 198 | -- 199 | -- Trigger function to check for duplicate keys in T_pkey2 200 | -- and to force key2 to be upper case only without leading whitespaces 201 | -- 202 | create function trig_pkey2_before() returns trigger as E' 203 | # 204 | # Prepare plan on first call 205 | # 206 | if {![info exists GD]} { 207 | set GD(plan_pkey2) [spi_prepare \\ 208 | "select 1 from T_pkey2 \\ 209 | where key1 = \\$1 and key2 = \\$2" \\ 210 | {int4 bpchar}] 211 | } 212 | 213 | # 214 | # Convert key2 value 215 | # 216 | set NEW(key2) [string toupper [string trim $NEW(key2)]] 217 | 218 | # 219 | # Check for duplicate key 220 | # 221 | set n [spi_execp -count 1 $GD(plan_pkey2) [list $NEW(key1) $NEW(key2)]] 222 | if {$n > 0} { 223 | elog ERROR \\ 224 | "duplicate key ''$NEW(key1)'', ''$NEW(key2)'' for T_pkey2" 225 | } 226 | 227 | # 228 | # Return modified tuple in NEW 229 | # 230 | return [array get NEW] 231 | ' language pltcl; 232 | 233 | 234 | create trigger pkey2_before before insert or update on T_pkey2 235 | for each row execute procedure 236 | trig_pkey2_before(); 237 | 238 | 239 | -- 240 | -- Trigger function to force references from T_dta2 follow changes 241 | -- in T_pkey2 or be deleted too. This must be done AFTER the changes 242 | -- in T_pkey2 are done so the trigger for primkey check on T_dta2 243 | -- fired on our updates will see the new key values in T_pkey2. 244 | -- 245 | create function trig_pkey2_after() returns trigger as E' 246 | # 247 | # Prepare plans on first call 248 | # 249 | if {![info exists GD]} { 250 | # 251 | # Plan to update references from T_dta2 252 | # 253 | set GD(plan_dta2_upd) [spi_prepare \\ 254 | "update T_dta2 set ref1 = \\$3, ref2 = \\$4 \\ 255 | where ref1 = \\$1 and ref2 = \\$2" \\ 256 | {int4 bpchar int4 bpchar}] 257 | # 258 | # Plan to delete references from T_dta2 259 | # 260 | set GD(plan_dta2_del) [spi_prepare \\ 261 | "delete from T_dta2 \\ 262 | where ref1 = \\$1 and ref2 = \\$2" \\ 263 | {int4 bpchar}] 264 | } 265 | 266 | # 267 | # Initialize flags 268 | # 269 | set old_ref_follow 0 270 | set old_ref_delete 0 271 | 272 | switch $TG_op { 273 | UPDATE { 274 | # 275 | # On update we must let old references follow 276 | # 277 | set NEW(key2) [string toupper $NEW(key2)] 278 | 279 | if {[string compare $NEW(key1) $OLD(key1)] != 0} { 280 | set old_ref_follow 1 281 | } 282 | if {[string compare $NEW(key2) $OLD(key2)] != 0} { 283 | set old_ref_follow 1 284 | } 285 | } 286 | DELETE { 287 | # 288 | # On delete we must delete references too 289 | # 290 | set old_ref_delete 1 291 | } 292 | } 293 | 294 | if {$old_ref_follow} { 295 | # 296 | # Let old references follow and fire NOTICE message if 297 | # there where some 298 | # 299 | set n [spi_execp $GD(plan_dta2_upd) \\ 300 | [list $OLD(key1) $OLD(key2) $NEW(key1) $NEW(key2)]] 301 | if {$n > 0} { 302 | elog NOTICE \\ 303 | "updated $n entries in T_dta2 for new key in T_pkey2" 304 | } 305 | } 306 | 307 | if {$old_ref_delete} { 308 | # 309 | # delete references and fire NOTICE message if 310 | # there where some 311 | # 312 | set n [spi_execp $GD(plan_dta2_del) \\ 313 | [list $OLD(key1) $OLD(key2)]] 314 | if {$n > 0} { 315 | elog NOTICE \\ 316 | "deleted $n entries from T_dta2" 317 | } 318 | } 319 | 320 | return OK 321 | ' language pltcl; 322 | 323 | 324 | create trigger pkey2_after after update or delete on T_pkey2 325 | for each row execute procedure 326 | trig_pkey2_after(); 327 | 328 | 329 | -- 330 | -- Generic trigger function to check references in T_dta1 and T_dta2 331 | -- 332 | create function check_primkey() returns trigger as E' 333 | # 334 | # For every trigger/relation pair we create 335 | # a saved plan and hold them in GD 336 | # 337 | set plankey [list "plan" $TG_name $TG_relid] 338 | set planrel [list "relname" $TG_relid] 339 | 340 | # 341 | # Extract the pkey relation name 342 | # 343 | set keyidx [expr [llength $args] / 2] 344 | set keyrel [string tolower [lindex $args $keyidx]] 345 | 346 | if {![info exists GD($plankey)]} { 347 | # 348 | # We must prepare a new plan. Build up a query string 349 | # for the primary key check. 350 | # 351 | set keylist [lrange $args [expr $keyidx + 1] end] 352 | 353 | set query "select 1 from $keyrel" 354 | set qual " where" 355 | set typlist "" 356 | set idx 1 357 | foreach key $keylist { 358 | set key [string tolower $key] 359 | # 360 | # Add the qual part to the query string 361 | # 362 | append query "$qual $key = \\$$idx" 363 | set qual " and" 364 | 365 | # 366 | # Lookup the fields type in pg_attribute 367 | # 368 | set n [spi_exec "select T.typname \\ 369 | from pg_catalog.pg_type T, pg_catalog.pg_attribute A, pg_catalog.pg_class C \\ 370 | where C.relname = ''[quote $keyrel]'' \\ 371 | and C.oid = A.attrelid \\ 372 | and A.attname = ''[quote $key]'' \\ 373 | and A.atttypid = T.oid"] 374 | if {$n != 1} { 375 | elog ERROR "table $keyrel doesn''t have a field named $key" 376 | } 377 | 378 | # 379 | # Append the fields type to the argument type list 380 | # 381 | lappend typlist $typname 382 | incr idx 383 | } 384 | 385 | # 386 | # Prepare the plan 387 | # 388 | set GD($plankey) [spi_prepare $query $typlist] 389 | 390 | # 391 | # Lookup and remember the table name for later error messages 392 | # 393 | spi_exec "select relname from pg_catalog.pg_class \\ 394 | where oid = ''$TG_relid''::oid" 395 | set GD($planrel) $relname 396 | } 397 | 398 | # 399 | # Build the argument list from the NEW row 400 | # 401 | incr keyidx -1 402 | set arglist "" 403 | foreach arg [lrange $args 0 $keyidx] { 404 | lappend arglist $NEW($arg) 405 | } 406 | 407 | # 408 | # Check for the primary key 409 | # 410 | set n [spi_execp -count 1 $GD($plankey) $arglist] 411 | if {$n <= 0} { 412 | elog ERROR "key for $GD($planrel) not in $keyrel" 413 | } 414 | 415 | # 416 | # Anything is fine 417 | # 418 | return OK 419 | ' language pltcl; 420 | 421 | 422 | create trigger dta1_before before insert or update on T_dta1 423 | for each row execute procedure 424 | check_primkey('ref1', 'ref2', 'T_pkey1', 'key1', 'key2'); 425 | 426 | 427 | create trigger dta2_before before insert or update on T_dta2 428 | for each row execute procedure 429 | check_primkey('ref1', 'ref2', 'T_pkey2', 'key1', 'key2'); 430 | 431 | 432 | create function tcl_composite_arg_ref1(T_dta1) returns int as ' 433 | return $1(ref1) 434 | ' language pltcl; 435 | 436 | create function tcl_composite_arg_ref2(T_dta1) returns text as ' 437 | return $1(ref2) 438 | ' language pltcl; 439 | 440 | create function tcl_argisnull(text) returns bool as ' 441 | argisnull 1 442 | ' language pltcl; 443 | 444 | create function tcl_lastoid(tabname text) returns int8 as ' 445 | spi_exec "insert into $1 default values" 446 | spi_lastoid 447 | ' language pltcl; 448 | 449 | 450 | create function tcl_int4add(int4,int4) returns int4 as ' 451 | return [expr $1 + $2] 452 | ' language pltcl; 453 | 454 | -- We use split(n) as a quick-and-dirty way of parsing the input array 455 | -- value, which comes in as a string like '{1,2}'. There are better ways... 456 | 457 | create function tcl_int4_accum(int4[], int4) returns int4[] as ' 458 | set state [split $1 "{,}"] 459 | set newsum [expr {[lindex $state 1] + $2}] 460 | set newcnt [expr {[lindex $state 2] + 1}] 461 | return "{$newsum,$newcnt}" 462 | ' language pltcl; 463 | 464 | create function tcl_int4_avg(int4[]) returns int4 as ' 465 | set state [split $1 "{,}"] 466 | if {[lindex $state 2] == 0} { return_null } 467 | return [expr {[lindex $state 1] / [lindex $state 2]}] 468 | ' language pltcl; 469 | 470 | create aggregate tcl_avg ( 471 | sfunc = tcl_int4_accum, 472 | basetype = int4, 473 | stype = int4[], 474 | finalfunc = tcl_int4_avg, 475 | initcond = '{0,0}' 476 | ); 477 | 478 | create aggregate tcl_sum ( 479 | sfunc = tcl_int4add, 480 | basetype = int4, 481 | stype = int4, 482 | initcond1 = 0 483 | ); 484 | 485 | create function tcl_int4lt(int4,int4) returns bool as ' 486 | if {$1 < $2} { 487 | return t 488 | } 489 | return f 490 | ' language pltcl; 491 | 492 | create function tcl_int4le(int4,int4) returns bool as ' 493 | if {$1 <= $2} { 494 | return t 495 | } 496 | return f 497 | ' language pltcl; 498 | 499 | create function tcl_int4eq(int4,int4) returns bool as ' 500 | if {$1 == $2} { 501 | return t 502 | } 503 | return f 504 | ' language pltcl; 505 | 506 | create function tcl_int4ge(int4,int4) returns bool as ' 507 | if {$1 >= $2} { 508 | return t 509 | } 510 | return f 511 | ' language pltcl; 512 | 513 | create function tcl_int4gt(int4,int4) returns bool as ' 514 | if {$1 > $2} { 515 | return t 516 | } 517 | return f 518 | ' language pltcl; 519 | 520 | create operator @< ( 521 | leftarg = int4, 522 | rightarg = int4, 523 | procedure = tcl_int4lt 524 | ); 525 | 526 | create operator @<= ( 527 | leftarg = int4, 528 | rightarg = int4, 529 | procedure = tcl_int4le 530 | ); 531 | 532 | create operator @= ( 533 | leftarg = int4, 534 | rightarg = int4, 535 | procedure = tcl_int4eq 536 | ); 537 | 538 | create operator @>= ( 539 | leftarg = int4, 540 | rightarg = int4, 541 | procedure = tcl_int4ge 542 | ); 543 | 544 | create operator @> ( 545 | leftarg = int4, 546 | rightarg = int4, 547 | procedure = tcl_int4gt 548 | ); 549 | 550 | create function tcl_int4cmp(int4,int4) returns int4 as ' 551 | if {$1 < $2} { 552 | return -1 553 | } 554 | if {$1 > $2} { 555 | return 1 556 | } 557 | return 0 558 | ' language pltcl; 559 | 560 | CREATE OPERATOR CLASS tcl_int4_ops 561 | FOR TYPE int4 USING btree AS 562 | OPERATOR 1 @<, 563 | OPERATOR 2 @<=, 564 | OPERATOR 3 @=, 565 | OPERATOR 4 @>=, 566 | OPERATOR 5 @>, 567 | FUNCTION 1 tcl_int4cmp(int4,int4) ; 568 | 569 | -- 570 | -- Test usage of Tcl's "clock" command. In recent Tcl versions this 571 | -- command fails without working "unknown" support, so it's a good canary 572 | -- for initialization problems. 573 | -- 574 | create function tcl_date_week(int4,int4,int4) returns text as $$ 575 | return [clock format [clock scan "$2/$3/$1"] -format "%U"] 576 | $$ language pltcl immutable; 577 | 578 | select tcl_date_week(2010,1,24); 579 | select tcl_date_week(2001,10,24); 580 | 581 | -- test pltcl event triggers 582 | create or replace function tclsnitch() returns event_trigger language pltcl as $$ 583 | elog NOTICE "tclsnitch: $TG_event $TG_tag" 584 | $$; 585 | 586 | create event trigger tcl_a_snitch on ddl_command_start execute procedure tclsnitch(); 587 | create event trigger tcl_b_snitch on ddl_command_end execute procedure tclsnitch(); 588 | 589 | create or replace function foobar() returns int language sql as $$select 1;$$; 590 | alter function foobar() cost 77; 591 | drop function foobar(); 592 | 593 | create table foo(); 594 | drop table foo; 595 | 596 | drop event trigger tcl_a_snitch; 597 | drop event trigger tcl_b_snitch; 598 | 599 | -- test use of errorCode in error handling 600 | 601 | create function tcl_error_handling_test() returns text as $$ 602 | global errorCode 603 | if {[catch { spi_exec "select no_such_column from foo;" }]} { 604 | array set errArray $errorCode 605 | if {$errArray(condition) == "undefined_table"} { 606 | return "expected error: $errArray(message)" 607 | } else { 608 | return "unexpected error: $errArray(condition) $errArray(message)" 609 | } 610 | } else { 611 | return "no error" 612 | } 613 | $$ language pltcl; 614 | 615 | select tcl_error_handling_test(); 616 | 617 | create temp table foo(f1 int); 618 | 619 | select tcl_error_handling_test(); 620 | 621 | drop table foo; 622 | -------------------------------------------------------------------------------- /expected/pltcl_setup.out: -------------------------------------------------------------------------------- 1 | -- 2 | -- Create the tables used in the test queries 3 | -- 4 | -- T_pkey1 is the primary key table for T_dta1. Entries from T_pkey1 5 | -- Cannot be changed or deleted if they are referenced from T_dta1. 6 | -- 7 | -- T_pkey2 is the primary key table for T_dta2. If the key values in 8 | -- T_pkey2 are changed, the references in T_dta2 follow. If entries 9 | -- are deleted, the referencing entries from T_dta2 are deleted too. 10 | -- The values for field key2 in T_pkey2 are silently converted to 11 | -- upper case on insert/update. 12 | -- 13 | create table T_pkey1 ( 14 | key1 int4, 15 | key2 char(20), 16 | txt char(40) 17 | ); 18 | create table T_pkey2 ( 19 | key1 int4, 20 | key2 char(20), 21 | txt char(40) 22 | ); 23 | create table T_dta1 ( 24 | tkey char(10), 25 | ref1 int4, 26 | ref2 char(20) 27 | ); 28 | create table T_dta2 ( 29 | tkey char(10), 30 | ref1 int4, 31 | ref2 char(20) 32 | ); 33 | -- 34 | -- Function to check key existence in T_pkey1 35 | -- 36 | create function check_pkey1_exists(int4, bpchar) returns bool as E' 37 | if {![info exists GD]} { 38 | set GD(plan) [spi_prepare \\ 39 | "select 1 from T_pkey1 \\ 40 | where key1 = \\$1 and key2 = \\$2" \\ 41 | {int4 bpchar}] 42 | } 43 | 44 | set n [spi_execp -count 1 $GD(plan) [list $1 $2]] 45 | 46 | if {$n > 0} { 47 | return "t" 48 | } 49 | return "f" 50 | ' language pltcl; 51 | -- dump trigger data 52 | CREATE TABLE trigger_test 53 | (i int, v text ); 54 | CREATE VIEW trigger_test_view AS SELECT * FROM trigger_test; 55 | CREATE FUNCTION trigger_data() returns trigger language pltcl as $_$ 56 | 57 | if { [info exists TG_relid] } { 58 | set TG_relid "bogus:12345" 59 | } 60 | 61 | set dnames [info locals {[a-zA-Z]*} ] 62 | 63 | foreach key [lsort $dnames] { 64 | 65 | if { [array exists $key] } { 66 | set str "{" 67 | foreach akey [lsort [ array names $key ] ] { 68 | if {[string length $str] > 1} { set str "$str, " } 69 | set cmd "($akey)" 70 | set cmd "set val \$$key$cmd" 71 | eval $cmd 72 | set str "$str$akey: $val" 73 | } 74 | set str "$str}" 75 | elog NOTICE "$key: $str" 76 | } else { 77 | set val [eval list "\$$key" ] 78 | elog NOTICE "$key: $val" 79 | } 80 | } 81 | 82 | 83 | return OK 84 | 85 | $_$; 86 | CREATE TRIGGER show_trigger_data_trig 87 | BEFORE INSERT OR UPDATE OR DELETE ON trigger_test 88 | FOR EACH ROW EXECUTE PROCEDURE trigger_data(23,'skidoo'); 89 | CREATE TRIGGER show_trigger_data_view_trig 90 | INSTEAD OF INSERT OR UPDATE OR DELETE ON trigger_test_view 91 | FOR EACH ROW EXECUTE PROCEDURE trigger_data(24,'skidoo view'); 92 | -- 93 | -- Trigger function on every change to T_pkey1 94 | -- 95 | create function trig_pkey1_before() returns trigger as E' 96 | # 97 | # Create prepared plans on the first call 98 | # 99 | if {![info exists GD]} { 100 | # 101 | # Plan to check for duplicate key in T_pkey1 102 | # 103 | set GD(plan_pkey1) [spi_prepare \\ 104 | "select check_pkey1_exists(\\$1, \\$2) as ret" \\ 105 | {int4 bpchar}] 106 | # 107 | # Plan to check for references from T_dta1 108 | # 109 | set GD(plan_dta1) [spi_prepare \\ 110 | "select 1 from T_dta1 \\ 111 | where ref1 = \\$1 and ref2 = \\$2" \\ 112 | {int4 bpchar}] 113 | } 114 | 115 | # 116 | # Initialize flags 117 | # 118 | set check_old_ref 0 119 | set check_new_dup 0 120 | 121 | switch $TG_op { 122 | INSERT { 123 | # 124 | # Must check for duplicate key on INSERT 125 | # 126 | set check_new_dup 1 127 | } 128 | UPDATE { 129 | # 130 | # Must check for duplicate key on UPDATE only if 131 | # the key changes. In that case we must check for 132 | # references to OLD values too. 133 | # 134 | if {[string compare $NEW(key1) $OLD(key1)] != 0} { 135 | set check_old_ref 1 136 | set check_new_dup 1 137 | } 138 | if {[string compare $NEW(key2) $OLD(key2)] != 0} { 139 | set check_old_ref 1 140 | set check_new_dup 1 141 | } 142 | } 143 | DELETE { 144 | # 145 | # Must only check for references to OLD on DELETE 146 | # 147 | set check_old_ref 1 148 | } 149 | } 150 | 151 | if {$check_new_dup} { 152 | # 153 | # Check for duplicate key 154 | # 155 | spi_execp -count 1 $GD(plan_pkey1) [list $NEW(key1) $NEW(key2)] 156 | if {$ret == "t"} { 157 | elog ERROR \\ 158 | "duplicate key ''$NEW(key1)'', ''$NEW(key2)'' for T_pkey1" 159 | } 160 | } 161 | 162 | if {$check_old_ref} { 163 | # 164 | # Check for references to OLD 165 | # 166 | set n [spi_execp -count 1 $GD(plan_dta1) [list $OLD(key1) $OLD(key2)]] 167 | if {$n > 0} { 168 | elog ERROR \\ 169 | "key ''$OLD(key1)'', ''$OLD(key2)'' referenced by T_dta1" 170 | } 171 | } 172 | 173 | # 174 | # Anything is fine - let operation pass through 175 | # 176 | return OK 177 | ' language pltcl; 178 | create trigger pkey1_before before insert or update or delete on T_pkey1 179 | for each row execute procedure 180 | trig_pkey1_before(); 181 | -- 182 | -- Trigger function to check for duplicate keys in T_pkey2 183 | -- and to force key2 to be upper case only without leading whitespaces 184 | -- 185 | create function trig_pkey2_before() returns trigger as E' 186 | # 187 | # Prepare plan on first call 188 | # 189 | if {![info exists GD]} { 190 | set GD(plan_pkey2) [spi_prepare \\ 191 | "select 1 from T_pkey2 \\ 192 | where key1 = \\$1 and key2 = \\$2" \\ 193 | {int4 bpchar}] 194 | } 195 | 196 | # 197 | # Convert key2 value 198 | # 199 | set NEW(key2) [string toupper [string trim $NEW(key2)]] 200 | 201 | # 202 | # Check for duplicate key 203 | # 204 | set n [spi_execp -count 1 $GD(plan_pkey2) [list $NEW(key1) $NEW(key2)]] 205 | if {$n > 0} { 206 | elog ERROR \\ 207 | "duplicate key ''$NEW(key1)'', ''$NEW(key2)'' for T_pkey2" 208 | } 209 | 210 | # 211 | # Return modified tuple in NEW 212 | # 213 | return [array get NEW] 214 | ' language pltcl; 215 | create trigger pkey2_before before insert or update on T_pkey2 216 | for each row execute procedure 217 | trig_pkey2_before(); 218 | -- 219 | -- Trigger function to force references from T_dta2 follow changes 220 | -- in T_pkey2 or be deleted too. This must be done AFTER the changes 221 | -- in T_pkey2 are done so the trigger for primkey check on T_dta2 222 | -- fired on our updates will see the new key values in T_pkey2. 223 | -- 224 | create function trig_pkey2_after() returns trigger as E' 225 | # 226 | # Prepare plans on first call 227 | # 228 | if {![info exists GD]} { 229 | # 230 | # Plan to update references from T_dta2 231 | # 232 | set GD(plan_dta2_upd) [spi_prepare \\ 233 | "update T_dta2 set ref1 = \\$3, ref2 = \\$4 \\ 234 | where ref1 = \\$1 and ref2 = \\$2" \\ 235 | {int4 bpchar int4 bpchar}] 236 | # 237 | # Plan to delete references from T_dta2 238 | # 239 | set GD(plan_dta2_del) [spi_prepare \\ 240 | "delete from T_dta2 \\ 241 | where ref1 = \\$1 and ref2 = \\$2" \\ 242 | {int4 bpchar}] 243 | } 244 | 245 | # 246 | # Initialize flags 247 | # 248 | set old_ref_follow 0 249 | set old_ref_delete 0 250 | 251 | switch $TG_op { 252 | UPDATE { 253 | # 254 | # On update we must let old references follow 255 | # 256 | set NEW(key2) [string toupper $NEW(key2)] 257 | 258 | if {[string compare $NEW(key1) $OLD(key1)] != 0} { 259 | set old_ref_follow 1 260 | } 261 | if {[string compare $NEW(key2) $OLD(key2)] != 0} { 262 | set old_ref_follow 1 263 | } 264 | } 265 | DELETE { 266 | # 267 | # On delete we must delete references too 268 | # 269 | set old_ref_delete 1 270 | } 271 | } 272 | 273 | if {$old_ref_follow} { 274 | # 275 | # Let old references follow and fire NOTICE message if 276 | # there where some 277 | # 278 | set n [spi_execp $GD(plan_dta2_upd) \\ 279 | [list $OLD(key1) $OLD(key2) $NEW(key1) $NEW(key2)]] 280 | if {$n > 0} { 281 | elog NOTICE \\ 282 | "updated $n entries in T_dta2 for new key in T_pkey2" 283 | } 284 | } 285 | 286 | if {$old_ref_delete} { 287 | # 288 | # delete references and fire NOTICE message if 289 | # there where some 290 | # 291 | set n [spi_execp $GD(plan_dta2_del) \\ 292 | [list $OLD(key1) $OLD(key2)]] 293 | if {$n > 0} { 294 | elog NOTICE \\ 295 | "deleted $n entries from T_dta2" 296 | } 297 | } 298 | 299 | return OK 300 | ' language pltcl; 301 | create trigger pkey2_after after update or delete on T_pkey2 302 | for each row execute procedure 303 | trig_pkey2_after(); 304 | -- 305 | -- Generic trigger function to check references in T_dta1 and T_dta2 306 | -- 307 | create function check_primkey() returns trigger as E' 308 | # 309 | # For every trigger/relation pair we create 310 | # a saved plan and hold them in GD 311 | # 312 | set plankey [list "plan" $TG_name $TG_relid] 313 | set planrel [list "relname" $TG_relid] 314 | 315 | # 316 | # Extract the pkey relation name 317 | # 318 | set keyidx [expr [llength $args] / 2] 319 | set keyrel [string tolower [lindex $args $keyidx]] 320 | 321 | if {![info exists GD($plankey)]} { 322 | # 323 | # We must prepare a new plan. Build up a query string 324 | # for the primary key check. 325 | # 326 | set keylist [lrange $args [expr $keyidx + 1] end] 327 | 328 | set query "select 1 from $keyrel" 329 | set qual " where" 330 | set typlist "" 331 | set idx 1 332 | foreach key $keylist { 333 | set key [string tolower $key] 334 | # 335 | # Add the qual part to the query string 336 | # 337 | append query "$qual $key = \\$$idx" 338 | set qual " and" 339 | 340 | # 341 | # Lookup the fields type in pg_attribute 342 | # 343 | set n [spi_exec "select T.typname \\ 344 | from pg_catalog.pg_type T, pg_catalog.pg_attribute A, pg_catalog.pg_class C \\ 345 | where C.relname = ''[quote $keyrel]'' \\ 346 | and C.oid = A.attrelid \\ 347 | and A.attname = ''[quote $key]'' \\ 348 | and A.atttypid = T.oid"] 349 | if {$n != 1} { 350 | elog ERROR "table $keyrel doesn''t have a field named $key" 351 | } 352 | 353 | # 354 | # Append the fields type to the argument type list 355 | # 356 | lappend typlist $typname 357 | incr idx 358 | } 359 | 360 | # 361 | # Prepare the plan 362 | # 363 | set GD($plankey) [spi_prepare $query $typlist] 364 | 365 | # 366 | # Lookup and remember the table name for later error messages 367 | # 368 | spi_exec "select relname from pg_catalog.pg_class \\ 369 | where oid = ''$TG_relid''::oid" 370 | set GD($planrel) $relname 371 | } 372 | 373 | # 374 | # Build the argument list from the NEW row 375 | # 376 | incr keyidx -1 377 | set arglist "" 378 | foreach arg [lrange $args 0 $keyidx] { 379 | lappend arglist $NEW($arg) 380 | } 381 | 382 | # 383 | # Check for the primary key 384 | # 385 | set n [spi_execp -count 1 $GD($plankey) $arglist] 386 | if {$n <= 0} { 387 | elog ERROR "key for $GD($planrel) not in $keyrel" 388 | } 389 | 390 | # 391 | # Anything is fine 392 | # 393 | return OK 394 | ' language pltcl; 395 | create trigger dta1_before before insert or update on T_dta1 396 | for each row execute procedure 397 | check_primkey('ref1', 'ref2', 'T_pkey1', 'key1', 'key2'); 398 | create trigger dta2_before before insert or update on T_dta2 399 | for each row execute procedure 400 | check_primkey('ref1', 'ref2', 'T_pkey2', 'key1', 'key2'); 401 | create function tcl_composite_arg_ref1(T_dta1) returns int as ' 402 | return $1(ref1) 403 | ' language pltcl; 404 | create function tcl_composite_arg_ref2(T_dta1) returns text as ' 405 | return $1(ref2) 406 | ' language pltcl; 407 | create function tcl_argisnull(text) returns bool as ' 408 | argisnull 1 409 | ' language pltcl; 410 | create function tcl_lastoid(tabname text) returns int8 as ' 411 | spi_exec "insert into $1 default values" 412 | spi_lastoid 413 | ' language pltcl; 414 | create function tcl_int4add(int4,int4) returns int4 as ' 415 | return [expr $1 + $2] 416 | ' language pltcl; 417 | -- We use split(n) as a quick-and-dirty way of parsing the input array 418 | -- value, which comes in as a string like '{1,2}'. There are better ways... 419 | create function tcl_int4_accum(int4[], int4) returns int4[] as ' 420 | set state [split $1 "{,}"] 421 | set newsum [expr {[lindex $state 1] + $2}] 422 | set newcnt [expr {[lindex $state 2] + 1}] 423 | return "{$newsum,$newcnt}" 424 | ' language pltcl; 425 | create function tcl_int4_avg(int4[]) returns int4 as ' 426 | set state [split $1 "{,}"] 427 | if {[lindex $state 2] == 0} { return_null } 428 | return [expr {[lindex $state 1] / [lindex $state 2]}] 429 | ' language pltcl; 430 | create aggregate tcl_avg ( 431 | sfunc = tcl_int4_accum, 432 | basetype = int4, 433 | stype = int4[], 434 | finalfunc = tcl_int4_avg, 435 | initcond = '{0,0}' 436 | ); 437 | create aggregate tcl_sum ( 438 | sfunc = tcl_int4add, 439 | basetype = int4, 440 | stype = int4, 441 | initcond1 = 0 442 | ); 443 | create function tcl_int4lt(int4,int4) returns bool as ' 444 | if {$1 < $2} { 445 | return t 446 | } 447 | return f 448 | ' language pltcl; 449 | create function tcl_int4le(int4,int4) returns bool as ' 450 | if {$1 <= $2} { 451 | return t 452 | } 453 | return f 454 | ' language pltcl; 455 | create function tcl_int4eq(int4,int4) returns bool as ' 456 | if {$1 == $2} { 457 | return t 458 | } 459 | return f 460 | ' language pltcl; 461 | create function tcl_int4ge(int4,int4) returns bool as ' 462 | if {$1 >= $2} { 463 | return t 464 | } 465 | return f 466 | ' language pltcl; 467 | create function tcl_int4gt(int4,int4) returns bool as ' 468 | if {$1 > $2} { 469 | return t 470 | } 471 | return f 472 | ' language pltcl; 473 | create operator @< ( 474 | leftarg = int4, 475 | rightarg = int4, 476 | procedure = tcl_int4lt 477 | ); 478 | create operator @<= ( 479 | leftarg = int4, 480 | rightarg = int4, 481 | procedure = tcl_int4le 482 | ); 483 | create operator @= ( 484 | leftarg = int4, 485 | rightarg = int4, 486 | procedure = tcl_int4eq 487 | ); 488 | create operator @>= ( 489 | leftarg = int4, 490 | rightarg = int4, 491 | procedure = tcl_int4ge 492 | ); 493 | create operator @> ( 494 | leftarg = int4, 495 | rightarg = int4, 496 | procedure = tcl_int4gt 497 | ); 498 | create function tcl_int4cmp(int4,int4) returns int4 as ' 499 | if {$1 < $2} { 500 | return -1 501 | } 502 | if {$1 > $2} { 503 | return 1 504 | } 505 | return 0 506 | ' language pltcl; 507 | CREATE OPERATOR CLASS tcl_int4_ops 508 | FOR TYPE int4 USING btree AS 509 | OPERATOR 1 @<, 510 | OPERATOR 2 @<=, 511 | OPERATOR 3 @=, 512 | OPERATOR 4 @>=, 513 | OPERATOR 5 @>, 514 | FUNCTION 1 tcl_int4cmp(int4,int4) ; 515 | -- 516 | -- Test usage of Tcl's "clock" command. In recent Tcl versions this 517 | -- command fails without working "unknown" support, so it's a good canary 518 | -- for initialization problems. 519 | -- 520 | create function tcl_date_week(int4,int4,int4) returns text as $$ 521 | return [clock format [clock scan "$2/$3/$1"] -format "%U"] 522 | $$ language pltcl immutable; 523 | select tcl_date_week(2010,1,24); 524 | tcl_date_week 525 | --------------- 526 | 04 527 | (1 row) 528 | 529 | select tcl_date_week(2001,10,24); 530 | tcl_date_week 531 | --------------- 532 | 42 533 | (1 row) 534 | 535 | -- test pltcl event triggers 536 | create or replace function tclsnitch() returns event_trigger language pltcl as $$ 537 | elog NOTICE "tclsnitch: $TG_event $TG_tag" 538 | $$; 539 | create event trigger tcl_a_snitch on ddl_command_start execute procedure tclsnitch(); 540 | create event trigger tcl_b_snitch on ddl_command_end execute procedure tclsnitch(); 541 | create or replace function foobar() returns int language sql as $$select 1;$$; 542 | NOTICE: tclsnitch: ddl_command_start CREATE FUNCTION 543 | NOTICE: tclsnitch: ddl_command_end CREATE FUNCTION 544 | alter function foobar() cost 77; 545 | NOTICE: tclsnitch: ddl_command_start ALTER FUNCTION 546 | NOTICE: tclsnitch: ddl_command_end ALTER FUNCTION 547 | drop function foobar(); 548 | NOTICE: tclsnitch: ddl_command_start DROP FUNCTION 549 | NOTICE: tclsnitch: ddl_command_end DROP FUNCTION 550 | create table foo(); 551 | NOTICE: tclsnitch: ddl_command_start CREATE TABLE 552 | NOTICE: tclsnitch: ddl_command_end CREATE TABLE 553 | drop table foo; 554 | NOTICE: tclsnitch: ddl_command_start DROP TABLE 555 | NOTICE: tclsnitch: ddl_command_end DROP TABLE 556 | drop event trigger tcl_a_snitch; 557 | drop event trigger tcl_b_snitch; 558 | -- test use of errorCode in error handling 559 | create function tcl_error_handling_test() returns text as $$ 560 | global errorCode 561 | if {[catch { spi_exec "select no_such_column from foo;" }]} { 562 | array set errArray $errorCode 563 | if {$errArray(condition) == "undefined_table"} { 564 | return "expected error: $errArray(message)" 565 | } else { 566 | return "unexpected error: $errArray(condition) $errArray(message)" 567 | } 568 | } else { 569 | return "no error" 570 | } 571 | $$ language pltcl; 572 | select tcl_error_handling_test(); 573 | tcl_error_handling_test 574 | ----------------------------------------------- 575 | expected error: relation "foo" does not exist 576 | (1 row) 577 | 578 | create temp table foo(f1 int); 579 | select tcl_error_handling_test(); 580 | tcl_error_handling_test 581 | --------------------------------------------------------------------------- 582 | unexpected error: undefined_column column "no_such_column" does not exist 583 | (1 row) 584 | 585 | drop table foo; 586 | -------------------------------------------------------------------------------- /pltcl.c: -------------------------------------------------------------------------------- 1 | /********************************************************************** 2 | * pltcl.c - PostgreSQL support for Tcl as 3 | * procedural language (PL) 4 | * 5 | * src/pl/tcl/pltcl.c 6 | * 7 | **********************************************************************/ 8 | 9 | #include "postgres.h" 10 | 11 | #include 12 | 13 | #include 14 | #include 15 | 16 | #include "access/htup_details.h" 17 | #include "access/xact.h" 18 | #include "catalog/pg_proc.h" 19 | #include "catalog/pg_type.h" 20 | #include "commands/event_trigger.h" 21 | #include "commands/trigger.h" 22 | #include "executor/spi.h" 23 | #include "fmgr.h" 24 | #include "mb/pg_wchar.h" 25 | #include "miscadmin.h" 26 | #include "nodes/makefuncs.h" 27 | #include "parser/parse_type.h" 28 | #include "tcop/tcopprot.h" 29 | #include "utils/builtins.h" 30 | #include "utils/lsyscache.h" 31 | #include "utils/memutils.h" 32 | #include "utils/rel.h" 33 | #include "utils/syscache.h" 34 | #include "utils/typcache.h" 35 | 36 | 37 | PG_MODULE_MAGIC; 38 | 39 | #define HAVE_TCL_VERSION(maj,min) \ 40 | ((TCL_MAJOR_VERSION > maj) || \ 41 | (TCL_MAJOR_VERSION == maj && TCL_MINOR_VERSION >= min)) 42 | 43 | /* Insist on Tcl >= 8.4 */ 44 | #if !HAVE_TCL_VERSION(8,4) 45 | #error PostgreSQL only supports Tcl 8.4 or later. 46 | #endif 47 | 48 | /* Hack to deal with Tcl 8.6 const-ification without losing compatibility */ 49 | #ifndef CONST86 50 | #define CONST86 51 | #endif 52 | 53 | /* define our text domain for translations */ 54 | #undef TEXTDOMAIN 55 | #define TEXTDOMAIN PG_TEXTDOMAIN("pltcl") 56 | 57 | 58 | /* 59 | * Support for converting between UTF8 (which is what all strings going into 60 | * or out of Tcl should be) and the database encoding. 61 | * 62 | * If you just use utf_u2e() or utf_e2u() directly, they will leak some 63 | * palloc'd space when doing a conversion. This is not worth worrying about 64 | * if it only happens, say, once per PL/Tcl function call. If it does seem 65 | * worth worrying about, use the wrapper macros. 66 | */ 67 | 68 | static inline char * 69 | utf_u2e(const char *src) 70 | { 71 | return pg_any_to_server(src, strlen(src), PG_UTF8); 72 | } 73 | 74 | static inline char * 75 | utf_e2u(const char *src) 76 | { 77 | return pg_server_to_any(src, strlen(src), PG_UTF8); 78 | } 79 | 80 | #define UTF_BEGIN \ 81 | do { \ 82 | const char *_pltcl_utf_src = NULL; \ 83 | char *_pltcl_utf_dst = NULL 84 | 85 | #define UTF_END \ 86 | if (_pltcl_utf_src != (const char *) _pltcl_utf_dst) \ 87 | pfree(_pltcl_utf_dst); \ 88 | } while (0) 89 | 90 | #define UTF_U2E(x) \ 91 | (_pltcl_utf_dst = utf_u2e(_pltcl_utf_src = (x))) 92 | 93 | #define UTF_E2U(x) \ 94 | (_pltcl_utf_dst = utf_e2u(_pltcl_utf_src = (x))) 95 | 96 | 97 | /********************************************************************** 98 | * Information associated with a Tcl interpreter. We have one interpreter 99 | * that is used for all pltclu (untrusted) functions. For pltcl (trusted) 100 | * functions, there is a separate interpreter for each effective SQL userid. 101 | * (This is needed to ensure that an unprivileged user can't inject Tcl code 102 | * that'll be executed with the privileges of some other SQL user.) 103 | * 104 | * The pltcl_interp_desc structs are kept in a Postgres hash table indexed 105 | * by userid OID, with OID 0 used for the single untrusted interpreter. 106 | **********************************************************************/ 107 | typedef struct pltcl_interp_desc 108 | { 109 | Oid user_id; /* Hash key (must be first!) */ 110 | Tcl_Interp *interp; /* The interpreter */ 111 | Tcl_HashTable query_hash; /* pltcl_query_desc structs */ 112 | } pltcl_interp_desc; 113 | 114 | 115 | /********************************************************************** 116 | * The information we cache about loaded procedures 117 | **********************************************************************/ 118 | typedef struct pltcl_proc_desc 119 | { 120 | char *user_proname; 121 | char *internal_proname; 122 | TransactionId fn_xmin; 123 | ItemPointerData fn_tid; 124 | bool fn_readonly; 125 | bool lanpltrusted; 126 | pltcl_interp_desc *interp_desc; 127 | FmgrInfo result_in_func; 128 | Oid result_typioparam; 129 | int nargs; 130 | FmgrInfo arg_out_func[FUNC_MAX_ARGS]; 131 | bool arg_is_rowtype[FUNC_MAX_ARGS]; 132 | } pltcl_proc_desc; 133 | 134 | 135 | /********************************************************************** 136 | * The information we cache about prepared and saved plans 137 | **********************************************************************/ 138 | typedef struct pltcl_query_desc 139 | { 140 | char qname[20]; 141 | SPIPlanPtr plan; 142 | int nargs; 143 | Oid *argtypes; 144 | FmgrInfo *arginfuncs; 145 | Oid *argtypioparams; 146 | } pltcl_query_desc; 147 | 148 | 149 | /********************************************************************** 150 | * For speedy lookup, we maintain a hash table mapping from 151 | * function OID + trigger flag + user OID to pltcl_proc_desc pointers. 152 | * The reason the pltcl_proc_desc struct isn't directly part of the hash 153 | * entry is to simplify recovery from errors during compile_pltcl_function. 154 | * 155 | * Note: if the same function is called by multiple userIDs within a session, 156 | * there will be a separate pltcl_proc_desc entry for each userID in the case 157 | * of pltcl functions, but only one entry for pltclu functions, because we 158 | * set user_id = 0 for that case. 159 | **********************************************************************/ 160 | typedef struct pltcl_proc_key 161 | { 162 | Oid proc_id; /* Function OID */ 163 | 164 | /* 165 | * is_trigger is really a bool, but declare as Oid to ensure this struct 166 | * contains no padding 167 | */ 168 | Oid is_trigger; /* is it a trigger function? */ 169 | Oid user_id; /* User calling the function, or 0 */ 170 | } pltcl_proc_key; 171 | 172 | typedef struct pltcl_proc_ptr 173 | { 174 | pltcl_proc_key proc_key; /* Hash key (must be first!) */ 175 | pltcl_proc_desc *proc_ptr; 176 | } pltcl_proc_ptr; 177 | 178 | 179 | /********************************************************************** 180 | * Global data 181 | **********************************************************************/ 182 | static bool pltcl_pm_init_done = false; 183 | static Tcl_Interp *pltcl_hold_interp = NULL; 184 | static HTAB *pltcl_interp_htab = NULL; 185 | static HTAB *pltcl_proc_htab = NULL; 186 | 187 | /* these are saved and restored by pltcl_handler */ 188 | static FunctionCallInfo pltcl_current_fcinfo = NULL; 189 | static pltcl_proc_desc *pltcl_current_prodesc = NULL; 190 | 191 | /********************************************************************** 192 | * Lookup table for SQLSTATE condition names 193 | **********************************************************************/ 194 | typedef struct 195 | { 196 | const char *label; 197 | int sqlerrstate; 198 | } TclExceptionNameMap; 199 | 200 | static const TclExceptionNameMap exception_name_map[] = { 201 | #include "pltclerrcodes.h" /* pgrminclude ignore */ 202 | {NULL, 0} 203 | }; 204 | 205 | /********************************************************************** 206 | * Forward declarations 207 | **********************************************************************/ 208 | void _PG_init(void); 209 | 210 | static void pltcl_init_interp(pltcl_interp_desc *interp_desc, bool pltrusted); 211 | static pltcl_interp_desc *pltcl_fetch_interp(bool pltrusted); 212 | 213 | static Datum pltcl_handler(PG_FUNCTION_ARGS, bool pltrusted); 214 | 215 | static Datum pltcl_func_handler(PG_FUNCTION_ARGS, bool pltrusted); 216 | 217 | static HeapTuple pltcl_trigger_handler(PG_FUNCTION_ARGS, bool pltrusted); 218 | static void pltcl_event_trigger_handler(PG_FUNCTION_ARGS, bool pltrusted); 219 | 220 | static void throw_tcl_error(Tcl_Interp *interp, const char *proname); 221 | 222 | static pltcl_proc_desc *compile_pltcl_function(Oid fn_oid, Oid tgreloid, 223 | bool is_event_trigger, 224 | bool pltrusted); 225 | 226 | static int pltcl_elog(ClientData cdata, Tcl_Interp *interp, 227 | int objc, Tcl_Obj *const objv[]); 228 | static void pltcl_construct_errorCode(Tcl_Interp *interp, ErrorData *edata); 229 | static const char *pltcl_get_condition_name(int sqlstate); 230 | static int pltcl_quote(ClientData cdata, Tcl_Interp *interp, 231 | int objc, Tcl_Obj *const objv[]); 232 | static int pltcl_cancel_pending(ClientData cdata, Tcl_Interp *interp, 233 | int objc, Tcl_Obj *const objv[]); 234 | static int pltcl_argisnull(ClientData cdata, Tcl_Interp *interp, 235 | int objc, Tcl_Obj *const objv[]); 236 | static int pltcl_returnnull(ClientData cdata, Tcl_Interp *interp, 237 | int objc, Tcl_Obj *const objv[]); 238 | 239 | static int pltcl_SPI_execute(ClientData cdata, Tcl_Interp *interp, 240 | int objc, Tcl_Obj *const objv[]); 241 | static int pltcl_process_SPI_result(Tcl_Interp *interp, 242 | const char *arrayname, 243 | Tcl_Obj *loop_body, 244 | int spi_rc, 245 | SPITupleTable *tuptable, 246 | uint64 ntuples); 247 | static int pltcl_SPI_prepare(ClientData cdata, Tcl_Interp *interp, 248 | int objc, Tcl_Obj *const objv[]); 249 | static int pltcl_SPI_execute_plan(ClientData cdata, Tcl_Interp *interp, 250 | int objc, Tcl_Obj *const objv[]); 251 | static int pltcl_SPI_lastoid(ClientData cdata, Tcl_Interp *interp, 252 | int objc, Tcl_Obj *const objv[]); 253 | 254 | static void pltcl_set_tuple_values(Tcl_Interp *interp, const char *arrayname, 255 | uint64 tupno, HeapTuple tuple, TupleDesc tupdesc); 256 | static Tcl_Obj *pltcl_build_tuple_argument(HeapTuple tuple, TupleDesc tupdesc); 257 | 258 | 259 | /* 260 | * Hack to override Tcl's builtin Notifier subsystem. This prevents the 261 | * backend from becoming multithreaded, which breaks all sorts of things. 262 | * That happens in the default version of Tcl_InitNotifier if the TCL library 263 | * has been compiled with multithreading support (i.e. when TCL_THREADS is 264 | * defined under Unix, and in all cases under Windows). 265 | * It's okay to disable the notifier because we never enter the Tcl event loop 266 | * from Postgres, so the notifier capabilities are initialized, but never 267 | * used. Only InitNotifier and DeleteFileHandler ever seem to get called 268 | * within Postgres, but we implement all the functions for completeness. 269 | */ 270 | static ClientData 271 | pltcl_InitNotifier(void) 272 | { 273 | static int fakeThreadKey; /* To give valid address for ClientData */ 274 | 275 | return (ClientData) &(fakeThreadKey); 276 | } 277 | 278 | static void 279 | pltcl_FinalizeNotifier(ClientData clientData) 280 | { 281 | } 282 | 283 | static void 284 | pltcl_SetTimer(CONST86 Tcl_Time *timePtr) 285 | { 286 | } 287 | 288 | static void 289 | pltcl_AlertNotifier(ClientData clientData) 290 | { 291 | } 292 | 293 | static void 294 | pltcl_CreateFileHandler(int fd, int mask, 295 | Tcl_FileProc *proc, ClientData clientData) 296 | { 297 | } 298 | 299 | static void 300 | pltcl_DeleteFileHandler(int fd) 301 | { 302 | } 303 | 304 | static void 305 | pltcl_ServiceModeHook(int mode) 306 | { 307 | } 308 | 309 | static int 310 | pltcl_WaitForEvent(CONST86 Tcl_Time *timePtr) 311 | { 312 | return 0; 313 | } 314 | 315 | 316 | /* 317 | * This routine is a crock, and so is everyplace that calls it. The problem 318 | * is that the cached form of pltcl functions/queries is allocated permanently 319 | * (mostly via malloc()) and never released until backend exit. Subsidiary 320 | * data structures such as fmgr info records therefore must live forever 321 | * as well. A better implementation would store all this stuff in a per- 322 | * function memory context that could be reclaimed at need. In the meantime, 323 | * fmgr_info_cxt must be called specifying TopMemoryContext so that whatever 324 | * it might allocate, and whatever the eventual function might allocate using 325 | * fn_mcxt, will live forever too. 326 | */ 327 | static void 328 | perm_fmgr_info(Oid functionId, FmgrInfo *finfo) 329 | { 330 | fmgr_info_cxt(functionId, finfo, TopMemoryContext); 331 | } 332 | 333 | /* 334 | * _PG_init() - library load-time initialization 335 | * 336 | * DO NOT make this static nor change its name! 337 | * 338 | * The work done here must be safe to do in the postmaster process, 339 | * in case the pltcl library is preloaded in the postmaster. 340 | */ 341 | void 342 | _PG_init(void) 343 | { 344 | Tcl_NotifierProcs notifier; 345 | HASHCTL hash_ctl; 346 | 347 | /* Be sure we do initialization only once (should be redundant now) */ 348 | if (pltcl_pm_init_done) 349 | return; 350 | 351 | pg_bindtextdomain(TEXTDOMAIN); 352 | 353 | #ifdef WIN32 354 | /* Required on win32 to prevent error loading init.tcl */ 355 | Tcl_FindExecutable(""); 356 | #endif 357 | 358 | /* 359 | * Override the functions in the Notifier subsystem. See comments above. 360 | */ 361 | notifier.setTimerProc = pltcl_SetTimer; 362 | notifier.waitForEventProc = pltcl_WaitForEvent; 363 | notifier.createFileHandlerProc = pltcl_CreateFileHandler; 364 | notifier.deleteFileHandlerProc = pltcl_DeleteFileHandler; 365 | notifier.initNotifierProc = pltcl_InitNotifier; 366 | notifier.finalizeNotifierProc = pltcl_FinalizeNotifier; 367 | notifier.alertNotifierProc = pltcl_AlertNotifier; 368 | notifier.serviceModeHookProc = pltcl_ServiceModeHook; 369 | Tcl_SetNotifier(¬ifier); 370 | 371 | /************************************************************ 372 | * Create the dummy hold interpreter to prevent close of 373 | * stdout and stderr on DeleteInterp 374 | ************************************************************/ 375 | if ((pltcl_hold_interp = Tcl_CreateInterp()) == NULL) 376 | elog(ERROR, "could not create master Tcl interpreter"); 377 | if (Tcl_Init(pltcl_hold_interp) == TCL_ERROR) 378 | elog(ERROR, "could not initialize master Tcl interpreter"); 379 | 380 | /************************************************************ 381 | * Create the hash table for working interpreters 382 | ************************************************************/ 383 | memset(&hash_ctl, 0, sizeof(hash_ctl)); 384 | hash_ctl.keysize = sizeof(Oid); 385 | hash_ctl.entrysize = sizeof(pltcl_interp_desc); 386 | pltcl_interp_htab = hash_create("PL/Tcl interpreters", 387 | 8, 388 | &hash_ctl, 389 | HASH_ELEM | HASH_BLOBS); 390 | 391 | /************************************************************ 392 | * Create the hash table for function lookup 393 | ************************************************************/ 394 | memset(&hash_ctl, 0, sizeof(hash_ctl)); 395 | hash_ctl.keysize = sizeof(pltcl_proc_key); 396 | hash_ctl.entrysize = sizeof(pltcl_proc_ptr); 397 | pltcl_proc_htab = hash_create("PL/Tcl functions", 398 | 100, 399 | &hash_ctl, 400 | HASH_ELEM | HASH_BLOBS); 401 | 402 | pltcl_pm_init_done = true; 403 | } 404 | 405 | /********************************************************************** 406 | * pltcl_init_interp() - initialize a new Tcl interpreter 407 | **********************************************************************/ 408 | static void 409 | pltcl_init_interp(pltcl_interp_desc *interp_desc, bool pltrusted) 410 | { 411 | Tcl_Interp *interp; 412 | char interpname[32]; 413 | 414 | /************************************************************ 415 | * Create the Tcl interpreter as a slave of pltcl_hold_interp. 416 | * Note: Tcl automatically does Tcl_Init in the untrusted case, 417 | * and it's not wanted in the trusted case. 418 | ************************************************************/ 419 | snprintf(interpname, sizeof(interpname), "slave_%u", interp_desc->user_id); 420 | if ((interp = Tcl_CreateSlave(pltcl_hold_interp, interpname, 421 | pltrusted ? 1 : 0)) == NULL) 422 | elog(ERROR, "could not create slave Tcl interpreter"); 423 | interp_desc->interp = interp; 424 | 425 | /************************************************************ 426 | * Initialize the query hash table associated with interpreter 427 | ************************************************************/ 428 | Tcl_InitHashTable(&interp_desc->query_hash, TCL_STRING_KEYS); 429 | 430 | /************************************************************ 431 | * Install the commands for SPI support in the interpreter 432 | ************************************************************/ 433 | Tcl_CreateObjCommand(interp, "elog", 434 | pltcl_elog, NULL, NULL); 435 | Tcl_CreateObjCommand(interp, "quote", 436 | pltcl_quote, NULL, NULL); 437 | Tcl_CreateObjCommand(interp, "cancel_pending", 438 | pltcl_cancel_pending, NULL, NULL); 439 | Tcl_CreateObjCommand(interp, "argisnull", 440 | pltcl_argisnull, NULL, NULL); 441 | Tcl_CreateObjCommand(interp, "return_null", 442 | pltcl_returnnull, NULL, NULL); 443 | 444 | Tcl_CreateObjCommand(interp, "spi_exec", 445 | pltcl_SPI_execute, NULL, NULL); 446 | Tcl_CreateObjCommand(interp, "spi_prepare", 447 | pltcl_SPI_prepare, NULL, NULL); 448 | Tcl_CreateObjCommand(interp, "spi_execp", 449 | pltcl_SPI_execute_plan, NULL, NULL); 450 | Tcl_CreateObjCommand(interp, "spi_lastoid", 451 | pltcl_SPI_lastoid, NULL, NULL); 452 | } 453 | 454 | /********************************************************************** 455 | * pltcl_fetch_interp() - fetch the Tcl interpreter to use for a function 456 | * 457 | * This also takes care of any on-first-use initialization required. 458 | * Note: we assume caller has already connected to SPI. 459 | **********************************************************************/ 460 | static pltcl_interp_desc * 461 | pltcl_fetch_interp(bool pltrusted) 462 | { 463 | Oid user_id; 464 | pltcl_interp_desc *interp_desc; 465 | bool found; 466 | 467 | /* Find or create the interpreter hashtable entry for this userid */ 468 | if (pltrusted) 469 | user_id = GetUserId(); 470 | else 471 | user_id = InvalidOid; 472 | 473 | interp_desc = hash_search(pltcl_interp_htab, &user_id, 474 | HASH_ENTER, 475 | &found); 476 | if (!found) 477 | pltcl_init_interp(interp_desc, pltrusted); 478 | 479 | return interp_desc; 480 | } 481 | 482 | /********************************************************************** 483 | * pltcl_call_handler - This is the only visible function 484 | * of the PL interpreter. The PostgreSQL 485 | * function manager and trigger manager 486 | * call this function for execution of 487 | * PL/Tcl procedures. 488 | **********************************************************************/ 489 | PG_FUNCTION_INFO_V1(pltcl_call_handler); 490 | 491 | /* keep non-static */ 492 | Datum 493 | pltcl_call_handler(PG_FUNCTION_ARGS) 494 | { 495 | return pltcl_handler(fcinfo, true); 496 | } 497 | 498 | /* 499 | * Alternative handler for unsafe functions 500 | */ 501 | PG_FUNCTION_INFO_V1(pltclu_call_handler); 502 | 503 | /* keep non-static */ 504 | Datum 505 | pltclu_call_handler(PG_FUNCTION_ARGS) 506 | { 507 | return pltcl_handler(fcinfo, false); 508 | } 509 | 510 | 511 | static Datum 512 | pltcl_handler(PG_FUNCTION_ARGS, bool pltrusted) 513 | { 514 | Datum retval; 515 | FunctionCallInfo save_fcinfo; 516 | pltcl_proc_desc *save_prodesc; 517 | 518 | /* 519 | * Ensure that static pointers are saved/restored properly 520 | */ 521 | save_fcinfo = pltcl_current_fcinfo; 522 | save_prodesc = pltcl_current_prodesc; 523 | 524 | PG_TRY(); 525 | { 526 | /* 527 | * Determine if called as function or trigger and call appropriate 528 | * subhandler 529 | */ 530 | if (CALLED_AS_TRIGGER(fcinfo)) 531 | { 532 | pltcl_current_fcinfo = NULL; 533 | retval = PointerGetDatum(pltcl_trigger_handler(fcinfo, pltrusted)); 534 | } 535 | else if (CALLED_AS_EVENT_TRIGGER(fcinfo)) 536 | { 537 | pltcl_current_fcinfo = NULL; 538 | pltcl_event_trigger_handler(fcinfo, pltrusted); 539 | retval = (Datum) 0; 540 | } 541 | else 542 | { 543 | pltcl_current_fcinfo = fcinfo; 544 | retval = pltcl_func_handler(fcinfo, pltrusted); 545 | } 546 | } 547 | PG_CATCH(); 548 | { 549 | pltcl_current_fcinfo = save_fcinfo; 550 | pltcl_current_prodesc = save_prodesc; 551 | PG_RE_THROW(); 552 | } 553 | PG_END_TRY(); 554 | 555 | pltcl_current_fcinfo = save_fcinfo; 556 | pltcl_current_prodesc = save_prodesc; 557 | 558 | return retval; 559 | } 560 | 561 | 562 | /********************************************************************** 563 | * pltcl_func_handler() - Handler for regular function calls 564 | **********************************************************************/ 565 | static Datum 566 | pltcl_func_handler(PG_FUNCTION_ARGS, bool pltrusted) 567 | { 568 | pltcl_proc_desc *prodesc; 569 | Tcl_Interp *volatile interp; 570 | Tcl_Obj *tcl_cmd; 571 | int i; 572 | int tcl_rc; 573 | Datum retval; 574 | 575 | /* Connect to SPI manager */ 576 | if (SPI_connect() != SPI_OK_CONNECT) 577 | elog(ERROR, "could not connect to SPI manager"); 578 | 579 | /* Find or compile the function */ 580 | prodesc = compile_pltcl_function(fcinfo->flinfo->fn_oid, InvalidOid, 581 | false, pltrusted); 582 | 583 | pltcl_current_prodesc = prodesc; 584 | 585 | interp = prodesc->interp_desc->interp; 586 | 587 | /************************************************************ 588 | * Create the tcl command to call the internal 589 | * proc in the Tcl interpreter 590 | ************************************************************/ 591 | tcl_cmd = Tcl_NewObj(); 592 | Tcl_ListObjAppendElement(NULL, tcl_cmd, 593 | Tcl_NewStringObj(prodesc->internal_proname, -1)); 594 | 595 | /* We hold a refcount on tcl_cmd just to be sure it stays around */ 596 | Tcl_IncrRefCount(tcl_cmd); 597 | 598 | /************************************************************ 599 | * Add all call arguments to the command 600 | ************************************************************/ 601 | PG_TRY(); 602 | { 603 | for (i = 0; i < prodesc->nargs; i++) 604 | { 605 | if (prodesc->arg_is_rowtype[i]) 606 | { 607 | /************************************************** 608 | * For tuple values, add a list for 'array set ...' 609 | **************************************************/ 610 | if (fcinfo->argnull[i]) 611 | Tcl_ListObjAppendElement(NULL, tcl_cmd, Tcl_NewObj()); 612 | else 613 | { 614 | HeapTupleHeader td; 615 | Oid tupType; 616 | int32 tupTypmod; 617 | TupleDesc tupdesc; 618 | HeapTupleData tmptup; 619 | Tcl_Obj *list_tmp; 620 | 621 | td = DatumGetHeapTupleHeader(fcinfo->arg[i]); 622 | /* Extract rowtype info and find a tupdesc */ 623 | tupType = HeapTupleHeaderGetTypeId(td); 624 | tupTypmod = HeapTupleHeaderGetTypMod(td); 625 | tupdesc = lookup_rowtype_tupdesc(tupType, tupTypmod); 626 | /* Build a temporary HeapTuple control structure */ 627 | tmptup.t_len = HeapTupleHeaderGetDatumLength(td); 628 | tmptup.t_data = td; 629 | 630 | list_tmp = pltcl_build_tuple_argument(&tmptup, tupdesc); 631 | Tcl_ListObjAppendElement(NULL, tcl_cmd, list_tmp); 632 | 633 | ReleaseTupleDesc(tupdesc); 634 | } 635 | } 636 | else 637 | { 638 | /************************************************** 639 | * Single values are added as string element 640 | * of their external representation 641 | **************************************************/ 642 | if (fcinfo->argnull[i]) 643 | Tcl_ListObjAppendElement(NULL, tcl_cmd, Tcl_NewObj()); 644 | else 645 | { 646 | char *tmp; 647 | 648 | tmp = OutputFunctionCall(&prodesc->arg_out_func[i], 649 | fcinfo->arg[i]); 650 | UTF_BEGIN; 651 | Tcl_ListObjAppendElement(NULL, tcl_cmd, 652 | Tcl_NewStringObj(UTF_E2U(tmp), -1)); 653 | UTF_END; 654 | pfree(tmp); 655 | } 656 | } 657 | } 658 | } 659 | PG_CATCH(); 660 | { 661 | /* Release refcount to free tcl_cmd */ 662 | Tcl_DecrRefCount(tcl_cmd); 663 | PG_RE_THROW(); 664 | } 665 | PG_END_TRY(); 666 | 667 | /************************************************************ 668 | * Call the Tcl function 669 | * 670 | * We assume no PG error can be thrown directly from this call. 671 | ************************************************************/ 672 | tcl_rc = Tcl_EvalObjEx(interp, tcl_cmd, (TCL_EVAL_DIRECT | TCL_EVAL_GLOBAL)); 673 | 674 | /* Release refcount to free tcl_cmd (and all subsidiary objects) */ 675 | Tcl_DecrRefCount(tcl_cmd); 676 | 677 | /************************************************************ 678 | * Check for errors reported by Tcl. 679 | ************************************************************/ 680 | if (tcl_rc != TCL_OK) 681 | throw_tcl_error(interp, prodesc->user_proname); 682 | 683 | /************************************************************ 684 | * Disconnect from SPI manager and then create the return 685 | * value datum (if the input function does a palloc for it 686 | * this must not be allocated in the SPI memory context 687 | * because SPI_finish would free it). But don't try to call 688 | * the result_in_func if we've been told to return a NULL; 689 | * the Tcl result may not be a valid value of the result type 690 | * in that case. 691 | ************************************************************/ 692 | if (SPI_finish() != SPI_OK_FINISH) 693 | elog(ERROR, "SPI_finish() failed"); 694 | 695 | if (fcinfo->isnull) 696 | retval = InputFunctionCall(&prodesc->result_in_func, 697 | NULL, 698 | prodesc->result_typioparam, 699 | -1); 700 | else 701 | retval = InputFunctionCall(&prodesc->result_in_func, 702 | utf_u2e(Tcl_GetStringResult(interp)), 703 | prodesc->result_typioparam, 704 | -1); 705 | 706 | return retval; 707 | } 708 | 709 | 710 | /********************************************************************** 711 | * pltcl_trigger_handler() - Handler for trigger calls 712 | **********************************************************************/ 713 | static HeapTuple 714 | pltcl_trigger_handler(PG_FUNCTION_ARGS, bool pltrusted) 715 | { 716 | pltcl_proc_desc *prodesc; 717 | Tcl_Interp *volatile interp; 718 | TriggerData *trigdata = (TriggerData *) fcinfo->context; 719 | char *stroid; 720 | TupleDesc tupdesc; 721 | volatile HeapTuple rettup; 722 | Tcl_Obj *tcl_cmd; 723 | Tcl_Obj *tcl_trigtup; 724 | Tcl_Obj *tcl_newtup; 725 | int tcl_rc; 726 | int i; 727 | int *modattrs; 728 | Datum *modvalues; 729 | char *modnulls; 730 | int ret_numvals; 731 | const char *result; 732 | const char **ret_values; 733 | 734 | /* Connect to SPI manager */ 735 | if (SPI_connect() != SPI_OK_CONNECT) 736 | elog(ERROR, "could not connect to SPI manager"); 737 | 738 | /* Find or compile the function */ 739 | prodesc = compile_pltcl_function(fcinfo->flinfo->fn_oid, 740 | RelationGetRelid(trigdata->tg_relation), 741 | false, /* not an event trigger */ 742 | pltrusted); 743 | 744 | pltcl_current_prodesc = prodesc; 745 | 746 | interp = prodesc->interp_desc->interp; 747 | 748 | tupdesc = trigdata->tg_relation->rd_att; 749 | 750 | /************************************************************ 751 | * Create the tcl command to call the internal 752 | * proc in the interpreter 753 | ************************************************************/ 754 | tcl_cmd = Tcl_NewObj(); 755 | Tcl_IncrRefCount(tcl_cmd); 756 | 757 | PG_TRY(); 758 | { 759 | /* The procedure name (note this is all ASCII, so no utf_e2u) */ 760 | Tcl_ListObjAppendElement(NULL, tcl_cmd, 761 | Tcl_NewStringObj(prodesc->internal_proname, -1)); 762 | 763 | /* The trigger name for argument TG_name */ 764 | Tcl_ListObjAppendElement(NULL, tcl_cmd, 765 | Tcl_NewStringObj(utf_e2u(trigdata->tg_trigger->tgname), -1)); 766 | 767 | /* The oid of the trigger relation for argument TG_relid */ 768 | /* Consider not converting to a string for more performance? */ 769 | stroid = DatumGetCString(DirectFunctionCall1(oidout, 770 | ObjectIdGetDatum(trigdata->tg_relation->rd_id))); 771 | Tcl_ListObjAppendElement(NULL, tcl_cmd, 772 | Tcl_NewStringObj(stroid, -1)); 773 | pfree(stroid); 774 | 775 | /* The name of the table the trigger is acting on: TG_table_name */ 776 | stroid = SPI_getrelname(trigdata->tg_relation); 777 | Tcl_ListObjAppendElement(NULL, tcl_cmd, 778 | Tcl_NewStringObj(utf_e2u(stroid), -1)); 779 | pfree(stroid); 780 | 781 | /* The schema of the table the trigger is acting on: TG_table_schema */ 782 | stroid = SPI_getnspname(trigdata->tg_relation); 783 | Tcl_ListObjAppendElement(NULL, tcl_cmd, 784 | Tcl_NewStringObj(utf_e2u(stroid), -1)); 785 | pfree(stroid); 786 | 787 | /* A list of attribute names for argument TG_relatts */ 788 | tcl_trigtup = Tcl_NewObj(); 789 | Tcl_ListObjAppendElement(NULL, tcl_trigtup, Tcl_NewObj()); 790 | for (i = 0; i < tupdesc->natts; i++) 791 | { 792 | if (tupdesc->attrs[i]->attisdropped) 793 | Tcl_ListObjAppendElement(NULL, tcl_trigtup, Tcl_NewObj()); 794 | else 795 | Tcl_ListObjAppendElement(NULL, tcl_trigtup, 796 | Tcl_NewStringObj(utf_e2u(NameStr(tupdesc->attrs[i]->attname)), -1)); 797 | } 798 | Tcl_ListObjAppendElement(NULL, tcl_cmd, tcl_trigtup); 799 | 800 | /* The when part of the event for TG_when */ 801 | if (TRIGGER_FIRED_BEFORE(trigdata->tg_event)) 802 | Tcl_ListObjAppendElement(NULL, tcl_cmd, 803 | Tcl_NewStringObj("BEFORE", -1)); 804 | else if (TRIGGER_FIRED_AFTER(trigdata->tg_event)) 805 | Tcl_ListObjAppendElement(NULL, tcl_cmd, 806 | Tcl_NewStringObj("AFTER", -1)); 807 | else if (TRIGGER_FIRED_INSTEAD(trigdata->tg_event)) 808 | Tcl_ListObjAppendElement(NULL, tcl_cmd, 809 | Tcl_NewStringObj("INSTEAD OF", -1)); 810 | else 811 | elog(ERROR, "unrecognized WHEN tg_event: %u", trigdata->tg_event); 812 | 813 | /* The level part of the event for TG_level */ 814 | if (TRIGGER_FIRED_FOR_ROW(trigdata->tg_event)) 815 | { 816 | Tcl_ListObjAppendElement(NULL, tcl_cmd, 817 | Tcl_NewStringObj("ROW", -1)); 818 | 819 | /* Build the data list for the trigtuple */ 820 | tcl_trigtup = pltcl_build_tuple_argument(trigdata->tg_trigtuple, 821 | tupdesc); 822 | 823 | /* 824 | * Now the command part of the event for TG_op and data for NEW 825 | * and OLD 826 | */ 827 | if (TRIGGER_FIRED_BY_INSERT(trigdata->tg_event)) 828 | { 829 | Tcl_ListObjAppendElement(NULL, tcl_cmd, 830 | Tcl_NewStringObj("INSERT", -1)); 831 | 832 | Tcl_ListObjAppendElement(NULL, tcl_cmd, tcl_trigtup); 833 | Tcl_ListObjAppendElement(NULL, tcl_cmd, Tcl_NewObj()); 834 | 835 | rettup = trigdata->tg_trigtuple; 836 | } 837 | else if (TRIGGER_FIRED_BY_DELETE(trigdata->tg_event)) 838 | { 839 | Tcl_ListObjAppendElement(NULL, tcl_cmd, 840 | Tcl_NewStringObj("DELETE", -1)); 841 | 842 | Tcl_ListObjAppendElement(NULL, tcl_cmd, Tcl_NewObj()); 843 | Tcl_ListObjAppendElement(NULL, tcl_cmd, tcl_trigtup); 844 | 845 | rettup = trigdata->tg_trigtuple; 846 | } 847 | else if (TRIGGER_FIRED_BY_UPDATE(trigdata->tg_event)) 848 | { 849 | Tcl_ListObjAppendElement(NULL, tcl_cmd, 850 | Tcl_NewStringObj("UPDATE", -1)); 851 | 852 | tcl_newtup = pltcl_build_tuple_argument(trigdata->tg_newtuple, 853 | tupdesc); 854 | 855 | Tcl_ListObjAppendElement(NULL, tcl_cmd, tcl_newtup); 856 | Tcl_ListObjAppendElement(NULL, tcl_cmd, tcl_trigtup); 857 | 858 | rettup = trigdata->tg_newtuple; 859 | } 860 | else 861 | elog(ERROR, "unrecognized OP tg_event: %u", trigdata->tg_event); 862 | } 863 | else if (TRIGGER_FIRED_FOR_STATEMENT(trigdata->tg_event)) 864 | { 865 | Tcl_ListObjAppendElement(NULL, tcl_cmd, 866 | Tcl_NewStringObj("STATEMENT", -1)); 867 | 868 | if (TRIGGER_FIRED_BY_INSERT(trigdata->tg_event)) 869 | Tcl_ListObjAppendElement(NULL, tcl_cmd, 870 | Tcl_NewStringObj("INSERT", -1)); 871 | else if (TRIGGER_FIRED_BY_DELETE(trigdata->tg_event)) 872 | Tcl_ListObjAppendElement(NULL, tcl_cmd, 873 | Tcl_NewStringObj("DELETE", -1)); 874 | else if (TRIGGER_FIRED_BY_UPDATE(trigdata->tg_event)) 875 | Tcl_ListObjAppendElement(NULL, tcl_cmd, 876 | Tcl_NewStringObj("UPDATE", -1)); 877 | else if (TRIGGER_FIRED_BY_TRUNCATE(trigdata->tg_event)) 878 | Tcl_ListObjAppendElement(NULL, tcl_cmd, 879 | Tcl_NewStringObj("TRUNCATE", -1)); 880 | else 881 | elog(ERROR, "unrecognized OP tg_event: %u", trigdata->tg_event); 882 | 883 | Tcl_ListObjAppendElement(NULL, tcl_cmd, Tcl_NewObj()); 884 | Tcl_ListObjAppendElement(NULL, tcl_cmd, Tcl_NewObj()); 885 | 886 | rettup = (HeapTuple) NULL; 887 | } 888 | else 889 | elog(ERROR, "unrecognized LEVEL tg_event: %u", trigdata->tg_event); 890 | 891 | /* Finally append the arguments from CREATE TRIGGER */ 892 | for (i = 0; i < trigdata->tg_trigger->tgnargs; i++) 893 | Tcl_ListObjAppendElement(NULL, tcl_cmd, 894 | Tcl_NewStringObj(utf_e2u(trigdata->tg_trigger->tgargs[i]), -1)); 895 | 896 | } 897 | PG_CATCH(); 898 | { 899 | Tcl_DecrRefCount(tcl_cmd); 900 | PG_RE_THROW(); 901 | } 902 | PG_END_TRY(); 903 | 904 | /************************************************************ 905 | * Call the Tcl function 906 | * 907 | * We assume no PG error can be thrown directly from this call. 908 | ************************************************************/ 909 | tcl_rc = Tcl_EvalObjEx(interp, tcl_cmd, (TCL_EVAL_DIRECT | TCL_EVAL_GLOBAL)); 910 | 911 | /* Release refcount to free tcl_cmd (and all subsidiary objects) */ 912 | Tcl_DecrRefCount(tcl_cmd); 913 | 914 | /************************************************************ 915 | * Check for errors reported by Tcl. 916 | ************************************************************/ 917 | if (tcl_rc != TCL_OK) 918 | throw_tcl_error(interp, prodesc->user_proname); 919 | 920 | /************************************************************ 921 | * The return value from the procedure might be one of 922 | * the magic strings OK or SKIP or a list from array get. 923 | * We can check for OK or SKIP without worrying about encoding. 924 | ************************************************************/ 925 | if (SPI_finish() != SPI_OK_FINISH) 926 | elog(ERROR, "SPI_finish() failed"); 927 | 928 | result = Tcl_GetStringResult(interp); 929 | 930 | if (strcmp(result, "OK") == 0) 931 | return rettup; 932 | if (strcmp(result, "SKIP") == 0) 933 | return (HeapTuple) NULL; 934 | 935 | /************************************************************ 936 | * Convert the result value from the Tcl interpreter 937 | * and setup structures for SPI_modifytuple(); 938 | ************************************************************/ 939 | if (Tcl_SplitList(interp, result, 940 | &ret_numvals, &ret_values) != TCL_OK) 941 | ereport(ERROR, 942 | (errcode(ERRCODE_E_R_I_E_TRIGGER_PROTOCOL_VIOLATED), 943 | errmsg("could not split return value from trigger: %s", 944 | utf_u2e(Tcl_GetStringResult(interp))))); 945 | 946 | /* Use a TRY to ensure ret_values will get freed */ 947 | PG_TRY(); 948 | { 949 | if (ret_numvals % 2 != 0) 950 | ereport(ERROR, 951 | (errcode(ERRCODE_E_R_I_E_TRIGGER_PROTOCOL_VIOLATED), 952 | errmsg("trigger's return list must have even number of elements"))); 953 | 954 | modattrs = (int *) palloc(tupdesc->natts * sizeof(int)); 955 | modvalues = (Datum *) palloc(tupdesc->natts * sizeof(Datum)); 956 | for (i = 0; i < tupdesc->natts; i++) 957 | { 958 | modattrs[i] = i + 1; 959 | modvalues[i] = (Datum) NULL; 960 | } 961 | 962 | modnulls = palloc(tupdesc->natts); 963 | memset(modnulls, 'n', tupdesc->natts); 964 | 965 | for (i = 0; i < ret_numvals; i += 2) 966 | { 967 | char *ret_name = utf_u2e(ret_values[i]); 968 | char *ret_value = utf_u2e(ret_values[i + 1]); 969 | int attnum; 970 | Oid typinput; 971 | Oid typioparam; 972 | FmgrInfo finfo; 973 | 974 | /************************************************************ 975 | * Ignore ".tupno" pseudo elements (see pltcl_set_tuple_values) 976 | ************************************************************/ 977 | if (strcmp(ret_name, ".tupno") == 0) 978 | continue; 979 | 980 | /************************************************************ 981 | * Get the attribute number 982 | ************************************************************/ 983 | attnum = SPI_fnumber(tupdesc, ret_name); 984 | if (attnum == SPI_ERROR_NOATTRIBUTE) 985 | ereport(ERROR, 986 | (errcode(ERRCODE_UNDEFINED_COLUMN), 987 | errmsg("unrecognized attribute \"%s\"", 988 | ret_name))); 989 | if (attnum <= 0) 990 | ereport(ERROR, 991 | (errcode(ERRCODE_FEATURE_NOT_SUPPORTED), 992 | errmsg("cannot set system attribute \"%s\"", 993 | ret_name))); 994 | 995 | /************************************************************ 996 | * Ignore dropped columns 997 | ************************************************************/ 998 | if (tupdesc->attrs[attnum - 1]->attisdropped) 999 | continue; 1000 | 1001 | /************************************************************ 1002 | * Lookup the attribute type in the syscache 1003 | * for the input function 1004 | ************************************************************/ 1005 | getTypeInputInfo(tupdesc->attrs[attnum - 1]->atttypid, 1006 | &typinput, &typioparam); 1007 | fmgr_info(typinput, &finfo); 1008 | 1009 | /************************************************************ 1010 | * Set the attribute to NOT NULL and convert the contents 1011 | ************************************************************/ 1012 | modvalues[attnum - 1] = InputFunctionCall(&finfo, 1013 | ret_value, 1014 | typioparam, 1015 | tupdesc->attrs[attnum - 1]->atttypmod); 1016 | modnulls[attnum - 1] = ' '; 1017 | } 1018 | 1019 | rettup = SPI_modifytuple(trigdata->tg_relation, rettup, tupdesc->natts, 1020 | modattrs, modvalues, modnulls); 1021 | 1022 | pfree(modattrs); 1023 | pfree(modvalues); 1024 | pfree(modnulls); 1025 | 1026 | if (rettup == NULL) 1027 | elog(ERROR, "SPI_modifytuple() failed - RC = %d", SPI_result); 1028 | } 1029 | PG_CATCH(); 1030 | { 1031 | ckfree((char *) ret_values); 1032 | PG_RE_THROW(); 1033 | } 1034 | PG_END_TRY(); 1035 | ckfree((char *) ret_values); 1036 | 1037 | return rettup; 1038 | } 1039 | 1040 | /********************************************************************** 1041 | * pltcl_event_trigger_handler() - Handler for event trigger calls 1042 | **********************************************************************/ 1043 | static void 1044 | pltcl_event_trigger_handler(PG_FUNCTION_ARGS, bool pltrusted) 1045 | { 1046 | pltcl_proc_desc *prodesc; 1047 | Tcl_Interp *volatile interp; 1048 | EventTriggerData *tdata = (EventTriggerData *) fcinfo->context; 1049 | Tcl_Obj *tcl_cmd; 1050 | int tcl_rc; 1051 | 1052 | /* Connect to SPI manager */ 1053 | if (SPI_connect() != SPI_OK_CONNECT) 1054 | elog(ERROR, "could not connect to SPI manager"); 1055 | 1056 | /* Find or compile the function */ 1057 | prodesc = compile_pltcl_function(fcinfo->flinfo->fn_oid, 1058 | InvalidOid, true, pltrusted); 1059 | 1060 | pltcl_current_prodesc = prodesc; 1061 | 1062 | interp = prodesc->interp_desc->interp; 1063 | 1064 | /* Create the tcl command and call the internal proc */ 1065 | tcl_cmd = Tcl_NewObj(); 1066 | Tcl_IncrRefCount(tcl_cmd); 1067 | Tcl_ListObjAppendElement(NULL, tcl_cmd, 1068 | Tcl_NewStringObj(prodesc->internal_proname, -1)); 1069 | Tcl_ListObjAppendElement(NULL, tcl_cmd, 1070 | Tcl_NewStringObj(utf_e2u(tdata->event), -1)); 1071 | Tcl_ListObjAppendElement(NULL, tcl_cmd, 1072 | Tcl_NewStringObj(utf_e2u(tdata->tag), -1)); 1073 | 1074 | tcl_rc = Tcl_EvalObjEx(interp, tcl_cmd, (TCL_EVAL_DIRECT | TCL_EVAL_GLOBAL)); 1075 | 1076 | /* Release refcount to free tcl_cmd (and all subsidiary objects) */ 1077 | Tcl_DecrRefCount(tcl_cmd); 1078 | 1079 | /* Check for errors reported by Tcl. */ 1080 | if (tcl_rc != TCL_OK) 1081 | throw_tcl_error(interp, prodesc->user_proname); 1082 | 1083 | if (SPI_finish() != SPI_OK_FINISH) 1084 | elog(ERROR, "SPI_finish() failed"); 1085 | } 1086 | 1087 | 1088 | /********************************************************************** 1089 | * throw_tcl_error - ereport an error returned from the Tcl interpreter 1090 | **********************************************************************/ 1091 | static void 1092 | throw_tcl_error(Tcl_Interp *interp, const char *proname) 1093 | { 1094 | /* 1095 | * Caution is needed here because Tcl_GetVar could overwrite the 1096 | * interpreter result (even though it's not really supposed to), and we 1097 | * can't control the order of evaluation of ereport arguments. Hence, make 1098 | * real sure we have our own copy of the result string before invoking 1099 | * Tcl_GetVar. 1100 | */ 1101 | char *emsg; 1102 | char *econtext; 1103 | 1104 | emsg = pstrdup(utf_u2e(Tcl_GetStringResult(interp))); 1105 | econtext = utf_u2e(Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY)); 1106 | ereport(ERROR, 1107 | (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION), 1108 | errmsg("%s", emsg), 1109 | errcontext("%s\nin PL/Tcl function \"%s\"", 1110 | econtext, proname))); 1111 | } 1112 | 1113 | 1114 | /********************************************************************** 1115 | * compile_pltcl_function - compile (or hopefully just look up) function 1116 | * 1117 | * tgreloid is the OID of the relation when compiling a trigger, or zero 1118 | * (InvalidOid) when compiling a plain function. 1119 | **********************************************************************/ 1120 | static pltcl_proc_desc * 1121 | compile_pltcl_function(Oid fn_oid, Oid tgreloid, 1122 | bool is_event_trigger, bool pltrusted) 1123 | { 1124 | HeapTuple procTup; 1125 | Form_pg_proc procStruct; 1126 | pltcl_proc_key proc_key; 1127 | pltcl_proc_ptr *proc_ptr; 1128 | bool found; 1129 | pltcl_proc_desc *prodesc; 1130 | 1131 | /* We'll need the pg_proc tuple in any case... */ 1132 | procTup = SearchSysCache1(PROCOID, ObjectIdGetDatum(fn_oid)); 1133 | if (!HeapTupleIsValid(procTup)) 1134 | elog(ERROR, "cache lookup failed for function %u", fn_oid); 1135 | procStruct = (Form_pg_proc) GETSTRUCT(procTup); 1136 | 1137 | /* Try to find function in pltcl_proc_htab */ 1138 | proc_key.proc_id = fn_oid; 1139 | proc_key.is_trigger = OidIsValid(tgreloid); 1140 | proc_key.user_id = pltrusted ? GetUserId() : InvalidOid; 1141 | 1142 | proc_ptr = hash_search(pltcl_proc_htab, &proc_key, 1143 | HASH_ENTER, 1144 | &found); 1145 | if (!found) 1146 | proc_ptr->proc_ptr = NULL; 1147 | 1148 | prodesc = proc_ptr->proc_ptr; 1149 | 1150 | /************************************************************ 1151 | * If it's present, must check whether it's still up to date. 1152 | * This is needed because CREATE OR REPLACE FUNCTION can modify the 1153 | * function's pg_proc entry without changing its OID. 1154 | ************************************************************/ 1155 | if (prodesc != NULL) 1156 | { 1157 | bool uptodate; 1158 | 1159 | uptodate = (prodesc->fn_xmin == HeapTupleHeaderGetRawXmin(procTup->t_data) && 1160 | ItemPointerEquals(&prodesc->fn_tid, &procTup->t_self)); 1161 | 1162 | if (!uptodate) 1163 | { 1164 | proc_ptr->proc_ptr = NULL; 1165 | prodesc = NULL; 1166 | } 1167 | } 1168 | 1169 | /************************************************************ 1170 | * If we haven't found it in the hashtable, we analyze 1171 | * the functions arguments and returntype and store 1172 | * the in-/out-functions in the prodesc block and create 1173 | * a new hashtable entry for it. 1174 | * 1175 | * Then we load the procedure into the Tcl interpreter. 1176 | ************************************************************/ 1177 | if (prodesc == NULL) 1178 | { 1179 | bool is_trigger = OidIsValid(tgreloid); 1180 | char internal_proname[128]; 1181 | HeapTuple typeTup; 1182 | Form_pg_type typeStruct; 1183 | Tcl_DString proc_internal_def; 1184 | Tcl_DString proc_internal_body; 1185 | char proc_internal_args[33 * FUNC_MAX_ARGS]; 1186 | Datum prosrcdatum; 1187 | bool isnull; 1188 | char *proc_source; 1189 | char buf[32]; 1190 | Tcl_Interp *interp; 1191 | int i; 1192 | int tcl_rc; 1193 | 1194 | /************************************************************ 1195 | * Build our internal proc name from the function's Oid. Append 1196 | * "_trigger" when appropriate to ensure the normal and trigger 1197 | * cases are kept separate. Note name must be all-ASCII. 1198 | ************************************************************/ 1199 | if (!is_trigger && !is_event_trigger) 1200 | snprintf(internal_proname, sizeof(internal_proname), 1201 | "__PLTcl_proc_%u", fn_oid); 1202 | else if (is_event_trigger) 1203 | snprintf(internal_proname, sizeof(internal_proname), 1204 | "__PLTcl_proc_%u_evttrigger", fn_oid); 1205 | else if (is_trigger) 1206 | snprintf(internal_proname, sizeof(internal_proname), 1207 | "__PLTcl_proc_%u_trigger", fn_oid); 1208 | 1209 | /************************************************************ 1210 | * Allocate a new procedure description block 1211 | ************************************************************/ 1212 | prodesc = (pltcl_proc_desc *) malloc(sizeof(pltcl_proc_desc)); 1213 | if (prodesc == NULL) 1214 | ereport(ERROR, 1215 | (errcode(ERRCODE_OUT_OF_MEMORY), 1216 | errmsg("out of memory"))); 1217 | MemSet(prodesc, 0, sizeof(pltcl_proc_desc)); 1218 | prodesc->user_proname = strdup(NameStr(procStruct->proname)); 1219 | prodesc->internal_proname = strdup(internal_proname); 1220 | if (prodesc->user_proname == NULL || prodesc->internal_proname == NULL) 1221 | ereport(ERROR, 1222 | (errcode(ERRCODE_OUT_OF_MEMORY), 1223 | errmsg("out of memory"))); 1224 | prodesc->fn_xmin = HeapTupleHeaderGetRawXmin(procTup->t_data); 1225 | prodesc->fn_tid = procTup->t_self; 1226 | 1227 | /* Remember if function is STABLE/IMMUTABLE */ 1228 | prodesc->fn_readonly = 1229 | (procStruct->provolatile != PROVOLATILE_VOLATILE); 1230 | /* And whether it is trusted */ 1231 | prodesc->lanpltrusted = pltrusted; 1232 | 1233 | /************************************************************ 1234 | * Identify the interpreter to use for the function 1235 | ************************************************************/ 1236 | prodesc->interp_desc = pltcl_fetch_interp(prodesc->lanpltrusted); 1237 | interp = prodesc->interp_desc->interp; 1238 | 1239 | /************************************************************ 1240 | * Get the required information for input conversion of the 1241 | * return value. 1242 | ************************************************************/ 1243 | if (!is_trigger && !is_event_trigger) 1244 | { 1245 | typeTup = 1246 | SearchSysCache1(TYPEOID, 1247 | ObjectIdGetDatum(procStruct->prorettype)); 1248 | if (!HeapTupleIsValid(typeTup)) 1249 | { 1250 | free(prodesc->user_proname); 1251 | free(prodesc->internal_proname); 1252 | free(prodesc); 1253 | elog(ERROR, "cache lookup failed for type %u", 1254 | procStruct->prorettype); 1255 | } 1256 | typeStruct = (Form_pg_type) GETSTRUCT(typeTup); 1257 | 1258 | /* Disallow pseudotype result, except VOID */ 1259 | if (typeStruct->typtype == TYPTYPE_PSEUDO) 1260 | { 1261 | if (procStruct->prorettype == VOIDOID) 1262 | /* okay */ ; 1263 | else if (procStruct->prorettype == TRIGGEROID || 1264 | procStruct->prorettype == EVTTRIGGEROID) 1265 | { 1266 | free(prodesc->user_proname); 1267 | free(prodesc->internal_proname); 1268 | free(prodesc); 1269 | ereport(ERROR, 1270 | (errcode(ERRCODE_FEATURE_NOT_SUPPORTED), 1271 | errmsg("trigger functions can only be called as triggers"))); 1272 | } 1273 | else 1274 | { 1275 | free(prodesc->user_proname); 1276 | free(prodesc->internal_proname); 1277 | free(prodesc); 1278 | ereport(ERROR, 1279 | (errcode(ERRCODE_FEATURE_NOT_SUPPORTED), 1280 | errmsg("PL/Tcl functions cannot return type %s", 1281 | format_type_be(procStruct->prorettype)))); 1282 | } 1283 | } 1284 | 1285 | if (typeStruct->typtype == TYPTYPE_COMPOSITE) 1286 | { 1287 | free(prodesc->user_proname); 1288 | free(prodesc->internal_proname); 1289 | free(prodesc); 1290 | ereport(ERROR, 1291 | (errcode(ERRCODE_FEATURE_NOT_SUPPORTED), 1292 | errmsg("PL/Tcl functions cannot return composite types"))); 1293 | } 1294 | 1295 | perm_fmgr_info(typeStruct->typinput, &(prodesc->result_in_func)); 1296 | prodesc->result_typioparam = getTypeIOParam(typeTup); 1297 | 1298 | ReleaseSysCache(typeTup); 1299 | } 1300 | 1301 | /************************************************************ 1302 | * Get the required information for output conversion 1303 | * of all procedure arguments 1304 | ************************************************************/ 1305 | if (!is_trigger && !is_event_trigger) 1306 | { 1307 | prodesc->nargs = procStruct->pronargs; 1308 | proc_internal_args[0] = '\0'; 1309 | for (i = 0; i < prodesc->nargs; i++) 1310 | { 1311 | typeTup = SearchSysCache1(TYPEOID, 1312 | ObjectIdGetDatum(procStruct->proargtypes.values[i])); 1313 | if (!HeapTupleIsValid(typeTup)) 1314 | { 1315 | free(prodesc->user_proname); 1316 | free(prodesc->internal_proname); 1317 | free(prodesc); 1318 | elog(ERROR, "cache lookup failed for type %u", 1319 | procStruct->proargtypes.values[i]); 1320 | } 1321 | typeStruct = (Form_pg_type) GETSTRUCT(typeTup); 1322 | 1323 | /* Disallow pseudotype argument */ 1324 | if (typeStruct->typtype == TYPTYPE_PSEUDO) 1325 | { 1326 | free(prodesc->user_proname); 1327 | free(prodesc->internal_proname); 1328 | free(prodesc); 1329 | ereport(ERROR, 1330 | (errcode(ERRCODE_FEATURE_NOT_SUPPORTED), 1331 | errmsg("PL/Tcl functions cannot accept type %s", 1332 | format_type_be(procStruct->proargtypes.values[i])))); 1333 | } 1334 | 1335 | if (typeStruct->typtype == TYPTYPE_COMPOSITE) 1336 | { 1337 | prodesc->arg_is_rowtype[i] = true; 1338 | snprintf(buf, sizeof(buf), "__PLTcl_Tup_%d", i + 1); 1339 | } 1340 | else 1341 | { 1342 | prodesc->arg_is_rowtype[i] = false; 1343 | perm_fmgr_info(typeStruct->typoutput, 1344 | &(prodesc->arg_out_func[i])); 1345 | snprintf(buf, sizeof(buf), "%d", i + 1); 1346 | } 1347 | 1348 | if (i > 0) 1349 | strcat(proc_internal_args, " "); 1350 | strcat(proc_internal_args, buf); 1351 | 1352 | ReleaseSysCache(typeTup); 1353 | } 1354 | } 1355 | else if (is_trigger) 1356 | { 1357 | /* trigger procedure has fixed args */ 1358 | strcpy(proc_internal_args, 1359 | "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"); 1360 | } 1361 | else if (is_event_trigger) 1362 | { 1363 | /* event trigger procedure has fixed args */ 1364 | strcpy(proc_internal_args, "TG_event TG_tag"); 1365 | } 1366 | 1367 | /************************************************************ 1368 | * Create the tcl command to define the internal 1369 | * procedure 1370 | * 1371 | * leave this code as DString - it's a text processing function 1372 | * that only gets invoked when the tcl function is invoked 1373 | * for the first time 1374 | ************************************************************/ 1375 | Tcl_DStringInit(&proc_internal_def); 1376 | Tcl_DStringInit(&proc_internal_body); 1377 | Tcl_DStringAppendElement(&proc_internal_def, "proc"); 1378 | Tcl_DStringAppendElement(&proc_internal_def, internal_proname); 1379 | Tcl_DStringAppendElement(&proc_internal_def, proc_internal_args); 1380 | 1381 | /************************************************************ 1382 | * prefix procedure body with 1383 | * upvar #0 GD 1384 | * and with appropriate setting of arguments 1385 | ************************************************************/ 1386 | Tcl_DStringAppend(&proc_internal_body, "upvar #0 ", -1); 1387 | Tcl_DStringAppend(&proc_internal_body, internal_proname, -1); 1388 | Tcl_DStringAppend(&proc_internal_body, " GD\n", -1); 1389 | if (is_trigger) 1390 | { 1391 | Tcl_DStringAppend(&proc_internal_body, 1392 | "array set NEW $__PLTcl_Tup_NEW\n", -1); 1393 | Tcl_DStringAppend(&proc_internal_body, 1394 | "array set OLD $__PLTcl_Tup_OLD\n", -1); 1395 | 1396 | Tcl_DStringAppend(&proc_internal_body, 1397 | "set i 0\n" 1398 | "set v 0\n" 1399 | "foreach v $args {\n" 1400 | " incr i\n" 1401 | " set $i $v\n" 1402 | "}\n" 1403 | "unset i v\n\n", -1); 1404 | } 1405 | else if (is_event_trigger) 1406 | { 1407 | /* no argument support for event triggers */ 1408 | } 1409 | else 1410 | { 1411 | for (i = 0; i < prodesc->nargs; i++) 1412 | { 1413 | if (prodesc->arg_is_rowtype[i]) 1414 | { 1415 | snprintf(buf, sizeof(buf), 1416 | "array set %d $__PLTcl_Tup_%d\n", 1417 | i + 1, i + 1); 1418 | Tcl_DStringAppend(&proc_internal_body, buf, -1); 1419 | } 1420 | } 1421 | } 1422 | 1423 | /************************************************************ 1424 | * Add user's function definition to proc body 1425 | ************************************************************/ 1426 | prosrcdatum = SysCacheGetAttr(PROCOID, procTup, 1427 | Anum_pg_proc_prosrc, &isnull); 1428 | if (isnull) 1429 | elog(ERROR, "null prosrc"); 1430 | proc_source = TextDatumGetCString(prosrcdatum); 1431 | UTF_BEGIN; 1432 | Tcl_DStringAppend(&proc_internal_body, UTF_E2U(proc_source), -1); 1433 | UTF_END; 1434 | pfree(proc_source); 1435 | Tcl_DStringAppendElement(&proc_internal_def, 1436 | Tcl_DStringValue(&proc_internal_body)); 1437 | Tcl_DStringFree(&proc_internal_body); 1438 | 1439 | /************************************************************ 1440 | * Create the procedure in the interpreter 1441 | ************************************************************/ 1442 | tcl_rc = Tcl_EvalEx(interp, 1443 | Tcl_DStringValue(&proc_internal_def), 1444 | Tcl_DStringLength(&proc_internal_def), 1445 | TCL_EVAL_GLOBAL); 1446 | Tcl_DStringFree(&proc_internal_def); 1447 | if (tcl_rc != TCL_OK) 1448 | { 1449 | free(prodesc->user_proname); 1450 | free(prodesc->internal_proname); 1451 | free(prodesc); 1452 | ereport(ERROR, 1453 | (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION), 1454 | errmsg("could not create internal procedure \"%s\": %s", 1455 | internal_proname, 1456 | utf_u2e(Tcl_GetStringResult(interp))))); 1457 | } 1458 | 1459 | /************************************************************ 1460 | * Add the proc description block to the hashtable. Note we do not 1461 | * attempt to free any previously existing prodesc block. This is 1462 | * annoying, but necessary since there could be active calls using 1463 | * the old prodesc. 1464 | ************************************************************/ 1465 | proc_ptr->proc_ptr = prodesc; 1466 | } 1467 | 1468 | ReleaseSysCache(procTup); 1469 | 1470 | return prodesc; 1471 | } 1472 | 1473 | 1474 | /********************************************************************** 1475 | * pltcl_elog() - elog() support for PLTcl 1476 | **********************************************************************/ 1477 | static int 1478 | pltcl_elog(ClientData cdata, Tcl_Interp *interp, 1479 | int objc, Tcl_Obj *const objv[]) 1480 | { 1481 | volatile int level; 1482 | MemoryContext oldcontext; 1483 | int priIndex; 1484 | 1485 | static const char *logpriorities[] = { 1486 | "DEBUG", "LOG", "INFO", "NOTICE", 1487 | "WARNING", "ERROR", "FATAL", (const char *) NULL 1488 | }; 1489 | 1490 | static const int loglevels[] = { 1491 | DEBUG2, LOG, INFO, NOTICE, 1492 | WARNING, ERROR, FATAL 1493 | }; 1494 | 1495 | if (objc != 3) 1496 | { 1497 | Tcl_WrongNumArgs(interp, 1, objv, "level msg"); 1498 | return TCL_ERROR; 1499 | } 1500 | 1501 | if (Tcl_GetIndexFromObj(interp, objv[1], logpriorities, "priority", 1502 | TCL_EXACT, &priIndex) != TCL_OK) 1503 | return TCL_ERROR; 1504 | 1505 | level = loglevels[priIndex]; 1506 | 1507 | if (level == ERROR) 1508 | { 1509 | /* 1510 | * We just pass the error back to Tcl. If it's not caught, it'll 1511 | * eventually get converted to a PG error when we reach the call 1512 | * handler. 1513 | */ 1514 | Tcl_SetObjResult(interp, objv[2]); 1515 | return TCL_ERROR; 1516 | } 1517 | 1518 | /* 1519 | * For non-error messages, just pass 'em to ereport(). We do not expect 1520 | * that this will fail, but just on the off chance it does, report the 1521 | * error back to Tcl. Note we are assuming that ereport() can't have any 1522 | * internal failures that are so bad as to require a transaction abort. 1523 | * 1524 | * This path is also used for FATAL errors, which aren't going to come 1525 | * back to us at all. 1526 | */ 1527 | oldcontext = CurrentMemoryContext; 1528 | PG_TRY(); 1529 | { 1530 | UTF_BEGIN; 1531 | ereport(level, 1532 | (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION), 1533 | errmsg("%s", UTF_U2E(Tcl_GetString(objv[2]))))); 1534 | UTF_END; 1535 | } 1536 | PG_CATCH(); 1537 | { 1538 | ErrorData *edata; 1539 | 1540 | /* Must reset elog.c's state */ 1541 | MemoryContextSwitchTo(oldcontext); 1542 | edata = CopyErrorData(); 1543 | FlushErrorState(); 1544 | 1545 | /* Pass the error data to Tcl */ 1546 | pltcl_construct_errorCode(interp, edata); 1547 | UTF_BEGIN; 1548 | Tcl_SetObjResult(interp, Tcl_NewStringObj(UTF_E2U(edata->message), -1)); 1549 | UTF_END; 1550 | FreeErrorData(edata); 1551 | 1552 | return TCL_ERROR; 1553 | } 1554 | PG_END_TRY(); 1555 | 1556 | return TCL_OK; 1557 | } 1558 | 1559 | 1560 | /********************************************************************** 1561 | * pltcl_construct_errorCode() - construct a Tcl errorCode 1562 | * list with detailed information from the PostgreSQL server 1563 | **********************************************************************/ 1564 | static void 1565 | pltcl_construct_errorCode(Tcl_Interp *interp, ErrorData *edata) 1566 | { 1567 | Tcl_Obj *obj = Tcl_NewObj(); 1568 | 1569 | Tcl_ListObjAppendElement(interp, obj, 1570 | Tcl_NewStringObj("POSTGRES", -1)); 1571 | Tcl_ListObjAppendElement(interp, obj, 1572 | Tcl_NewStringObj(PG_VERSION, -1)); 1573 | Tcl_ListObjAppendElement(interp, obj, 1574 | Tcl_NewStringObj("SQLSTATE", -1)); 1575 | Tcl_ListObjAppendElement(interp, obj, 1576 | Tcl_NewStringObj(unpack_sql_state(edata->sqlerrcode), -1)); 1577 | Tcl_ListObjAppendElement(interp, obj, 1578 | Tcl_NewStringObj("condition", -1)); 1579 | Tcl_ListObjAppendElement(interp, obj, 1580 | Tcl_NewStringObj(pltcl_get_condition_name(edata->sqlerrcode), -1)); 1581 | Tcl_ListObjAppendElement(interp, obj, 1582 | Tcl_NewStringObj("message", -1)); 1583 | UTF_BEGIN; 1584 | Tcl_ListObjAppendElement(interp, obj, 1585 | Tcl_NewStringObj(UTF_E2U(edata->message), -1)); 1586 | UTF_END; 1587 | if (edata->detail) 1588 | { 1589 | Tcl_ListObjAppendElement(interp, obj, 1590 | Tcl_NewStringObj("detail", -1)); 1591 | UTF_BEGIN; 1592 | Tcl_ListObjAppendElement(interp, obj, 1593 | Tcl_NewStringObj(UTF_E2U(edata->detail), -1)); 1594 | UTF_END; 1595 | } 1596 | if (edata->hint) 1597 | { 1598 | Tcl_ListObjAppendElement(interp, obj, 1599 | Tcl_NewStringObj("hint", -1)); 1600 | UTF_BEGIN; 1601 | Tcl_ListObjAppendElement(interp, obj, 1602 | Tcl_NewStringObj(UTF_E2U(edata->hint), -1)); 1603 | UTF_END; 1604 | } 1605 | if (edata->context) 1606 | { 1607 | Tcl_ListObjAppendElement(interp, obj, 1608 | Tcl_NewStringObj("context", -1)); 1609 | UTF_BEGIN; 1610 | Tcl_ListObjAppendElement(interp, obj, 1611 | Tcl_NewStringObj(UTF_E2U(edata->context), -1)); 1612 | UTF_END; 1613 | } 1614 | if (edata->schema_name) 1615 | { 1616 | Tcl_ListObjAppendElement(interp, obj, 1617 | Tcl_NewStringObj("schema", -1)); 1618 | UTF_BEGIN; 1619 | Tcl_ListObjAppendElement(interp, obj, 1620 | Tcl_NewStringObj(UTF_E2U(edata->schema_name), -1)); 1621 | UTF_END; 1622 | } 1623 | if (edata->table_name) 1624 | { 1625 | Tcl_ListObjAppendElement(interp, obj, 1626 | Tcl_NewStringObj("table", -1)); 1627 | UTF_BEGIN; 1628 | Tcl_ListObjAppendElement(interp, obj, 1629 | Tcl_NewStringObj(UTF_E2U(edata->table_name), -1)); 1630 | UTF_END; 1631 | } 1632 | if (edata->column_name) 1633 | { 1634 | Tcl_ListObjAppendElement(interp, obj, 1635 | Tcl_NewStringObj("column", -1)); 1636 | UTF_BEGIN; 1637 | Tcl_ListObjAppendElement(interp, obj, 1638 | Tcl_NewStringObj(UTF_E2U(edata->column_name), -1)); 1639 | UTF_END; 1640 | } 1641 | if (edata->datatype_name) 1642 | { 1643 | Tcl_ListObjAppendElement(interp, obj, 1644 | Tcl_NewStringObj("datatype", -1)); 1645 | UTF_BEGIN; 1646 | Tcl_ListObjAppendElement(interp, obj, 1647 | Tcl_NewStringObj(UTF_E2U(edata->datatype_name), -1)); 1648 | UTF_END; 1649 | } 1650 | if (edata->constraint_name) 1651 | { 1652 | Tcl_ListObjAppendElement(interp, obj, 1653 | Tcl_NewStringObj("constraint", -1)); 1654 | UTF_BEGIN; 1655 | Tcl_ListObjAppendElement(interp, obj, 1656 | Tcl_NewStringObj(UTF_E2U(edata->constraint_name), -1)); 1657 | UTF_END; 1658 | } 1659 | /* cursorpos is never interesting here; report internal query/pos */ 1660 | if (edata->internalquery) 1661 | { 1662 | Tcl_ListObjAppendElement(interp, obj, 1663 | Tcl_NewStringObj("statement", -1)); 1664 | UTF_BEGIN; 1665 | Tcl_ListObjAppendElement(interp, obj, 1666 | Tcl_NewStringObj(UTF_E2U(edata->internalquery), -1)); 1667 | UTF_END; 1668 | } 1669 | if (edata->internalpos > 0) 1670 | { 1671 | Tcl_ListObjAppendElement(interp, obj, 1672 | Tcl_NewStringObj("cursor_position", -1)); 1673 | Tcl_ListObjAppendElement(interp, obj, 1674 | Tcl_NewIntObj(edata->internalpos)); 1675 | } 1676 | if (edata->filename) 1677 | { 1678 | Tcl_ListObjAppendElement(interp, obj, 1679 | Tcl_NewStringObj("filename", -1)); 1680 | UTF_BEGIN; 1681 | Tcl_ListObjAppendElement(interp, obj, 1682 | Tcl_NewStringObj(UTF_E2U(edata->filename), -1)); 1683 | UTF_END; 1684 | } 1685 | if (edata->lineno > 0) 1686 | { 1687 | Tcl_ListObjAppendElement(interp, obj, 1688 | Tcl_NewStringObj("lineno", -1)); 1689 | Tcl_ListObjAppendElement(interp, obj, 1690 | Tcl_NewIntObj(edata->lineno)); 1691 | } 1692 | if (edata->funcname) 1693 | { 1694 | Tcl_ListObjAppendElement(interp, obj, 1695 | Tcl_NewStringObj("funcname", -1)); 1696 | UTF_BEGIN; 1697 | Tcl_ListObjAppendElement(interp, obj, 1698 | Tcl_NewStringObj(UTF_E2U(edata->funcname), -1)); 1699 | UTF_END; 1700 | } 1701 | 1702 | Tcl_SetObjErrorCode(interp, obj); 1703 | } 1704 | 1705 | 1706 | /********************************************************************** 1707 | * pltcl_get_condition_name() - find name for SQLSTATE 1708 | **********************************************************************/ 1709 | static const char * 1710 | pltcl_get_condition_name(int sqlstate) 1711 | { 1712 | int i; 1713 | 1714 | for (i = 0; exception_name_map[i].label != NULL; i++) 1715 | { 1716 | if (exception_name_map[i].sqlerrstate == sqlstate) 1717 | return exception_name_map[i].label; 1718 | } 1719 | return "unrecognized_sqlstate"; 1720 | } 1721 | 1722 | 1723 | /********************************************************************** 1724 | * pltcl_quote() - quote literal strings that are to 1725 | * be used in SPI_execute query strings 1726 | **********************************************************************/ 1727 | static int 1728 | pltcl_quote(ClientData cdata, Tcl_Interp *interp, 1729 | int objc, Tcl_Obj *const objv[]) 1730 | { 1731 | char *tmp; 1732 | const char *cp1; 1733 | char *cp2; 1734 | int length; 1735 | 1736 | /************************************************************ 1737 | * Check call syntax 1738 | ************************************************************/ 1739 | if (objc != 2) 1740 | { 1741 | Tcl_WrongNumArgs(interp, 1, objv, "string"); 1742 | return TCL_ERROR; 1743 | } 1744 | 1745 | /************************************************************ 1746 | * Allocate space for the maximum the string can 1747 | * grow to and initialize pointers 1748 | ************************************************************/ 1749 | cp1 = Tcl_GetStringFromObj(objv[1], &length); 1750 | tmp = palloc(length * 2 + 1); 1751 | cp2 = tmp; 1752 | 1753 | /************************************************************ 1754 | * Walk through string and double every quote and backslash 1755 | ************************************************************/ 1756 | while (*cp1) 1757 | { 1758 | if (*cp1 == '\'') 1759 | *cp2++ = '\''; 1760 | else 1761 | { 1762 | if (*cp1 == '\\') 1763 | *cp2++ = '\\'; 1764 | } 1765 | *cp2++ = *cp1++; 1766 | } 1767 | 1768 | /************************************************************ 1769 | * Terminate the string and set it as result 1770 | ************************************************************/ 1771 | *cp2 = '\0'; 1772 | Tcl_SetObjResult(interp, Tcl_NewStringObj(tmp, -1)); 1773 | pfree(tmp); 1774 | return TCL_OK; 1775 | } 1776 | 1777 | 1778 | /********************************************************************** 1779 | * pltcl_argisnull() - determine if a specific argument is NULL 1780 | **********************************************************************/ 1781 | static int 1782 | pltcl_argisnull(ClientData cdata, Tcl_Interp *interp, 1783 | int objc, Tcl_Obj *const objv[]) 1784 | { 1785 | int argno; 1786 | FunctionCallInfo fcinfo = pltcl_current_fcinfo; 1787 | 1788 | /************************************************************ 1789 | * Check call syntax 1790 | ************************************************************/ 1791 | if (objc != 2) 1792 | { 1793 | Tcl_WrongNumArgs(interp, 1, objv, "argno"); 1794 | return TCL_ERROR; 1795 | } 1796 | 1797 | /************************************************************ 1798 | * Check that we're called as a normal function 1799 | ************************************************************/ 1800 | if (fcinfo == NULL) 1801 | { 1802 | Tcl_SetObjResult(interp, 1803 | Tcl_NewStringObj("argisnull cannot be used in triggers", -1)); 1804 | return TCL_ERROR; 1805 | } 1806 | 1807 | /************************************************************ 1808 | * Get the argument number 1809 | ************************************************************/ 1810 | if (Tcl_GetIntFromObj(interp, objv[1], &argno) != TCL_OK) 1811 | return TCL_ERROR; 1812 | 1813 | /************************************************************ 1814 | * Check that the argno is valid 1815 | ************************************************************/ 1816 | argno--; 1817 | if (argno < 0 || argno >= fcinfo->nargs) 1818 | { 1819 | Tcl_SetObjResult(interp, 1820 | Tcl_NewStringObj("argno out of range", -1)); 1821 | return TCL_ERROR; 1822 | } 1823 | 1824 | /************************************************************ 1825 | * Get the requested NULL state 1826 | ************************************************************/ 1827 | Tcl_SetObjResult(interp, Tcl_NewBooleanObj(PG_ARGISNULL(argno))); 1828 | return TCL_OK; 1829 | } 1830 | 1831 | 1832 | /********************************************************************** 1833 | * pltcl_returnnull() - Cause a NULL return from the current function 1834 | **********************************************************************/ 1835 | static int 1836 | pltcl_returnnull(ClientData cdata, Tcl_Interp *interp, 1837 | int objc, Tcl_Obj *const objv[]) 1838 | { 1839 | FunctionCallInfo fcinfo = pltcl_current_fcinfo; 1840 | 1841 | /************************************************************ 1842 | * Check call syntax 1843 | ************************************************************/ 1844 | if (objc != 1) 1845 | { 1846 | Tcl_WrongNumArgs(interp, 1, objv, ""); 1847 | return TCL_ERROR; 1848 | } 1849 | 1850 | /************************************************************ 1851 | * Check that we're called as a normal function 1852 | ************************************************************/ 1853 | if (fcinfo == NULL) 1854 | { 1855 | Tcl_SetObjResult(interp, 1856 | Tcl_NewStringObj("return_null cannot be used in triggers", -1)); 1857 | return TCL_ERROR; 1858 | } 1859 | 1860 | /************************************************************ 1861 | * Set the NULL return flag and cause Tcl to return from the 1862 | * procedure. 1863 | ************************************************************/ 1864 | fcinfo->isnull = true; 1865 | 1866 | return TCL_RETURN; 1867 | } 1868 | 1869 | 1870 | /*---------- 1871 | * Support for running SPI operations inside subtransactions 1872 | * 1873 | * Intended usage pattern is: 1874 | * 1875 | * MemoryContext oldcontext = CurrentMemoryContext; 1876 | * ResourceOwner oldowner = CurrentResourceOwner; 1877 | * 1878 | * ... 1879 | * pltcl_subtrans_begin(oldcontext, oldowner); 1880 | * PG_TRY(); 1881 | * { 1882 | * do something risky; 1883 | * pltcl_subtrans_commit(oldcontext, oldowner); 1884 | * } 1885 | * PG_CATCH(); 1886 | * { 1887 | * pltcl_subtrans_abort(interp, oldcontext, oldowner); 1888 | * return TCL_ERROR; 1889 | * } 1890 | * PG_END_TRY(); 1891 | * return TCL_OK; 1892 | *---------- 1893 | */ 1894 | static void 1895 | pltcl_subtrans_begin(MemoryContext oldcontext, ResourceOwner oldowner) 1896 | { 1897 | BeginInternalSubTransaction(NULL); 1898 | 1899 | /* Want to run inside function's memory context */ 1900 | MemoryContextSwitchTo(oldcontext); 1901 | } 1902 | 1903 | static void 1904 | pltcl_subtrans_commit(MemoryContext oldcontext, ResourceOwner oldowner) 1905 | { 1906 | /* Commit the inner transaction, return to outer xact context */ 1907 | ReleaseCurrentSubTransaction(); 1908 | MemoryContextSwitchTo(oldcontext); 1909 | CurrentResourceOwner = oldowner; 1910 | 1911 | /* 1912 | * AtEOSubXact_SPI() should not have popped any SPI context, but just in 1913 | * case it did, make sure we remain connected. 1914 | */ 1915 | SPI_restore_connection(); 1916 | } 1917 | 1918 | static void 1919 | pltcl_subtrans_abort(Tcl_Interp *interp, 1920 | MemoryContext oldcontext, ResourceOwner oldowner) 1921 | { 1922 | ErrorData *edata; 1923 | 1924 | /* Save error info */ 1925 | MemoryContextSwitchTo(oldcontext); 1926 | edata = CopyErrorData(); 1927 | FlushErrorState(); 1928 | 1929 | /* Abort the inner transaction */ 1930 | RollbackAndReleaseCurrentSubTransaction(); 1931 | MemoryContextSwitchTo(oldcontext); 1932 | CurrentResourceOwner = oldowner; 1933 | 1934 | /* 1935 | * If AtEOSubXact_SPI() popped any SPI context of the subxact, it will 1936 | * have left us in a disconnected state. We need this hack to return to 1937 | * connected state. 1938 | */ 1939 | SPI_restore_connection(); 1940 | 1941 | /* Pass the error data to Tcl */ 1942 | pltcl_construct_errorCode(interp, edata); 1943 | UTF_BEGIN; 1944 | Tcl_SetObjResult(interp, Tcl_NewStringObj(UTF_E2U(edata->message), -1)); 1945 | UTF_END; 1946 | FreeErrorData(edata); 1947 | } 1948 | 1949 | /********************************************************************** 1950 | * pltcl_cancel_pending() - return state of the global 1951 | * QueryCancelPending 1952 | **********************************************************************/ 1953 | static int 1954 | pltcl_cancel_pending(ClientData cdata, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) 1955 | { 1956 | Tcl_SetObjResult(interp, Tcl_NewIntObj(QueryCancelPending)); 1957 | return TCL_OK; 1958 | } 1959 | 1960 | /********************************************************************** 1961 | * pltcl_SPI_execute() - The builtin SPI_execute command 1962 | * for the Tcl interpreter 1963 | **********************************************************************/ 1964 | static int 1965 | pltcl_SPI_execute(ClientData cdata, Tcl_Interp *interp, 1966 | int objc, Tcl_Obj *const objv[]) 1967 | { 1968 | int my_rc; 1969 | int spi_rc; 1970 | int query_idx; 1971 | int i; 1972 | int optIndex; 1973 | int count = 0; 1974 | const char *volatile arrayname = NULL; 1975 | Tcl_Obj *volatile loop_body = NULL; 1976 | MemoryContext oldcontext = CurrentMemoryContext; 1977 | ResourceOwner oldowner = CurrentResourceOwner; 1978 | 1979 | enum options 1980 | { 1981 | OPT_ARRAY, OPT_COUNT 1982 | }; 1983 | 1984 | static const char *options[] = { 1985 | "-array", "-count", (const char *) NULL 1986 | }; 1987 | 1988 | /************************************************************ 1989 | * Check the call syntax and get the options 1990 | ************************************************************/ 1991 | if (objc < 2) 1992 | { 1993 | Tcl_WrongNumArgs(interp, 1, objv, 1994 | "?-count n? ?-array name? query ?loop body?"); 1995 | return TCL_ERROR; 1996 | } 1997 | 1998 | i = 1; 1999 | while (i < objc) 2000 | { 2001 | if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 2002 | TCL_EXACT, &optIndex) != TCL_OK) 2003 | break; 2004 | 2005 | if (++i >= objc) 2006 | { 2007 | Tcl_SetObjResult(interp, 2008 | Tcl_NewStringObj("missing argument to -count or -array", -1)); 2009 | return TCL_ERROR; 2010 | } 2011 | 2012 | switch ((enum options) optIndex) 2013 | { 2014 | case OPT_ARRAY: 2015 | arrayname = Tcl_GetString(objv[i++]); 2016 | break; 2017 | 2018 | case OPT_COUNT: 2019 | if (Tcl_GetIntFromObj(interp, objv[i++], &count) != TCL_OK) 2020 | return TCL_ERROR; 2021 | break; 2022 | } 2023 | } 2024 | 2025 | query_idx = i; 2026 | if (query_idx >= objc || query_idx + 2 < objc) 2027 | { 2028 | Tcl_WrongNumArgs(interp, query_idx - 1, objv, "query ?loop body?"); 2029 | return TCL_ERROR; 2030 | } 2031 | 2032 | if (query_idx + 1 < objc) 2033 | loop_body = objv[query_idx + 1]; 2034 | 2035 | /************************************************************ 2036 | * Execute the query inside a sub-transaction, so we can cope with 2037 | * errors sanely 2038 | ************************************************************/ 2039 | 2040 | pltcl_subtrans_begin(oldcontext, oldowner); 2041 | 2042 | PG_TRY(); 2043 | { 2044 | UTF_BEGIN; 2045 | spi_rc = SPI_execute(UTF_U2E(Tcl_GetString(objv[query_idx])), 2046 | pltcl_current_prodesc->fn_readonly, count); 2047 | UTF_END; 2048 | 2049 | my_rc = pltcl_process_SPI_result(interp, 2050 | arrayname, 2051 | loop_body, 2052 | spi_rc, 2053 | SPI_tuptable, 2054 | SPI_processed); 2055 | 2056 | pltcl_subtrans_commit(oldcontext, oldowner); 2057 | } 2058 | PG_CATCH(); 2059 | { 2060 | pltcl_subtrans_abort(interp, oldcontext, oldowner); 2061 | return TCL_ERROR; 2062 | } 2063 | PG_END_TRY(); 2064 | 2065 | return my_rc; 2066 | } 2067 | 2068 | /* 2069 | * Process the result from SPI_execute or SPI_execute_plan 2070 | * 2071 | * Shared code between pltcl_SPI_execute and pltcl_SPI_execute_plan 2072 | */ 2073 | static int 2074 | pltcl_process_SPI_result(Tcl_Interp *interp, 2075 | const char *arrayname, 2076 | Tcl_Obj *loop_body, 2077 | int spi_rc, 2078 | SPITupleTable *tuptable, 2079 | uint64 ntuples) 2080 | { 2081 | int my_rc = TCL_OK; 2082 | int loop_rc; 2083 | HeapTuple *tuples; 2084 | TupleDesc tupdesc; 2085 | 2086 | switch (spi_rc) 2087 | { 2088 | case SPI_OK_SELINTO: 2089 | case SPI_OK_INSERT: 2090 | case SPI_OK_DELETE: 2091 | case SPI_OK_UPDATE: 2092 | Tcl_SetObjResult(interp, Tcl_NewWideIntObj(ntuples)); 2093 | break; 2094 | 2095 | case SPI_OK_UTILITY: 2096 | case SPI_OK_REWRITTEN: 2097 | if (tuptable == NULL) 2098 | { 2099 | Tcl_SetObjResult(interp, Tcl_NewIntObj(0)); 2100 | break; 2101 | } 2102 | /* FALL THRU for utility returning tuples */ 2103 | 2104 | case SPI_OK_SELECT: 2105 | case SPI_OK_INSERT_RETURNING: 2106 | case SPI_OK_DELETE_RETURNING: 2107 | case SPI_OK_UPDATE_RETURNING: 2108 | 2109 | /* 2110 | * Process the tuples we got 2111 | */ 2112 | tuples = tuptable->vals; 2113 | tupdesc = tuptable->tupdesc; 2114 | 2115 | if (loop_body == NULL) 2116 | { 2117 | /* 2118 | * If there is no loop body given, just set the variables from 2119 | * the first tuple (if any) 2120 | */ 2121 | if (ntuples > 0) 2122 | pltcl_set_tuple_values(interp, arrayname, 0, 2123 | tuples[0], tupdesc); 2124 | } 2125 | else 2126 | { 2127 | /* 2128 | * There is a loop body - process all tuples and evaluate the 2129 | * body on each 2130 | */ 2131 | uint64 i; 2132 | 2133 | for (i = 0; i < ntuples; i++) 2134 | { 2135 | pltcl_set_tuple_values(interp, arrayname, i, 2136 | tuples[i], tupdesc); 2137 | 2138 | loop_rc = Tcl_EvalObjEx(interp, loop_body, 0); 2139 | 2140 | if (loop_rc == TCL_OK) 2141 | continue; 2142 | if (loop_rc == TCL_CONTINUE) 2143 | continue; 2144 | if (loop_rc == TCL_RETURN) 2145 | { 2146 | my_rc = TCL_RETURN; 2147 | break; 2148 | } 2149 | if (loop_rc == TCL_BREAK) 2150 | break; 2151 | my_rc = TCL_ERROR; 2152 | break; 2153 | } 2154 | } 2155 | 2156 | if (my_rc == TCL_OK) 2157 | { 2158 | Tcl_SetObjResult(interp, Tcl_NewWideIntObj(ntuples)); 2159 | } 2160 | break; 2161 | 2162 | default: 2163 | Tcl_AppendResult(interp, "pltcl: SPI_execute failed: ", 2164 | SPI_result_code_string(spi_rc), NULL); 2165 | my_rc = TCL_ERROR; 2166 | break; 2167 | } 2168 | 2169 | SPI_freetuptable(tuptable); 2170 | 2171 | return my_rc; 2172 | } 2173 | 2174 | 2175 | /********************************************************************** 2176 | * pltcl_SPI_prepare() - Builtin support for prepared plans 2177 | * The Tcl command SPI_prepare 2178 | * always saves the plan using 2179 | * SPI_keepplan and returns a key for 2180 | * access. There is no chance to prepare 2181 | * and not save the plan currently. 2182 | **********************************************************************/ 2183 | static int 2184 | pltcl_SPI_prepare(ClientData cdata, Tcl_Interp *interp, 2185 | int objc, Tcl_Obj *const objv[]) 2186 | { 2187 | volatile MemoryContext plan_cxt = NULL; 2188 | int nargs; 2189 | Tcl_Obj **argsObj; 2190 | pltcl_query_desc *qdesc; 2191 | int i; 2192 | Tcl_HashEntry *hashent; 2193 | int hashnew; 2194 | Tcl_HashTable *query_hash; 2195 | MemoryContext oldcontext = CurrentMemoryContext; 2196 | ResourceOwner oldowner = CurrentResourceOwner; 2197 | 2198 | /************************************************************ 2199 | * Check the call syntax 2200 | ************************************************************/ 2201 | if (objc != 3) 2202 | { 2203 | Tcl_WrongNumArgs(interp, 1, objv, "query argtypes"); 2204 | return TCL_ERROR; 2205 | } 2206 | 2207 | /************************************************************ 2208 | * Split the argument type list 2209 | ************************************************************/ 2210 | if (Tcl_ListObjGetElements(interp, objv[2], &nargs, &argsObj) != TCL_OK) 2211 | return TCL_ERROR; 2212 | 2213 | /************************************************************ 2214 | * Allocate the new querydesc structure 2215 | * 2216 | * struct qdesc and subsidiary data all live in plan_cxt. Note that if the 2217 | * function is recompiled for whatever reason, permanent memory leaks 2218 | * occur. FIXME someday. 2219 | ************************************************************/ 2220 | plan_cxt = AllocSetContextCreate(TopMemoryContext, 2221 | "PL/TCL spi_prepare query", 2222 | ALLOCSET_SMALL_SIZES); 2223 | MemoryContextSwitchTo(plan_cxt); 2224 | qdesc = (pltcl_query_desc *) palloc0(sizeof(pltcl_query_desc)); 2225 | snprintf(qdesc->qname, sizeof(qdesc->qname), "%p", qdesc); 2226 | qdesc->nargs = nargs; 2227 | qdesc->argtypes = (Oid *) palloc(nargs * sizeof(Oid)); 2228 | qdesc->arginfuncs = (FmgrInfo *) palloc(nargs * sizeof(FmgrInfo)); 2229 | qdesc->argtypioparams = (Oid *) palloc(nargs * sizeof(Oid)); 2230 | MemoryContextSwitchTo(oldcontext); 2231 | 2232 | /************************************************************ 2233 | * Execute the prepare inside a sub-transaction, so we can cope with 2234 | * errors sanely 2235 | ************************************************************/ 2236 | 2237 | pltcl_subtrans_begin(oldcontext, oldowner); 2238 | 2239 | PG_TRY(); 2240 | { 2241 | /************************************************************ 2242 | * Resolve argument type names and then look them up by oid 2243 | * in the system cache, and remember the required information 2244 | * for input conversion. 2245 | ************************************************************/ 2246 | for (i = 0; i < nargs; i++) 2247 | { 2248 | Oid typId, 2249 | typInput, 2250 | typIOParam; 2251 | int32 typmod; 2252 | 2253 | parseTypeString(Tcl_GetString(argsObj[i]), &typId, &typmod, false); 2254 | 2255 | getTypeInputInfo(typId, &typInput, &typIOParam); 2256 | 2257 | qdesc->argtypes[i] = typId; 2258 | fmgr_info_cxt(typInput, &(qdesc->arginfuncs[i]), plan_cxt); 2259 | qdesc->argtypioparams[i] = typIOParam; 2260 | } 2261 | 2262 | /************************************************************ 2263 | * Prepare the plan and check for errors 2264 | ************************************************************/ 2265 | UTF_BEGIN; 2266 | qdesc->plan = SPI_prepare(UTF_U2E(Tcl_GetString(objv[1])), 2267 | nargs, qdesc->argtypes); 2268 | UTF_END; 2269 | 2270 | if (qdesc->plan == NULL) 2271 | elog(ERROR, "SPI_prepare() failed"); 2272 | 2273 | /************************************************************ 2274 | * Save the plan into permanent memory (right now it's in the 2275 | * SPI procCxt, which will go away at function end). 2276 | ************************************************************/ 2277 | if (SPI_keepplan(qdesc->plan)) 2278 | elog(ERROR, "SPI_keepplan() failed"); 2279 | 2280 | pltcl_subtrans_commit(oldcontext, oldowner); 2281 | } 2282 | PG_CATCH(); 2283 | { 2284 | pltcl_subtrans_abort(interp, oldcontext, oldowner); 2285 | 2286 | MemoryContextDelete(plan_cxt); 2287 | 2288 | return TCL_ERROR; 2289 | } 2290 | PG_END_TRY(); 2291 | 2292 | /************************************************************ 2293 | * Insert a hashtable entry for the plan and return 2294 | * the key to the caller 2295 | ************************************************************/ 2296 | query_hash = &pltcl_current_prodesc->interp_desc->query_hash; 2297 | 2298 | hashent = Tcl_CreateHashEntry(query_hash, qdesc->qname, &hashnew); 2299 | Tcl_SetHashValue(hashent, (ClientData) qdesc); 2300 | 2301 | /* qname is ASCII, so no need for encoding conversion */ 2302 | Tcl_SetObjResult(interp, Tcl_NewStringObj(qdesc->qname, -1)); 2303 | return TCL_OK; 2304 | } 2305 | 2306 | 2307 | /********************************************************************** 2308 | * pltcl_SPI_execute_plan() - Execute a prepared plan 2309 | **********************************************************************/ 2310 | static int 2311 | pltcl_SPI_execute_plan(ClientData cdata, Tcl_Interp *interp, 2312 | int objc, Tcl_Obj *const objv[]) 2313 | { 2314 | int my_rc; 2315 | int spi_rc; 2316 | int i; 2317 | int j; 2318 | int optIndex; 2319 | Tcl_HashEntry *hashent; 2320 | pltcl_query_desc *qdesc; 2321 | const char *nulls = NULL; 2322 | const char *arrayname = NULL; 2323 | Tcl_Obj *loop_body = NULL; 2324 | int count = 0; 2325 | int callObjc; 2326 | Tcl_Obj **callObjv = NULL; 2327 | Datum *argvalues; 2328 | MemoryContext oldcontext = CurrentMemoryContext; 2329 | ResourceOwner oldowner = CurrentResourceOwner; 2330 | Tcl_HashTable *query_hash; 2331 | 2332 | enum options 2333 | { 2334 | OPT_ARRAY, OPT_COUNT, OPT_NULLS 2335 | }; 2336 | 2337 | static const char *options[] = { 2338 | "-array", "-count", "-nulls", (const char *) NULL 2339 | }; 2340 | 2341 | /************************************************************ 2342 | * Get the options and check syntax 2343 | ************************************************************/ 2344 | i = 1; 2345 | while (i < objc) 2346 | { 2347 | if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 2348 | TCL_EXACT, &optIndex) != TCL_OK) 2349 | break; 2350 | 2351 | if (++i >= objc) 2352 | { 2353 | Tcl_SetObjResult(interp, 2354 | Tcl_NewStringObj("missing argument to -array, -count or -nulls", -1)); 2355 | return TCL_ERROR; 2356 | } 2357 | 2358 | switch ((enum options) optIndex) 2359 | { 2360 | case OPT_ARRAY: 2361 | arrayname = Tcl_GetString(objv[i++]); 2362 | break; 2363 | 2364 | case OPT_COUNT: 2365 | if (Tcl_GetIntFromObj(interp, objv[i++], &count) != TCL_OK) 2366 | return TCL_ERROR; 2367 | break; 2368 | 2369 | case OPT_NULLS: 2370 | nulls = Tcl_GetString(objv[i++]); 2371 | break; 2372 | } 2373 | } 2374 | 2375 | /************************************************************ 2376 | * Get the prepared plan descriptor by its key 2377 | ************************************************************/ 2378 | if (i >= objc) 2379 | { 2380 | Tcl_SetObjResult(interp, 2381 | Tcl_NewStringObj("missing argument to -count or -array", -1)); 2382 | return TCL_ERROR; 2383 | } 2384 | 2385 | query_hash = &pltcl_current_prodesc->interp_desc->query_hash; 2386 | 2387 | hashent = Tcl_FindHashEntry(query_hash, Tcl_GetString(objv[i])); 2388 | if (hashent == NULL) 2389 | { 2390 | Tcl_AppendResult(interp, "invalid queryid '", Tcl_GetString(objv[i]), "'", NULL); 2391 | return TCL_ERROR; 2392 | } 2393 | qdesc = (pltcl_query_desc *) Tcl_GetHashValue(hashent); 2394 | i++; 2395 | 2396 | /************************************************************ 2397 | * If a nulls string is given, check for correct length 2398 | ************************************************************/ 2399 | if (nulls != NULL) 2400 | { 2401 | if (strlen(nulls) != qdesc->nargs) 2402 | { 2403 | Tcl_SetObjResult(interp, 2404 | Tcl_NewStringObj( 2405 | "length of nulls string doesn't match number of arguments", 2406 | -1)); 2407 | return TCL_ERROR; 2408 | } 2409 | } 2410 | 2411 | /************************************************************ 2412 | * If there was a argtype list on preparation, we need 2413 | * an argument value list now 2414 | ************************************************************/ 2415 | if (qdesc->nargs > 0) 2416 | { 2417 | if (i >= objc) 2418 | { 2419 | Tcl_SetObjResult(interp, 2420 | Tcl_NewStringObj( 2421 | "argument list length doesn't match number of arguments for query" 2422 | ,-1)); 2423 | return TCL_ERROR; 2424 | } 2425 | 2426 | /************************************************************ 2427 | * Split the argument values 2428 | ************************************************************/ 2429 | if (Tcl_ListObjGetElements(interp, objv[i++], &callObjc, &callObjv) != TCL_OK) 2430 | return TCL_ERROR; 2431 | 2432 | /************************************************************ 2433 | * Check that the number of arguments matches 2434 | ************************************************************/ 2435 | if (callObjc != qdesc->nargs) 2436 | { 2437 | Tcl_SetObjResult(interp, 2438 | Tcl_NewStringObj( 2439 | "argument list length doesn't match number of arguments for query" 2440 | ,-1)); 2441 | return TCL_ERROR; 2442 | } 2443 | } 2444 | else 2445 | callObjc = 0; 2446 | 2447 | /************************************************************ 2448 | * Get loop body if present 2449 | ************************************************************/ 2450 | if (i < objc) 2451 | loop_body = objv[i++]; 2452 | 2453 | if (i != objc) 2454 | { 2455 | Tcl_WrongNumArgs(interp, 1, objv, 2456 | "?-count n? ?-array name? ?-nulls string? " 2457 | "query ?args? ?loop body?"); 2458 | return TCL_ERROR; 2459 | } 2460 | 2461 | /************************************************************ 2462 | * Execute the plan inside a sub-transaction, so we can cope with 2463 | * errors sanely 2464 | ************************************************************/ 2465 | 2466 | pltcl_subtrans_begin(oldcontext, oldowner); 2467 | 2468 | PG_TRY(); 2469 | { 2470 | /************************************************************ 2471 | * Setup the value array for SPI_execute_plan() using 2472 | * the type specific input functions 2473 | ************************************************************/ 2474 | argvalues = (Datum *) palloc(callObjc * sizeof(Datum)); 2475 | 2476 | for (j = 0; j < callObjc; j++) 2477 | { 2478 | if (nulls && nulls[j] == 'n') 2479 | { 2480 | argvalues[j] = InputFunctionCall(&qdesc->arginfuncs[j], 2481 | NULL, 2482 | qdesc->argtypioparams[j], 2483 | -1); 2484 | } 2485 | else 2486 | { 2487 | UTF_BEGIN; 2488 | argvalues[j] = InputFunctionCall(&qdesc->arginfuncs[j], 2489 | UTF_U2E(Tcl_GetString(callObjv[j])), 2490 | qdesc->argtypioparams[j], 2491 | -1); 2492 | UTF_END; 2493 | } 2494 | } 2495 | 2496 | /************************************************************ 2497 | * Execute the plan 2498 | ************************************************************/ 2499 | spi_rc = SPI_execute_plan(qdesc->plan, argvalues, nulls, 2500 | pltcl_current_prodesc->fn_readonly, count); 2501 | 2502 | my_rc = pltcl_process_SPI_result(interp, 2503 | arrayname, 2504 | loop_body, 2505 | spi_rc, 2506 | SPI_tuptable, 2507 | SPI_processed); 2508 | 2509 | pltcl_subtrans_commit(oldcontext, oldowner); 2510 | } 2511 | PG_CATCH(); 2512 | { 2513 | pltcl_subtrans_abort(interp, oldcontext, oldowner); 2514 | return TCL_ERROR; 2515 | } 2516 | PG_END_TRY(); 2517 | 2518 | return my_rc; 2519 | } 2520 | 2521 | 2522 | /********************************************************************** 2523 | * pltcl_SPI_lastoid() - return the last oid. To 2524 | * be used after insert queries 2525 | **********************************************************************/ 2526 | static int 2527 | pltcl_SPI_lastoid(ClientData cdata, Tcl_Interp *interp, 2528 | int objc, Tcl_Obj *const objv[]) 2529 | { 2530 | Tcl_SetObjResult(interp, Tcl_NewWideIntObj(SPI_lastoid)); 2531 | return TCL_OK; 2532 | } 2533 | 2534 | 2535 | /********************************************************************** 2536 | * pltcl_set_tuple_values() - Set variables for all attributes 2537 | * of a given tuple 2538 | * 2539 | * Note: arrayname is presumed to be UTF8; it usually came from Tcl 2540 | **********************************************************************/ 2541 | static void 2542 | pltcl_set_tuple_values(Tcl_Interp *interp, const char *arrayname, 2543 | uint64 tupno, HeapTuple tuple, TupleDesc tupdesc) 2544 | { 2545 | int i; 2546 | char *outputstr; 2547 | Datum attr; 2548 | bool isnull; 2549 | const char *attname; 2550 | Oid typoutput; 2551 | bool typisvarlena; 2552 | const char **arrptr; 2553 | const char **nameptr; 2554 | const char *nullname = NULL; 2555 | 2556 | /************************************************************ 2557 | * Prepare pointers for Tcl_SetVar2() below and in array 2558 | * mode set the .tupno element 2559 | ************************************************************/ 2560 | if (arrayname == NULL) 2561 | { 2562 | arrptr = &attname; 2563 | nameptr = &nullname; 2564 | } 2565 | else 2566 | { 2567 | arrptr = &arrayname; 2568 | nameptr = &attname; 2569 | Tcl_SetVar2Ex(interp, arrayname, ".tupno", Tcl_NewWideIntObj(tupno), 0); 2570 | } 2571 | 2572 | for (i = 0; i < tupdesc->natts; i++) 2573 | { 2574 | /* ignore dropped attributes */ 2575 | if (tupdesc->attrs[i]->attisdropped) 2576 | continue; 2577 | 2578 | /************************************************************ 2579 | * Get the attribute name 2580 | ************************************************************/ 2581 | UTF_BEGIN; 2582 | attname = pstrdup(UTF_E2U(NameStr(tupdesc->attrs[i]->attname))); 2583 | UTF_END; 2584 | 2585 | /************************************************************ 2586 | * Get the attributes value 2587 | ************************************************************/ 2588 | attr = heap_getattr(tuple, i + 1, tupdesc, &isnull); 2589 | 2590 | /************************************************************ 2591 | * If there is a value, set the variable 2592 | * If not, unset it 2593 | * 2594 | * Hmmm - Null attributes will cause functions to 2595 | * crash if they don't expect them - need something 2596 | * smarter here. 2597 | ************************************************************/ 2598 | if (!isnull) 2599 | { 2600 | getTypeOutputInfo(tupdesc->attrs[i]->atttypid, 2601 | &typoutput, &typisvarlena); 2602 | outputstr = OidOutputFunctionCall(typoutput, attr); 2603 | UTF_BEGIN; 2604 | Tcl_SetVar2Ex(interp, *arrptr, *nameptr, 2605 | Tcl_NewStringObj(UTF_E2U(outputstr), -1), 0); 2606 | UTF_END; 2607 | pfree(outputstr); 2608 | } 2609 | else 2610 | Tcl_UnsetVar2(interp, *arrptr, *nameptr, 0); 2611 | 2612 | pfree((char *) attname); 2613 | } 2614 | } 2615 | 2616 | 2617 | /********************************************************************** 2618 | * pltcl_build_tuple_argument() - Build a list object usable for 'array set' 2619 | * from all attributes of a given tuple 2620 | **********************************************************************/ 2621 | static Tcl_Obj * 2622 | pltcl_build_tuple_argument(HeapTuple tuple, TupleDesc tupdesc) 2623 | { 2624 | Tcl_Obj *retobj = Tcl_NewObj(); 2625 | int i; 2626 | char *outputstr; 2627 | Datum attr; 2628 | bool isnull; 2629 | char *attname; 2630 | Oid typoutput; 2631 | bool typisvarlena; 2632 | 2633 | for (i = 0; i < tupdesc->natts; i++) 2634 | { 2635 | /* ignore dropped attributes */ 2636 | if (tupdesc->attrs[i]->attisdropped) 2637 | continue; 2638 | 2639 | /************************************************************ 2640 | * Get the attribute name 2641 | ************************************************************/ 2642 | attname = NameStr(tupdesc->attrs[i]->attname); 2643 | 2644 | /************************************************************ 2645 | * Get the attributes value 2646 | ************************************************************/ 2647 | attr = heap_getattr(tuple, i + 1, tupdesc, &isnull); 2648 | 2649 | /************************************************************ 2650 | * If there is a value, append the attribute name and the 2651 | * value to the list 2652 | * 2653 | * Hmmm - Null attributes will cause functions to 2654 | * crash if they don't expect them - need something 2655 | * smarter here. 2656 | ************************************************************/ 2657 | if (!isnull) 2658 | { 2659 | getTypeOutputInfo(tupdesc->attrs[i]->atttypid, 2660 | &typoutput, &typisvarlena); 2661 | outputstr = OidOutputFunctionCall(typoutput, attr); 2662 | UTF_BEGIN; 2663 | Tcl_ListObjAppendElement(NULL, retobj, 2664 | Tcl_NewStringObj(UTF_E2U(attname), -1)); 2665 | UTF_END; 2666 | UTF_BEGIN; 2667 | Tcl_ListObjAppendElement(NULL, retobj, 2668 | Tcl_NewStringObj(UTF_E2U(outputstr), -1)); 2669 | UTF_END; 2670 | pfree(outputstr); 2671 | } 2672 | } 2673 | 2674 | return retobj; 2675 | } 2676 | --------------------------------------------------------------------------------