pgin.tcl

用于TCL/TK的可视化集成开发环境.(GUI)

# pgin.tcl - PostgreSQL Tcl Interface direct to protocol v3 backend
# $Id: pgin.tcl,v 1.1 2005/08/14 19:08:23 dennis Exp $
#
# Copyright 1998-2004 by ljb ([e-mail])
# May be freely distributed with or without modification; must retain this
# notice; provided with no warranties.
# See the file COPYING for complete information on usage and redistribution
# of this file, and for a disclaimer of all warranties.
#
# See the file INTERNALS in the source distribution for more information
# about how this thing works, including namespace variables.
#
# Also includes:
#    md5.tcl - Compute MD5 Checksum

package require Tcl 8.3

# === Definition of the pgtcl namespace ===

namespace eval pgtcl {
  # Debug flag:
  variable debug 0

  # Version number, also used in package provide at the bottom of this file:
  variable version 2.0.0

  # Counter for making uniquely named result structures:
  variable rn 0

  # Array mapping error field names to protocol codes:
  variable errnames
  array set errnames {
    SEVERITY S
    SQLSTATE C
    MESSAGE_PRIMARY M
    MESSAGE_DETAIL D
    MESSAGE_HINT H
    STATEMENT_POSITION P
    CONTEXT W
    SOURCE_FILE F
    SOURCE_LINE L
    SOURCE_FUNCTION R
  }
}

# === Internal Low-level I/O procedures for v3 protocol ===

# Internal procedure to send a packet to the backend with type and length.
# Type can be empty - this is used for the startup packet.
proc pgtcl::sendmsg {sock type data} {
  set len [expr {[string length $data]+4}]
  puts -nonewline $sock $type[binary format I $len]$data
}

# Read a message and return the message type byte:
# This initializes the per-connection buffer too.
# This has a special check for a v2 error message, which is needed at
# startup in case of talking to v2 server. It assumes we will not
# get a V3 error message longer than 0x20000000 bytes, which is pretty safe.
# It fakes up a V3 error with severity ERROR, code (5 spaces), and the message.
proc pgtcl::readmsg {sock} {
  upvar #0 pgtcl::buf_$sock buf pgtcl::bufi_$sock bufi pgtcl::bufn_$sock bufn
  set bufi 0
  if {[binary scan [read $sock 5] aI type len] != 2} {
    set err "pgtcl: Unable to read message from database"
    if {[eof $sock]} {
      append err " - server closed connection"
    }
    error $err
  }
  if {$type == "E" && $len >= 0x20000000} {
    if {$pgtcl::debug} { puts "Warning: V2 error message received!" }
    # Build the start of the V3 error, including the 4 misread bytes in $len:
    set buf [binary format {a a*x a a*x a I} S ERROR C "     " M $len]
    while {[set c [read $sock 1]] != ""} {
      append buf $c
      if {$c == "\000"} break
    }
    # This is 'code=0' to mark no more error options.
    append buf "\000"
    set bufn [string length $buf]
  } else {
    set bufn [expr {$len - 4}]
    set buf [read $sock $bufn]
  }
  return $type
}

# Return the next byte from the buffer:
proc pgtcl::get_byte {db} {
  upvar #0 pgtcl::buf_$db buf pgtcl::bufi_$db bufi
  set result [string index $buf $bufi]
  incr bufi
  return $result
}

# Return the next $n bytes from the buffer:
proc pgtcl::get_bytes {db n} {
  upvar #0 pgtcl::buf_$db buf pgtcl::bufi_$db bufi
  set result [string range $buf $bufi [expr {$bufi + $n - 1}]]
  incr bufi $n
  return $result
}

# Return the rest of the buffer.
proc pgtcl::get_rest {db} {
  upvar #0 pgtcl::buf_$db buf pgtcl::bufi_$db bufi pgtcl::bufn_$db bufn
  set result [string range $buf $bufi end]
  set bufi $bufn
  return $result
}

# Skip next $n bytes in the buffer.
proc pgtcl::skip {db n} {
  upvar #0 pgtcl::bufi_$db bufi
  incr bufi $n
}

# Return next int32 from the buffer:
proc pgtcl::get_int32 {db} {
  upvar #0 pgtcl::buf_$db buf pgtcl::bufi_$db bufi
  if {[binary scan $buf "x$bufi I" i] != 1} {
    set i 0
  }
  incr bufi 4
  return $i
}

# Return next signed int16 from the buffer:
proc pgtcl::get_int16 {db} {
  upvar #0 pgtcl::buf_$db buf pgtcl::bufi_$db bufi
  if {[binary scan $buf "x$bufi S" i] != 1} {
    set i 0
  }
  incr bufi 2
  return $i
}

# Return next unsigned int16 from the buffer:
proc pgtcl::get_uint16 {db} {
  upvar #0 pgtcl::buf_$db buf pgtcl::bufi_$db bufi
  if {[binary scan $buf "x$bufi S" i] != 1} {
    set i 0
  }
  incr bufi 2
  return [expr {$i & 0xffff}]
}

# Return next signed int8 from the buffer:
# (This is only used in 1 place in the protocol...)
proc pgtcl::get_int8 {db} {
  upvar #0 pgtcl::buf_$db buf pgtcl::bufi_$db bufi
  if {[binary scan $buf "x$bufi c" i] != 1} {
    set i 0
  }
  incr bufi
  return $i
}

# Return the next null-terminated string from the buffer:
proc pgtcl::get_string {db} {
  upvar #0 pgtcl::buf_$db buf pgtcl::bufi_$db bufi
  set end [string first "\000" $buf $bufi]
  if {$end < 0} {
    return ""
  }
  set result [string range $buf $bufi [expr {$end - 1}]]
  set bufi [expr {$end + 1}]
  return $result
}

# === Internal Mid-level I/O procedures for v3 protocol ===

# Parse a backend ErrorResponse or NoticeResponse message. The Severity
# and Message parts are returned together with a trailing newline, like v2
# protocol did. If optional result_name is supplied, it is the name of
# a result structure to store all error parts in, indexed as (error,$code).
proc pgtcl::get_response {db {result_name ""}} {
  if {$result_name != ""} {
    upvar $result_name result
  }
  array set result {error,S ERROR error,M {}}
  while {[set c [pgtcl::get_byte $db]] != "\000" && $c != ""} {
    set result(error,$c) [pgtcl::get_string $db]
  }
  return "$result(error,S):  $result(error,M)\n"
}

# Handle ParameterStatus and remember the name and value:
proc pgtcl::get_parameter_status {db} {
  upvar #0 pgtcl::param_$db param
  set name [pgtcl::get_string $db]
  set param($name) [pgtcl::get_string $db]
  if {$pgtcl::debug} { puts "+server param $name=$param($name)" }
}

# Handle a notification ('A') message.
# The notifying backend pid and more_info are read but ignored.
proc pgtcl::get_notification_response {db} {
  set notify_pid [pgtcl::get_int32 $db]
  set notify_rel [pgtcl::get_string $db]
  set more_info [pgtcl::get_string $db]
  if {$pgtcl::debug} { puts "+pgtcl got notify from $notify_pid: $notify_rel" }
  if {[info exists pgtcl::notify($db,$notify_rel)]} {
    after idle $pgtcl::notify($db,$notify_rel)
  }
}

# Handle a notice ('N') message. If no handler is defined, or the handler is
# empty, do nothing, otherwise, call the handler with the message argument
# appended. For backward compatibility with v2 protocol, the message is
# assumed to end in a newline.
proc pgtcl::get_notice {db} {
  set msg [pgtcl::get_response $db]
  if {[info exists pgtcl::notice($db)] && [set cmd $pgtcl::notice($db)] != ""} {
    eval $cmd [list $msg]
  }
}

# Internal procedure to read a tuple (row) from the backend.
# Column count is redundant, but check it anyway.
# Format code (text/binary) is not used; Tcl strings are binary safe.
proc pgtcl::gettuple {db result_name} {
  upvar $result_name result
  if {$result(nattr) == 0} {
    unset result
    error "Protocol error, data before descriptor"
  }
  set irow $result(ntuple)
  set nattr [pgtcl::get_uint16 $db]
  if {$nattr != $result(nattr)} {
    unset result
    error "Expecting $result(nattr) columns, but data row has $nattr"
  }
  for {set icol 0} {$icol < $nattr} {incr icol} {
    set col_len [pgtcl::get_int32 $db]
    if {$col_len > 0} {
      set result($irow,$icol) [pgtcl::get_bytes $db $col_len]
    } else {
      set result($irow,$icol) ""
      if {$col_len < 0} {
        set result(null,$irow,$icol) ""
      }
    }
  }
  incr result(ntuple)
}

# Internal procedure to handle common backend utility message types:
#    C : Completion status        E : Error
#    N : Notice message           A : Notification
#    S : ParameterStatus
# This can be given any message type. If it handles the message,
# it returns 1. If it doesn't handle the message, it returns 0.
#
proc pgtcl::common_message {msgchar db result_name} {
  upvar $result_name result
  switch -- $msgchar {
    A { pgtcl::get_notification_response $db }
    C { set result(complete) [pgtcl::get_string $db] }
    N { pgtcl::get_notice $db }
    S { pgtcl::get_parameter_status $db }
    E {
      set result(status) PGRES_FATAL_ERROR
      set result(error) [pgtcl::get_response $db result]
    }
    default { return 0 }
  }
  return 1
}

# === Other internal support procedures ===

# Internal procedure to set a default value from the environment:
proc pgtcl::default {default args} {
  global env
  foreach a $args {
    if {[info exists env($a)]} {
      return $env($a)
    }
  }
  return $default
}

# Internal procedure to parse a connection info string.
# This has to handle quoting and escaping. See the PostgreSQL Programmer's
# Guide, Client Interfaces, Libpq, Database Connection Functions.
# The definitive reference is the PostgreSQL source code in:
#          interface/libpq/fe-connect.c:conninfo_parse()
# One quirk to note: backslash escapes work in quoted values, and also in
# unquoted values, but you cannot use backslash-space in an unquoted value,
# because the space ends the value regardless of the backslash.
#
# Stores the results in an array $result(paramname)=value. It will not
# create a new index in the array; if paramname does not already exist,
# it means a bad parameter was given (one not defined by pg_conndefaults).
# Returns an error message on error, else an empty string if OK.
proc pgtcl::parse_conninfo {conninfo result_name} {
  upvar $result_name result
  while {[regexp {^ *([^=]*)= *(.+)} $conninfo unused name conninfo]} {
    set name [string trim $name]
    if {[regexp {^'(.*)} $conninfo unused conninfo]} {
      set value ""
      set n [string length $conninfo]
      for {set i 0} {$i < $n} {incr i} {
        if {[set c [string index $conninfo $i]] == "\\"} {
          set c [string index $conninfo [incr i]]
        } elseif {$c == "'"} break
        append value $c
      }
      if {$i >= $n} {
        return "unterminated quoted string in connection info string"
      }
      set conninfo [string range $conninfo [incr i] end]
    } else {
      regexp {^([^ ]*)(.*)} $conninfo unused value conninfo
      regsub -all {\\(.)} $value {\1} value
    }
    if {$pgtcl::debug} { puts "+parse_conninfo name=$name value=$value" }
    if {![info exists result($name)]} {
      return "invalid connection option \"$name\""
    }
    set result($name) $value
  }
  if {[string trim $conninfo] != ""} {
    return "syntax error in connection info string '...$conninfo'"
  }
  return ""
}

# Internal procedure to check for valid result handle. This returns
# the fully qualified name of the result array.
# Usage:  upvar #0 [pgtcl::checkres $res] result
proc pgtcl::checkres {res} {
  if {![info exists pgtcl::result$res]} {
    error "Invalid result handle\n$res is not a valid query result"
  }
  return "pgtcl::result$res"
}

# === Public procedures : Connecting and Disconnecting ===

# Return connection defaults as {optname label dispchar dispsize value}...
proc pg_conndefaults {} {
  set user [pgtcl::default user PGUSER USER LOGNAME USERNAME]
  set result [list \
    [list user     Database-User    {} 20 $user] \
    [list password Database-Password *  20 [pgtcl::default {} PGPASSWORD]] \
    [list host     Database-Host    {} 40 [pgtcl::default localhost PGHOST]] \
         {hostaddr Database-Host-IP-Address {} 45 {}} \
    [list port     Database-Port    {}  6 [pgtcl::default 5432 PGPORT]] \
    [list dbname   Database-Name    {} 20 [pgtcl::default $user PGDATABASE]] \
    [list tty      Backend-Debug-TTY  D 40 [pgtcl::default {} PGTTY]] \
    [list options  Backend-Debug-Options D 40 [pgtcl::default {} PGOPTIONS]] \
  ]
  if {$pgtcl::debug} { puts "+pg_conndefaults: $result" }
  return $result
}

# Connect to database. Only the new form, with -conninfo, is recognized.
# We speak backend protocol v3, and only handle clear-text password and
# MD5 authentication (messages R 3, and R 5).
proc pg_connect {args} {

  if {[llength $args] != 2 || [lindex $args 0] != "-conninfo"} {
    error "Connection to database failed\nMust use pg_connect -conninfo form"
  }

  # Get connection defaults into an array opt(), then merge caller params:
  foreach o [pg_conndefaults] {
    set opt([lindex $o 0]) [lindex $o 4]
  }
  if {[set msg [pgtcl::parse_conninfo [lindex $args 1] opt]] != ""} {
    error "Connection to database failed\n$msg"
  }

  # Hostaddr overrides host, per documentation, and we need host below.
  if {$opt(hostaddr) != ""} {
    set opt(host) $opt(hostaddr)
  }

  if {$pgtcl::debug} {
    puts "+pg_connect to $opt(dbname)@$opt(host):$opt(port) as $opt(user)"
  }

  if {[catch {socket $opt(host) $opt(port)} sock]} {
    error "Connection to database failed\n$sock"
  }
  fconfigure $sock -buffering none -translation binary

  # Startup packet:
  pgtcl::sendmsg $sock {} [binary format "I a*x a*x a*x a*x a*x a*x x" \
        0x00030000 \
        user $opt(user) database $opt(dbname) options $opt(options)]

  set msg {}
  while {[set c [pgtcl::readmsg $sock]] != "Z"} {
    switch $c {
      E {
        set msg [pgtcl::get_response $sock]
        break
      }
      R {
        set n [pgtcl::get_int32 $sock]
        if {$n == 3} {