pgin.tcl

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

# pgin.tcl - PostgreSQL Tcl Interface direct to protocol v2 backend
# $Id: pgin.tcl,v 1.1 2005/08/14 19:08:13 dennis Exp $
#
# Copyright 2003 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.
#
# Also includes:
#    md5.tcl - Compute MD5 Checksum

namespace eval pgtcl {
  # Debug flag:
  variable debug 0

  # Internal version number:
  variable version 1.5.0

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

  # Function OID cache, indexed by function name, self initializing:
  variable fnoids

  # Array of notification information, indexed on $conn,$relname:
  variable notify

  # Value to use for NULL results:
  variable nulls {}

  # Command to execute when a NOTICE message arrives.
  # The message text argument will be appended to the command.
  # Like libpq, we expect the message to already have a newline.
  variable notice {puts -nonewline stderr}
}

# 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 routine to read a null-terminated string from the PostgreSQL backend.
# String is stored in the 2nd argument if given, else it is returned.
# I wish there was a more efficient way to do this!
proc pgtcl::gets {sock {s_name ""}} {
  if {$s_name != ""} {
    upvar $s_name s
  }
  set s ""
  while {[set c [read $sock 1]] != "\000"} {
    append s $c
  }
  if {$s_name == ""} {
    return $s
  }
}

# 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"
}

# 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-IPv4-Address {} 15 {}} \
    [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 v2, 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
  puts -nonewline $sock [binary format "I S S a64 a32 a64 x64 a64" \
        296 2 0 $opt(dbname) $opt(user) $opt(options) $opt(tty)]

  set msg {}
  while {[set c [read $sock 1]] != "Z"} {
    switch $c {
      E {
        pgtcl::gets $sock msg
        break
      }
      R {
        set n -1
        binary scan [read $sock 4] I n
        if {$n == 3} {
          set n [expr "5 + [string length $opt(password)]"]
          puts -nonewline $sock [binary format "I a* x" $n $opt(password)]
        } elseif {$n == 5} {
          set salt [read $sock 4]
          # This is from PostgreSQL source backend/libpq/crypt.c:
          set md5_response \
            "md5[md5::digest [md5::digest $opt(password)$opt(user)]$salt]"
          if {$pgtcl::debug} { puts "+pg_connect MD5 sending: $md5_response" }
          puts -nonewline $sock [binary format "I a* x" 40 $md5_response]

        } elseif {$n != 0} {
          set msg "Unknown database authentication request($n)"
          break
        }
      }
      K {
        binary scan [read $sock 8] II pid key
        if {$pgtcl::debug} { puts "+server pid=$pid key=$key" }
      }
      default {
        set msg "Unexpected reply from database: $c"
        break
      }
    }
  }
  if {$msg != ""} {
    close $sock
    error "Connection to database failed\n$msg"
  }
  return $sock
}

# Disconnect from the database. Free all result structures and notify
# functions for this connection.
proc pg_disconnect {db} {
  if {$pgtcl::debug} { puts "+Disconnecting $db from database" }
  puts -nonewline $db X
  catch {close $db}
  foreach v [info vars pgtcl::result*] {
    upvar #0 $v result
    if {$result(conn) == $db} {
      if {$pgtcl::debug} { puts "+Freeing left-over result structure $v" }
      unset result
    }
  }
  if {[array exists pgtcl::notify]} {
    foreach v [array names pgtcl::notify $db,*] {
      if {$pgtcl::debug} { puts "+Forgetting notify callback $v" }
      unset pgtcl::notify($v)
    }
  }
}

# Internal procedure to read a tuple (row) from the backend, ASCII or Binary.
proc pgtcl::gettuple {db result_name is_binary} {
  upvar $result_name result

  if {$result(nattr) == 0} {
    unset result
    error "Protocol error, data before descriptor"
  }
  if {$is_binary} {
    set size_includes_size 0
  } else {
    set size_includes_size -4
  }
  set irow $result(ntuple)
  # Read the Null Mask Bytes and make a string of [10]* in $nulls:
  binary scan [read $db $result(nmb)] "B$result(nattr)" nulls

  set nattr $result(nattr)
  for {set icol 0} {$icol < $nattr} {incr icol} {
    if {[string index $nulls $icol]} {
      binary scan [read $db 4] I nbytes
      incr nbytes $size_includes_size
      set result($irow,$icol) [read $db $nbytes]
    } else {
      set result($irow,$icol) $pgtcl::nulls
    }
  }
  incr result(ntuple)
}

# Handle a notification ('A') message.
# The notifying backend pid is read but ignored.
proc pgtcl::gotnotify {db} {
  read $db 4
  pgtcl::gets $db notify_rel
  if {$pgtcl::debug} { puts "+pgtcl got notify: $notify_rel" }
  if {[info exists pgtcl::notify($db,$notify_rel)]} {
    after idle $pgtcl::notify($db,$notify_rel)
  }
}

# Internal procedure to handle common backend utility message types:
#    C : Completion status        E : Error
#    N : Notice message           A : Notification
# 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
  if {$msgchar == "C"} {
    pgtcl::gets $db result(complete)
  } elseif {$msgchar == "E"} {
    set result(status) PGRES_FATAL_ERROR
    pgtcl::gets $db result(error)
  } elseif {$msgchar == "N"} {
    eval $pgtcl::notice {[pgtcl::gets $db]}
  } elseif {$msgchar == "A"} {
    pgtcl::gotnotify $db
  } else {
    return 0
  }
  return 1
}

# Execute SQL and return a result handle. See the documentation for a
# description of the innards of a result structure. This proc implements
# most of the backend response protocol. The important reply codes are:
#  T : RowDescriptor describes the attributes (columns) of each data row.
#      Followed by descriptor for each attribute: name, type, size, modifier
#      Also compute result(nmb), number of bytes in the NULL-value maps.
#  D : AsciiRow has data for 1 tuple.
#  B : BinaryRow has data for 1 tuple, result of a Binary Cursor.
#  Z : Operation complete
#  H : Ready for Copy Out
#  G : Ready for Copy In
# Plus the C E N A codes handled by pgtcl::common_message.
#
proc pg_exec {db query} {
  if {$pgtcl::debug} { puts "+pg_exec $query" }
  puts -nonewline $db [binary format "a* x" Q$query]

  upvar #0 pgtcl::result[incr pgtcl::rn] result
  set result(conn) $db
  set result(nattr) 0
  set result(attrs) {}
  set result(types) {}
  set result(sizes) {}
  set result(modifs) {}
  set result(ntuple) 0
  set result(error) {}
  set result(complete) {}
  set result(status) PGRES_COMMAND_OK

  while {[set c [read $db 1]] != "Z"} {
    switch $c {
      D {
        pgtcl::gettuple $db result 0
      }
      B {
        pgtcl::gettuple $db result 1
      }
      T {
        if {$result(nattr) != 0} {
          unset result
          error "Protocol failure, multiple descriptors"
        }
        set result(status) PGRES_TUPLES_OK
        binary scan [read $db 2] S nattr
        set result(nattr) $nattr
        for {set icol 0} {$icol < $nattr} {incr icol} {
          lappend result(attrs) [pgtcl::gets $db]
          binary scan [read $db 10] ISI type size modif
          lappend result(types) $type
          lappend result(sizes) $size
          lappend result(modifs) $modif
        }
        set result(nmb) [expr {($nattr+7)/8}]
      }
      I {
        pgtcl::gets $db
        set result(status) PGRES_EMPTY_QUERY
      }
      P {
        pgtcl::gets $db
      }
      H {
        set result(status) PGRES_COPY_OUT
        fconfigure $db -buffering line -translation lf
        if {$pgtcl::debug} { puts "+pg_exec begin copy out" }
        break
      }
      G {
        set result(status) PGRES_COPY_IN
        if {$pgtcl::debug} { puts "+pg_exec begin copy in" }
        break
      }
      default {
        if {![pgtcl::common_message $c $db result]} {
          unset result
          error "Unexpected reply from database: $c"
        }
      }
    }
  }
  return $pgtcl::rn
}

# I/O routines to support COPY. These are not yet needed, because you can read
# and write directly to the I/O channel, but will be needed with PostgreSQL
# protocol v3. They are included here to help transition to a future version
# of pgin.tcl.
# These do not currently check that COPY is actually in progress.

# Read line from COPY TO. Returns the line read if OK, else "" at the end.
proc pg_copy_read {res} {
  upvar #0 [pgtcl::checkres $res] result
  if {[gets $result(conn) line] < 0} {
    error "Unexpected end of data during COPY OUT"
  }
  if {$line == "\\."} {
    return ""
  }
  incr result(ntuple)
  return $line
}

# Write line for COPY FROM. Do not call with "\\." - just call pg_endcopy.