1# 2# STAPI PostgreSQL Client 3# 4# This stuff adds sql:// as a stapi URI and provides a way to look at 5# PostgreSQL tables as if they are ctables 6# 7 8package require st_client 9package require st_client_uri 10package require st_postgres 11 12namespace eval ::stapi { 13 # 14 # make_sql_uri - given a table name and some optional arguments like 15 # host, user, pass, db, keys, and key, construct a sql URI that 16 # looks like sql://... 17 # 18 proc make_sql_uri {table args} { 19 while {[llength $args]} { 20 set arg [lindex $args 0] 21 set args [lrange $args 1 end] 22 23 if {![regexp {^-(.*)} $arg _ opt]} { 24 lappend cols [uri_esc $arg /?] 25 } else { 26 set val [lindex $args 0] 27 set args [lrange $args 1 end] 28 29 switch -- $opt { 30 cols { 31 foreach col $val { 32 lappend cols [uri_esc $col /?] 33 } 34 } 35 36 host { 37 set host [uri_esc $val @/:] 38 } 39 40 user { 41 set user [uri_esc $val @/:] 42 } 43 44 pass { 45 set pass [uri_esc $val @/:] 46 } 47 48 db { 49 set db [uri_esc $val @/:] 50 } 51 52 keys { 53 lappend params [uri_esc _keys=[join $val :] &] 54 } 55 56 key { 57 lappend params [uri_esc _key=$val &] 58 } 59 60 -* { 61 regexp {^-(.*)} $opt _ opt 62 lappend params [uri_esc $opt &=]=[uri_esc $val &] 63 } 64 65 * { 66 lappend params [uri_esc $opt &=]=[uri_esc $val &] 67 } 68 } 69 } 70 } 71 72 set uri sql:// 73 if {[info exists user]} { 74 if {[info exists pass]} { 75 append user : $pass 76 } 77 78 append uri $user @ 79 } 80 81 if {[info exists host]} { 82 append uri $host : 83 } 84 85 if {[info exists db]} { 86 append uri $db 87 } 88 89 append uri / [uri_esc $table /?] 90 if {[info exists cols]} { 91 append uri / [join $cols /] 92 } 93 94 if {[info exists params]} { 95 append uri ? [join $params &] 96 } 97 return $uri 98 } 99 100 variable sqltable_seq 0 101 102 # 103 # connect_pgsql - connect to postgres by cracking a sql uri 104 # 105 proc connect_pgsql {table {address "-"} args} { 106 variable sqltable_seq 107 108 set params "" 109 regexp {^([^?]*)[?](.*)} $table _ table params 110 set path "" 111 regexp {^/*([^/]*)/(.*)} $table _ table path 112 set path [split $path "/"] 113 set table [uri_unesc $table] 114 115 foreach param [split $params "&"] { 116 if {[regexp {^([^=]*)=(.*)} $param _ name val]} { 117 set vars([uri_unesc $name]) [uri_unesc $val] 118 } else { 119 set vars([uri_unesc $name]) "" 120 } 121 } 122 123 set raw_fields {} 124 foreach {name type} [get_columns $table] { 125 lappend raw_fields $name 126 set field2type($name) $type 127 } 128 129 if {[llength $path]} { 130 set raw_fields {} 131 foreach field $path { 132 set field [uri_unesc $field] 133 134 if {[regexp {^([^:]*):(.*)} $field _ field type]} { 135 set field2type($field) $type 136 } 137 lappend raw_fields $field 138 } 139 } 140 141 # If the key is a simple column name, remember it and eliminate _key 142 if {[info exists vars(_key)]} { 143 if {[lsearch $raw_fields $vars(_key)] != -1} { 144 set key $vars(_key) 145 unset vars(_key) 146 } 147 } 148 149 if {[info exists vars(_key)] || [info exists vars(_keys)]} { 150 if {[lsearch $path _key] == -1} { 151 set raw_fields [concat {_key} $raw_fields] 152 } 153 } 154 155 if {[info exists vars(_keys)]} { 156 regsub -all {[+: ]+} $vars(_keys) ":" vars(_keys) 157 set keys [split $vars(_keys) ":"] 158 159 if {[llength $keys] == 1} { 160 set vars(_key) [lindex $keys 0] 161 } elseif {[llength $keys] > 1} { 162 set list {} 163 164 foreach field $keys { 165 if {[info exists vars($field)]} { 166 lappend list $vars($field) 167 } else { 168 set type varchar 169 170 if {[info exists field2type($field)]} { 171 set type $field2type($field) 172 } 173 174 if {"$type" == "varchar" || "$type" == "text"} { 175 lappend list $field 176 } else { 177 lappend list TEXT($field) 178 } 179 180 } 181 } 182 183 if {[llength $list] < 2} { 184 set vars(_key) $list 185 } else { 186 set newList [list] 187 foreach element $list { 188 lappend newList "coalesce($list,'')" 189 } 190 set vars(_key) [join $newList "||':'||"] 191 } 192 } 193 } 194 195 foreach field $raw_fields { 196 if {"$field" == "_key"} { 197 set key $vars(_key) 198 } else { 199 lappend fields $field 200 } 201 202 if {[info exists params($field)]} { 203 set field2sql($field) $params($field) 204 unset params($field) 205 } 206 } 207 208 # last ditch - use first field in table 209 if {![info exists key]} { 210 set key [lindex $fields 0] 211 # set fields [lrange $fields 1 end] 212 } 213 214 set ns ::stapi::sqltable[incr sqltable_seq] 215 216 namespace eval $ns { 217 # 218 # ctable - 219 # 220 proc ctable {args} { 221 set level [expr {[info level] - 1}] 222 catch {::stapi::sql_ctable $level [namespace current] {*}$args} catchResult catchOptions 223 dict incr catchOptions -level 1 224 return -options $catchOptions $catchResult 225 } 226 227 # copy the search proc into this namespace 228 proc search_to_sql [info args ::stapi::search_to_sql] [info body ::stapi::search_to_sql] 229 } 230 231 set ${ns}::table_name $table 232 array set ${ns}::sql [array get field2sql] 233 set ${ns}::key $key 234 set ${ns}::fields $fields 235 array set ${ns}::types [array get field2type] 236 237 return ${ns}::ctable 238 } 239 register sql connect_pgsql 240 241 variable ctable_commands 242 array set ctable_commands { 243 get sql_ctable_get 244 set sql_ctable_set 245 array_get sql_ctable_array_get 246 array_get_with_nulls sql_ctable_array_get_with_nulls 247 exists sql_ctable_exists 248 delete sql_ctable_delete 249 count sql_ctable_count 250 foreach sql_ctable_foreach 251 type sql_ctable_type 252 import sql_ctable_unimplemented 253 import_postgres_result sql_ctable_unimplemented 254 export sql_ctable_unimplemented 255 fields sql_ctable_fields 256 fieldtype sql_ctable_fieldtype 257 needs_quoting sql_ctable_needs_quoting 258 names sql_ctable_names 259 reset sql_ctable_unimplemented 260 destroy sql_ctable_destroy 261 search sql_ctable_search 262 search+ sql_ctable_search 263 statistics sql_ctable_unimplemented 264 write_tabsep sql_ctable_unimplemented 265 read_tabsep sql_ctable_read_tabsep 266 index sql_ctable_ignore_null 267 } 268 variable ctable_extended_commands 269 array set ctable_extended_commands { 270 methods sql_ctable_methods 271 key sql_ctable_key 272 keys sql_ctable_keys 273 makekey sql_ctable_makekey 274 store sql_ctable_store 275 } 276 277 # 278 # sql_ctable - 279 # 280 proc sql_ctable {level ns cmd args} { 281 variable ctable_commands 282 variable ctable_extended_commands 283 284 if {[info exists ctable_commands($cmd)]} { 285 set proc $ctable_commands($cmd) 286 } elseif {[info exists ctable_extended_commands($cmd)]} { 287 set proc $ctable_extended_commands($cmd) 288 } else { 289 set proc sql_ctable_unimplemented 290 } 291 292 catch {$proc $level $ns $cmd {*}$args} catchResult catchOptions 293 dict incr catchOptions -level 1 294 return -options $catchOptions $catchResult 295 296 #return [eval [list $proc $level $ns $cmd] $args] 297 #return [$proc $level $ns $cmd {*}$args] 298 } 299 300 # 301 # sql_ctable_methods - 302 # 303 proc sql_ctable_methods {level ns cmd args} { 304 variable ctable_commands 305 variable ctable_extended_commands 306 307 return [ 308 lsort [ 309 concat [array names ctable_commands] \ 310 [array names ctable_extended_commands] 311 ] 312 ] 313 } 314 315 # 316 # sql_ctable_key - 317 # 318 proc sql_ctable_key {level ns cmd args} { 319 set keys [set ${ns}::key] 320 if {[llength $keys] == 1} { 321 return [lindex $keys 0] 322 } else { 323 return "_key" 324 } 325 } 326 327 # 328 # sql_ctable_keys - 329 # 330 proc sql_ctable_keys {level ns cmd args} { 331 return [set ${ns}::key] 332 } 333 334 # 335 # sql_ctable_makekey 336 # 337 proc sql_ctable_makekey {level ns cmd args} { 338 if {[llength $args] == 1} { 339 set args [lindex $args 0] 340 } 341 342 array set array $args 343 set key [set ${ns}::key] 344 345 if {[info exists array($key)]} { 346 return $array($key) 347 } 348 349 if {[info exists array(_key)]} { 350 return $array(_key) 351 } 352 return -code error "No key in list" 353 } 354 355 # 356 # sql_ctable_unimplemented 357 # 358 proc sql_ctable_unimplemented {level ns cmd args} { 359 return -code error "Unimplemented command $cmd" 360 } 361 362 # 363 # sql_ctable_ignore_null 364 # 365 proc sql_ctable_ignore_null {args} { 366 return "" 367 } 368 369 # 370 # sql_ctable_ignore_true 371 # 372 proc sql_ctable_ignore_true {args} { 373 return 1 374 } 375 376 # 377 # sql_ctable_ignore_false 378 # 379 proc sql_ctable_ignore_false {args} { 380 return 0 381 } 382 383 # 384 # sql_create_sql 385 # 386 proc sql_create_sql {ns val slist} { 387 if {![llength $slist]} { 388 set slist [set ${ns}::fields] 389 } 390 391 foreach arg $slist { 392 if {[info exists ${ns}::sql($arg)]} { 393 lappend select [set ${ns}::sql($arg)] 394 } else { 395 lappend select $arg 396 } 397 } 398 399 set sql "SELECT [join $select ,] FROM [set ${ns}::table_name]" 400 append sql " WHERE [set ${ns}::key] = [pg_quote $val]" 401 append sql " LIMIT 1;" 402 403 return $sql 404 } 405 406 # 407 # sql_ctable_get - implement ctable get operation on a postgres table 408 # 409 # Get list - return empty list for no data, SQL error is error 410 # 411 proc sql_ctable_get {level ns cmd val args} { 412 set sql [sql_create_sql $ns $val $args] 413 set result "" 414 415 if {![sql_get_one_tuple $sql result]} { 416 error $result 417 } 418 419 return $result 420 } 421 422 # 423 # sql_ctable_array_get 424 # 425 # Get name-value list - return empty list for no data, SQL error is error 426 # 427 proc sql_ctable_array_get {level ns cmd val args} { 428 set sql [sql_create_sql $ns $val $args] 429 430 pg_select -withoutnulls -nodotfields [conn] $sql row { 431 return [array get row] 432 } 433 434 return [list] 435 } 436 437 438 # 439 # sql_ctable_array_get_with_nulls 440 # 441 # Get name-value list - return empty list for no data, SQL error is error 442 # 443 proc sql_ctable_array_get_with_nulls {level ns cmd val args} { 444 set sql [sql_create_sql $ns $val $args] 445 446 pg_select -nodotfields [conn] $sql row { 447 return [array get row] 448 } 449 450 return [list] 451 } 452 453 # 454 # sql_ctable_exists - implement a ctable exists method for SQL tables 455 # 456 proc sql_ctable_exists {level ns cmd val} { 457 set sql "SELECT [set ${ns}::key] FROM [set ${ns}::table_name]" 458 append sql " WHERE [set ${ns}::key] = [pg_quote $val]" 459 append sql " LIMIT 1;" 460 # debug "\[pg_exec \[conn] \"$sql\"]" 461 462 set pg_res [pg_exec [conn] $sql] 463 if {![set ok [string match "PGRES_*_OK" [pg_result $pg_res -status]]]} { 464 set err [pg_result $pg_res -error] 465 set errinf "$err\nIn $sql" 466 } else { 467 set result [pg_result $pg_res -numTuples] 468 } 469 470 pg_result $pg_res -clear 471 472 if {!$ok} { 473 return -code error -errorinfo $errinf $err 474 } 475 return $result 476 } 477 478 # 479 # sql_ctable_count - implement a ctable count method for SQL tables 480 # 481 proc sql_ctable_count {level ns cmd args} { 482 set sql "SELECT COUNT([set ${ns}::key]) FROM [set ${ns}::table_name]" 483 484 if {[llength $args] == 1} { 485 append sql " WHERE [set ${ns}::key] = [pg_quote $val]" 486 } 487 488 append sql ";" 489 return [lindex [sql_get_one_tuple $sql] 0] 490 } 491 492 # 493 # sql_ctable_fields - implement a ctables fields method for SQL tables 494 # 495 proc sql_ctable_fields {level ns cmd args} { 496 return [set ${ns}::fields] 497 } 498 499 # 500 # sql_ctable_type - implement a ctables "type" method for SQL tables 501 # 502 proc sql_ctable_type {level ns cmd args} { 503 return sql:///[set ${ns}::table_name] 504 } 505 506 # 507 # sql_ctable_fieldtype - implement a ctables "fieldtype" method for SQL tables 508 # 509 proc sql_ctable_fieldtype {level ns cmd field} { 510 if {![info exists ${ns}::types($field)]} { 511 return -code error "No such field: $field" 512 } 513 return [set ${ns}::types($field)] 514 } 515 516 # 517 # sql_ctable_search - implement a ctable search method for SQL tables 518 # 519 proc sql_ctable_search {level ns cmd args} { 520 array set search $args 521 522 if {![info exists search(-code)] && 523 ![info exists search(-key)] && 524 ![info exists search(-array)] && 525 ![info exists search(-array_get)] && 526 ![info exists search(-array_get_with_nulls)] && 527 ![info exists search(-array_with_nulls)]} { 528 set search(-countOnly) 1 529 } 530 531 set sql [${ns}::search_to_sql search] 532 if {[info exists search(-countOnly)]} { 533 return [lindex [sql_get_one_tuple $sql] 0] 534 } 535 536 set code {} 537 set array ${ns}::select_array 538 539 if {[info exists search(-array)]} { 540 set array $search(-array) 541 } 542 if {[info exists search(-array_with_nulls)]} { 543 set array $search(-array_with_nulls) 544 } 545 546 if {[info exists search(-array_get_with_nulls)]} { 547 lappend code "set $search(-array_get_with_nulls) \[array get $array]" 548 } 549 550 if {[info exists search(-array_get)]} { 551 lappend code "set $search(-array_get) \[array get $array]" 552 } 553 554 if {[info exists search(-key)]} { 555 lappend code "set $search(-key) \$${array}(__key)" 556 } 557 558 lappend code $search(-code) 559 lappend code "incr ${ns}::select_count" 560 set ${ns}::select_count 0 561 562 set selectCommand [list pg_select] 563 if {[info exists search(-array)] || [info exists search(-array_get)]} { 564 lappend selectCommand "-withoutnulls" 565 } 566 lappend selectCommand "-nodotfields" 567 lappend selectCommand [conn] $sql $array [join $code "\n"] 568 569 #puts stderr "sql_ctable_search level $level ns $ns cmd $cmd args $args: selectCommand is $selectCommand" 570 571 if {[catch {uplevel #$level $selectCommand} catchResult catchOptions]} { 572 dict incr catchOptions -level 1 573 return -options $catchOptions $catchResult 574 } 575 return [set ${ns}::select_count] 576 } 577 578 # 579 # sql_ctable_foreach - implement a ctable foreach method for SQL tables 580 # 581 proc sql_ctable_foreach {level ns cmd keyvar value code} { 582 set sql "SELECT [set ${ns}::key] FROM [set ${ns}::table_name]" 583 append sql " WHERE [set ${ns}::key] ILIKE [::stapi::quote_glob $val];" 584 set code "set $keyvar \[lindex $__key 0]\n$code" 585 uplevel #$level [list pg_select -nodotfields [conn] $sql __key $code] 586 } 587 588 # 589 # sql_ctable_destroy - implement a ctable destroy method for SQL tables 590 # 591 proc sql_ctable_destroy {level ns cmd args} { 592 namespace delete $ns 593 } 594 595 # 596 # sql_ctable_delete - implement a ctable delete method for SQL tables 597 # 598 proc sql_ctable_delete {level ns cmd key args} { 599 set sql "DELETE FROM [set ${ns}::table_name] WHERE [set ${ns}::key] = [pg_quote $key];" 600 return [exec_sql $sql] 601 } 602 603 # 604 # sql_ctable_set - implement a ctable set method for SQL tables 605 # 606 proc sql_ctable_set {level ns cmd key args} { 607 if {![llength $args]} { 608 return 609 } 610 611 if {[llength $args] == 1} { 612 set args [lindex $args 0] 613 } 614 615 foreach {col value} $args { 616 if {[info exists ${ns}::sql($col)]} { 617 set col [set ${ns}::sql($col)] 618 } 619 620 lappend assigns "$col = [pg_quote $value]" 621 lappend cols $col 622 lappend vals [pg_quote $value] 623 } 624 625 set sql "UPDATE [set ${ns}::table_name] SET [join $assigns ", "]" 626 append sql " WHERE [set ${ns}::key] = [pg_quote $key];" 627 set rows 0 628 629 if {![exec_sql_rows $sql rows]} { 630 return 0 631 } 632 633 if {$rows > 0} { 634 return 1 635 } 636 637 lappend cols [set ${ns}::key] 638 lappend vals [pg_quote $key] 639 640 set sql "INSERT INTO [set ${ns}::table_name] ([join $cols ","]) VALUES ([join $vals ","]);" 641 return [exec_sql $sql] 642 } 643 644 # 645 # sql_ctable_store - implement a ctable store method for SQL tables 646 # 647 proc sql_ctable_store {level ns cmd args} { 648 if {[llength $args] == 1} { 649 set args [lindex $args 0] 650 } 651 return [ 652 eval [list sql_ctable_set $level $ns $cmd [ 653 sql_ctable_makekey $level $ns $cmd $args 654 ]] $args 655 ] 656 } 657 658 # 659 # sql_ctable_needs_quoting 660 # 661 proc sql_ctable_needs_quoting {level ns cmd args} { sql_ctable_unimplemented } 662 663 # 664 # sql_ctable_names 665 # 666 proc sql_ctable_names {level ns cmd args} { sql_ctable_unimplemented } 667 668 # 669 # sql_ctable_read_tabsep 670 # 671 proc sql_ctable_read_tabsep {level ns cmd args} { sql_ctable_unimplemented } 672 673 # 674 # search_to_sql 675 # 676 # This is never evaluated directly, it's only copied into a namespace 677 # with [info body], so variables are from $ns and anything in ::stapi 678 # needs direct quoting 679 # 680 proc search_to_sql {_req} { 681 upvar 1 $_req req 682 variable key 683 variable table_name 684 variable fields 685 686 set select {} 687 if {[info exists req(-countOnly)]} { 688 lappend select "COUNT($key) AS count" 689 } else { 690 if {[info exists req(-key)]} { 691 if {[info exists sql($key)]} { 692 lappend select "$sql($key) AS __key" 693 } else { 694 lappend select "$key AS __key" 695 } 696 } 697 698 if {[info exists req(-fields)]} { 699 set cols $req(-fields) 700 701 foreach col $cols { 702 if {[info exists sql($col)]} { 703 lappend select "$sql($col) AS $col" 704 } else { 705 lappend select $col 706 } 707 } 708 } else { 709 # they want all fields 710 lappend select * 711 } 712 } 713 714 set where {} 715 if {[info exists req(-glob)]} { 716 lappend where "$key LIKE [quote_glob $req(-glob)]" 717 } 718 719 if {[info exists req(-compare)]} { 720 foreach tuple $req(-compare) { 721 foreach {op col v1 v2} $tuple break 722 723 if {[info exists sql($col)]} { 724 set col $sql($col) 725 } 726 727 switch -exact -- [string tolower $op] { 728 false { 729 lappend where "$col = FALSE" 730 } 731 732 true { 733 lappend where "$col = TRUE" 734 } 735 736 null { 737 lappend where "$col IS NULL" 738 } 739 740 notnull { 741 lappend where "$col IS NOT NULL" 742 } 743 744 < { 745 lappend where "$col < [pg_quote $v1]" 746 } 747 748 <= { 749 lappend where "$col <= [pg_quote $v1]" 750 } 751 752 = { 753 lappend where "$col = [pg_quote $v1]" 754 } 755 756 != { 757 lappend where "$col <> [pg_quote $v1]" 758 } 759 760 <> { 761 lappend where "$col <> [pg_quote $v1]" 762 } 763 764 >= { 765 lappend where "$col >= [pg_quote $v1]" 766 } 767 768 > { 769 lappend where "$col > [pg_quote $v1]" 770 } 771 772 imatch { 773 lappend where "$col ILIKE [::stapi::quote_glob $v1]" 774 } 775 776 -imatch { 777 lappend where "NOT $col ILIKE [::stapi::quote_glob $v1]" 778 } 779 780 match { 781 lappend where "$col ILIKE [::stapi::quote_glob $v1]" 782 } 783 784 notmatch { 785 lappend where "NOT $col ILIKE [::stapi::quote_glob $v1]" 786 } 787 788 xmatch { 789 lappend where "$col LIKE [::stapi::quote_glob $v1]" 790 } 791 792 -xmatch { 793 lappend where "NOT $col LIKE [::stapi::quote_glob $v1]" 794 } 795 796 match_case { 797 lappend where "$col LIKE [::stapi::quote_glob $v1]" 798 } 799 800 notmatch_case { 801 lappend where "NOT $col LIKE [::stapi::quote_glob $v1]" 802 } 803 804 umatch { 805 lappend where "$col LIKE [::stapi::quote_glob [string toupper $v1]]" 806 } 807 808 -umatch { 809 lappend where "NOT $col LIKE [ 810 ::stapi::quote_glob [string toupper $v1]]" 811 } 812 813 lmatch { 814 lappend where "$col LIKE [::stapi::quote_glob [string tolower $v1]]" 815 } 816 817 -lmatch { 818 lappend where "NOT $col LIKE [ 819 ::stapi::quote_glob [string tolower $v1]]" 820 } 821 822 range { 823 lappend where "$col >= [pg_quote $v1]" 824 lappend where "$col < [pg_quote $v2]" 825 } 826 827 in { 828 foreach v $v1 { 829 lappend q [pg_quote $v] 830 } 831 lappend where "$col IN ([join $q ","])" 832 } 833 } 834 } 835 } 836 837 set order {} 838 if {[info exists req(-sort)]} { 839 foreach field $req(-sort) { 840 set desc "" 841 842 if {[regexp {^-(.*)} $field _ field]} { 843 set desc " DESC" 844 } 845 846 if {[info exists sql(field)]} { 847 lappend order "$sql($field)$desc" 848 } else { 849 lappend order "$field$desc" 850 } 851 } 852 } 853 854 # NB include a space for load balancing - total kludge, please remove asap 855 set sql " SELECT [join $select ","] FROM $table_name" 856 857 if {[llength $where]} { 858 append sql " WHERE [join $where " AND "]" 859 } 860 861 if {[llength $order]} { 862 append sql " ORDER BY [join $order ","]" 863 } 864 865 if {[info exists req(-limit)]} { 866 append sql " LIMIT $req(-limit)" 867 } 868 869 if {[info exists req(-offset)]} { 870 append sql " OFFSET $req(-offset)" 871 } 872 873 append sql ";" 874 875 876 return $sql 877 } 878 879 # 880 # sql_get_one_tuple 881 # 882 # Get one tuple from request 883 # Two calling sequences: 884 # set result [sql_get_one_tuple $sql] 885 # No data is an error (No Match) 886 # set status [sql_set_one_tuple $sql result] 887 # status == 1 - success 888 # status == -1 - No data, *result not modified* 889 # status == 0 - SQL error, result is error string 890 # 891 proc sql_get_one_tuple {req {_result ""}} { 892 if {[string length $_result]} { 893 upvar 1 $_result result 894 } 895 896 set pg_res [pg_exec [conn] $req] 897 898 if {![set ok [string match "PGRES_*_OK" [pg_result $pg_res -status]]]} { 899 set err [pg_result $pg_res -error] 900 } elseif {[pg_result $pg_res -numTuples] == 0} { 901 set ok -1 902 } else { 903 set result [pg_result $pg_res -getTuple 0] 904 } 905 906 pg_result $pg_res -clear 907 908 if {[string length $_result]} { 909 if {$ok == 0} { 910 set result $err 911 } 912 return $ok 913 } 914 915 if {$ok <= 0} { 916 set errinf "$err\nIn $req" 917 return -code error -errorinfo $errinf $err 918 } 919 920 return $result 921 } 922 923 # 924 # quote_glob - 925 # 926 proc quote_glob {pattern} { 927 regsub -all {[%_]} $pattern {\\&} pattern 928 regsub -all {@} $pattern {@%} pattern 929 regsub -all {\\[*]} $pattern @_ pattern 930 regsub -all {[*]} $pattern "%" pattern 931 regsub -all {@_} $pattern {*} pattern 932 regsub -all {\\[?]} $pattern @_ pattern 933 regsub -all {[?]} $pattern "_" pattern 934 regsub -all {@_} $pattern {?} pattern 935 regsub -all {@%} $pattern {@} pattern 936 return [pg_quote $pattern] 937 } 938 939 # 940 # connect_sql 941 # 942 # Helper routine to shortcut the business of creating a URI and connecting 943 # with the same keys. Using this implicitly pulls in stapi::extend inside connect 944 # if it hasn't already been pulled in. 945 # 946 # Eg: ::stapi::connect_sql my_table {index} -cols {index name value} 947 # 948 proc connect_sql {table keys args} { 949 lappend make make_sql_uri $table -keys $keys 950 set uri [$make {*}$args] 951 return [connect $uri -keys $keys] 952 } 953} 954 955package provide st_client_postgres 1.13.12 956 957# vim: set ts=8 sw=4 sts=4 noet : 958