diff options
Diffstat (limited to 'src/pl/tcl/sql/pltcl_setup.sql')
| -rw-r--r-- | src/pl/tcl/sql/pltcl_setup.sql | 278 |
1 files changed, 278 insertions, 0 deletions
diff --git a/src/pl/tcl/sql/pltcl_setup.sql b/src/pl/tcl/sql/pltcl_setup.sql new file mode 100644 index 0000000..b9892ea --- /dev/null +++ b/src/pl/tcl/sql/pltcl_setup.sql @@ -0,0 +1,278 @@ +create table T_comp1 ( + tkey char(10), + ref1 int4, + ref2 char(20) +); + +create function tcl_composite_arg_ref1(T_comp1) returns int as ' + return $1(ref1) +' language pltcl; + +create function tcl_composite_arg_ref2(T_comp1) returns text as ' + return $1(ref2) +' language pltcl; + +create function tcl_argisnull(text) returns bool as ' + argisnull 1 +' language pltcl; + + +create function tcl_int4add(int4,int4) returns int4 as ' + return [expr $1 + $2] +' language pltcl; + +-- We use split(n) as a quick-and-dirty way of parsing the input array +-- value, which comes in as a string like '{1,2}'. There are better ways... + +create function tcl_int4_accum(int4[], int4) returns int4[] as ' + set state [split $1 "{,}"] + set newsum [expr {[lindex $state 1] + $2}] + set newcnt [expr {[lindex $state 2] + 1}] + return "{$newsum,$newcnt}" +' language pltcl; + +create function tcl_int4_avg(int4[]) returns int4 as ' + set state [split $1 "{,}"] + if {[lindex $state 2] == 0} { return_null } + return [expr {[lindex $state 1] / [lindex $state 2]}] +' language pltcl; + +create aggregate tcl_avg ( + sfunc = tcl_int4_accum, + basetype = int4, + stype = int4[], + finalfunc = tcl_int4_avg, + initcond = '{0,0}' + ); + +create aggregate tcl_sum ( + sfunc = tcl_int4add, + basetype = int4, + stype = int4, + initcond1 = 0 + ); + +create function tcl_int4lt(int4,int4) returns bool as ' + if {$1 < $2} { + return t + } + return f +' language pltcl; + +create function tcl_int4le(int4,int4) returns bool as ' + if {$1 <= $2} { + return t + } + return f +' language pltcl; + +create function tcl_int4eq(int4,int4) returns bool as ' + if {$1 == $2} { + return t + } + return f +' language pltcl; + +create function tcl_int4ge(int4,int4) returns bool as ' + if {$1 >= $2} { + return t + } + return f +' language pltcl; + +create function tcl_int4gt(int4,int4) returns bool as ' + if {$1 > $2} { + return t + } + return f +' language pltcl; + +create operator @< ( + leftarg = int4, + rightarg = int4, + procedure = tcl_int4lt + ); + +create operator @<= ( + leftarg = int4, + rightarg = int4, + procedure = tcl_int4le + ); + +create operator @= ( + leftarg = int4, + rightarg = int4, + procedure = tcl_int4eq + ); + +create operator @>= ( + leftarg = int4, + rightarg = int4, + procedure = tcl_int4ge + ); + +create operator @> ( + leftarg = int4, + rightarg = int4, + procedure = tcl_int4gt + ); + +create function tcl_int4cmp(int4,int4) returns int4 as ' + if {$1 < $2} { + return -1 + } + if {$1 > $2} { + return 1 + } + return 0 +' language pltcl; + +CREATE OPERATOR CLASS tcl_int4_ops + FOR TYPE int4 USING btree AS + OPERATOR 1 @<, + OPERATOR 2 @<=, + OPERATOR 3 @=, + OPERATOR 4 @>=, + OPERATOR 5 @>, + FUNCTION 1 tcl_int4cmp(int4,int4) ; + +-- +-- Test usage of Tcl's "clock" command. In recent Tcl versions this +-- command fails without working "unknown" support, so it's a good canary +-- for initialization problems. +-- +create function tcl_date_week(int4,int4,int4) returns text as $$ + return [clock format [clock scan "$2/$3/$1" -gmt 1] -format "%U" -gmt 1] +$$ language pltcl immutable; + +select tcl_date_week(2010,1,26); +select tcl_date_week(2001,10,24); + +-- test pltcl event triggers +create function tclsnitch() returns event_trigger language pltcl as $$ + elog NOTICE "tclsnitch: $TG_event $TG_tag" +$$; + +create event trigger tcl_a_snitch on ddl_command_start execute procedure tclsnitch(); +create event trigger tcl_b_snitch on ddl_command_end execute procedure tclsnitch(); + +create function foobar() returns int language sql as $$select 1;$$; +alter function foobar() cost 77; +drop function foobar(); + +create table foo(); +drop table foo; + +drop event trigger tcl_a_snitch; +drop event trigger tcl_b_snitch; + +create function tcl_test_cube_squared(in int, out squared int, out cubed int) as $$ + return [list squared [expr {$1 * $1}] cubed [expr {$1 * $1 * $1}]] +$$ language pltcl; + +create function tcl_test_squared_rows(int,int) returns table (x int, y int) as $$ + for {set i $1} {$i < $2} {incr i} { + return_next [list y [expr {$i * $i}] x $i] + } +$$ language pltcl; + +create function tcl_test_sequence(int,int) returns setof int as $$ + for {set i $1} {$i < $2} {incr i} { + return_next $i + } +$$ language pltcl; + +create function tcl_eval(string text) returns text as $$ + eval $1 +$$ language pltcl; + +-- test use of errorCode in error handling +create function tcl_error_handling_test(text) returns text +language pltcl +as $function$ + if {[catch $1 err]} { + # If not a Postgres error, just return the basic error message + if {[lindex $::errorCode 0] != "POSTGRES"} { + return $err + } + + # Get rid of keys that can't be expected to remain constant + array set myArray $::errorCode + unset myArray(POSTGRES) + unset -nocomplain myArray(funcname) + unset -nocomplain myArray(filename) + unset -nocomplain myArray(lineno) + + # Format into something nicer + set vals [] + foreach {key} [lsort [array names myArray]] { + set value [string map {"\n" "\n\t"} $myArray($key)] + lappend vals "$key: $value" + } + return [join $vals "\n"] + } else { + return "no error" + } +$function$; + +-- test spi_exec and spi_execp with -array +create function tcl_spi_exec( + prepare boolean, + action text +) +returns void language pltcl AS $function$ +set query "select * from (values (1,'foo'),(2,'bar'),(3,'baz')) v(col1,col2)" +if {$1 == "t"} { + set prep [spi_prepare $query {}] + spi_execp -array A $prep { + elog NOTICE "col1 $A(col1), col2 $A(col2)" + + switch $A(col1) { + 2 { + elog NOTICE "action: $2" + switch $2 { + break { + break + } + continue { + continue + } + return { + return + } + error { + error "error message" + } + } + error "should not get here" + } + } + } +} else { + spi_exec -array A $query { + elog NOTICE "col1 $A(col1), col2 $A(col2)" + + switch $A(col1) { + 2 { + elog NOTICE "action: $2" + switch $2 { + break { + break + } + continue { + continue + } + return { + return + } + error { + error "error message" + } + } + error "should not get here" + } + } + } +} +elog NOTICE "end of function" +$function$; |