--- /dev/null
+
+ 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
--- /dev/null
+#!/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_mklang.sql
+
+echo "**** Create tables, functions and triggers ****"
+psql -q -n $DBNAME <test_setup.sql
+
+echo "**** Running test queries ****"
+psql -q -n -e $DBNAME <test_queries.sql > 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
+
--- /dev/null
+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)
+
--- /dev/null
+
+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';
+
--- /dev/null
+
+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 @<;
+
--- /dev/null
+--
+-- 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
+ );
+
projects / postgresql / commitdiff