tcl/sql/pltcl_setup.sql

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"] -format "%U"]
$$ 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$;