pgin.tcl

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

          pgtcl::sendmsg $sock p "$opt(password)\000"
        } elseif {$n == 5} {
          set salt [pgtcl::get_bytes $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" }
          pgtcl::sendmsg $sock p "$md5_response\000"
        } elseif {$n != 0} {
          set msg "Unknown database authentication request($n)"
          break
        }
      }
      K {
        set pid [pgtcl::get_int32 $sock]
        set key [pgtcl::get_int32 $sock]
        if {$pgtcl::debug} { puts "+server pid=$pid key=$key" }
      }
      S {
        pgtcl::get_parameter_status $sock
      }
      default {
        set msg "Unexpected reply from database: $c"
        break
      }
    }
  }
  if {$msg != ""} {
    close $sock
    error "Connection to database failed\n$msg"
  }
  # Initialize transaction status; should be get_byte but it better be I:
  set pgtcl::xstate($sock) I
  # Initialize action for NOTICE messages (see get_notice):
  set pgtcl::notice($sock) {puts -nonewline stderr}

  return $sock
}

# Disconnect from the database. Free all result structures which are
# associated with this connection, and other data for this connection,
# including the buffer.
# Note: This does not use {array unset} (Tcl 8.3) nor {unset -nocomplain}
# (Tcl 8.4), but is coded to be compatible with earlier versions.
proc pg_disconnect {db} {
  if {$pgtcl::debug} { puts "+Disconnecting $db from database" }
  pgtcl::sendmsg $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,*] {
      unset pgtcl::notify($v)
    }
  }
  catch { unset pgtcl::param_$db }
  catch { unset pgtcl::xstate($db) pgtcl::notice($db) }
  catch { unset pgtcl::buf_$db pgtcl::bufi_$db pgtcl::bufn_$db }
}

# === Internal procedures: Query Result and supporting functions ===

# Read the backend reply to a query (simple or extended) and build a
# result structure. For extended query mode, the client already sent
# the Bind, DescribePortal, Execute, and Sync.
# This implements most of the backend query response protocol. The important
# reply codes are:
#  T : RowDescription describes the attributes (columns) of each data row.
#  D : DataRow has data for 1 tuple.
#  Z : ReadyForQuery, update transaction status.
#  H : Ready for Copy Out
#  G : Ready for Copy In
# Plus the messages handled by pgtcl::common_message.
# If the optional parameter $extq == 1, the result handle is from an extended
# mode query (see pg_exec_prepared) and these messages are allowed and ignored:
#  2 : BindComplete
#  n : NoData
#
# Returns a result handle (the number pgtcl::rn), or throws an error.

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

  while {1} {
    set c [pgtcl::readmsg $db]
    switch $c {
      D {
        pgtcl::gettuple $db result
      }
      T {
        if {$result(nattr) != 0} {
          unset result
          error "Protocol failure, multiple descriptors"
        }
        set result(status) PGRES_TUPLES_OK
        set nattr [pgtcl::get_uint16 $db]
        set result(nattr) $nattr
        for {set icol 0} {$icol < $nattr} {incr icol} {
          lappend result(attrs) [pgtcl::get_string $db]
          lappend result(tbloids) [pgtcl::get_int32 $db]
          lappend result(tblcols) [pgtcl::get_uint16 $db]
          lappend result(types) [pgtcl::get_int32 $db]
          lappend result(sizes) [pgtcl::get_int16 $db]
          lappend result(modifs) [pgtcl::get_int32 $db]
          lappend result(formats) [pgtcl::get_int16 $db]
        }
      }
      I {
        set result(status) PGRES_EMPTY_QUERY
      }
      H {
        pgtcl::begincopy result OUT
        break
      }
      G {
        pgtcl::begincopy result IN
        break
      }
      Z {
        set pgtcl::xstate($db) [pgtcl::get_byte $db]
        break
      }
      default {
        if {(!$extq || ($c != "2" && $c != "n")) && \
              ![pgtcl::common_message $c $db result]} {
          unset result
          error "Unexpected reply from database: $c"
        }
      }
    }
  }
  if {$pgtcl::debug > 1} {
    puts "+pgtcl::getresult $pgtcl::rn = "
    parray result
  }
  return $pgtcl::rn
}

# Process format code information for pg_exec_prepared.
#   fclist       A list of BINARY (or B*) or TEXT (or T*) format code words.
#   ncodes_name  The name of a variable to get the number of format codes.
#   codes_name   The name of a variable to get a list of format codes in
#                the PostgreSQL syntax: 0=text 1=binary.
proc pgtcl::crunch_fcodes {fclist ncodes_name codes_name} {
  upvar $ncodes_name ncodes $codes_name codes
  set ncodes [llength $fclist]
  set codes {}
  foreach k $fclist {
    if {[string match B* $k]} {
      lappend codes 1
    } else {
      lappend codes 0
    }
  }
}

# Return an error code field value for pg_result -errorField code.
# For field names, it accepts either the libpq name (without PG_DIAG_) or the
# single-letter protocol code.
# If an unknown field name is used, or the field isn't part of the error
# message, an empty string is substituted.

proc pgtcl::error_fields {result_name argc code} {
  upvar $result_name result
  variable errnames
  if {[info exists errnames($code)]} {
    set code $errnames($code)
  }
  if {[info exists result(error,$code)]} {
    return $result(error,$code)
  }
  return ""
}

# === Public procedures : Query and Result ===

# Execute SQL and return a result handle.
#
proc pg_exec {db query} {
  if {$pgtcl::debug} { puts "+pg_exec $query" }
  pgtcl::sendmsg $db Q "$query\000"
  return [pgtcl::getresult $db]
}

# Extract data from a pg_exec result structure.
# -cmdTuples, -list, and -llist are extensions to the baseline libpgtcl which
# have appeared or will appear in beta or future versions.
# -errorField, -lxAttributes and -getNull are proposed new for 7.4.

proc pg_result {res option args} {
  upvar #0 [pgtcl::checkres $res] result
  set argc [llength $args]
  set ntuple $result(ntuple)
  set nattr $result(nattr)
  switch -- $option {
    -status { return $result(status) }
    -error  { return $result(error) }
    -conn   { return $result(conn) }
    -oid {
      if {[regexp {^INSERT +([0-9]*)} $result(complete) unused oid]} {
        return $oid
      }
      return 0
    }
    -cmdTuples {
      if {[regexp {^INSERT +[0-9]* +([0-9]*)} $result(complete) x num] \
       || [regexp {^(UPDATE|DELETE) +([0-9]*)} $result(complete) x y num]} {
        return $num
      }
      return ""
    }
    -numTuples { return $ntuple }
    -numAttrs  { return $nattr }
    -assign {
      if {$argc != 1} {
        error "-assign option must be followed by a variable name"
      }
      upvar $args a
      set icol 0
      foreach attr $result(attrs) {
        for {set irow 0} {$irow < $ntuple} {incr irow} {
          set a($irow,$attr) $result($irow,$icol)
        }
        incr icol
      }
    }
    -assignbyidx {
      if {$argc != 1 && $argc != 2} {
        error "-assignbyidxoption requires an array name and optionally an\
          append string"
      }
      upvar [lindex $args 0] a
      if {$argc == 2} {
        set suffix [lindex $args 1]
      } else {
        set suffix {}
      }
      set attr_first [lindex $result(attrs) 0]
      set attr_rest [lrange $result(attrs) 1 end]
      for {set irow 0} {$irow < $ntuple} {incr irow} {
        set val_first $result($irow,0)
        set icol 1
        foreach attr $attr_rest {
          set a($val_first,$attr$suffix) $result($irow,$icol)
          incr icol
        }
      }
    }
    -getTuple {
      if {$argc != 1} {
        error "-getTuple option must be followed by a tuple number"
      }
      set irow $args
      if {$irow < 0 || $irow >= $ntuple} {
        error "argument to getTuple cannot exceed number of tuples - 1"
      }
      set list {}
      for {set icol 0} {$icol < $nattr} {incr icol} {
        lappend list $result($irow,$icol)
      }
      return $list
    }
    -getNull {
      if {$argc != 1} {
        error "-getNull option must be followed by a tuple number"
      }
      set irow $args
      if {$irow < 0 || $irow >= $ntuple} {
        error "argument to getNull cannot exceed number of tuples - 1"
      }
      set list {}
      for {set icol 0} {$icol < $nattr} {incr icol} {
        lappend list [info exists result(null,$irow,$icol)]
      }
      return $list
    }
    -tupleArray {
      if {$argc != 2} {
        error "-tupleArray option must be followed by a tuple number and\
           array name"
      }
      set irow [lindex $args 0]
      if {$irow < 0 || $irow >= $ntuple} {
        error "argument to tupleArray cannot exceed number of tuples - 1"
      }
      upvar [lindex $args 1] a
      set icol 0
      foreach attr $result(attrs) {
        set a($attr) $result($irow,$icol)
        incr icol
      }
    }
    -list {
      set list {}
      for {set irow 0} {$irow < $ntuple} {incr irow} {
        for {set icol 0} {$icol < $nattr} {incr icol} {
          lappend list $result($irow,$icol)
        }
      }
      return $list
    }
    -llist {
      set list {}
      for {set irow 0} {$irow < $ntuple} {incr irow} {
        set sublist {}
        for {set icol 0} {$icol < $nattr} {incr icol} {
          lappend sublist $result($irow,$icol)
        }
        lappend list $sublist
      }
      return $list
    }
    -attributes {
      return $result(attrs)
    }
    -lAttributes {
      set list {}
      foreach attr $result(attrs) type $result(types) size $result(sizes) {
        lappend list [list $attr $type $size]
      }
      return $list
    }
    -lxAttributes {
      set list {}
      foreach attr $result(attrs) type $result(types) size $result(sizes) \
              modif $result(modifs) format $result(formats) \
              tbloid $result(tbloids) tblcol $result(tblcols) {
        lappend list [list $attr $type $size $modif $format $tbloid $tblcol]
      }
      return $list
    }
    -clear {
      unset result
    }
    -errorField {
      if {$argc != 1} {
        error "-errorField option must be followed by an error code field name"
      }
      return [pgtcl::error_fields result $argc $args]
    }
    default { error "Invalid option to pg_result: $option" }
  }
}

# Run a select query and iterate over the results. Uses pg_exec to run the
# query and build the result structure, but we cheat and directly use the
# result array rather than calling pg_result.
# Each returned tuple is stored into the caller's array, then the caller's
# proc is called. 
# If the caller's proc does "break", "return", or gets an error, get out
# of the processing loop. Tcl codes: 0=OK 1=error 2=return 3=break 4=continue
proc pg_select {db query var_name proc} {
  upvar $var_name var
  global errorCode errorInfo
  set res [pg_exec $db $query]
  upvar #0 pgtcl::result$res result
  if {$result(status) != "PGRES_TUPLES_OK"} {
    set msg $result(error)
    unset result
    error $msg
  }
  set code 0
  set var(.headers) $result(attrs)
  set var(.numcols) $result(nattr)
  set ntuple $result(ntuple)
  for {set irow 0} {$irow < $ntuple} {incr irow} {
    set var(.tupno) $irow
    set icol 0
    foreach attr $result(attrs) {
      set var($attr) $result($irow,$icol)
      incr icol
    }
    set code [catch {uplevel 1 $proc} s]
    if {$code != 0 && $code != 4} break
  }
  unset result var
  if {$code == 1} {
    return -code error -errorinfo $errorInfo -errorcode $errorCode $s
  } elseif {$code == 2 || $code > 4} {
    return -code $code $s
  }
}

# Register a listener for backend notification, or cancel a listener.
proc pg_listen {db name {proc ""}} {
  if {$proc != ""} {
    set pgtcl::notify($db,$name) $proc
    set r [pg_exec $db "listen $name"]
    pg_result $r -clear
  } elseif {[info exists pgtcl::notify($db,$name)]} {
    unset pgtcl::notify($db,$name)
    set r [pg_exec $db "unlisten $name"]