Expand the regression tests for PL/Tcl.

This raises the test coverage (by line count) in pltcl.c from about 70%
to 86%.

Karl Lehenbauer and Jim Nasby

Discussion: https://postgr.es/m/92a1670d-21b6-8f03-9c13-e4fb2207ab7b@BlueTreble.com

src/pl/tcl/expected/pltcl_setup.out

@@ -49,10 +49,31 @@ create function check_pkey1_exists(int4, bpchar) returns bool as E'
     return "f"
 ' language pltcl;
 -- dump trigger data
-CREATE TABLE trigger_test
-    (i int, v text );
-CREATE VIEW trigger_test_view AS SELECT * FROM trigger_test;
+CREATE TABLE trigger_test (
+	i int,
+	v text,
+	dropme text,
+	test_skip boolean DEFAULT false,
+	test_return_null boolean DEFAULT false,
+	test_argisnull boolean DEFAULT false
+);
+-- Make certain dropped attributes are handled correctly
+ALTER TABLE trigger_test DROP dropme;
+CREATE VIEW trigger_test_view AS SELECT i, v FROM trigger_test;
 CREATE FUNCTION trigger_data() returns trigger language pltcl as $_$
+	if {$TG_table_name eq "trigger_test" && $TG_level eq "ROW" && $TG_op ne "DELETE"} {
+		# Special case tests
+		if {$NEW(test_return_null) eq "t" } {
+			return_null
+		}
+		if {$NEW(test_argisnull) eq "t" } {
+			set should_error [argisnull 1]
+		}
+		if {$NEW(test_skip) eq "t" } {
+			elog NOTICE "SKIPPING OPERATION $TG_op"
+			return SKIP
+		}
+	}
 
 	if { [info exists TG_relid] } {
 	set TG_relid "bogus:12345"
@@ -86,6 +107,9 @@ $_$;
 CREATE TRIGGER show_trigger_data_trig
 BEFORE INSERT OR UPDATE OR DELETE ON trigger_test
 FOR EACH ROW EXECUTE PROCEDURE trigger_data(23,'skidoo');
+CREATE TRIGGER statement_trigger
+BEFORE INSERT OR UPDATE OR DELETE OR TRUNCATE ON trigger_test
+FOR EACH STATEMENT EXECUTE PROCEDURE trigger_data(42,'statement trigger');
 CREATE TRIGGER show_trigger_data_view_trig
 INSTEAD OF INSERT OR UPDATE OR DELETE ON trigger_test_view
 FOR EACH ROW EXECUTE PROCEDURE trigger_data(24,'skidoo view');
@@ -533,12 +557,12 @@ select tcl_date_week(2001,10,24);
 (1 row)
 
 -- test pltcl event triggers
-create or replace function tclsnitch() returns event_trigger language pltcl as $$
+create function tclsnitch() returns event_trigger language pltcl as $$
   elog NOTICE "tclsnitch: $TG_event $TG_tag"
 $$;
 create event trigger tcl_a_snitch on ddl_command_start execute procedure tclsnitch();
 create event trigger tcl_b_snitch on ddl_command_end execute procedure tclsnitch();
-create or replace function foobar() returns int language sql as $$select 1;$$;
+create function foobar() returns int language sql as $$select 1;$$;
 NOTICE:  tclsnitch: ddl_command_start CREATE FUNCTION
 NOTICE:  tclsnitch: ddl_command_end CREATE FUNCTION
 alter function foobar() cost 77;
@@ -555,44 +579,108 @@ NOTICE:  tclsnitch: ddl_command_start DROP TABLE
 NOTICE:  tclsnitch: ddl_command_end DROP TABLE
 drop event trigger tcl_a_snitch;
 drop event trigger tcl_b_snitch;
-CREATE FUNCTION tcl_test_cube_squared(in int, out squared int, out cubed int) AS $$
+create function tcl_test_cube_squared(in int, out squared int, out cubed int) as $$
     return [list squared [expr {$1 * $1}] cubed [expr {$1 * $1 * $1}]]
 $$ language pltcl;
-CREATE FUNCTION tcl_test_squared_rows(int,int) RETURNS TABLE (x int, y int) AS $$
+create function tcl_test_squared_rows(int,int) returns table (x int, y int) as $$
     for {set i $1} {$i < $2} {incr i} {
         return_next [list y [expr {$i * $i}] x $i]
     }
 $$ language pltcl;
-CREATE FUNCTION tcl_test_sequence(int,int) RETURNS SETOF int AS $$
+create function tcl_test_sequence(int,int) returns setof int as $$
     for {set i $1} {$i < $2} {incr i} {
         return_next $i
     }
 $$ language pltcl;
+create function tcl_eval(string text) returns text as $$
+    eval $1
+$$ language pltcl;
 -- test use of errorCode in error handling
-create function tcl_error_handling_test() returns text as $$
-    global errorCode
-    if {[catch { spi_exec "select no_such_column from foo;" }]} {
-        array set errArray $errorCode
-        if {$errArray(condition) == "undefined_table"} {
-            return "expected error: $errArray(message)"
-        } else {
-            return "unexpected error: $errArray(condition) $errArray(message)"
+create function tcl_error_handling_test(text) returns text
+language pltcl
+as $function$
+    if {[catch $1 err]} {
+        # If not a Postgres error, just return the basic error message
+        if {[lindex $::errorCode 0] != "POSTGRES"} {
+            return $err
+        }
+
+        # Get rid of keys that can't be expected to remain constant
+        array set myArray $::errorCode
+        unset myArray(POSTGRES)
+        unset myArray(funcname)
+        unset myArray(filename)
+        unset myArray(lineno)
+
+        # Format into something nicer
+        set vals []
+        foreach {key} [lsort [array names myArray]] {
+            set value [string map {"\n" "\n\t"} $myArray($key)]
+            lappend vals "$key: $value"
         }
+        return [join $vals "\n"]
     } else {
         return "no error"
     }
-$$ language pltcl;
-select tcl_error_handling_test();
-            tcl_error_handling_test            
------------------------------------------------
- expected error: relation "foo" does not exist
-(1 row)
-
-create temp table foo(f1 int);
-select tcl_error_handling_test();
-                          tcl_error_handling_test                          
----------------------------------------------------------------------------
- unexpected error: undefined_column column "no_such_column" does not exist
-(1 row)
-
-drop table foo;
+$function$;
+-- test spi_exec and spi_execp with -array
+create function tcl_spi_exec(
+    prepare boolean,
+    action text
+)
+returns void language pltcl AS $function$
+set query "select * from (values (1,'foo'),(2,'bar'),(3,'baz')) v(col1,col2)"
+if {$1 == "t"} {
+    set prep [spi_prepare $query {}]
+    spi_execp -array A $prep {
+        elog NOTICE "col1 $A(col1), col2 $A(col2)"
+
+        switch $A(col1) {
+            2 {
+                elog NOTICE "action: $2"
+                switch $2 {
+                    break {
+                        break
+                    }
+                    continue {
+                        continue
+                    }
+                    return {
+                        return
+                    }
+                    error {
+                        error "error message"
+                    }
+                }
+                error "should not get here"
+            }
+        }
+    }
+} else {
+    spi_exec -array A $query {
+        elog NOTICE "col1 $A(col1), col2 $A(col2)"
+
+        switch $A(col1) {
+            2 {
+                elog NOTICE "action: $2"
+                switch $2 {
+                    break {
+                        break
+                    }
+                    continue {
+                        continue
+                    }
+                    return {
+                        return
+                    }
+                    error {
+                        error "error message"
+                    }
+                }
+                error "should not get here"
+            }
+        }
+    }
+}
+elog NOTICE "end of function"
+$function$;

src/pl/tcl/sql/pltcl_queries.sql

@@ -80,8 +80,10 @@ insert into trigger_test_view values(2,'insert');
 update trigger_test_view set v = 'update' where i=1;
 delete from trigger_test_view;
 
+update trigger_test set v = 'update', test_skip=true where i = 1;
 update trigger_test set v = 'update' where i = 1;
 delete from trigger_test;
+truncate trigger_test;
 
 -- Test composite-type arguments
 select tcl_composite_arg_ref1(row('tkey', 42, 'ref2'));
@@ -91,6 +93,9 @@ select tcl_composite_arg_ref2(row('tkey', 42, 'ref2'));
 select tcl_argisnull('foo');
 select tcl_argisnull('');
 select tcl_argisnull(null);
+-- should error
+insert into trigger_test(test_argisnull) values(true);
+select trigger_data();
 
 -- Test spi_lastoid primitive
 create temp table t1 (f1 int);
@@ -99,14 +104,14 @@ create temp table t2 (f1 int) with oids;
 select tcl_lastoid('t2') > 0;
 
 -- test some error cases
-CREATE FUNCTION tcl_error(OUT a int, OUT b int) AS $$return {$$ LANGUAGE pltcl;
-SELECT tcl_error();
+create function tcl_error(out a int, out b int) as $$return {$$ language pltcl;
+select tcl_error();
 
-CREATE FUNCTION bad_record(OUT a text, OUT b text) AS $$return [list a]$$ LANGUAGE pltcl;
-SELECT bad_record();
+create function bad_record(out a text, out b text) as $$return [list a]$$ language pltcl;
+select bad_record();
 
-CREATE FUNCTION bad_field(OUT a text, OUT b text) AS $$return [list a 1 b 2 cow 3]$$ LANGUAGE pltcl;
-SELECT bad_field();
+create function bad_field(out a text, out b text) as $$return [list a 1 b 2 cow 3]$$ language pltcl;
+select bad_field();
 
 -- test compound return
 select * from tcl_test_cube_squared(5);
@@ -118,15 +123,96 @@ select * from tcl_test_sequence(0,5) as a;
 
 select 1, tcl_test_sequence(0,5);
 
-CREATE FUNCTION non_srf() RETURNS int AS $$return_next 1$$ LANGUAGE pltcl;
+create function non_srf() returns int as $$return_next 1$$ language pltcl;
 select non_srf();
 
-CREATE FUNCTION bad_record_srf(OUT a text, OUT b text) RETURNS SETOF record AS $$
+create function bad_record_srf(out a text, out b text) returns setof record as $$
 return_next [list a]
-$$ LANGUAGE pltcl;
-SELECT bad_record_srf();
+$$ language pltcl;
+select bad_record_srf();
 
-CREATE FUNCTION bad_field_srf(OUT a text, OUT b text) RETURNS SETOF record AS $$
+create function bad_field_srf(out a text, out b text) returns setof record as $$
 return_next [list a 1 b 2 cow 3]
-$$ LANGUAGE pltcl;
-SELECT bad_field_srf();
+$$ language pltcl;
+select bad_field_srf();
+
+-- test quote
+select tcl_eval('quote foo bar');
+select tcl_eval('quote [format %c 39]');
+select tcl_eval('quote [format %c 92]');
+
+-- Test argisnull
+select tcl_eval('argisnull');
+select tcl_eval('argisnull 14');
+select tcl_eval('argisnull abc');
+
+-- Test return_null
+select tcl_eval('return_null 14');
+-- should error
+insert into trigger_test(test_return_null) values(true);
+
+-- Test spi_exec
+select tcl_eval('spi_exec');
+select tcl_eval('spi_exec -count');
+select tcl_eval('spi_exec -array');
+select tcl_eval('spi_exec -count abc');
+select tcl_eval('spi_exec query loop body toomuch');
+select tcl_eval('spi_exec "begin; rollback;"');
+
+-- Test spi_execp
+select tcl_eval('spi_execp');
+select tcl_eval('spi_execp -count');
+select tcl_eval('spi_execp -array');
+select tcl_eval('spi_execp -count abc');
+select tcl_eval('spi_execp -nulls');
+select tcl_eval('spi_execp ""');
+
+-- test spi_prepare
+select tcl_eval('spi_prepare');
+select tcl_eval('spi_prepare a b');
+select tcl_eval('spi_prepare a "b {"');
+select tcl_error_handling_test($tcl$spi_prepare "select moo" []$tcl$);
+
+-- test full error text
+select tcl_error_handling_test($tcl$
+spi_exec "DO $$
+BEGIN
+RAISE 'my message'
+	USING HINT = 'my hint'
+	, DETAIL = 'my detail'
+	, SCHEMA = 'my schema'
+	, TABLE = 'my table'
+	, COLUMN = 'my column'
+	, CONSTRAINT = 'my constraint'
+	, DATATYPE = 'my datatype'
+;
+END$$;"
+$tcl$);
+
+-- verify tcl_error_handling_test() properly reports non-postgres errors
+select tcl_error_handling_test('moo');
+
+-- test elog
+select tcl_eval('elog');
+select tcl_eval('elog foo bar');
+
+-- test forced error
+select tcl_eval('error "forced error"');
+
+-- test loop control in spi_exec[p]
+select tcl_spi_exec(true, 'break');
+select tcl_spi_exec(true, 'continue');
+select tcl_spi_exec(true, 'error');
+select tcl_spi_exec(true, 'return');
+select tcl_spi_exec(false, 'break');
+select tcl_spi_exec(false, 'continue');
+select tcl_spi_exec(false, 'error');
+select tcl_spi_exec(false, 'return');
+
+-- forcibly run the Tcl event loop for awhile, to check that we have not
+-- messed things up too badly by disabling the Tcl notifier subsystem
+select tcl_eval($$
+  unset -nocomplain ::tcl_vwait
+  after 100 {set ::tcl_vwait 1}
+  vwait ::tcl_vwait
+  unset -nocomplain ::tcl_vwait$$);

src/pl/tcl/sql/pltcl_setup.sql

@@ -57,12 +57,33 @@ create function check_pkey1_exists(int4, bpchar) returns bool as E'
 
 -- dump trigger data
 
-CREATE TABLE trigger_test
-    (i int, v text );
+CREATE TABLE trigger_test (
+	i int,
+	v text,
+	dropme text,
+	test_skip boolean DEFAULT false,
+	test_return_null boolean DEFAULT false,
+	test_argisnull boolean DEFAULT false
+);
+-- Make certain dropped attributes are handled correctly
+ALTER TABLE trigger_test DROP dropme;
 
-CREATE VIEW trigger_test_view AS SELECT * FROM trigger_test;
+CREATE VIEW trigger_test_view AS SELECT i, v FROM trigger_test;
 
 CREATE FUNCTION trigger_data() returns trigger language pltcl as $_$
+	if {$TG_table_name eq "trigger_test" && $TG_level eq "ROW" && $TG_op ne "DELETE"} {
+		# Special case tests
+		if {$NEW(test_return_null) eq "t" } {
+			return_null
+		}
+		if {$NEW(test_argisnull) eq "t" } {
+			set should_error [argisnull 1]
+		}
+		if {$NEW(test_skip) eq "t" } {
+			elog NOTICE "SKIPPING OPERATION $TG_op"
+			return SKIP
+		}
+	}
 
 	if { [info exists TG_relid] } {
 	set TG_relid "bogus:12345"
@@ -97,6 +118,9 @@ $_$;
 CREATE TRIGGER show_trigger_data_trig
 BEFORE INSERT OR UPDATE OR DELETE ON trigger_test
 FOR EACH ROW EXECUTE PROCEDURE trigger_data(23,'skidoo');
+CREATE TRIGGER statement_trigger
+BEFORE INSERT OR UPDATE OR DELETE OR TRUNCATE ON trigger_test
+FOR EACH STATEMENT EXECUTE PROCEDURE trigger_data(42,'statement trigger');
 
 CREATE TRIGGER show_trigger_data_view_trig
 INSTEAD OF INSERT OR UPDATE OR DELETE ON trigger_test_view
@@ -579,14 +603,14 @@ select tcl_date_week(2010,1,24);
 select tcl_date_week(2001,10,24);
 
 -- test pltcl event triggers
-create or replace function tclsnitch() returns event_trigger language pltcl as $$
+create function tclsnitch() returns event_trigger language pltcl as $$
   elog NOTICE "tclsnitch: $TG_event $TG_tag"
 $$;
 
 create event trigger tcl_a_snitch on ddl_command_start execute procedure tclsnitch();
 create event trigger tcl_b_snitch on ddl_command_end execute procedure tclsnitch();
 
-create or replace function foobar() returns int language sql as $$select 1;$$;
+create function foobar() returns int language sql as $$select 1;$$;
 alter function foobar() cost 77;
 drop function foobar();
 
@@ -596,42 +620,113 @@ drop table foo;
 drop event trigger tcl_a_snitch;
 drop event trigger tcl_b_snitch;
 
-CREATE FUNCTION tcl_test_cube_squared(in int, out squared int, out cubed int) AS $$
+create function tcl_test_cube_squared(in int, out squared int, out cubed int) as $$
     return [list squared [expr {$1 * $1}] cubed [expr {$1 * $1 * $1}]]
 $$ language pltcl;
 
-CREATE FUNCTION tcl_test_squared_rows(int,int) RETURNS TABLE (x int, y int) AS $$
+create function tcl_test_squared_rows(int,int) returns table (x int, y int) as $$
     for {set i $1} {$i < $2} {incr i} {
         return_next [list y [expr {$i * $i}] x $i]
     }
 $$ language pltcl;
 
-CREATE FUNCTION tcl_test_sequence(int,int) RETURNS SETOF int AS $$
+create function tcl_test_sequence(int,int) returns setof int as $$
     for {set i $1} {$i < $2} {incr i} {
         return_next $i
     }
 $$ language pltcl;
 
+create function tcl_eval(string text) returns text as $$
+    eval $1
+$$ language pltcl;
+
 -- test use of errorCode in error handling
+create function tcl_error_handling_test(text) returns text
+language pltcl
+as $function$
+    if {[catch $1 err]} {
+        # If not a Postgres error, just return the basic error message
+        if {[lindex $::errorCode 0] != "POSTGRES"} {
+            return $err
+        }
 
-create function tcl_error_handling_test() returns text as $$
-    global errorCode
-    if {[catch { spi_exec "select no_such_column from foo;" }]} {
-        array set errArray $errorCode
-        if {$errArray(condition) == "undefined_table"} {
-            return "expected error: $errArray(message)"
-        } else {
-            return "unexpected error: $errArray(condition) $errArray(message)"
+        # Get rid of keys that can't be expected to remain constant
+        array set myArray $::errorCode
+        unset myArray(POSTGRES)
+        unset myArray(funcname)
+        unset myArray(filename)
+        unset myArray(lineno)
+
+        # Format into something nicer
+        set vals []
+        foreach {key} [lsort [array names myArray]] {
+            set value [string map {"\n" "\n\t"} $myArray($key)]
+            lappend vals "$key: $value"
         }
+        return [join $vals "\n"]
     } else {
         return "no error"
     }
-$$ language pltcl;
-
-select tcl_error_handling_test();
-
-create temp table foo(f1 int);
-
-select tcl_error_handling_test();
-
-drop table foo;
+$function$;
+
+-- test spi_exec and spi_execp with -array
+create function tcl_spi_exec(
+    prepare boolean,
+    action text
+)
+returns void language pltcl AS $function$
+set query "select * from (values (1,'foo'),(2,'bar'),(3,'baz')) v(col1,col2)"
+if {$1 == "t"} {
+    set prep [spi_prepare $query {}]
+    spi_execp -array A $prep {
+        elog NOTICE "col1 $A(col1), col2 $A(col2)"
+
+        switch $A(col1) {
+            2 {
+                elog NOTICE "action: $2"
+                switch $2 {
+                    break {
+                        break
+                    }
+                    continue {
+                        continue
+                    }
+                    return {
+                        return
+                    }
+                    error {
+                        error "error message"
+                    }
+                }
+                error "should not get here"
+            }
+        }
+    }
+} else {
+    spi_exec -array A $query {
+        elog NOTICE "col1 $A(col1), col2 $A(col2)"
+
+        switch $A(col1) {
+            2 {
+                elog NOTICE "action: $2"
+                switch $2 {
+                    break {
+                        break
+                    }
+                    continue {
+                        continue
+                    }
+                    return {
+                        return
+                    }
+                    error {
+                        error "error message"
+                    }
+                }
+                error "should not get here"
+            }
+        }
+    }
+}
+elog NOTICE "end of function"
+$function$;