src/pl/tcl/expected/pltcl_setup.out

   1 --
   2 -- Create the tables used in the test queries
   3 --
   4 -- T_pkey1 is the primary key table for T_dta1. Entries from T_pkey1
   5 -- Cannot be changed or deleted if they are referenced from T_dta1.
   6 --
   7 -- T_pkey2 is the primary key table for T_dta2. If the key values in
   8 -- T_pkey2 are changed, the references in T_dta2 follow. If entries
   9 -- are deleted, the referencing entries from T_dta2 are deleted too.
  10 -- The values for field key2 in T_pkey2 are silently converted to
  11 -- upper case on insert/update.
  12 --
  13 create table T_pkey1 (
  14     key1        int4,
  15     key2        char(20),
  16     txt         char(40)
  17 );
  18 create table T_pkey2 (
  19     key1        int4,
  20     key2        char(20),
  21     txt         char(40)
  22 );
  23 create table T_dta1 (
  24     tkey        char(10),
  25     ref1        int4,
  26     ref2        char(20)
  27 );
  28 create table T_dta2 (
  29     tkey        char(10),
  30     ref1        int4,
  31     ref2        char(20)
  32 );
  33 --
  34 -- Function to check key existance in T_pkey1
  35 --
  36 create function check_pkey1_exists(int4, bpchar) returns bool as E'
  37     if {![info exists GD]} {
  38         set GD(plan) [spi_prepare                               \\
  39             "select 1 from T_pkey1                              \\
  40                 where key1 = \\$1 and key2 = \\$2"              \\
  41             {int4 bpchar}]
  42     }
  43
  44     set n [spi_execp -count 1 $GD(plan) [list $1 $2]]
  45
  46     if {$n > 0} {
  47         return "t"
  48     }
  49     return "f"
  50 ' language pltcl;
  51 -- dump trigger data
  52 CREATE TABLE trigger_test
  53     (i int, v text );
  54 CREATE FUNCTION trigger_data() returns trigger language pltcl as $_$
  55
  56         if { [info exists TG_relid] } {
  57         set TG_relid "bogus:12345"
  58         }
  59
  60         set dnames [info locals {[a-zA-Z]*} ]
  61
  62         foreach key [lsort $dnames] {
  63
  64                 if { [array exists $key] } {
  65                         set str "{"
  66                         foreach akey [lsort [ array names $key ] ] {
  67                                 if {[string length $str] > 1} { set str "$str, " }
  68                                 set cmd "($akey)"
  69                                 set cmd "set val \$$key$cmd"
  70                                 eval $cmd
  71                                 set str "$str$akey: $val"
  72                         }
  73                         set str "$str}"
  74                 elog NOTICE "$key: $str"
  75                 } else {
  76                         set val [eval list "\$$key" ]
  77                 elog NOTICE "$key: $val"
  78                 }
  79         }
  80
  81
  82         return OK
  83
  84 $_$;
  85 CREATE TRIGGER show_trigger_data_trig
  86 BEFORE INSERT OR UPDATE OR DELETE ON trigger_test
  87 FOR EACH ROW EXECUTE PROCEDURE trigger_data(23,'skidoo');
  88 --
  89 -- Trigger function on every change to T_pkey1
  90 --
  91 create function trig_pkey1_before() returns trigger as E'
  92     #
  93     # Create prepared plans on the first call
  94     #
  95     if {![info exists GD]} {
  96         #
  97         # Plan to check for duplicate key in T_pkey1
  98         #
  99         set GD(plan_pkey1) [spi_prepare                         \\
 100             "select check_pkey1_exists(\\$1, \\$2) as ret"      \\
 101             {int4 bpchar}]
 102         #
 103         # Plan to check for references from T_dta1
 104         #
 105         set GD(plan_dta1) [spi_prepare                          \\
 106             "select 1 from T_dta1                               \\
 107                 where ref1 = \\$1 and ref2 = \\$2"              \\
 108             {int4 bpchar}]
 109     }
 110
 111     #
 112     # Initialize flags
 113     #
 114     set check_old_ref 0
 115     set check_new_dup 0
 116
 117     switch $TG_op {
 118         INSERT {
 119             #
 120             # Must check for duplicate key on INSERT
 121             #
 122             set check_new_dup 1
 123         }
 124         UPDATE {
 125             #
 126             # Must check for duplicate key on UPDATE only if
 127             # the key changes. In that case we must check for
 128             # references to OLD values too.
 129             #
 130             if {[string compare $NEW(key1) $OLD(key1)] != 0} {
 131                 set check_old_ref 1
 132                 set check_new_dup 1
 133             }
 134             if {[string compare $NEW(key2) $OLD(key2)] != 0} {
 135                 set check_old_ref 1
 136                 set check_new_dup 1
 137             }
 138         }
 139         DELETE {
 140             #
 141             # Must only check for references to OLD on DELETE
 142             #
 143             set check_old_ref 1
 144         }
 145     }
 146
 147     if {$check_new_dup} {
 148         #
 149         # Check for duplicate key
 150         #
 151         spi_execp -count 1 $GD(plan_pkey1) [list $NEW(key1) $NEW(key2)]
 152         if {$ret == "t"} {
 153             elog ERROR \\
 154                 "duplicate key ''$NEW(key1)'', ''$NEW(key2)'' for T_pkey1"
 155         }
 156     }
 157
 158     if {$check_old_ref} {
 159         #
 160         # Check for references to OLD
 161         #
 162         set n [spi_execp -count 1 $GD(plan_dta1) [list $OLD(key1) $OLD(key2)]]
 163         if {$n > 0} {
 164             elog ERROR \\
 165                 "key ''$OLD(key1)'', ''$OLD(key2)'' referenced by T_dta1"
 166         }
 167     }
 168
 169     #
 170     # Anything is fine - let operation pass through
 171     #
 172     return OK
 173 ' language pltcl;
 174 create trigger pkey1_before before insert or update or delete on T_pkey1
 175         for each row execute procedure
 176         trig_pkey1_before();
 177 --
 178 -- Trigger function to check for duplicate keys in T_pkey2
 179 -- and to force key2 to be upper case only without leading whitespaces
 180 --
 181 create function trig_pkey2_before() returns trigger as E'
 182     #
 183     # Prepare plan on first call
 184     #
 185     if {![info exists GD]} {
 186         set GD(plan_pkey2) [spi_prepare                         \\
 187             "select 1 from T_pkey2                              \\
 188                 where key1 = \\$1 and key2 = \\$2"              \\
 189             {int4 bpchar}]
 190     }
 191
 192     #
 193     # Convert key2 value
 194     #
 195     set NEW(key2) [string toupper [string trim $NEW(key2)]]
 196
 197     #
 198     # Check for duplicate key
 199     #
 200     set n [spi_execp -count 1 $GD(plan_pkey2) [list $NEW(key1) $NEW(key2)]]
 201     if {$n > 0} {
 202         elog ERROR \\
 203             "duplicate key ''$NEW(key1)'', ''$NEW(key2)'' for T_pkey2"
 204     }
 205
 206     #
 207     # Return modified tuple in NEW
 208     #
 209     return [array get NEW]
 210 ' language pltcl;
 211 create trigger pkey2_before before insert or update on T_pkey2
 212         for each row execute procedure
 213         trig_pkey2_before();
 214 --
 215 -- Trigger function to force references from T_dta2 follow changes
 216 -- in T_pkey2 or be deleted too. This must be done AFTER the changes
 217 -- in T_pkey2 are done so the trigger for primkey check on T_dta2
 218 -- fired on our updates will see the new key values in T_pkey2.
 219 --
 220 create function trig_pkey2_after() returns trigger as E'
 221     #
 222     # Prepare plans on first call
 223     #
 224     if {![info exists GD]} {
 225         #
 226         # Plan to update references from T_dta2
 227         #
 228         set GD(plan_dta2_upd) [spi_prepare                      \\
 229             "update T_dta2 set ref1 = \\$3, ref2 = \\$4         \\
 230                 where ref1 = \\$1 and ref2 = \\$2"              \\
 231             {int4 bpchar int4 bpchar}]
 232         #
 233         # Plan to delete references from T_dta2
 234         #
 235         set GD(plan_dta2_del) [spi_prepare                      \\
 236             "delete from T_dta2                                 \\
 237                 where ref1 = \\$1 and ref2 = \\$2"              \\
 238             {int4 bpchar}]
 239     }
 240
 241     #
 242     # Initialize flags
 243     #
 244     set old_ref_follow 0
 245     set old_ref_delete 0
 246
 247     switch $TG_op {
 248         UPDATE {
 249             #
 250             # On update we must let old references follow
 251             #
 252             set NEW(key2) [string toupper $NEW(key2)]
 253
 254             if {[string compare $NEW(key1) $OLD(key1)] != 0} {
 255                 set old_ref_follow 1
 256             }
 257             if {[string compare $NEW(key2) $OLD(key2)] != 0} {
 258                 set old_ref_follow 1
 259             }
 260         }
 261         DELETE {
 262             #
 263             # On delete we must delete references too
 264             #
 265             set old_ref_delete 1
 266         }
 267     }
 268
 269     if {$old_ref_follow} {
 270         #
 271         # Let old references follow and fire NOTICE message if
 272         # there where some
 273         #
 274         set n [spi_execp $GD(plan_dta2_upd) \\
 275             [list $OLD(key1) $OLD(key2) $NEW(key1) $NEW(key2)]]
 276         if {$n > 0} {
 277             elog NOTICE \\
 278                 "updated $n entries in T_dta2 for new key in T_pkey2"
 279         }
 280     }
 281
 282     if {$old_ref_delete} {
 283         #
 284         # delete references and fire NOTICE message if
 285         # there where some
 286         #
 287         set n [spi_execp $GD(plan_dta2_del) \\
 288             [list $OLD(key1) $OLD(key2)]]
 289         if {$n > 0} {
 290             elog NOTICE \\
 291                 "deleted $n entries from T_dta2"
 292         }
 293     }
 294
 295     return OK
 296 ' language pltcl;
 297 create trigger pkey2_after after update or delete on T_pkey2
 298         for each row execute procedure
 299         trig_pkey2_after();
 300 --
 301 -- Generic trigger function to check references in T_dta1 and T_dta2
 302 --
 303 create function check_primkey() returns trigger as E'
 304     #
 305     # For every trigger/relation pair we create
 306     # a saved plan and hold them in GD
 307     #
 308     set plankey [list "plan" $TG_name $TG_relid]
 309     set planrel [list "relname" $TG_relid]
 310
 311     #
 312     # Extract the pkey relation name
 313     #
 314     set keyidx [expr [llength $args] / 2]
 315     set keyrel [string tolower [lindex $args $keyidx]]
 316
 317     if {![info exists GD($plankey)]} {
 318         #
 319         # We must prepare a new plan. Build up a query string
 320         # for the primary key check.
 321         #
 322         set keylist [lrange $args [expr $keyidx + 1] end]
 323
 324         set query "select 1 from $keyrel"
 325         set qual " where"
 326         set typlist ""
 327         set idx 1
 328         foreach key $keylist {
 329             set key [string tolower $key]
 330             #
 331             # Add the qual part to the query string
 332             #
 333             append query "$qual $key = \\$$idx"
 334             set qual " and"
 335
 336             #
 337             # Lookup the fields type in pg_attribute
 338             #
 339             set n [spi_exec "select T.typname                   \\
 340                 from pg_catalog.pg_type T, pg_catalog.pg_attribute A, pg_catalog.pg_class C     \\
 341                 where C.relname  = ''[quote $keyrel]''          \\
 342                   and C.oid      = A.attrelid                   \\
 343                   and A.attname  = ''[quote $key]''             \\
 344                   and A.atttypid = T.oid"]
 345             if {$n != 1} {
 346                 elog ERROR "table $keyrel doesn''t have a field named $key"
 347             }
 348
 349             #
 350             # Append the fields type to the argument type list
 351             #
 352             lappend typlist $typname
 353             incr idx
 354         }
 355
 356         #
 357         # Prepare the plan
 358         #
 359         set GD($plankey) [spi_prepare $query $typlist]
 360
 361         #
 362         # Lookup and remember the table name for later error messages
 363         #
 364         spi_exec "select relname from pg_catalog.pg_class       \\
 365                 where oid = ''$TG_relid''::oid"
 366         set GD($planrel) $relname
 367     }
 368
 369     #
 370     # Build the argument list from the NEW row
 371     #
 372     incr keyidx -1
 373     set arglist ""
 374     foreach arg [lrange $args 0 $keyidx] {
 375         lappend arglist $NEW($arg)
 376     }
 377
 378     #
 379     # Check for the primary key
 380     #
 381     set n [spi_execp -count 1 $GD($plankey) $arglist]
 382     if {$n <= 0} {
 383         elog ERROR "key for $GD($planrel) not in $keyrel"
 384     }
 385
 386     #
 387     # Anything is fine
 388     #
 389     return OK
 390 ' language pltcl;
 391 create trigger dta1_before before insert or update on T_dta1
 392         for each row execute procedure
 393         check_primkey('ref1', 'ref2', 'T_pkey1', 'key1', 'key2');
 394 create trigger dta2_before before insert or update on T_dta2
 395         for each row execute procedure
 396         check_primkey('ref1', 'ref2', 'T_pkey2', 'key1', 'key2');
 397 create function tcl_int4add(int4,int4) returns int4 as '
 398     return [expr $1 + $2]
 399 ' language pltcl;
 400 -- We use split(n) as a quick-and-dirty way of parsing the input array
 401 -- value, which comes in as a string like '{1,2}'.  There are better ways...
 402 create function tcl_int4_accum(int4[], int4) returns int4[] as '
 403     set state [split $1 "{,}"]
 404     set newsum [expr {[lindex $state 1] + $2}]
 405     set newcnt [expr {[lindex $state 2] + 1}]
 406     return "{$newsum,$newcnt}"
 407 ' language pltcl;
 408 create function tcl_int4_avg(int4[]) returns int4 as '
 409     set state [split $1 "{,}"]
 410     if {[lindex $state 2] == 0} { return_null }
 411     return [expr {[lindex $state 1] / [lindex $state 2]}]
 412 ' language pltcl;
 413 create aggregate tcl_avg (
 414                 sfunc = tcl_int4_accum,
 415                 basetype = int4,
 416                 stype = int4[],
 417                 finalfunc = tcl_int4_avg,
 418                 initcond = '{0,0}'
 419         );
 420 create aggregate tcl_sum (
 421                 sfunc = tcl_int4add,
 422                 basetype = int4,
 423                 stype = int4,
 424                 initcond1 = 0
 425         );
 426 create function tcl_int4lt(int4,int4) returns bool as '
 427     if {$1 < $2} {
 428         return t
 429     }
 430     return f
 431 ' language pltcl;
 432 create function tcl_int4le(int4,int4) returns bool as '
 433     if {$1 <= $2} {
 434         return t
 435     }
 436     return f
 437 ' language pltcl;
 438 create function tcl_int4eq(int4,int4) returns bool as '
 439     if {$1 == $2} {
 440         return t
 441     }
 442     return f
 443 ' language pltcl;
 444 create function tcl_int4ge(int4,int4) returns bool as '
 445     if {$1 >= $2} {
 446         return t
 447     }
 448     return f
 449 ' language pltcl;
 450 create function tcl_int4gt(int4,int4) returns bool as '
 451     if {$1 > $2} {
 452         return t
 453     }
 454     return f
 455 ' language pltcl;
 456 create operator @< (
 457                 leftarg = int4,
 458                 rightarg = int4,
 459                 procedure = tcl_int4lt
 460         );
 461 create operator @<= (
 462                 leftarg = int4,
 463                 rightarg = int4,
 464                 procedure = tcl_int4le
 465         );
 466 create operator @= (
 467                 leftarg = int4,
 468                 rightarg = int4,
 469                 procedure = tcl_int4eq
 470         );
 471 create operator @>= (
 472                 leftarg = int4,
 473                 rightarg = int4,
 474                 procedure = tcl_int4ge
 475         );
 476 create operator @> (
 477                 leftarg = int4,
 478                 rightarg = int4,
 479                 procedure = tcl_int4gt
 480         );
 481 create function tcl_int4cmp(int4,int4) returns int4 as '
 482     if {$1 < $2} {
 483         return -1
 484     }
 485     if {$1 > $2} {
 486         return 1
 487     }
 488     return 0
 489 ' language pltcl;
 490 CREATE OPERATOR CLASS tcl_int4_ops
 491         FOR TYPE int4 USING btree AS
 492         OPERATOR 1  @<,
 493         OPERATOR 2  @<=,
 494         OPERATOR 3  @=,
 495         OPERATOR 4  @>=,
 496         OPERATOR 5  @>,
 497         FUNCTION 1  tcl_int4cmp(int4,int4) ;