File: postgres-helpers.tcl

package info (click to toggle)
pgtcl 1:2.6.1-1
  • links: PTS
  • area: main
  • in suites: bullseye, buster, sid
  • size: 2,132 kB
  • sloc: ansic: 6,913; tcl: 643; sh: 470; makefile: 38; sql: 11
file content (283 lines) | stat: -rw-r--r-- 7,810 bytes parent folder | download
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
#
# Copyright (C) 1996 NeoSoft.
#
# Permission to use, copy, modify, and distribute this software and its
# documentation for any purpose and without fee is hereby granted, provided
# that the above copyright notice appear in all copies.  NeoSoft makes no 
# representations about the suitability of this software for any purpose.
# It is provided "as is" without express or implied warranty.
#
#
# Copyright (C) 2003 Proc Place.
#  Berkeley copyright as above.
#
# Copyright (C) 2004 Superconnect, Ltd.
#  Berkeley copyright as above.
#
# Copyright (C) 2005-2017 FlightAware, LLC
#  Berkeley copyright as above.
#

#
# postgres interface stuff
#

package provide sc_postgres 1.3

package require Tclx
package require Pgtcl

namespace eval sc_pg {

#
# foreach_tuple - given a postgres result, an array name, and a code
#  body, fill the array in turn with each result tuple and execute
#  the code body against it.
#
proc foreach_tuple {res arrayName body} {
    upvar $arrayName $arrayName

    set numTuples [pg_result $res -numTuples]
    for {set i 0} {$i < $numTuples} {incr i} {
	pg_result $res -tupleArray $i $arrayName
	uplevel 1 $body
    }
}

#
# quote - make string legally quoted for postgres  
# (obsoleted by pg_quote... it used to do it with a bunch of regexps)
#
proc quote_sql {string} {
    return [pg_quote $string]
}

#
# gen_sql_insert_from_array - return a sql insert statement based on the
#   contents of an array
#
proc gen_insert_from_array {tableName arrayName} {
    upvar $arrayName array

    set nameList [array names array]

    set result "insert into $tableName ([join $nameList ","]) values ("

    foreach name $nameList {
	append result "[pg_quote $array($name)],"
    }
    return "[string range $result 0 end-1]);"
}

#
# gen_sql_update_from_array - return a sql update statement based on the
#   contents of an array and a list of key fields
#
proc gen_update_from_array {tableName arrayName keyFields {nullableColumns ""}} {
    upvar $arrayName array

    set result "update $tableName set "

    foreach element [array names array] {
        # don't emit key fields into the update body
        if {[lsearch $keyFields $element] >= 0} {
	    continue
	}
	append result "$element = [pg_quote $array($element)], "
    }

    foreach element $nullableColumns {
	if {![info exists array($element)]} {
	    append result "$element = NULL, "
	}
    }
    set result "[string range $result 0 end-2] where ("

    foreach key $keyFields {
        if {![info exists array($key)]} {
	    error "required key field '$key' not found in array '$arrayName'"
	}
        append result "$key = [pg_quote $array($key)] and "
    }
    return "[string range $result 0 end-5]);"
}


#
# gen_insert_front_part - generate a sql insert front part
#
proc gen_insert_front_part {tableName nameList} {

    return "insert into $tableName ([join $nameList ","]) values ("
}

#
# gen_insert_back_part - generate a sql insert back part
#
proc gen_insert_back_part {valueList} {
    set result ""
    foreach value $valueList {
	append result "[pg_quote $value],"
    }
    return "[string range $result 0 end-1]);"
}

#
# gen_insert_simplex_front_part - generate a sql insert command based on 
#  contents of a properly ordered list (fields same as the order in the table)
#
proc gen_insert_simplex_front_part {tableName} {
    set result "insert into $tableName values ("
}

#
# perform_insert - generate a sql insert command based on the contents
# of an array and execute it against the specified database session
#
proc perform_insert {session insertStatement} {
    set result [pg_exec $session $insertStatement]
    set status [pg_result $result -status]
    pg_result $result -clear
    return $status
}

#
# gen_insert_from_lists - generate a sql insert command based on the
# contents of an element list and a corresponding value list
#
proc gen_insert_from_lists {tableName nameList valueList} {

    set result "insert into $tableName ([join $nameList ","]) values ("

    foreach value $valueList {
	append result "[pg_quote $value],"
    }
    return "[string range $result 0 end-1]);"
}

#
# perform_insert_from_lists - generate a sql insert command based on the
# contents of an element list and a corresponding value list 
# and execute it against the specified database session
#
proc perform_insert_from_lists {session tableName nameList valueList} {
    set result [pg_exec $session [gen_insert_from_lists $tableName $nameList $valueList]]
    set status [pg_result $result -status]
    pg_result $result -clear
    return $status
}

#
# perform_insert_from_array - generate a sql insert command based on the
# contents of an array and execute it against the specified database session
#
proc perform_insert_from_array {session tableName arrayName} {
    upvar $arrayName array
    set result [pg_exec $session [gen_insert_from_array $tableName array]]
    set status [pg_result $result -status]
    pg_result $result -clear
    return $status
}

#
# perform_update_from_array - generate a sql update command based on the
# contents of an array and execute it against the specified database session
#
proc perform_update_from_array {session tableName arrayName keyFields} {
    upvar $arrayName array
    set result [pg_exec $session [gen_update_from_array $tableName array $keyFields]]
    set status [pg_result $result -status]
    pg_result $result -clear
    return $status
}

#
# clock_to_sql_time - convert a clock value (integer seconds since 1970) to a 
# sql standard abstime value, accurate to a day.
#
#        Month  Day [ Hour : Minute : Second ]  Year [ Timezone ]
#
proc clock_to_sql_time {clock} {
    return [clock format $clock -format "%b %d %Y" -gmt 1]
}

#
# clock_to_precise_sql_time - generate a SQL time from an integer clock
#  time (seconds since 1970), accurate to the second, with timezone
#
proc clock_to_precise_sql_time {clock} {
    return [clock format $clock -format "%b %d %H:%M:%S %Y GMT" -gmt 1]
}

#
# clock_to_precise_sql_time_without_timezone - generate a SQL time from an 
# integer clock time (seconds since 1970), accurate to the second, without
# timezone info (using local timezone)
#
proc clock_to_precise_sql_time_without_timezone {clock} {
    return [clock format $clock -format "%b %d %H:%M:%S %Y"]
}

#
# convert a sql standard abstime value to a clock value (integer
# seconds since 1970)
#
proc sql_time_to_clock {date} {
    if {$date == ""} {
	return 0
    }
    set firstPeriod [string first "." $date]
    if {$firstPeriod >= 0} {
	set date [string range $date 0 [expr $firstPeriod - 1]]
    }
    return [clock scan $date -gmt 1]
}

#
# convert a sql time with timezone to a clock value (seconds since 1970)
#
# ERROR - this ain't right, it discards timezone and assumes local
#
proc sql_time_with_timezone_to_clock {date} {
    if {$date == ""} {
	return 0
    }

    if {![regexp {(.*:..)[^-]*(.*)} $date dummy a b]} {
	error "unable to convert time-with-timezone value $date"
    }
    return [clock scan "$a"]
}

#
# res_must_succeed - a postgres result must be PGRES_COMMAND_OK and
# if not throw an error, and if so, clear the postgres result.
#
proc res_must_succeed {res} {
    set status [pg_result $res -status]
    if {$status != "PGRES_COMMAND_OK" && $status != "PGRES_TUPLES_OK"} {
	set errorString [pg_result $res -error]
	pg_result $res -clear
	error $errorString
    }
    pg_result $res -clear
}

#
# res_dont_care - any postgres result is OK, we don't care,
# clear the postgres result and return.
#
proc res_dont_care {res} {
    set status [pg_result $res -status]
    if {$status != "PGRES_COMMAND_OK" && $status != "PGRES_TUPLES_OK"} {
	puts "[pg_result $res -error] (ignored)"
	pg_result $res -clear
	return 0
    }
    pg_result $res -clear
    return 1
}

}

# vim: set ts=8 sw=4 sts=4 noet :