« back to all changes in this revision
Viewing changes to pgintcl-3.0.1/pgin.tcl
- browse files at revision 1.1.1
- compare with another revision
- download diff
- download tarball
- view history from revision 1.1.1
- Committer: Package Import Robot
- Author(s): Mark Hindley
- Date: 2013-02-13 10:54:36 UTC
- mto: This revision was merged to the branch mainline in revision 3.
- Revision ID: package-import@ubuntu.com-20130213105436-w8flw5ecbt8s7w2d
Tags: upstream-2.0.7
Import upstream version 2.0.7
- files added:
- arrow-end.xbm
- doc/en
- license
- msgs
- files removed:
- arrow_down.xbm
- help
- pgintcl-1.5.0
- pgintcl-3.0.1
- tclkit
- files modified:
- CHANGE_LOG.txt
added
removed
pgintcl-3.0.1/pgin.tcl
1
# pgin.tcl - PostgreSQL Tcl Interface direct to protocol v3 backend
2
# $Id: pgin.tcl,v 3.34 2006-08-14 01:52:04+00 lbayuk Exp $
3
# This version encodes/decodes UNICODE data to/from PostgreSQL.
4
#
5
# Copyright 1998-2006 by ljb (lbayuk@mindspring.com)
6
# May be freely distributed with or without modification; must retain this
7
# notice; provided with no warranties.
8
# See the file COPYING for complete information on usage and redistribution
9
# of this file, and for a disclaimer of all warranties.
10
#
11
# See the file INTERNALS in the source distribution for more information
12
# about how this thing works, including namespace variables.
13
#
14
# Also includes:
15
# md5.tcl - Compute MD5 Checksum
16
17
package require Tcl 8.3
18
19
# === Definition of the pgtcl namespace ===
20
21
namespace eval pgtcl {
22
# Debug flag:
23
variable debug 0
24
25
# Version number, also used in package provide at the bottom of this file:
26
variable version 3.0.1
27
28
# Counter for making uniquely named result structures:
29
variable rn 0
30
31
# Array mapping error field names to protocol codes:
32
# Secondary values (without prefix before '_') have been added for
33
# compatibility with Gborg pgtcl (sigh...)
34
variable errnames
35
array set errnames {
36
SEVERITY S
37
SQLSTATE C
38
MESSAGE_PRIMARY M
39
MESSAGE_DETAIL D
40
MESSAGE_HINT H
41
STATEMENT_POSITION P
42
CONTEXT W
43
SOURCE_FILE F
44
SOURCE_LINE L
45
SOURCE_FUNCTION R
46
PRIMARY M
47
DETAIL D
48
HINT H
49
POSITION P
50
FILE F
51
LINE L
52
FUNCTION R
53
}
54
}
55
56
# === Internal Low-level I/O procedures for v3 protocol ===
57
58
# Internal procedure to send a packet to the backend with type and length.
59
# Type can be empty - this is used for the startup packet.
60
# The default is to flush the channel, since almost all messages generated
61
# by pgin.tcl need to wait for a response. The exception is prepared queries.
62
proc pgtcl::sendmsg {sock type data {noflush ""}} {
63
puts -nonewline $sock \
64
$type[binary format I [expr {[string length $data]+4}]]$data
65
if {$noflush == ""} {
66
flush $sock
67
}
68
}
69
70
# Read a message and return the message type byte:
71
# This initializes the per-connection buffer too.
72
# This has a special check for a v2 error message, which is needed at
73
# startup in case of talking to v2 server. It assumes we will not
74
# get a V3 error message longer than 0x20000000 bytes, which is pretty safe.
75
# It fakes up a V3 error with severity ERROR, code (5 spaces), and the message.
76
proc pgtcl::readmsg {sock} {
77
upvar #0 pgtcl::buf_$sock buf pgtcl::bufi_$sock bufi pgtcl::bufn_$sock bufn
78
set bufi 0
79
if {[binary scan [read $sock 5] aI type len] != 2} {
80
set err "pgtcl: Unable to read message from database"
81
if {[eof $sock]} {
82
append err " - server closed connection"
83
}
84
error $err
85
}
86
if {$type == "E" && $len >= 0x20000000} {
87
if {$pgtcl::debug} { puts "Warning: V2 error message received!" }
88
# Build the start of the V3 error, including the 4 misread bytes in $len:
89
set buf [binary format {a a*x a a*x a I} S ERROR C " " M $len]
90
while {[set c [read $sock 1]] != ""} {
91
append buf $c
92
if {$c == "\000"} break
93
}
94
# This is 'code=0' to mark no more error options.
95
append buf "\000"
96
set bufn [string length $buf]
97
} else {
98
set bufn [expr {$len - 4}]
99
set buf [read $sock $bufn]
100
}
101
return $type
102
}
103
104
# Return the next byte from the buffer:
105
proc pgtcl::get_byte {db} {
106
upvar #0 pgtcl::buf_$db buf pgtcl::bufi_$db bufi
107
set result [string index $buf $bufi]
108
incr bufi
109
return $result
110
}
111
112
# Return the next $n bytes from the buffer:
113
proc pgtcl::get_bytes {db n} {
114
upvar #0 pgtcl::buf_$db buf pgtcl::bufi_$db bufi
115
set obufi $bufi
116
incr bufi $n
117
return [string range $buf $obufi [expr {$obufi + $n - 1}]]
118
}
119
120
# Return the rest of the buffer.
121
proc pgtcl::get_rest {db} {
122
upvar #0 pgtcl::buf_$db buf pgtcl::bufi_$db bufi pgtcl::bufn_$db bufn
123
set obufi $bufi
124
set bufi $bufn
125
return [string range $buf $obufi end]
126
}
127
128
# Skip next $n bytes in the buffer.
129
proc pgtcl::skip {db n} {
130
upvar #0 pgtcl::bufi_$db bufi
131
incr bufi $n
132
}
133
134
# Return next int32 from the buffer:
135
proc pgtcl::get_int32 {db} {
136
upvar #0 pgtcl::buf_$db buf pgtcl::bufi_$db bufi
137
if {[binary scan $buf "x$bufi I" i] != 1} {
138
set i 0
139
}
140
incr bufi 4
141
return $i
142
}
143
144
# Return next signed int16 from the buffer:
145
proc pgtcl::get_int16 {db} {
146
upvar #0 pgtcl::buf_$db buf pgtcl::bufi_$db bufi
147
if {[binary scan $buf "x$bufi S" i] != 1} {
148
set i 0
149
}
150
incr bufi 2
151
return $i
152
}
153
154
# Return next unsigned int16 from the buffer:
155
proc pgtcl::get_uint16 {db} {
156
upvar #0 pgtcl::buf_$db buf pgtcl::bufi_$db bufi
157
if {[binary scan $buf "x$bufi S" i] != 1} {
158
set i 0
159
}
160
incr bufi 2
161
return [expr {$i & 0xffff}]
162
}
163
164
# Return next signed int8 from the buffer:
165
# (This is only used in 1 place in the protocol...)
166
proc pgtcl::get_int8 {db} {
167
upvar #0 pgtcl::buf_$db buf pgtcl::bufi_$db bufi
168
if {[binary scan $buf "x$bufi c" i] != 1} {
169
set i 0
170
}
171
incr bufi
172
return $i
173
}
174
175
# Return the next null-terminated string from the buffer:
176
# This decodes the UNICODE data. It is used for people-readable text like
177
# messages, not query result data.
178
proc pgtcl::get_string {db} {
179
upvar #0 pgtcl::buf_$db buf pgtcl::bufi_$db bufi
180
set end [string first "\000" $buf $bufi]
181
if {$end < 0} {
182
return ""
183
}
184
set obufi $bufi
185
set bufi [expr {$end + 1}]
186
return [encoding convertfrom identity \
187
[string range $buf $obufi [expr {$end - 1}]]]
188
}
189
190
# === Internal Mid-level I/O procedures for v3 protocol ===
191
192
# Parse a backend ErrorResponse or NoticeResponse message. The Severity
193
# and Message parts are returned together with a trailing newline, like v2
194
# protocol did. If optional result_name is supplied, it is the name of
195
# a result structure to store all error parts in, indexed as (error,$code).
196
proc pgtcl::get_response {db {result_name ""}} {
197
if {$result_name != ""} {
198
upvar $result_name result
199
}
200
array set result {error,S ERROR error,M {}}
201
while {[set c [pgtcl::get_byte $db]] != "\000" && $c != ""} {
202
set result(error,$c) [pgtcl::get_string $db]
203
}
204
return "$result(error,S): $result(error,M)\n"
205
}
206
207
# Handle ParameterStatus and remember the name and value:
208
proc pgtcl::get_parameter_status {db} {
209
upvar #0 pgtcl::param_$db param
210
set name [pgtcl::get_string $db]
211
set param($name) [pgtcl::get_string $db]
212
if {$pgtcl::debug} { puts "+server param $name=$param($name)" }
213
}
214
215
# Handle a notification ('A') message.
216
# The notifying backend pid and more_info are read but ignored.
217
proc pgtcl::get_notification_response {db} {
218
set notify_pid [pgtcl::get_int32 $db]
219
set notify_rel [pgtcl::get_string $db]
220
set more_info [pgtcl::get_string $db]
221
if {$pgtcl::debug} { puts "+pgtcl got notify from $notify_pid: $notify_rel" }
222
if {[info exists pgtcl::notify($db,$notify_rel)]} {
223
after idle $pgtcl::notify($db,$notify_rel)
224
}
225
}
226
227
# Handle a notice ('N') message. If no handler is defined, or the handler is
228
# empty, do nothing, otherwise, call the handler with the message argument
229
# appended. For backward compatibility with v2 protocol, the message is
230
# assumed to end in a newline.
231
proc pgtcl::get_notice {db} {
232
set msg [pgtcl::get_response $db]
233
if {[info exists pgtcl::notice($db)] && [set cmd $pgtcl::notice($db)] != ""} {
234
eval $cmd [list $msg]
235
}
236
}
237
238
# Internal procedure to read a tuple (row) from the backend.
239
# Column count is redundant, but check it anyway.
240
# Format code (text/binary) is used to do Unicode decoding on Text only.
241
proc pgtcl::gettuple {db result_name} {
242
upvar $result_name result
243
if {$result(nattr) == 0} {
244
unset result
245
error "Protocol error, data before descriptor"
246
}
247
set irow $result(ntuple)
248
set nattr [pgtcl::get_uint16 $db]
249
if {$nattr != $result(nattr)} {
250
unset result
251
error "Expecting $result(nattr) columns, but data row has $nattr"
252
}
253
set icol 0
254
foreach format $result(formats) {
255
set col_len [pgtcl::get_int32 $db]
256
if {$col_len > 0} {
257
if ($format) {
258
set result($irow,$icol) [pgtcl::get_bytes $db $col_len]
259
} else {
260
set result($irow,$icol) [encoding convertfrom identity \
261
[pgtcl::get_bytes $db $col_len]]
262
}
263
} else {
264
set result($irow,$icol) ""
265
if {$col_len < 0} {
266
set result(null,$irow,$icol) ""
267
}
268
}
269
incr icol
270
}
271
incr result(ntuple)
272
}
273
274
# Internal procedure to handle common backend utility message types:
275
# C : Completion status E : Error
276
# N : Notice message A : Notification
277
# S : ParameterStatus
278
# This can be given any message type. If it handles the message,
279
# it returns 1. If it doesn't handle the message, it returns 0.
280
#
281
proc pgtcl::common_message {msgchar db result_name} {
282
upvar $result_name result
283
switch -- $msgchar {
284
A { pgtcl::get_notification_response $db }
285
C { set result(complete) [pgtcl::get_string $db] }
286
N { pgtcl::get_notice $db }
287
S { pgtcl::get_parameter_status $db }
288
E {
289
set result(status) PGRES_FATAL_ERROR
290
set result(error) [pgtcl::get_response $db result]
291
}
292
default { return 0 }
293
}
294
return 1
295
}
296
297
# === Other internal support procedures ===
298
299
# Internal procedure to set a default value from the environment:
300
proc pgtcl::default {default args} {
301
global env
302
foreach a $args {
303
if {[info exists env($a)]} {
304
return $env($a)
305
}
306
}
307
return $default
308
}
309
310
# Internal procedure to parse a connection info string.
311
# This has to handle quoting and escaping. See the PostgreSQL Programmer's
312
# Guide, Client Interfaces, Libpq, Database Connection Functions.
313
# The definitive reference is the PostgreSQL source code in:
314
# interface/libpq/fe-connect.c:conninfo_parse()
315
# One quirk to note: backslash escapes work in quoted values, and also in
316
# unquoted values, but you cannot use backslash-space in an unquoted value,
317
# because the space ends the value regardless of the backslash.
318
#
319
# Stores the results in an array $result(paramname)=value. It will not
320
# create a new index in the array; if paramname does not already exist,
321
# it means a bad parameter was given (one not defined by pg_conndefaults).
322
# Returns an error message on error, else an empty string if OK.
323
proc pgtcl::parse_conninfo {conninfo result_name} {
324
upvar $result_name result
325
while {[regexp {^ *([^=]*)= *(.+)} $conninfo unused name conninfo]} {
326
set name [string trim $name]
327
if {[regexp {^'(.*)} $conninfo unused conninfo]} {
328
set value ""
329
set n [string length $conninfo]
330
for {set i 0} {$i < $n} {incr i} {
331
if {[set c [string index $conninfo $i]] == "\\"} {
332
set c [string index $conninfo [incr i]]
333
} elseif {$c == "'"} break
334
append value $c
335
}
336
if {$i >= $n} {
337
return "unterminated quoted string in connection info string"
338
}
339
set conninfo [string range $conninfo [incr i] end]
340
} else {
341
regexp {^([^ ]*)(.*)} $conninfo unused value conninfo
342
regsub -all {\\(.)} $value {\1} value
343
}
344
if {$pgtcl::debug} { puts "+parse_conninfo name=$name value=$value" }
345
if {![info exists result($name)]} {
346
return "invalid connection option \"$name\""
347
}
348
set result($name) $value
349
}
350
if {[string trim $conninfo] != ""} {
351
return "syntax error in connection info string '...$conninfo'"
352
}
353
return ""
354
}
355
356
# Internal procedure to check for valid result handle. This returns
357
# the fully qualified name of the result array.
358
# Usage: upvar #0 [pgtcl::checkres $res] result
359
proc pgtcl::checkres {res} {
360
if {![info exists pgtcl::result$res]} {
361
error "Invalid result handle\n$res is not a valid query result"
362
}
363
return "pgtcl::result$res"
364
}
365
366
# === Public procedures : Connecting and Disconnecting ===
367
368
# Return connection defaults as {optname label dispchar dispsize value}...
369
proc pg_conndefaults {} {
370
set user [pgtcl::default user PGUSER USER LOGNAME USERNAME]
371
set result [list \
372
[list user Database-User {} 20 $user] \
373
[list password Database-Password * 20 [pgtcl::default {} PGPASSWORD]] \
374
[list host Database-Host {} 40 [pgtcl::default localhost PGHOST]] \
375
{hostaddr Database-Host-IP-Address {} 45 {}} \
376
[list port Database-Port {} 6 [pgtcl::default 5432 PGPORT]] \
377
[list dbname Database-Name {} 20 [pgtcl::default $user PGDATABASE]] \
378
[list tty Backend-Debug-TTY D 40 [pgtcl::default {} PGTTY]] \
379
[list options Backend-Debug-Options D 40 [pgtcl::default {} PGOPTIONS]] \
380
]
381
if {$pgtcl::debug} { puts "+pg_conndefaults: $result" }
382
return $result
383
}
384
385
# Connect to database. Only the new form, with -conninfo, is recognized.
386
# We speak backend protocol v3, and only handle clear-text password and
387
# MD5 authentication (messages R 3, and R 5).
388
# A parameter is added to set client_encoding to UNICODE. This is due to
389
# Tcl's way of representing strings.
390
proc pg_connect {args} {
391
392
if {[llength $args] != 2 || [lindex $args 0] != "-conninfo"} {
393
error "Connection to database failed\nMust use pg_connect -conninfo form"
394
}
395
396
# Get connection defaults into an array opt(), then merge caller params:
397
foreach o [pg_conndefaults] {
398
set opt([lindex $o 0]) [lindex $o 4]
399
}
400
if {[set msg [pgtcl::parse_conninfo [lindex $args 1] opt]] != ""} {
401
error "Connection to database failed\n$msg"
402
}
403
404
# Hostaddr overrides host, per documentation, and we need host below.
405
if {$opt(hostaddr) != ""} {
406
set opt(host) $opt(hostaddr)
407
}
408
409
if {$pgtcl::debug} {
410
puts "+pg_connect to $opt(dbname)@$opt(host):$opt(port) as $opt(user)"
411
}
412
413
if {[catch {socket $opt(host) $opt(port)} sock]} {
414
error "Connection to database failed\n$sock"
415
}
416
# Note: full buffering, socket must be flushed after write!
417
fconfigure $sock -buffering full -translation binary
418
419
# Startup packet:
420
pgtcl::sendmsg $sock {} [binary format "I a*x a*x a*x a*x a*x a*x a*x a*x x" \
421
0x00030000 \
422
user $opt(user) database $opt(dbname) \
423
client_encoding UNICODE options $opt(options)]
424
425
set msg {}
426
while {[set c [pgtcl::readmsg $sock]] != "Z"} {
427
switch $c {
428
E {
429
set msg [pgtcl::get_response $sock]
430
break
431
}
432
R {
433
set n [pgtcl::get_int32 $sock]
434
if {$n == 3} {
435
pgtcl::sendmsg $sock p "$opt(password)\000"
436
} elseif {$n == 5} {
437
set salt [pgtcl::get_bytes $sock 4]
438
# This is from PostgreSQL source backend/libpq/crypt.c:
439
set md5_response \
440
"md5[md5::digest [md5::digest $opt(password)$opt(user)]$salt]"
441
if {$pgtcl::debug} { puts "+pg_connect MD5 sending: $md5_response" }
442
pgtcl::sendmsg $sock p "$md5_response\000"
443
} elseif {$n != 0} {
444
set msg "Unknown database authentication request($n)"
445
break
446
}
447
}
448
K {
449
set pid [pgtcl::get_int32 $sock]
450
set key [pgtcl::get_int32 $sock]
451
if {$pgtcl::debug} { puts "+server pid=$pid key=$key" }
452
}
453
S {
454
pgtcl::get_parameter_status $sock
455
}
456
default {
457
set msg "Unexpected reply from database: $c"
458
break
459
}
460
}
461
}
462
if {$msg != ""} {
463
close $sock
464
error "Connection to database failed\n$msg"
465
}
466
# Initialize transaction status; should be get_byte but it better be I:
467
set pgtcl::xstate($sock) I
468
# Initialize action for NOTICE messages (see get_notice):
469
set pgtcl::notice($sock) {puts -nonewline stderr}
470
471
return $sock
472
}
473
474
# Disconnect from the database. Free all result structures which are
475
# associated with this connection, and other data for this connection,
476
# including the buffer.
477
# Note: This does not use {array unset} (Tcl 8.3) nor {unset -nocomplain}
478
# (Tcl 8.4), but is coded to be compatible with earlier versions.
479
proc pg_disconnect {db} {
480
if {$pgtcl::debug} { puts "+Disconnecting $db from database" }
481
pgtcl::sendmsg $db X {}
482
catch {close $db}
483
foreach v [info vars pgtcl::result*] {
484
upvar #0 $v result
485
if {$result(conn) == $db} {
486
if {$pgtcl::debug} { puts "+Freeing left-over result structure $v" }
487
unset result
488
}
489
}
490
if {[array exists pgtcl::notify]} {
491
foreach v [array names pgtcl::notify $db,*] {
492
unset pgtcl::notify($v)
493
}
494
}
495
catch { unset pgtcl::param_$db }
496
catch { unset pgtcl::xstate($db) pgtcl::notice($db) }
497
catch { unset pgtcl::buf_$db pgtcl::bufi_$db pgtcl::bufn_$db }
498
}
499
500
# === Internal procedures: Query Result and supporting functions ===
501
502
# Read the backend reply to a query (simple or extended) and build a
503
# result structure. For extended query mode, the client already sent
504
# the Bind, DescribePortal, Execute, and Sync.
505
# This implements most of the backend query response protocol. The important
506
# reply codes are:
507
# T : RowDescription describes the attributes (columns) of each data row.
508
# D : DataRow has data for 1 tuple.
509
# Z : ReadyForQuery, update transaction status.
510
# H : Ready for Copy Out
511
# G : Ready for Copy In
512
# Plus the messages handled by pgtcl::common_message.
513
# If the optional parameter $extq == 1, the result handle is from an extended
514
# mode query (see pg_exec_prepared) and these messages are allowed and ignored:
515
# 2 : BindComplete
516
# 1 : ParseComplete (used only for exec_params)
517
# n : NoData
518
#
519
# Returns a result handle (the number pgtcl::rn), or throws an error.
520
521
proc pgtcl::getresult {db {extq 0}} {
522
upvar #0 pgtcl::result[incr pgtcl::rn] result
523
set result(conn) $db
524
array set result {
525
nattr 0 ntuple 0
526
attrs {} types {} sizes {} modifs {} formats {}
527
error {} tbloids {} tblcols {}
528
complete {}
529
status PGRES_COMMAND_OK
530
}
531
532
while {1} {
533
set c [pgtcl::readmsg $db]
534
switch $c {
535
D {
536
pgtcl::gettuple $db result
537
}
538
T {
539
if {$result(nattr) != 0} {
540
unset result
541
error "Protocol failure, multiple descriptors"
542
}
543
set result(status) PGRES_TUPLES_OK
544
set nattr [pgtcl::get_uint16 $db]
545
set result(nattr) $nattr
546
for {set icol 0} {$icol < $nattr} {incr icol} {
547
lappend result(attrs) [pgtcl::get_string $db]
548
lappend result(tbloids) [pgtcl::get_int32 $db]
549
lappend result(tblcols) [pgtcl::get_uint16 $db]
550
lappend result(types) [pgtcl::get_int32 $db]
551
lappend result(sizes) [pgtcl::get_int16 $db]
552
lappend result(modifs) [pgtcl::get_int32 $db]
553
lappend result(formats) [pgtcl::get_int16 $db]
554
}
555
}
556
I {
557
set result(status) PGRES_EMPTY_QUERY
558
}
559
H {
560
pgtcl::begincopy result OUT
561
break
562
}
563
G {
564
pgtcl::begincopy result IN
565
break
566
}
567
Z {
568
set pgtcl::xstate($db) [pgtcl::get_byte $db]
569
break
570
}
571
default {
572
if {(!$extq || ($c != "2" && $c != "n" && $c != "1")) && \
573
![pgtcl::common_message $c $db result]} {
574
unset result
575
error "Unexpected reply from database: $c"
576
}
577
}
578
}
579
}
580
if {$pgtcl::debug > 1} {
581
puts "+pgtcl::getresult $pgtcl::rn = "
582
parray result
583
}
584
return $pgtcl::rn
585
}
586
587
# Process format code information for pg_exec_prepared.
588
# fclist A list of BINARY (or B*) or TEXT (or T*) format code words.
589
# ncodes_name The name of a variable to get the number of format codes.
590
# codes_name The name of a variable to get a list of format codes in
591
# the PostgreSQL syntax: 0=text 1=binary.
592
proc pgtcl::crunch_fcodes {fclist ncodes_name codes_name} {
593
upvar $ncodes_name ncodes $codes_name codes
594
set ncodes [llength $fclist]
595
set codes {}
596
foreach k $fclist {
597
if {[string match B* $k]} {
598
lappend codes 1
599
} else {
600
lappend codes 0
601
}
602
}
603
}
604
605
# Return an error code field value for pg_result -error?Field? code.
606
# For field names, it accepts either the libpq name (without PG_DIAG_) or the
607
# single-letter protocol code.
608
# For compatibility with changes made to Gborg pgtcl after this feature was
609
# added here, it also accepts names without prefixes, and $code is case
610
# insensitive.
611
# If an unknown field name is used, or the field isn't part of the error
612
# message, an empty string is substituted.
613
614
proc pgtcl::error_fields {result_name code} {
615
upvar $result_name result
616
variable errnames
617
set code [string toupper $code]
618
if {[info exists errnames($code)]} {
619
set code $errnames($code)
620
}
621
if {[info exists result(error,$code)]} {
622
return $result(error,$code)
623
}
624
return ""
625
}
626
627
# === Public procedures : Query and Result ===
628
629
# Execute SQL and return a result handle.
630
# If parameters are supplied, use pg_exec_params in all-text arg mode.
631
# (Let pg_exec_params encode the query in that case.)
632
633
proc pg_exec {db query args} {
634
if {$pgtcl::debug} { puts "+pg_exec $query {$args}" }
635
if {[llength $args] == 0} {
636
pgtcl::sendmsg $db Q "[encoding convertto identity $query]\000"
637
return [pgtcl::getresult $db]
638
}
639
return [eval pg_exec_params {$db} {$query} {{}} {{}} {{}} $args]
640
}
641
642
# Extract data from a pg_exec result structure.
643
# -cmdTuples, -list, and -llist are extensions to the baseline libpgtcl which
644
# have appeared or will appear in beta or future versions.
645
# -errorField, -lxAttributes and -getNull are proposed new for 7.4.
646
# -cmdStatus is new with pgintcl-2.0.1
647
648
proc pg_result {res option args} {
649
upvar #0 [pgtcl::checkres $res] result
650
set argc [llength $args]
651
set ntuple $result(ntuple)
652
set nattr $result(nattr)
653
switch -- $option {
654
-status { return $result(status) }
655
-conn { return $result(conn) }
656
-oid {
657
if {[regexp {^INSERT +([0-9]*)} $result(complete) unused oid]} {
658
return $oid
659
}
660
return 0
661
}
662
-cmdTuples {
663
if {[regexp {^INSERT +[0-9]* +([0-9]*)} $result(complete) x num] \
664
|| [regexp {^(UPDATE|DELETE) +([0-9]*)} $result(complete) x y num]} {
665
return $num
666
}
667
return ""
668
}
669
-cmdStatus { return $result(complete) }
670
-numTuples { return $ntuple }
671
-numAttrs { return $nattr }
672
-assign {
673
if {$argc != 1} {
674
error "-assign option must be followed by a variable name"
675
}
676
upvar $args a
677
set icol 0
678
foreach attr $result(attrs) {
679
for {set irow 0} {$irow < $ntuple} {incr irow} {
680
set a($irow,$attr) $result($irow,$icol)
681
}
682
incr icol
683
}
684
}
685
-assignbyidx {
686
if {$argc != 1 && $argc != 2} {
687
error "-assignbyidxoption requires an array name and optionally an\
688
append string"
689
}
690
upvar [lindex $args 0] a
691
if {$argc == 2} {
692
set suffix [lindex $args 1]
693
} else {
694
set suffix {}
695
}
696
set attr_first [lindex $result(attrs) 0]
697
set attr_rest [lrange $result(attrs) 1 end]
698
for {set irow 0} {$irow < $ntuple} {incr irow} {
699
set val_first $result($irow,0)
700
set icol 1
701
foreach attr $attr_rest {
702
set a($val_first,$attr$suffix) $result($irow,$icol)
703
incr icol
704
}
705
}
706
}
707
-getTuple {
708
if {$argc != 1} {
709
error "-getTuple option must be followed by a tuple number"
710
}
711
set irow $args
712
if {$irow < 0 || $irow >= $ntuple} {
713
error "argument to getTuple cannot exceed number of tuples - 1"
714
}
715
set list {}
716
for {set icol 0} {$icol < $nattr} {incr icol} {
717
lappend list $result($irow,$icol)
718
}
719
return $list
720
}
721
-getNull {
722
if {$argc != 1} {
723
error "-getNull option must be followed by a tuple number"
724
}
725
set irow $args
726
if {$irow < 0 || $irow >= $ntuple} {
727
error "argument to getNull cannot exceed number of tuples - 1"
728
}
729
set list {}
730
for {set icol 0} {$icol < $nattr} {incr icol} {
731
lappend list [info exists result(null,$irow,$icol)]
732
}
733
return $list
734
}
735
-tupleArray {
736
if {$argc != 2} {
737
error "-tupleArray option must be followed by a tuple number and\
738
array name"
739
}
740
set irow [lindex $args 0]
741
if {$irow < 0 || $irow >= $ntuple} {
742
error "argument to tupleArray cannot exceed number of tuples - 1"
743
}
744
upvar [lindex $args 1] a
745
set icol 0
746
foreach attr $result(attrs) {
747
set a($attr) $result($irow,$icol)
748
incr icol
749
}
750
}
751
-list {
752
set list {}
753
for {set irow 0} {$irow < $ntuple} {incr irow} {
754
for {set icol 0} {$icol < $nattr} {incr icol} {
755
lappend list $result($irow,$icol)
756
}
757
}
758
return $list
759
}
760
-llist {
761
set list {}
762
for {set irow 0} {$irow < $ntuple} {incr irow} {
763
set sublist {}
764
for {set icol 0} {$icol < $nattr} {incr icol} {
765
lappend sublist $result($irow,$icol)
766
}
767
lappend list $sublist
768
}
769
return $list
770
}
771
-attributes {
772
return $result(attrs)
773
}
774
-lAttributes {
775
set list {}
776
foreach attr $result(attrs) type $result(types) size $result(sizes) {
777
lappend list [list $attr $type $size]
778
}
779
return $list
780
}
781
-lxAttributes {
782
set list {}
783
foreach attr $result(attrs) type $result(types) size $result(sizes) \
784
modif $result(modifs) format $result(formats) \
785
tbloid $result(tbloids) tblcol $result(tblcols) {
786
lappend list [list $attr $type $size $modif $format $tbloid $tblcol]
787
}
788
return $list
789
}
790
-clear {
791
unset result
792
}
793
-error -
794
-errorField {
795
if {$argc == 0} {
796
return $result(error)
797
}
798
return [pgtcl::error_fields result $args]
799
}
800
default { error "Invalid option to pg_result: $option" }
801
}
802
}
803
804
# Run a select query and iterate over the results. Uses pg_exec to run the
805
# query and build the result structure, but we cheat and directly use the
806
# result array rather than calling pg_result.
807
# Each returned tuple is stored into the caller's array, then the caller's
808
# proc is called.
809
# If the caller's proc does "break", "return", or gets an error, get out
810
# of the processing loop. Tcl codes: 0=OK 1=error 2=return 3=break 4=continue
811
proc pg_select {db query var_name proc} {
812
upvar $var_name var
813
global errorCode errorInfo
814
set res [pg_exec $db $query]
815
upvar #0 pgtcl::result$res result
816
if {$result(status) != "PGRES_TUPLES_OK"} {
817
set msg $result(error)
818
unset result
819
error $msg
820
}
821
set code 0
822
set var(.headers) $result(attrs)
823
set var(.numcols) $result(nattr)
824
set ntuple $result(ntuple)
825
for {set irow 0} {$irow < $ntuple} {incr irow} {
826
set var(.tupno) $irow
827
set icol 0
828
foreach attr $result(attrs) {
829
set var($attr) $result($irow,$icol)
830
incr icol
831
}
832
set code [catch {uplevel 1 $proc} s]
833
if {$code != 0 && $code != 4} break
834
}
835
unset result var
836
if {$code == 1} {
837
return -code error -errorinfo $errorInfo -errorcode $errorCode $s
838
} elseif {$code == 2 || $code > 4} {
839
return -code $code $s
840
}
841
return
842
}
843
844
# Register a listener for backend notification, or cancel a listener.
845
proc pg_listen {db name {proc ""}} {
846
if {$proc != ""} {
847
set pgtcl::notify($db,$name) $proc
848
set r [pg_exec $db "listen $name"]
849
pg_result $r -clear
850
} elseif {[info exists pgtcl::notify($db,$name)]} {
851
unset pgtcl::notify($db,$name)
852
set r [pg_exec $db "unlisten $name"]
853
pg_result $r -clear
854
}
855
}
856
857
# pg_execute: Execute a query, optionally iterating over the results.
858
#
859
# Returns the number of tuples selected or affected by the query.
860
# Usage: pg_execute ?options? connection query ?proc?
861
# Options: -array ArrayVar
862
# -oid OidVar
863
# If -array is not given with a SELECT, the data is put in variables
864
# named by the fields. This is generally a bad idea and could be dangerous.
865
#
866
# If there is no proc body and the query return 1 or more rows, the first
867
# row is stored in the array or variables and we return (as does libpgtcl).
868
#
869
# Notes: Handles proc return codes of:
870
# 0(OK) 1(error) 2(return) 3(break) 4(continue)
871
# Uses pg_exec and pg_result, but also makes direct access to the
872
# structures used by them.
873
874
proc pg_execute {args} {
875
global errorCode errorInfo
876
877
set usage "pg_execute ?-array arrayname?\
878
?-oid varname? connection queryString ?loop_body?"
879
880
# Set defaults and parse command arguments:
881
set use_array 0
882
set set_oid 0
883
set do_proc 0
884
set last_option_arg {}
885
set n_nonswitch_args 0
886
set conn {}
887
set query {}
888
set proc {}
889
foreach arg $args {
890
if {$last_option_arg != ""} {
891
if {$last_option_arg == "-array"} {
892
set use_array 1
893
upvar $arg data
894
} elseif {$last_option_arg == "-oid"} {
895
set set_oid 1
896
upvar $arg oid
897
} else {
898
error "Unknown option $last_option_arg\n$usage"
899
}
900
set last_option_arg {}
901
} elseif {[regexp ^- $arg]} {
902
set last_option_arg $arg
903
} else {
904
if {[incr n_nonswitch_args] == 1} {
905
set conn $arg
906
} elseif {$n_nonswitch_args == 2} {
907
set query $arg
908
} elseif {$n_nonswitch_args == 3} {
909
set do_proc 1
910
set proc $arg
911
} else {
912
error "Wrong # of arguments\n$usage"
913
}
914
}
915
}
916
if {$last_option_arg != "" || $n_nonswitch_args < 2} {
917
error "Bad arguments\n$usage"
918
}
919
920
set res [pg_exec $conn $query]
921
upvar #0 pgtcl::result$res result
922
923
# For non-SELECT query, just process oid and return value.
924
# Let pg_result do the decoding.
925
if {[regexp {^PGRES_(COMMAND_OK|COPY|EMPTY_QUERY)} $result(status)]} {
926
if {$set_oid} {
927
set oid [pg_result $res -oid]
928
}
929
set ntuple [pg_result $res -cmdTuples]
930
pg_result $res -clear
931
return $ntuple
932
}
933
934
if {$result(status) != "PGRES_TUPLES_OK"} {
935
set status [list $result(status) $result(error)]
936
pg_result $res -clear
937
error $status
938
}
939
940
# Handle a SELECT query. This is like pg_select, except the proc is optional,
941
# and the fields can go in an array or variables.
942
# With no proc, store the first row only.
943
set code 0
944
if {!$use_array} {
945
foreach attr $result(attrs) {
946
upvar $attr data_$attr
947
}
948
}
949
set ntuple $result(ntuple)
950
for {set irow 0} {$irow < $ntuple} {incr irow} {
951
set icol 0
952
if {$use_array} {
953
foreach attr $result(attrs) {
954
set data($attr) $result($irow,$icol)
955
incr icol
956
}
957
} else {
958
foreach attr $result(attrs) {
959
set data_$attr $result($irow,$icol)
960
incr icol
961
}
962
}
963
if {!$do_proc} break
964
set code [catch {uplevel 1 $proc} s]
965
if {$code != 0 && $code != 4} break
966
}
967
pg_result $res -clear
968
if {$code == 1} {
969
return -code error -errorinfo $errorInfo -errorcode $errorCode $s
970
} elseif {$code == 2 || $code > 4} {
971
return -code $code $s
972
}
973
return $ntuple
974
}
975
976
# Extended query protocol: Bind parameters and execute prepared statement.
977
# This is modelled on libpq PQexecPrepared. Use pg_exec to send a PREPARE
978
# first; when called externally it does not handle unnamed statements.
979
# This is also used internally by pg_exec_params, with an unnamed statement.
980
# Parameters:
981
# db Connection handle
982
# stmt Name of the prepared SQL statement to execute
983
# res_formats A list describing results: B* => Binary, else Text.
984
# arg_formats A list describing args: B* => Binary, else Text.
985
# args Variable number of arguments to bind to the query params.
986
proc pg_exec_prepared {db stmt res_formats arg_formats args} {
987
set nargs [llength $args]
988
989
if {$pgtcl::debug} { puts "+pg_exec_prepared stmt=$stmt nargs=$nargs" }
990
# Calculate argument format information:
991
pgtcl::crunch_fcodes $arg_formats nfcodes fcodes
992
993
# Build the first part of the Bind message:
994
set out [binary format {x a*x S S* S} \
995
[encoding convertto identity $stmt] $nfcodes $fcodes $nargs]
996
997
# Expand fcodes so there is a text/binary flag for each argument:
998
if {$nfcodes == 0} {
999
set all_fcodes [string repeat "0 " $nargs]
1000
} elseif {$nfcodes == 1} {
1001
set all_fcodes [string repeat "$fcodes " $nargs]
1002
} else {
1003
set all_fcodes $fcodes
1004
}
1005
1006
# Append parameter values as { int32 length or 0 or -1 for NULL; data}
1007
# Note: There is no support for NULLs as parameters.
1008
# Encode all text parameters, leave binary parameters alone.
1009
foreach arg $args fcode $all_fcodes {
1010
if {$fcode} {
1011
append out [binary format I [string length $arg]] $arg
1012
} else {
1013
append out [binary format I [string length $arg]] \
1014
[encoding convertto identity $arg]
1015
}
1016
}
1017
1018
# Append result parameter format information:
1019
pgtcl::crunch_fcodes $res_formats nrfcodes rfcodes
1020
append out [binary format {S S*} $nrfcodes $rfcodes]
1021
1022
# Send it off. Don't wait for BindComplete or Error, because the protocol
1023
# says the BE will discard until Sync anyway.
1024
pgtcl::sendmsg $db B $out -noflush
1025
unset out
1026
# Send DescribePortal for the unnamed portal:
1027
pgtcl::sendmsg $db D "P\0" -noflush
1028
# Send Execute, unnamed portal, unlimited rows:
1029
pgtcl::sendmsg $db E "\0\0\0\0\0" -noflush
1030
# Send Sync
1031
pgtcl::sendmsg $db S {}
1032
1033
# Fetch query result and return result handle:
1034
return [pgtcl::getresult $db 1]
1035
}
1036
1037
# Extended query protocol: Parse, Bind and execute statement. This is similar
1038
# to pg_exec_prepared, but doesn't use a pre-prepared statement, and if you
1039
# want to pass binary parameters you must also provide the type OIDs.
1040
# This is modelled on libpq PQexecParams.
1041
# Parameters:
1042
# db Connection handle
1043
# query Query to execute, may contain parameters $1, $2, ...
1044
# res_formats A list describing results: B* => binary, else text
1045
# arg_formats A list describing args: B* => Binary, else Text.
1046
# arg_types A list of type OIDs for each argument (if Binary).
1047
# args Variable number of arguments to bind to the query params.
1048
1049
# Protocol note: Perhaps the right way to do this is to send Parse,
1050
# then Flush, and check for ParseComplete or ErrorResponse. But then
1051
# if there is an error, you need to send Sync and build a result structure.
1052
# Since the backend will ignore everything after error until Sync, this
1053
# is coded the easier way: Just send everything and let the lower-level code
1054
# report the errors, whether on Parse or Bind or Execute.
1055
1056
proc pg_exec_params {db query res_formats arg_formats arg_types args} {
1057
if {$pgtcl::debug} { puts "+pg_exec_params query=$query" }
1058
# Build and send Parse message with the SQL command and list of arg types:
1059
set out [binary format {x a*x S} [encoding convertto identity $query] \
1060
[llength $arg_types]]
1061
foreach type $arg_types {
1062
append out [binary format I $type]
1063
}
1064
pgtcl::sendmsg $db P $out -noflush
1065
# See note above regarding not checking for ParseComplete here.
1066
# Proceed as with pg_exec_prepared, but with an unnamed statement:
1067
return [eval pg_exec_prepared {$db} {""} {$res_formats} {$arg_formats} $args]
1068
}
1069
1070
# === Public procedures : Miscellaneous ===
1071
1072
# pg_notice_handler: Set/get handler command for Notice/Warning
1073
# Usage: pg_notice_handler connection ?command?
1074
# Parameters:
1075
# command If supplied, the new handler command. The notice text
1076
# will be appended as a list element.
1077
# If supplied but empty, ignore notice/warnings.
1078
# If not supplied, just return the current value.
1079
# Returns the previous handler command.
1080
proc pg_notice_handler {db args} {
1081
set return_value $pgtcl::notice($db)
1082
if {[set nargs [llength $args]] == 1} {
1083
set pgtcl::notice($db) [lindex $args 0]
1084
} elseif {$nargs != 0} {
1085
error "Wrong # args: should be \"pg_notice_handler connection ?command?\""
1086
}
1087
return $return_value
1088
}
1089
1090
# pg_configure: Configure options for PostgreSQL connections
1091
# This is provided only for backward compatibility with earlier versions.
1092
# Do not use.
1093
proc pg_configure {db option args} {
1094
if {[set nargs [llength $args]] > 1} {
1095
error "Wrong # args: should be \"pg_configure connection option ?value?\""
1096
}
1097
switch -- $option {
1098
debug { upvar pgtcl::debug var }
1099
notice { upvar pgtcl::notice($db) var }
1100
default {
1101
error "Bad option \"$option\": must be one of notice, debug"
1102
}
1103
}
1104
set return_value $var
1105
if {$nargs} {
1106
set var [lindex $args 0]
1107
}
1108
return $return_value
1109
}
1110
1111
# pg_escape_string: Escape a string for use as a quoted SQL string
1112
# Returns the escaped string. This was added to PostgreSQL after 7.3.2
1113
# and to libpgtcl after 1.4b3.
1114
# Note: string map requires Tcl >= 8.1 but is faster than regsub here.
1115
proc pg_escape_string {s} {
1116
return [string map {' '' \\ \\\\} $s]
1117
}
1118
1119
# pg_quote: Same as pg_escape_string but returns the quotes around the
1120
# argument too. Found this in gborg pgtcl cvs logs, not sure why.
1121
# pg_quote instead.
1122
proc pg_quote {s} {
1123
return "'[string map {' '' \\ \\\\} $s]'"
1124
}
1125
1126
# pg_escape_bytea: Escape a binary string for use as a quoted SQL string.
1127
# Returns the escaped string, which is safe for use inside single quotes
1128
# in an SQL statement. Note back-slashes are doubled due to double parsing
1129
# in the backend. Emulates libpq PQescapeBytea()
1130
# See also pg_unescape_bytea, but note that these functions are not inverses.
1131
# (I tried many versions to improve speed and this was fastest, although still
1132
# slow. The numeric constants 92=\ and 39=` were part of that optimization.)
1133
proc pg_escape_bytea {binstr} {
1134
set result {}
1135
binary scan $binstr c* val_list
1136
foreach c [split $binstr {}] val $val_list {
1137
if {$val == 92} {
1138
append result {\\\\}
1139
} elseif {$val == 39} {
1140
append result {''}
1141
} elseif {$val < 32 || 126 < $val} {
1142
append result [format {\\%03o} [expr {$val & 255}]]
1143
} else {
1144
append result $c
1145
}
1146
}
1147
return $result
1148
}
1149
1150
# pg_unescape_bytea: Unescape a string returned from PostgreSQL as an
1151
# escaped bytea object and return a binary string.
1152
# Emulates libpq PQunescapeBytea().
1153
# See also pg_escape_bytea, but note that these functions are not inverses.
1154
# Implementation note: Iterative implementations perform very poorly.
1155
# This method is from Benny Riefenstahl via Jerry Levan. It works much
1156
# faster, and returns the correct data on any value produced by the
1157
# PostgreSQL backend from converting a bytea data type to text (byteaout).
1158
# But it does NOT work the same as PQunescapeBytea() for all values.
1159
# For example, passing \a here returns 0x07, but PQunescapeBytea returns 'a'.
1160
proc pg_unescape_bytea {str} {
1161
return [subst -nocommands -novariables $str]
1162
}
1163
1164
# pg_parameter_status: Return the value of a backend parameter value.
1165
# These are generally supplied by the backend during startup.
1166
proc pg_parameter_status {db name} {
1167
upvar #0 pgtcl::param_$db param
1168
if {[info exists param($name)]} {
1169
return $param($name)
1170
}
1171
return ""
1172
}
1173
1174
# pg_transaction_status: Return the current transaction status.
1175
# Returns a string: IDLE INTRANS INERROR or UNKNOWN.
1176
proc pg_transaction_status {db} {
1177
if {[info exists pgtcl::xstate($db)]} {
1178
switch -- $pgtcl::xstate($db) {
1179
I { return IDLE }
1180
T { return INTRANS }
1181
E { return INERROR }
1182
}
1183
}
1184
return UNKNOWN
1185
}
1186
1187
# === Internal Procedure to support COPY ===
1188
1189
# Handle a CopyInResponse or CopyOutResponse message:
1190
proc pgtcl::begincopy {result_name direction} {
1191
upvar $result_name result
1192
set db $result(conn)
1193
if {[pgtcl::get_int8 $db]} {
1194
error "pg_exec: COPY BINARY is not supported"
1195
}
1196
set result(status) PGRES_COPY_$direction
1197
# Column count and per-column formats are ignored.
1198
set ncol [pgtcl::get_int16 $db]
1199
pgtcl::skip $db [expr {2*$ncol}]
1200
if {$pgtcl::debug} { puts "+pg_exec begin copy $direction" }
1201
}
1202
1203
# === Public procedures: COPY ===
1204
1205
# I/O procedures to support COPY. No longer able to just read/write the
1206
# channel, due to the message procotol.
1207
1208
# Read line from COPY TO. Returns the copy line if OK, else "" on end.
1209
# Note: The returned line does not end in a newline, so you can split it
1210
# on tab and get a list of column values.
1211
# At end of COPY, it takes the CopyDone only. pg_endcopy must be called to
1212
# get the CommandComplete and ReadyForQuery messages.
1213
proc pg_copy_read {res} {
1214
upvar #0 [pgtcl::checkres $res] result
1215
set db $result(conn)
1216
if {$result(status) != "PGRES_COPY_OUT"} {
1217
error "pg_copy_read called but connection is not doing a COPY OUT"
1218
}
1219
# Notice/Notify etc are not allowed during copy, so no loop needed.
1220
set c [pgtcl::readmsg $db]
1221
if {$pgtcl::debug} { puts "+pg_copy_read msg $c" }
1222
if {$c == "d"} {
1223
return [string trimright \
1224
[encoding convertfrom identity [pgtcl::get_rest $db]] "\n\r"]
1225
}
1226
if {$c == "c"} {
1227
return ""
1228
}
1229
# Error or invalid response.
1230
if {$c == "E"} {
1231
set result(status) PGRES_FATAL_ERROR
1232
set result(error) [pgtcl::get_response $db result]
1233
return ""
1234
}
1235
error "pg_copy_read: procotol violation, unexpected $c in copy out"
1236
}
1237
1238
# Write line for COPY FROM. This must represent a single record (tuple) with
1239
# values separated by tabs. Do not add a newline; pg_copy_write does this.
1240
proc pg_copy_write {res line} {
1241
upvar #0 [pgtcl::checkres $res] result
1242
pgtcl::sendmsg $result(conn) d "[encoding convertto identity $line]\n"
1243
}
1244
1245
# End a COPY TO/FROM. This is needed to finish up the protocol after
1246
# reading or writing. On COPY TO, this needs to be called after
1247
# pg_copy_read returns an empty string. On COPY FROM, this needs to
1248
# be called after writing the last record with pg_copy_write.
1249
# Note: Do not write or expect to read "\." anymore.
1250
# When it returns, the result structure (res) will be updated.
1251
proc pg_endcopy {res} {
1252
upvar #0 [pgtcl::checkres $res] result
1253
set db $result(conn)
1254
if {$pgtcl::debug} { puts "+pg_endcopy end $result(status)" }
1255
1256
# An error might have been sent during a COPY TO, so the result
1257
# status will already be FATAL and should not be disturbed.
1258
if {$result(status) != "PGRES_FATAL_ERROR"} {
1259
if {$result(status) == "PGRES_COPY_IN"} {
1260
# Send CopyDone
1261
pgtcl::sendmsg $db c {}
1262
} elseif {$result(status) != "PGRES_COPY_OUT"} {
1263
error "pg_endcopy called but connection is not doing a COPY"
1264
}
1265
set result(status) PGRES_COMMAND_OK
1266
}
1267
1268
# We're looking for CommandComplete and ReadyForQuery here, but other
1269
# things can happen too.
1270
while {[set c [pgtcl::readmsg $db]] != "Z"} {
1271
if {![pgtcl::common_message $c $db result]} {
1272
error "Unexpected reply from database: $c"
1273
}
1274
}
1275
set pgtcl::xstate($db) [pgtcl::get_byte $db]
1276
if {$pgtcl::debug} { puts "+pg_endcopy returns, st=$result(status)" }
1277
}
1278
1279
# === Internal producedures for Function Call (used by Large Object) ===
1280
1281
# Internal procedure to lookup, cache, and return a PostgreSQL function OID.
1282
# This assumes all connections have the same function OIDs, which might not be
1283
# true if you connect to servers running different versions of PostgreSQL.
1284
# Throws an error if the OID is not found by PostgreSQL.
1285
# To call overloaded functions, argument types must be specified in parentheses
1286
# after the function name, in the the exact same format as psql "\df".
1287
# This is a list of types separated by a comma and one space.
1288
# For example: fname="like(text, text)".
1289
# The return type cannot be specified. I don't think there are any functions
1290
# distinguished only by return type.
1291
proc pgtcl::getfnoid {db fname} {
1292
variable fnoids
1293
1294
if {![info exists fnoids($fname)]} {
1295
1296
# Separate the function name from the (arg type list):
1297
if {[regexp {^([^(]*)\(([^)]*)\)$} $fname unused fcn arglist]} {
1298
set amatch " and oidvectortypes(proargtypes)='$arglist'"
1299
} else {
1300
set fcn $fname
1301
set amatch ""
1302
}
1303
pg_select $db "select oid from pg_proc where proname='$fcn' $amatch" d {
1304
set fnoids($fname) $d(oid)
1305
}
1306
if {![info exists fnoids($fname)]} {
1307
error "Unable to get OID of database function $fname"
1308
}
1309
}
1310
return $fnoids($fname)
1311
}
1312
1313
# Internal procedure to implement PostgreSQL "fast-path" function calls.
1314
# $fn_oid is the OID of the PostgreSQL function. See pgtcl::getfnoid.
1315
# $result_name is the name of the variable to store the backend function
1316
# result into.
1317
# $arginfo is a list of argument descriptors, each is I or S or a number.
1318
# I means the argument is an integer32.
1319
# S means the argument is a string, and its actual length is used.
1320
# A number means send exactly that many bytes (null-pad if needed) from
1321
# the argument.
1322
# (Argument type S is passed in Ascii format code, others as Binary.)
1323
# $arglist is a list of arguments to the PostgreSQL function. (This
1324
# is actually a pass-through argument 'args' from the wrappers.)
1325
# Throws Tcl error on error, otherwise returns size of the result
1326
# stored into the $result_name variable.
1327
1328
proc pgtcl::callfn {db fn_oid result_name arginfo arglist} {
1329
upvar $result_name result
1330
1331
set nargs [llength $arginfo]
1332
if {$pgtcl::debug} {
1333
puts "+callfn oid=$fn_oid nargs=$nargs info=$arginfo args=$arglist"
1334
}
1335
1336
# Function call: oid nfcodes fcodes... nargs {arglen arg}... resultfcode
1337
set fcodes {}
1338
foreach k $arginfo {
1339
if {$k == "S"} {
1340
lappend fcodes 0
1341
} else {
1342
lappend fcodes 1
1343
}
1344
}
1345
set out [binary format {I S S* S} $fn_oid $nargs $fcodes $nargs]
1346
# Append each argument and its length:
1347
foreach k $arginfo arg $arglist {
1348
if {$k == "I"} {
1349
append out [binary format II 4 $arg]
1350
} elseif {$k == "S"} {
1351
append out [binary format I [string length $arg]] $arg
1352
} else {
1353
append out [binary format Ia$k $k $arg]
1354
}
1355
}
1356
# Append format code for binary result:
1357
append out [binary format S 1]
1358
pgtcl::sendmsg $db F $out
1359
1360
set result {}
1361
set result_size 0
1362
# Fake up a partial result structure for pgtcl::common_message :
1363
set res(error) ""
1364
1365
# FunctionCall response. Also handles common messages (notify, notice).
1366
while {[set c [pgtcl::readmsg $db]] != "Z"} {
1367
if {$c == "V"} {
1368
set result_size [pgtcl::get_int32 $db]
1369
if {$result_size > 0} {
1370
set result [pgtcl::get_bytes $db $result_size]
1371
} else {
1372
set result ""
1373
}
1374
} elseif {![pgtcl::common_message $c $db res]} {
1375
error "Unexpected reply from database: $c"
1376
}
1377
}
1378
set pgtcl::xstate($db) [pgtcl::get_byte $db]
1379
if {$res(error) != ""} {
1380
error $res(error)
1381
}
1382
return $result_size
1383
}
1384
1385
# === Public prodedures: Function Call ===
1386
1387
# Public interface to pgtcl::callfn.
1388
proc pg_callfn {db fname result_name arginfo args} {
1389
upvar $result_name result
1390
return [pgtcl::callfn $db [pgtcl::getfnoid $db $fname] result $arginfo $args]
1391
}
1392
1393
# Public, simplified interface to pgtcl::callfn when an int32 return value is
1394
# expected. Returns the backend function return value.
1395
proc pg_callfn_int {db fname arginfo args} {
1396
set n [pgtcl::callfn $db [pgtcl::getfnoid $db $fname] result $arginfo $args]
1397
if {$n != 4} {
1398
error "Unexpected response size ($result_size) to pg function call $fname"
1399
}
1400
binary scan $result I val
1401
return $val
1402
}
1403
1404
# === Internal procedure to support Large Object ===
1405
1406
# Convert a LO mode string into the value of the constants used by libpq.
1407
# Note: libpgtcl uses a mode like INV_READ|INV_WRITE for lo_creat, but
1408
# r, w, or rw for lo_open (which it translates to INV_READ|INV_WRITE).
1409
# This seems like a mistake. The code here accepts either form for either.
1410
proc pgtcl::lomode {mode} {
1411
set imode 0
1412
if {[string match -nocase *INV_* $mode]} {
1413
if {[string match -nocase *INV_READ* $mode]} {
1414
set imode 0x40000
1415
}
1416
if {[string match -nocase *INV_WRITE* $mode]} {
1417
set imode [expr {$imode + 0x20000}]
1418
}
1419
} else {
1420
if {[string match -nocase *r* $mode]} {
1421
set imode 0x40000
1422
}
1423
if {[string match -nocase *w* $mode]} {
1424
set imode [expr {$imode + 0x20000}]
1425
}
1426
}
1427
if {$imode == 0} {
1428
error "Invalid large object mode $mode"
1429
}
1430
return $imode
1431
}
1432
1433
# === Public prodedures: Large Object ===
1434
1435
# Create large object and return OID.
1436
# See note regarding mode above at pgtcl::lomode.
1437
proc pg_lo_creat {db mode} {
1438
if {[catch {pg_callfn_int $db lo_creat I [pgtcl::lomode $mode]} result]} {
1439
error "Large Object create failed\n$result"
1440
}
1441
if {$result == -1} {
1442
error "Large Object create failed"
1443
}
1444
return $result
1445
}
1446
1447
# Open large object and return large object file descriptor.
1448
# See note regarding mode above at pgtcl::lomode.
1449
proc pg_lo_open {db loid mode} {
1450
if {[catch {pg_callfn_int $db lo_open "I I" $loid [pgtcl::lomode $mode]} \
1451
result]} {
1452
error "Large Object open failed\n$result"
1453
}
1454
if {$result == -1} {
1455
error "Large Object open failed"
1456
}
1457
return $result
1458
}
1459
1460
# Close large object file descriptor.
1461
proc pg_lo_close {db lofd} {
1462
if {[catch {pg_callfn_int $db lo_close I $lofd} result]} {
1463
error "Large Object close failed\n$result"
1464
}
1465
return $result
1466
}
1467
1468
# Delete large object:
1469
proc pg_lo_unlink {db loid} {
1470
if {[catch {pg_callfn_int $db lo_unlink I $loid} result]} {
1471
error "Large Object unlink failed\n$result"
1472
}
1473
return $result
1474
}
1475
1476
# Read from large object.
1477
# Note: The original PostgreSQL documentation says it returns -1 on error,
1478
# which is a bad idea since you can't get to the error message. But it's
1479
# probably too late to change it, so we remain bug compatible.
1480
proc pg_lo_read {db lofd buf_name maxlen} {
1481
upvar $buf_name buf
1482
if {[catch {pg_callfn $db loread buf "I I" $lofd $maxlen} result]} {
1483
return -1
1484
}
1485
return $result
1486
}
1487
1488
# Write to large object. At most $len bytes are written.
1489
# See note above on pg_lo_read error return.
1490
proc pg_lo_write {db lofd buf len} {
1491
if {[set buflen [string length $buf]] < $len} {
1492
set len $buflen
1493
}
1494
if {[catch {pg_callfn_int $db lowrite "I $len" $lofd $buf} result]} {
1495
return -1
1496
}
1497
return $result
1498
}
1499
1500
# Seek to offset inside large object:
1501
proc pg_lo_lseek {db lofd offset whence} {
1502
switch $whence {
1503
SEEK_SET { set iwhence 0 }
1504
SEEK_CUR { set iwhence 1 }
1505
SEEK_END { set iwhence 2 }
1506
default { error "'whence' must be SEEK_SET, SEEK_CUR, or SEEK_END" }
1507
}
1508
if {[catch {pg_callfn_int $db lo_lseek "I I I" $lofd $offset $iwhence} \
1509
result]} {
1510
error "Large Object seek failed\n$result"
1511
}
1512
return $result
1513
}
1514
1515
# Return location of file offset in large object:
1516
proc pg_lo_tell {db lofd} {
1517
if {[catch {pg_callfn_int $db lo_tell I $lofd} result]} {
1518
error "Large Object tell offset failed\n$result"
1519
}
1520
return $result
1521
}
1522
1523
# Import large object. Wrapper for lo_creat, lo_open, lo_write.
1524
# Returns Large Object OID, which should be stored in a table somewhere.
1525
proc pg_lo_import {db filename} {
1526
if {[catch {open $filename} f]} {
1527
error "Large object import of $filename failed\n$f"
1528
}
1529
fconfigure $f -translation binary
1530
set loid [pg_lo_creat $db INV_READ|INV_WRITE]
1531
set lofd [pg_lo_open $db $loid w]
1532
while {1} {
1533
set buf [read $f 32768]
1534
if {[set len [string length $buf]] == 0} break
1535
if {[pg_lo_write $db $lofd $buf $len] != $len} {
1536
error "Large Object import failed to write $len bytes"
1537
}
1538
}
1539
pg_lo_close $db $lofd
1540
close $f
1541
return $loid
1542
}
1543
1544
# Export large object. Wrapper for lo_open, lo_read.
1545
proc pg_lo_export {db loid filename} {
1546
if {[catch {open $filename w} f]} {
1547
error "Large object export to $filename failed\n$f"
1548
}
1549
fconfigure $f -translation binary
1550
if {[catch {pg_lo_open $db $loid r} lofd]} {
1551
error "Large Object export to $filename failed\n$lofd"
1552
}
1553
while {[set len [pg_lo_read $db $lofd buf 32768]] > 0} {
1554
puts -nonewline $f $buf
1555
}
1556
pg_lo_close $db $lofd
1557
close $f
1558
}
1559
1560
# === MD5 Checksum procedures for password authentication ===
1561
1562
# Coded in Tcl by ljb <lbayuk@mindspring.com>, using these sources:
1563
# RFC1321
1564
# PostgreSQL: src/backend/libpq/md5.c
1565
# If you want a better/faster MD5 implementation, see tcllib.
1566
1567
namespace eval md5 { }
1568
1569
# Round 1 helper, e.g.:
1570
# a = b + ROT_LEFT((a + F(b, c, d) + X[0] + 0xd76aa478), 7)
1571
# p1 p2 p1 p3 p4 p5 p6 p7
1572
# Where F(x,y,z) = (x & y) | (~x & z)
1573
#
1574
proc md5::round1 {p1 p2 p3 p4 p5 p6 p7} {
1575
set r [expr {$p2 + ($p1 & $p3 | ~$p1 & $p4) + $p5 + $p6}]
1576
return [expr {$p1 + ($r << $p7 | (($r >> (32 - $p7)) & ((1 << $p7) - 1)))}]
1577
}
1578
1579
# Round 2 helper, e.g.:
1580
# a = b + ROT_LEFT((a + G(b, c, d) + X[1] + 0xf61e2562), 5)
1581
# p1 p2 p1 p3 p4 p5 p6 p7
1582
# Where G(x,y,z) = (x & z) | (y & ~z)
1583
#
1584
proc md5::round2 {p1 p2 p3 p4 p5 p6 p7} {
1585
set r [expr {$p2 + ($p1 & $p4 | $p3 & ~$p4) + $p5 + $p6}]
1586
return [expr {$p1 + ($r << $p7 | (($r >> (32 - $p7)) & ((1 << $p7) - 1)))}]
1587
}
1588
1589
# Round 3 helper, e.g.:
1590
# a = b + ROT_LEFT((a + H(b, c, d) + X[5] + 0xfffa3942), 4)
1591
# p1 p2 p1 p3 p4 p5 p6 p7
1592
# Where H(x, y, z) = x ^ y ^ z
1593
#
1594
proc md5::round3 {p1 p2 p3 p4 p5 p6 p7} {
1595
set r [expr {$p2 + ($p1 ^ $p3 ^ $p4) + $p5 + $p6}]
1596
return [expr {$p1 + ($r << $p7 | (($r >> (32 - $p7)) & ((1 << $p7) - 1)))}]
1597
}
1598
1599
# Round 4 helper, e.g.:
1600
# a = b + ROT_LEFT((a + I(b, c, d) + X[0] + 0xf4292244), 6)
1601
# p1 p2 p1 p3 p4 p5 p6 p7
1602
# Where I(x, y, z) = y ^ (x | ~z)
1603
#
1604
proc md5::round4 {p1 p2 p3 p4 p5 p6 p7} {
1605
set r [expr {$p2 + ($p3 ^ ($p1 | ~$p4)) + $p5 + $p6}]
1606
return [expr {$p1 + ($r << $p7 | (($r >> (32 - $p7)) & ((1 << $p7) - 1)))}]
1607
}
1608
1609
# Do one set of rounds. Updates $state(0:3) with results from $x(0:16).
1610
proc md5::round {x_name state_name} {
1611
upvar $x_name x $state_name state
1612
set a $state(0)
1613
set b $state(1)
1614
set c $state(2)
1615
set d $state(3)
1616
1617
# Round 1, steps 1-16
1618
set a [round1 $b $a $c $d $x(0) 0xd76aa478 7]
1619
set d [round1 $a $d $b $c $x(1) 0xe8c7b756 12]
1620
set c [round1 $d $c $a $b $x(2) 0x242070db 17]
1621
set b [round1 $c $b $d $a $x(3) 0xc1bdceee 22]
1622
set a [round1 $b $a $c $d $x(4) 0xf57c0faf 7]
1623
set d [round1 $a $d $b $c $x(5) 0x4787c62a 12]
1624
set c [round1 $d $c $a $b $x(6) 0xa8304613 17]
1625
set b [round1 $c $b $d $a $x(7) 0xfd469501 22]
1626
set a [round1 $b $a $c $d $x(8) 0x698098d8 7]
1627
set d [round1 $a $d $b $c $x(9) 0x8b44f7af 12]
1628
set c [round1 $d $c $a $b $x(10) 0xffff5bb1 17]
1629
set b [round1 $c $b $d $a $x(11) 0x895cd7be 22]
1630
set a [round1 $b $a $c $d $x(12) 0x6b901122 7]
1631
set d [round1 $a $d $b $c $x(13) 0xfd987193 12]
1632
set c [round1 $d $c $a $b $x(14) 0xa679438e 17]
1633
set b [round1 $c $b $d $a $x(15) 0x49b40821 22]
1634
1635
# Round 2, steps 17-32
1636
set a [round2 $b $a $c $d $x(1) 0xf61e2562 5]
1637
set d [round2 $a $d $b $c $x(6) 0xc040b340 9]
1638
set c [round2 $d $c $a $b $x(11) 0x265e5a51 14]
1639
set b [round2 $c $b $d $a $x(0) 0xe9b6c7aa 20]
1640
set a [round2 $b $a $c $d $x(5) 0xd62f105d 5]
1641
set d [round2 $a $d $b $c $x(10) 0x02441453 9]
1642
set c [round2 $d $c $a $b $x(15) 0xd8a1e681 14]
1643
set b [round2 $c $b $d $a $x(4) 0xe7d3fbc8 20]
1644
set a [round2 $b $a $c $d $x(9) 0x21e1cde6 5]
1645
set d [round2 $a $d $b $c $x(14) 0xc33707d6 9]
1646
set c [round2 $d $c $a $b $x(3) 0xf4d50d87 14]
1647
set b [round2 $c $b $d $a $x(8) 0x455a14ed 20]
1648
set a [round2 $b $a $c $d $x(13) 0xa9e3e905 5]
1649
set d [round2 $a $d $b $c $x(2) 0xfcefa3f8 9]
1650
set c [round2 $d $c $a $b $x(7) 0x676f02d9 14]
1651
set b [round2 $c $b $d $a $x(12) 0x8d2a4c8a 20]
1652
1653
# Round 3, steps 33-48
1654
set a [round3 $b $a $c $d $x(5) 0xfffa3942 4]
1655
set d [round3 $a $d $b $c $x(8) 0x8771f681 11]
1656
set c [round3 $d $c $a $b $x(11) 0x6d9d6122 16]
1657
set b [round3 $c $b $d $a $x(14) 0xfde5380c 23]
1658
set a [round3 $b $a $c $d $x(1) 0xa4beea44 4]
1659
set d [round3 $a $d $b $c $x(4) 0x4bdecfa9 11]
1660
set c [round3 $d $c $a $b $x(7) 0xf6bb4b60 16]
1661
set b [round3 $c $b $d $a $x(10) 0xbebfbc70 23]
1662
set a [round3 $b $a $c $d $x(13) 0x289b7ec6 4]
1663
set d [round3 $a $d $b $c $x(0) 0xeaa127fa 11]
1664
set c [round3 $d $c $a $b $x(3) 0xd4ef3085 16]
1665
set b [round3 $c $b $d $a $x(6) 0x04881d05 23]
1666
set a [round3 $b $a $c $d $x(9) 0xd9d4d039 4]
1667
set d [round3 $a $d $b $c $x(12) 0xe6db99e5 11]
1668
set c [round3 $d $c $a $b $x(15) 0x1fa27cf8 16]
1669
set b [round3 $c $b $d $a $x(2) 0xc4ac5665 23]
1670
1671
# Round 4, steps 49-64
1672
set a [round4 $b $a $c $d $x(0) 0xf4292244 6]
1673
set d [round4 $a $d $b $c $x(7) 0x432aff97 10]
1674
set c [round4 $d $c $a $b $x(14) 0xab9423a7 15]
1675
set b [round4 $c $b $d $a $x(5) 0xfc93a039 21]
1676
set a [round4 $b $a $c $d $x(12) 0x655b59c3 6]
1677
set d [round4 $a $d $b $c $x(3) 0x8f0ccc92 10]
1678
set c [round4 $d $c $a $b $x(10) 0xffeff47d 15]
1679
set b [round4 $c $b $d $a $x(1) 0x85845dd1 21]
1680
set a [round4 $b $a $c $d $x(8) 0x6fa87e4f 6]
1681
set d [round4 $a $d $b $c $x(15) 0xfe2ce6e0 10]
1682
set c [round4 $d $c $a $b $x(6) 0xa3014314 15]
1683
set b [round4 $c $b $d $a $x(13) 0x4e0811a1 21]
1684
set a [round4 $b $a $c $d $x(4) 0xf7537e82 6]
1685
set d [round4 $a $d $b $c $x(11) 0xbd3af235 10]
1686
set c [round4 $d $c $a $b $x(2) 0x2ad7d2bb 15]
1687
set b [round4 $c $b $d $a $x(9) 0xeb86d391 21]
1688
1689
incr state(0) $a
1690
incr state(1) $b
1691
incr state(2) $c
1692
incr state(3) $d
1693
}
1694
1695
# Pad out buffer per MD5 spec:
1696
proc md5::pad {buf_name} {
1697
upvar $buf_name buf
1698
1699
# Length in bytes:
1700
set len [string length $buf]
1701
# Length in bits as 2 32 bit words:
1702
set len64hi [expr {$len >> 29 & 7}]
1703
set len64lo [expr {$len << 3}]
1704
1705
# Append 1 special byte, then append 0 or more 0 bytes until
1706
# (length in bytes % 64) == 56
1707
set pad [expr {64 - ($len + 8) % 64}]
1708
append buf [binary format a$pad "\x80"]
1709
1710
# Append the length in bits as a 64 bit value, low bytes first.
1711
append buf [binary format i1i1 $len64lo $len64hi]
1712
1713
}
1714
1715
# Calculate MD5 Digest over a string, return as 32 hex digit string.
1716
proc md5::digest {buf} {
1717
# This is 0123456789abcdeffedcba9876543210 in byte-swapped order:
1718
set state(0) 0x67452301
1719
set state(1) 0xEFCDAB89
1720
set state(2) 0x98BADCFE
1721
set state(3) 0x10325476
1722
1723
# Pad buffer per RFC to exact multiple of 64 bytes.
1724
pad buf
1725
1726
# Calculate digest in 64 byte chunks:
1727
set nwords 0
1728
set nbytes 0
1729
set word 0
1730
binary scan $buf c* bytes
1731
# Unclear, but the data seems to get byte swapped here.
1732
foreach c $bytes {
1733
set word [expr {$c << 24 | ($word >> 8 & 0xffffff) }]
1734
if {[incr nbytes] == 4} {
1735
set nbytes 0
1736
set x($nwords) $word
1737
set word 0
1738
if {[incr nwords] == 16} {
1739
round x state
1740
set nwords 0
1741
}
1742
}
1743
}
1744
1745
# Result is state(0:3), but each word is taken low byte first.
1746
set result {}
1747
for {set i 0} {$i <= 3} {incr i} {
1748
set w $state($i)
1749
append result [format %02x%02x%02x%02x \
1750
[expr {$w & 255}] \
1751
[expr {$w >> 8 & 255}] \
1752
[expr {$w >> 16 & 255}] \
1753
[expr {$w >> 24 & 255}]]
1754
}
1755
return $result
1756
}
1757
package provide pgintcl $pgtcl::version
Loggerhead is a web-based interface for Breezy
Version: 2.0.1