From: Marc G. Fournier Date: Wed, 11 Feb 1998 14:38:31 +0000 (+0000) Subject: From: Jan Wieck X-Git-Tag: REL6_3~183 X-Git-Url: https://granicus.if.org/sourcecode?a=commitdiff_plain;h=2784f7c81a9ddd286da7ddac9af071011a4f0f37;p=postgresql From: Jan Wieck A few minutes ago I sent down the PL/Tcl directory to this list. Look at it and reuse anything that might help to build PL/perl. I really hope that PL/perl and PL/Tcl appear in the 6.3 distribution. I'll do whatever I can to make this happen. --- diff --git a/src/pl/tcl/test/README b/src/pl/tcl/test/README new file mode 100644 index 0000000000..ed931420fa --- /dev/null +++ b/src/pl/tcl/test/README @@ -0,0 +1,8 @@ + + This is a small test suite for PL/Tcl. + + Just run the script runtest and compare the files + test.expected against test.out after. + + + Jan diff --git a/src/pl/tcl/test/runtest b/src/pl/tcl/test/runtest new file mode 100755 index 0000000000..08b55e1b1b --- /dev/null +++ b/src/pl/tcl/test/runtest @@ -0,0 +1,27 @@ +#!/bin/sh + +DBNAME=pltcl_test +export DBNAME + +echo "**** Destroy old database $DBNAME ****" +destroydb $DBNAME + +echo "**** Create test database $DBNAME ****" +createdb $DBNAME + +echo "**** Create procedural language pltcl ****" +psql -q -n $DBNAME test.out 2>&1 + +if diff test.expected test.out >/dev/null 2>&1 ; then + echo " Tests passed O.K." +else + echo " Tests faild - look at diffs between" + echo " test.expected and test.out" +fi + diff --git a/src/pl/tcl/test/test.expected b/src/pl/tcl/test/test.expected new file mode 100644 index 0000000000..217b27adbc --- /dev/null +++ b/src/pl/tcl/test/test.expected @@ -0,0 +1,178 @@ +QUERY: insert into T_pkey1 values (1, 'key1-1', 'test key'); +QUERY: insert into T_pkey1 values (1, 'key1-2', 'test key'); +QUERY: insert into T_pkey1 values (1, 'key1-3', 'test key'); +QUERY: insert into T_pkey1 values (2, 'key2-1', 'test key'); +QUERY: insert into T_pkey1 values (2, 'key2-2', 'test key'); +QUERY: insert into T_pkey1 values (2, 'key2-3', 'test key'); +QUERY: insert into T_pkey2 values (1, 'key1-1', 'test key'); +QUERY: insert into T_pkey2 values (1, 'key1-2', 'test key'); +QUERY: insert into T_pkey2 values (1, 'key1-3', 'test key'); +QUERY: insert into T_pkey2 values (2, 'key2-1', 'test key'); +QUERY: insert into T_pkey2 values (2, 'key2-2', 'test key'); +QUERY: insert into T_pkey2 values (2, 'key2-3', 'test key'); +QUERY: select * from T_pkey1; +key1|key2 |txt +----+--------------------+---------------------------------------- + 1|key1-1 |test key + 1|key1-2 |test key + 1|key1-3 |test key + 2|key2-1 |test key + 2|key2-2 |test key + 2|key2-3 |test key +(6 rows) + +QUERY: select * from T_pkey2; +key1|key2 |txt +----+--------------------+---------------------------------------- + 1|KEY1-1 |test key + 1|KEY1-2 |test key + 1|KEY1-3 |test key + 2|KEY2-1 |test key + 2|KEY2-2 |test key + 2|KEY2-3 |test key +(6 rows) + +QUERY: insert into T_pkey1 values (1, 'KEY1-3', 'should work'); +QUERY: insert into T_pkey2 values (1, 'KEY1-3', 'should fail'); +ERROR: duplicate key '1', 'KEY1-3' for T_pkey2 +QUERY: insert into T_dta1 values ('trec 1', 1, 'key1-1'); +QUERY: insert into T_dta1 values ('trec 2', 1, 'key1-2'); +QUERY: insert into T_dta1 values ('trec 3', 1, 'key1-3'); +QUERY: insert into T_dta1 values ('trec 4', 1, 'key1-4'); +ERROR: key for t_dta1 not in t_pkey1 +QUERY: insert into T_dta2 values ('trec 1', 1, 'KEY1-1'); +QUERY: insert into T_dta2 values ('trec 2', 1, 'KEY1-2'); +QUERY: insert into T_dta2 values ('trec 3', 1, 'KEY1-3'); +QUERY: insert into T_dta2 values ('trec 4', 1, 'KEY1-4'); +ERROR: key for t_dta2 not in t_pkey2 +QUERY: select * from T_dta1; +tkey |ref1|ref2 +----------+----+-------------------- +trec 1 | 1|key1-1 +trec 2 | 1|key1-2 +trec 3 | 1|key1-3 +(3 rows) + +QUERY: select * from T_dta2; +tkey |ref1|ref2 +----------+----+-------------------- +trec 1 | 1|KEY1-1 +trec 2 | 1|KEY1-2 +trec 3 | 1|KEY1-3 +(3 rows) + +QUERY: update T_pkey1 set key2 = 'key2-9' where key1 = 2 and key2 = 'key2-1'; +QUERY: update T_pkey1 set key2 = 'key1-9' where key1 = 1 and key2 = 'key1-1'; +ERROR: key '1', 'key1-1 ' referenced by T_dta1 +QUERY: delete from T_pkey1 where key1 = 2 and key2 = 'key2-2'; +QUERY: delete from T_pkey1 where key1 = 1 and key2 = 'key1-2'; +ERROR: key '1', 'key1-2 ' referenced by T_dta1 +QUERY: update T_pkey2 set key2 = 'KEY2-9' where key1 = 2 and key2 = 'KEY2-1'; +QUERY: update T_pkey2 set key2 = 'KEY1-9' where key1 = 1 and key2 = 'KEY1-1'; +NOTICE: updated 1 entries in T_dta2 for new key in T_pkey2 +QUERY: delete from T_pkey2 where key1 = 2 and key2 = 'KEY2-2'; +QUERY: delete from T_pkey2 where key1 = 1 and key2 = 'KEY1-2'; +NOTICE: deleted 1 entries from T_dta2 +QUERY: select * from T_pkey1; +key1|key2 |txt +----+--------------------+---------------------------------------- + 1|key1-1 |test key + 1|key1-2 |test key + 1|key1-3 |test key + 2|key2-3 |test key + 1|KEY1-3 |should work + 2|key2-9 |test key +(6 rows) + +QUERY: select * from T_pkey2; +key1|key2 |txt +----+--------------------+---------------------------------------- + 1|KEY1-3 |test key + 2|KEY2-3 |test key + 2|KEY2-9 |test key + 1|KEY1-9 |test key +(4 rows) + +QUERY: select * from T_dta1; +tkey |ref1|ref2 +----------+----+-------------------- +trec 1 | 1|key1-1 +trec 2 | 1|key1-2 +trec 3 | 1|key1-3 +(3 rows) + +QUERY: select * from T_dta2; +tkey |ref1|ref2 +----------+----+-------------------- +trec 3 | 1|KEY1-3 +trec 1 | 1|KEY1-9 +(2 rows) + +QUERY: select tcl_avg(key1) from T_pkey1; +tcl_avg +------- + 1 +(1 row) + +QUERY: select tcl_sum(key1) from T_pkey1; +tcl_sum +------- + 8 +(1 row) + +QUERY: select tcl_avg(key1) from T_pkey2; +tcl_avg +------- + 1 +(1 row) + +QUERY: select tcl_sum(key1) from T_pkey2; +tcl_sum +------- + 6 +(1 row) + +QUERY: select tcl_avg(key1) from T_pkey1 where key1 = 99; +tcl_avg +------- + +(1 row) + +QUERY: select tcl_sum(key1) from T_pkey1 where key1 = 99; +tcl_sum +------- + 0 +(1 row) + +QUERY: select 1 @< 2; +?column? +-------- +t +(1 row) + +QUERY: select 100 @< 4; +?column? +-------- +f +(1 row) + +QUERY: select * from T_pkey1 order by key1 using @<; +key1|key2 |txt +----+--------------------+---------------------------------------- + 1|key1-1 |test key + 1|key1-2 |test key + 1|key1-3 |test key + 1|KEY1-3 |should work + 2|key2-3 |test key + 2|key2-9 |test key +(6 rows) + +QUERY: select * from T_pkey2 order by key1 using @<; +key1|key2 |txt +----+--------------------+---------------------------------------- + 1|KEY1-3 |test key + 1|KEY1-9 |test key + 2|KEY2-3 |test key + 2|KEY2-9 |test key +(4 rows) + diff --git a/src/pl/tcl/test/test_mklang.sql b/src/pl/tcl/test/test_mklang.sql new file mode 100644 index 0000000000..48176f4850 --- /dev/null +++ b/src/pl/tcl/test/test_mklang.sql @@ -0,0 +1,9 @@ + +create function pltcl_call_handler() returns opaque + as '/usr/local/pgsql/lib/pltcl.so' + language 'C'; + +create trusted procedural language 'pltcl' + handler pltcl_call_handler + lancompiler 'PL/Tcl'; + diff --git a/src/pl/tcl/test/test_queries.sql b/src/pl/tcl/test/test_queries.sql new file mode 100644 index 0000000000..ff652135a5 --- /dev/null +++ b/src/pl/tcl/test/test_queries.sql @@ -0,0 +1,73 @@ + +insert into T_pkey1 values (1, 'key1-1', 'test key'); +insert into T_pkey1 values (1, 'key1-2', 'test key'); +insert into T_pkey1 values (1, 'key1-3', 'test key'); +insert into T_pkey1 values (2, 'key2-1', 'test key'); +insert into T_pkey1 values (2, 'key2-2', 'test key'); +insert into T_pkey1 values (2, 'key2-3', 'test key'); + +insert into T_pkey2 values (1, 'key1-1', 'test key'); +insert into T_pkey2 values (1, 'key1-2', 'test key'); +insert into T_pkey2 values (1, 'key1-3', 'test key'); +insert into T_pkey2 values (2, 'key2-1', 'test key'); +insert into T_pkey2 values (2, 'key2-2', 'test key'); +insert into T_pkey2 values (2, 'key2-3', 'test key'); + +select * from T_pkey1; + +-- key2 in T_pkey2 should have upper case only +select * from T_pkey2; + +insert into T_pkey1 values (1, 'KEY1-3', 'should work'); + +-- Due to the upper case translation in trigger this must fail +insert into T_pkey2 values (1, 'KEY1-3', 'should fail'); + +insert into T_dta1 values ('trec 1', 1, 'key1-1'); +insert into T_dta1 values ('trec 2', 1, 'key1-2'); +insert into T_dta1 values ('trec 3', 1, 'key1-3'); + +-- Must fail due to unknown key in T_pkey1 +insert into T_dta1 values ('trec 4', 1, 'key1-4'); + +insert into T_dta2 values ('trec 1', 1, 'KEY1-1'); +insert into T_dta2 values ('trec 2', 1, 'KEY1-2'); +insert into T_dta2 values ('trec 3', 1, 'KEY1-3'); + +-- Must fail due to unknown key in T_pkey2 +insert into T_dta2 values ('trec 4', 1, 'KEY1-4'); + +select * from T_dta1; + +select * from T_dta2; + +update T_pkey1 set key2 = 'key2-9' where key1 = 2 and key2 = 'key2-1'; +update T_pkey1 set key2 = 'key1-9' where key1 = 1 and key2 = 'key1-1'; +delete from T_pkey1 where key1 = 2 and key2 = 'key2-2'; +delete from T_pkey1 where key1 = 1 and key2 = 'key1-2'; + +update T_pkey2 set key2 = 'KEY2-9' where key1 = 2 and key2 = 'KEY2-1'; +update T_pkey2 set key2 = 'KEY1-9' where key1 = 1 and key2 = 'KEY1-1'; +delete from T_pkey2 where key1 = 2 and key2 = 'KEY2-2'; +delete from T_pkey2 where key1 = 1 and key2 = 'KEY1-2'; + +select * from T_pkey1; +select * from T_pkey2; +select * from T_dta1; +select * from T_dta2; + +select tcl_avg(key1) from T_pkey1; +select tcl_sum(key1) from T_pkey1; +select tcl_avg(key1) from T_pkey2; +select tcl_sum(key1) from T_pkey2; + +-- The following should return NULL instead of 0 +select tcl_avg(key1) from T_pkey1 where key1 = 99; +select tcl_sum(key1) from T_pkey1 where key1 = 99; + +select 1 @< 2; +select 100 @< 4; + +select * from T_pkey1 order by key1 using @<; +select * from T_pkey2 order by key1 using @<; + diff --git a/src/pl/tcl/test/test_setup.sql b/src/pl/tcl/test/test_setup.sql new file mode 100644 index 0000000000..fe71584e1a --- /dev/null +++ b/src/pl/tcl/test/test_setup.sql @@ -0,0 +1,426 @@ +-- +-- Create the tables used in the test queries +-- +-- T_pkey1 is the primary key table for T_dta1. Entries from T_pkey1 +-- Cannot be changed or deleted if they are referenced from T_dta1. +-- +-- T_pkey2 is the primary key table for T_dta2. If the key values in +-- T_pkey2 are changed, the references in T_dta2 follow. If entries +-- are deleted, the referencing entries from T_dta2 are deleted too. +-- The values for field key2 in T_pkey2 are silently converted to +-- upper case on insert/update. +-- +create table T_pkey1 ( + key1 int4, + key2 char(20), + txt char(40) +); + +create table T_pkey2 ( + key1 int4, + key2 char(20), + txt char(40) +); + +create table T_dta1 ( + tkey char(10), + ref1 int4, + ref2 char(20) +); + +create table T_dta2 ( + tkey char(10), + ref1 int4, + ref2 char(20) +); + + +-- +-- Function to check key existance in T_pkey1 +-- +create function check_pkey1_exists(int4, bpchar) returns bool as ' + if {![info exists GD]} { + set GD(plan) [spi_prepare \\ + "select 1 from T_pkey1 \\ + where key1 = \\$1 and key2 = \\$2" \\ + {int4 bpchar}] + } + + set n [spi_execp -count 1 $GD(plan) [list $1 $2]] + + if {$n > 0} { + return "t" + } + return "f" +' language 'pltcl'; + + +-- +-- Trigger function on every change to T_pkey1 +-- +create function trig_pkey1_before() returns opaque as ' + # + # Create prepared plans on the first call + # + if {![info exists GD]} { + # + # Plan to check for duplicate key in T_pkey1 + # + set GD(plan_pkey1) [spi_prepare \\ + "select check_pkey1_exists(\\$1, \\$2) as ret" \\ + {int4 bpchar}] + # + # Plan to check for references from T_dta1 + # + set GD(plan_dta1) [spi_prepare \\ + "select 1 from T_dta1 \\ + where ref1 = \\$1 and ref2 = \\$2" \\ + {int4 bpchar}] + } + + # + # Initialize flags + # + set check_old_ref 0 + set check_new_dup 0 + + switch $TG_op { + INSERT { + # + # Must check for duplicate key on INSERT + # + set check_new_dup 1 + } + UPDATE { + # + # Must check for duplicate key on UPDATE only if + # the key changes. In that case we must check for + # references to OLD values too. + # + if {[string compare $NEW(key1) $OLD(key1)] != 0} { + set check_old_ref 1 + set check_new_dup 1 + } + if {[string compare $NEW(key2) $OLD(key2)] != 0} { + set check_old_ref 1 + set check_new_dup 1 + } + } + DELETE { + # + # Must only check for references to OLD on DELETE + # + set check_old_ref 1 + } + } + + if {$check_new_dup} { + # + # Check for duplicate key + # + spi_execp -count 1 $GD(plan_pkey1) [list $NEW(key1) $NEW(key2)] + if {$ret == "t"} { + elog WARN \\ + "duplicate key ''$NEW(key1)'', ''$NEW(key2)'' for T_pkey1" + } + } + + if {$check_old_ref} { + # + # Check for references to OLD + # + set n [spi_execp -count 1 $GD(plan_dta1) [list $OLD(key1) $OLD(key2)]] + if {$n > 0} { + elog WARN \\ + "key ''$OLD(key1)'', ''$OLD(key2)'' referenced by T_dta1" + } + } + + # + # Anything is fine - let operation pass through + # + return OK +' language 'pltcl'; + + +create trigger pkey1_before before insert or update or delete on T_pkey1 + for each row execute procedure + trig_pkey1_before(); + + +-- +-- Trigger function to check for duplicate keys in T_pkey2 +-- and to force key2 to be upper case only without leading whitespaces +-- +create function trig_pkey2_before() returns opaque as ' + # + # Prepare plan on first call + # + if {![info exists GD]} { + set GD(plan_pkey2) [spi_prepare \\ + "select 1 from T_pkey2 \\ + where key1 = \\$1 and key2 = \\$2" \\ + {int4 bpchar}] + } + + # + # Convert key2 value + # + set NEW(key2) [string toupper [string trim $NEW(key2)]] + + # + # Check for duplicate key + # + set n [spi_execp -count 1 $GD(plan_pkey2) [list $NEW(key1) $NEW(key2)]] + if {$n > 0} { + elog WARN \\ + "duplicate key ''$NEW(key1)'', ''$NEW(key2)'' for T_pkey2" + } + + # + # Return modified tuple in NEW + # + return [array get NEW] +' language 'pltcl'; + + +create trigger pkey2_before before insert or update on T_pkey2 + for each row execute procedure + trig_pkey2_before(); + + +-- +-- Trigger function to force references from T_dta2 follow changes +-- in T_pkey2 or be deleted too. This must be done AFTER the changes +-- in T_pkey2 are done so the trigger for primkey check on T_dta2 +-- fired on our updates will see the new key values in T_pkey2. +-- +create function trig_pkey2_after() returns opaque as ' + # + # Prepare plans on first call + # + if {![info exists GD]} { + # + # Plan to update references from T_dta2 + # + set GD(plan_dta2_upd) [spi_prepare \\ + "update T_dta2 set ref1 = \\$3, ref2 = \\$4 \\ + where ref1 = \\$1 and ref2 = \\$2" \\ + {int4 bpchar int4 bpchar}] + # + # Plan to delete references from T_dta2 + # + set GD(plan_dta2_del) [spi_prepare \\ + "delete from T_dta2 \\ + where ref1 = \\$1 and ref2 = \\$2" \\ + {int4 bpchar}] + } + + # + # Initialize flags + # + set old_ref_follow 0 + set old_ref_delete 0 + + switch $TG_op { + UPDATE { + # + # On update we must let old references follow + # + set NEW(key2) [string toupper $NEW(key2)] + + if {[string compare $NEW(key1) $OLD(key1)] != 0} { + set old_ref_follow 1 + } + if {[string compare $NEW(key2) $OLD(key2)] != 0} { + set old_ref_follow 1 + } + } + DELETE { + # + # On delete we must delete references too + # + set old_ref_delete 1 + } + } + + if {$old_ref_follow} { + # + # Let old references follow and fire NOTICE message if + # there where some + # + set n [spi_execp $GD(plan_dta2_upd) \\ + [list $OLD(key1) $OLD(key2) $NEW(key1) $NEW(key2)]] + if {$n > 0} { + elog NOTICE \\ + "updated $n entries in T_dta2 for new key in T_pkey2" + } + } + + if {$old_ref_delete} { + # + # delete references and fire NOTICE message if + # there where some + # + set n [spi_execp $GD(plan_dta2_del) \\ + [list $OLD(key1) $OLD(key2)]] + if {$n > 0} { + elog NOTICE \\ + "deleted $n entries from T_dta2" + } + } + + return OK +' language 'pltcl'; + + +create trigger pkey2_after after update or delete on T_pkey2 + for each row execute procedure + trig_pkey2_after(); + + +-- +-- Generic trigger function to check references in T_dta1 and T_dta2 +-- +create function check_primkey() returns opaque as ' + # + # For every trigger/relation pair we create + # a saved plan and hold them in GD + # + set plankey [list "plan" $TG_name $TG_relid] + set planrel [list "relname" $TG_relid] + + # + # Extract the pkey relation name + # + set keyidx [expr [llength $args] / 2] + set keyrel [string tolower [lindex $args $keyidx]] + + if {![info exists GD($plankey)]} { + # + # We must prepare a new plan. Build up a query string + # for the primary key check. + # + set keylist [lrange $args [expr $keyidx + 1] end] + + set query "select 1 from $keyrel" + set qual " where" + set typlist "" + set idx 1 + foreach key $keylist { + set key [string tolower $key] + # + # Add the qual part to the query string + # + append query "$qual $key = \\$$idx" + set qual " and" + + # + # Lookup the fields type in pg_attribute + # + set n [spi_exec "select T.typname \\ + from pg_type T, pg_attribute A, pg_class C \\ + where C.relname = ''[quote $keyrel]'' \\ + and C.oid = A.attrelid \\ + and A.attname = ''[quote $key]'' \\ + and A.atttypid = T.oid"] + if {$n != 1} { + elog WARN "table $keyrel doesn''t have a field named $key" + } + + # + # Append the fields type to the argument type list + # + lappend typlist $typname + incr idx + } + + # + # Prepare the plan + # + set GD($plankey) [spi_prepare $query $typlist] + + # + # Lookup and remember the table name for later error messages + # + spi_exec "select relname from pg_class \\ + where oid = ''$TG_relid''::oid" + set GD($planrel) $relname + } + + # + # Build the argument list from the NEW row + # + incr keyidx -1 + set arglist "" + foreach arg [lrange $args 0 $keyidx] { + lappend arglist $NEW($arg) + } + + # + # Check for the primary key + # + set n [spi_execp -count 1 $GD($plankey) $arglist] + if {$n <= 0} { + elog WARN "key for $GD($planrel) not in $keyrel" + } + + # + # Anything is fine + # + return OK +' language 'pltcl'; + + +create trigger dta1_before before insert or update on T_dta1 + for each row execute procedure + check_primkey('ref1', 'ref2', 'T_pkey1', 'key1', 'key2'); + + +create trigger dta2_before before insert or update on T_dta2 + for each row execute procedure + check_primkey('ref1', 'ref2', 'T_pkey2', 'key1', 'key2'); + + +create function tcl_int4add(int4,int4) returns int4 as ' + return [expr $1 + $2] +' language 'pltcl'; + +create function tcl_int4div(int4,int4) returns int4 as ' + return [expr $1 / $2] +' language 'pltcl'; + +create function tcl_int4inc(int4) returns int4 as ' + return [expr $1 + 1] +' language 'pltcl'; + +create aggregate tcl_avg ( + sfunc1 = tcl_int4add, + basetype = int4, + stype1 = int4, + sfunc2 = tcl_int4inc, + stype2 = int4, + finalfunc = tcl_int4div, + initcond2 = '0' + ); + +create aggregate tcl_sum ( + sfunc1 = tcl_int4add, + basetype = int4, + stype1 = int4, + initcond1 = '0' + ); + +create function tcl_int4lt(int4,int4) returns bool as ' + if {$1 < $2} { + return t + } + return f +' language 'pltcl'; + +create operator @< ( + leftarg = int4, + rightarg = int4, + procedure = tcl_int4lt + ); +