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);
 tcl_date_week 
---------------
 04
(1 row)

select tcl_date_week(2001,10,24);
 tcl_date_week 
---------------
 42
(1 row)

-- 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;$$;
NOTICE:  tclsnitch: ddl_command_start CREATE FUNCTION
NOTICE:  tclsnitch: ddl_command_end CREATE FUNCTION
alter function foobar() cost 77;
NOTICE:  tclsnitch: ddl_command_start ALTER FUNCTION
NOTICE:  tclsnitch: ddl_command_end ALTER FUNCTION
drop function foobar();
NOTICE:  tclsnitch: ddl_command_start DROP FUNCTION
NOTICE:  tclsnitch: ddl_command_end DROP FUNCTION
create table foo();
NOTICE:  tclsnitch: ddl_command_start CREATE TABLE
NOTICE:  tclsnitch: ddl_command_end CREATE TABLE
drop table foo;
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 $$
    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$;