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