pgin.tcl

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

    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
}

# Extended query protocol: Bind parameters and execute prepared statement.
# This is modelled on libpq PQexecPrepared. Use pg_exec to send a PREPARE
# first; this does not handle unnamed statements.
# Parameters:
#  db          Connection handle
#  stmt        Name of the prepared SQL statement to execute
#  resultinfo  BINARY => Want all results as binary, else as text
#  arginfo     A list describing args: B* => Binary, else Text.
#  args        Variable number of arguments to bind to the query params.
proc pg_exec_prepared {db stmt res_formats arg_formats args} {
  set nargs [llength $args]

  # Calculate argument format information:
  pgtcl::crunch_fcodes $arg_formats nfcodes fcodes

  # Build the first part of the Bind message:
  set out [binary format {x a*x S S* S} $stmt $nfcodes $fcodes $nargs]

  # Append parameter values as { int32 length or 0 or -1 for NULL; data}
  # Note: There is no support for NULLs as parameters.
  foreach arg $args {
    append out [binary format I [string length $arg]] $arg
  }

  # Append result parameter format information:
  pgtcl::crunch_fcodes $res_formats nrfcodes rfcodes
  append out [binary format {S S*} $nrfcodes $rfcodes]

  # Send it off. Don't wait for BindComplete or Error, because the protocol
  # says the BE will discard until Sync anyway.
  pgtcl::sendmsg $db B $out
  unset out
  # Send DescribePortal for the unnamed portal:
  pgtcl::sendmsg $db D "P\0"
  # Send Execute, unnamed portal, unlimited rows:
  pgtcl::sendmsg $db E "\0\0\0\0\0"
  # Send Sync
  pgtcl::sendmsg $db S {}

  # Fetch query result and return result handle:
  return [pgtcl::getresult $db 1]
}

# === Public procedures : Miscellaneous ===

# pg_notice_handler: Set/get handler command for Notice/Warning
# Usage: pg_notice_handler connection ?command?
# Parameters:
#   command      If supplied, the new handler command. The notice text
#                will be appended as a list element.
#                If supplied but empty, ignore notice/warnings.
#                If not supplied, just return the current value.
# Returns the previous handler command.
proc pg_notice_handler {db args} {
  set return_value $pgtcl::notice($db)
  if {[set nargs [llength $args]] == 1} {
    set pgtcl::notice($db) [lindex $args 0]
  } elseif {$nargs != 0} {
    error "Wrong # args: should be \"pg_notice_handler connection ?command?\""
  }
  return $return_value
}

# pg_configure: Configure options for PostgreSQL connections
# This is provided only for backward compatibility with earlier versions.
# Do not use.
proc pg_configure {db option args} {
  if {[set nargs [llength $args]] > 1} {
    error "Wrong # args: should be \"pg_configure connection option ?value?\""
  }
  switch -- $option {
    debug { upvar pgtcl::debug var }
    notice { upvar pgtcl::notice($db) var }
    default {
      error "Bad option \"$option\": must be one of notice, debug"
    }
  }
  set return_value $var
  if {$nargs} {
    set var [lindex $args 0]
  }
  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]
}

# pg_parameter_status: Return the value of a backend parameter value.
# These are generally supplied by the backend during startup.
proc pg_parameter_status {db name} {
  upvar #0 pgtcl::param_$db param
  if {[info exists param($name)]} {
    return $param($name)
  }
  return ""
}

# pg_transaction_status: Return the current transaction status.
# Returns a string: IDLE INTRANS INERROR or UNKNOWN.
proc pg_transaction_status {db} {
  if {[info exists pgtcl::xstate($db)]} {
    switch -- $pgtcl::xstate($db) {
      I { return IDLE }
      T { return INTRANS }
      E { return INERROR }
    }
  }
  return UNKNOWN
}

# === Internal Procedure to support COPY ===

# Handle a CopyInResponse or CopyOutResponse message:
proc pgtcl::begincopy {result_name direction} {
  upvar $result_name result
  set db $result(conn)
  if {[pgtcl::get_int8 $db]} {
    error "pg_exec: COPY BINARY is not supported"
  }
  set result(status) PGRES_COPY_$direction
  # Column count and per-column formats are ignored.
  set ncol [pgtcl::get_int16 $db]
  pgtcl::skip $db [expr {2*$ncol}]
  if {$pgtcl::debug} { puts "+pg_exec begin copy $direction" }
}

# === Public procedures: COPY ===

# I/O procedures to support COPY. No longer able to just read/write the
# channel, due to the message procotol.

# Read line from COPY TO. Returns the copy line if OK, else "" on end.
# Note: The returned line does not end in a newline, so you can split it
# on tab and get a list of column values.
# At end of COPY, it takes the CopyDone only. pg_endcopy must be called to
# get the CommandComplete and ReadyForQuery messages.
proc pg_copy_read {res} {
  upvar #0 [pgtcl::checkres $res] result
  set db $result(conn)
  if {$result(status) != "PGRES_COPY_OUT"} {
    error "pg_copy_read called but connection is not doing a COPY OUT"
  }
  # Notice/Notify etc are not allowed during copy, so no loop needed.
  set c [pgtcl::readmsg $db]
  if {$pgtcl::debug} { puts "+pg_copy_read msg $c" }
  if {$c == "d"} {
    return [string trimright [pgtcl::get_rest $db] "\n\r"]
  }
  if {$c == "c"} {
    return ""
  }
  # Error or invalid response.
  if {$c == "E"} {
    set result(status) PGRES_FATAL_ERROR
    set result(error) [pgtcl::get_response $db result]
    return ""
  }
  error "pg_copy_read: procotol violation, unexpected $c in copy out"
}

# Write line for COPY FROM. This must represent a single record (tuple) with
# values separated by tabs. Do not add a newline; pg_copy_write does this.
proc pg_copy_write {res line} {
  upvar #0 [pgtcl::checkres $res] result
  pgtcl::sendmsg $result(conn) d "$line\n"
}

# End a COPY TO/FROM. This is needed to finish up the protocol after
# reading or writing. On COPY TO, this needs to be called after
# pg_copy_read returns an empty string. On COPY FROM, this needs to
# be called after writing the last record with pg_copy_write.
# Note: Do not write or expect to read "\." anymore.
# 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)" }

  # An error might have been sent during a COPY TO, so the result
  # status will already be FATAL and should not be disturbed.
  if {$result(status) != "PGRES_FATAL_ERROR"} {
    if {$result(status) == "PGRES_COPY_IN"} {
      # Send CopyDone
      pgtcl::sendmsg $db c {}
    } elseif {$result(status) != "PGRES_COPY_OUT"} {
      error "pg_endcopy called but connection is not doing a COPY"
    }
    set result(status) PGRES_COMMAND_OK
  }

  # We're looking for CommandComplete and ReadyForQuery here, but other
  # things can happen too.
  while {[set c [pgtcl::readmsg $db]] != "Z"} {
    if {![pgtcl::common_message $c $db result]} {
      error "Unexpected reply from database: $c"
    }
  }
  set pgtcl::xstate($db) [pgtcl::get_byte $db]
  if {$pgtcl::debug} { puts "+pg_endcopy returns, st=$result(status)" }
}

# === Internal producedures for Function Call (used by Large Object) ===

# 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 {
      set fcn $fname
      set amatch ""
    }
    pg_select $db "select oid from pg_proc where proname='$fcn' $amatch" d {
      set fnoids($fname) $d(oid)
    }
    if {![info exists fnoids($fname)]} {
      error "Unable to get OID of database function $fname"
    }
  }
  return $fnoids($fname)
}

# Internal procedure to implement PostgreSQL "fast-path" function calls.
# $fn_oid is the OID of the PostgreSQL function. See pgtcl::getfnoid.
# $result_name is the name of the variable to store the backend function
#   result into.
# $arginfo is a list of argument descriptors, each is I or S or a number.
#   I means the argument is an integer32.
#   S means the argument is a string, and its actual length is used.
#   A number means send exactly that many bytes (null-pad if needed) from
# the argument.
#   (Argument type S is passed in Ascii format code, others as Binary.)
# $arglist  is a list of arguments to the PostgreSQL function. (This
#    is actually a pass-through argument 'args' from the wrappers.)
# Throws Tcl error on error, otherwise returns size of the result
# stored into the $result_name variable.

proc pgtcl::callfn {db fn_oid result_name arginfo arglist} {
  upvar $result_name result

  set nargs [llength $arginfo]
  if {$pgtcl::debug} {
    puts "+callfn oid=$fn_oid nargs=$nargs info=$arginfo args=$arglist"
  }

  # Function call: oid nfcodes fcodes... nargs {arglen arg}... resultfcode
  set fcodes {}
  foreach k $arginfo {
    if {$k == "S"} {
      lappend fcodes 0
    } else {
      lappend fcodes 1
    }
  }
  set out [binary format {I S S* S} $fn_oid $nargs $fcodes $nargs]
  # Append each argument and its length:
  foreach k $arginfo arg $arglist {
    if {$k == "I"} {
      append out [binary format II 4 $arg]
    } elseif {$k == "S"} {
      append out [binary format I [string length $arg]] $arg
    } else {
      append out [binary format Ia$k $k $arg]
    }