pgin.tcl

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

proc pg_copy_write {res line} {
  upvar #0 [pgtcl::checkres $res] result
  puts $result(conn) $line
  incr result(ntuple)
}

# End a Copy In/Out. This is needed because Tcl cannot do channel magic in
# Tcl like it can from C code.
# Call this after writing "\\." on Copy In, or after reading "\\." on Copy Out.
# Or, call this after reading "" from pg_copy_read, or when done with
# pg_copy_write. (This knows if pg_copy_write was used because ntuples will
# be > 0, in which case the ending "\\." needs to be written.)
# When it returns, the result structure (res) will be updated.
proc pg_endcopy {res} {
  upvar #0 [pgtcl::checkres $res] result
  set db $result(conn)
  if {$pgtcl::debug} { puts "+pg_endcopy end $result(status)" }

  if {$result(status) == "PGRES_COPY_OUT"} {
    fconfigure $db -buffering none -translation binary
  } elseif {$result(status) != "PGRES_COPY_IN"} {
    error "pg_endcopy called but connection is not doing a COPY"
  } elseif {$result(ntuple) > 0} {
    puts $db "\\."
  }

  # We're looking for C COPY and Z here, but other things can happen.
  set result(status) PGRES_COMMAND_OK
  while {[set c [read $db 1]] != "Z"} {
    if {![pgtcl::common_message $c $db result]} {
      error "Unexpected reply from database: $c"
    }
  }
}

# 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.

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
    }
    -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
    }
    -clear {
      unset result
    }
    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"]
    pg_result $r -clear
  }
}

# pg_execute: Execute a query, optionally iterating over the results.
#
# Returns the number of tuples selected or affected by the query.
# Usage: pg_execute ?options? connection query ?proc?
#   Options:  -array ArrayVar
#             -oid OidVar
# If -array is not given with a SELECT, the data is put in variables
# named by the fields. This is generally a bad idea and could be dangerous.
#
# If there is no proc body and the query return 1 or more rows, the first
# row is stored in the array or variables and we return (as does libpgtcl).
#
# Notes: Handles proc return codes of:
#    0(OK) 1(error) 2(return) 3(break) 4(continue)
#   Uses pg_exec and pg_result, but also makes direct access to the
# structures used by them.

proc pg_execute {args} {
  global errorCode errorInfo

  set usage "pg_execute ?-array arrayname?\
     ?-oid varname? connection queryString ?loop_body?"

  # Set defaults and parse command arguments:
  set use_array 0
  set set_oid 0
  set do_proc 0
  set last_option_arg {}
  set n_nonswitch_args 0
  set conn {}
  set query {}
  set proc {}
  foreach arg $args {
    if {$last_option_arg != ""} {
      if {$last_option_arg == "-array"} {
        set use_array 1
        upvar $arg data
      } elseif {$last_option_arg == "-oid"} {
        set set_oid 1
        upvar $arg oid
      } else {
        error "Unknown option $last_option_arg\n$usage"
      }
      set last_option_arg {}
    } elseif {[regexp ^- $arg]} {
      set last_option_arg $arg
    } else {
      if {[incr n_nonswitch_args] == 1} {
        set conn $arg
      } elseif {$n_nonswitch_args == 2} {
        set query $arg
      } elseif {$n_nonswitch_args == 3} {
        set do_proc 1
        set proc $arg
      } else {
        error "Wrong # of arguments\n$usage"
      }
    }
  }
  if {$last_option_arg != "" || $n_nonswitch_args < 2} {
    error "Bad arguments\n$usage"
  }

  set res [pg_exec $conn $query]
  upvar #0 pgtcl::result$res result

  # For non-SELECT query, just process oid and return value.
  # Let pg_result do the decoding.
  if {[regexp {^PGRES_(COMMAND_OK|COPY|EMPTY_QUERY)} $result(status)]} {
    if {$set_oid} {
      set oid [pg_result $res -oid]
    }
    set ntuple [pg_result $res -cmdTuples]
    pg_result $res -clear
    return $ntuple
  }

  if {$result(status) != "PGRES_TUPLES_OK"} {
    set status [list $result(status) $result(error)]
    pg_result $res -clear
    error $status
  }

  # Handle a SELECT query. This is like pg_select, except the proc is optional,
  # and the fields can go in an array or variables.
  # With no proc, store the first row only.
  set code 0
  if {!$use_array} {
    foreach attr $result(attrs) {
      upvar $attr data_$attr
    }
  }
  set ntuple $result(ntuple)
  for {set irow 0} {$irow < $ntuple} {incr irow} {
    set icol 0
    if {$use_array} {
      foreach attr $result(attrs) {
        set data($attr) $result($irow,$icol)
        incr icol
      }
    } else {
      foreach attr $result(attrs) {
        set data_$attr $result($irow,$icol)
        incr icol
      }
    }
    if {!$do_proc} break
    set code [catch {uplevel 1 $proc} s]
    if {$code != 0 && $code != 4} break
  }
  pg_result $res -clear
  if {$code == 1} {
    return -code error -errorInfo $errorInfo -errorCode $s
  } elseif {$code == 2 || $code > 4} {
    return -code $code $s
  }
  return $ntuple
}

# pg_configure: Configure options for PostgreSQL connections
# This is an extension and not available in libpgtcl.
# Usage: pg_configure connection option ?value?
#   connection   Which connection the option applies to.
#                This is currently ignored, as all options are global.
#   option       One of the following options.
#      nulls       Set the string to be returned for NULL values
#                  Default is ""
#      notice      A command to execute when a NOTICE message comes in.
#                  Default is a procedure which prints to stderr.
#   value        If supplied, the new value of the option.
#                If not supplied, return the current value.
# Returns the previous value of the option.

proc pg_configure {db option args} {
  if {[set nargs [llength $args]] == 0} {
    set modify 0
  } elseif {$nargs == 1} {
    set modify 1
    set newvalue [lindex $args 0]
  } else {
    error "Wrong # args: should be \"pg_configure connection option ?value?\""
  }

  set options {nulls notice debug}
  if {[lsearch -exact $options $option] < 0} {
    error "Bad option \"$option\": must be one of [join $options {, }]"
  }
  eval set return_value \$pgtcl::$option
  if {$modify} {
   eval set pgtcl::$option {$newvalue}
  }
  return $return_value
}

# pg_escape_string: Escape a string for use as a quoted SQL string
# Returns the escaped string. This was added to PostgreSQL after 7.3.2
# and to libpgtcl after 1.4b3.
# Note: string map requires Tcl >= 8.1 but is faster than regsub here.
proc pg_escape_string {s} {
  return [string map {' '' \\ \\\\} $s]
}

# ===== Large Object Interface ====

# Internal procedure to lookup, cache, and return a PostgreSQL function OID.
# This assumes all connections have the same function OIDs, which might not be
# true if you connect to servers running different versions of PostgreSQL.
# Throws an error if the OID is not found by PostgreSQL.
# To call overloaded functions, argument types must be specified in parentheses
# after the function name, in the the exact same format as psql "\df".
# This is a list of types separated by a comma and one space.
# For example: fname="like(text, text)".
# The return type cannot be specified. I don't think there are any functions
# distinguished only by return type.
proc pgtcl::getfnoid {db fname} {
  variable fnoids

  if {![info exists fnoids($fname)]} {

    # Separate the function name from the (arg type list):
    if {[regexp {^([^(]*)\(([^)]*)\)$} $fname unused fcn arglist]} {
      set amatch " and oidvectortypes(proargtypes)='$arglist'"
    } else {