punkshell/src/vfs/punk9win.vfs/lib/pgintcl3.5.2/tkpsql.tcl

# $Id: tkpsql.tcl 515 2011-09-17 19:18:53Z lbayuk $
# tkpsql - Interactive PostgreSQL SQL Interface
# Copyright 2003-2008 by L Bayuk
# 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.

# Global variables:
#   version   - Our version string.
#   widgets() - Main widget pathnames : input output status
#   n_history - Number of history elements
#   history() - History array 1:n_history
#   history_p - Index in history where next command will be stored
#   history_q - Index in history where next command will be recalled from
#   db        - Handle to open database, if empty there is no connection.
#   dbinfo()  - Remembers db conection info: host, user, dbname, port, password
#     dbinfo(has_schema)   Flag: Database has schemas (PostgreSQL >=7.3)
#   form_status - Temporary flag for waiting on a popup
#   pwd       - Starting directory for file open/save
#   option()  - Array of options
#   " (outstyle)  - Output style, "wide" or "narrow"
#   " (debug)     - Debug flag, 0 for none
#   " (maxlook)   - Max. result rows to examine for column widths
#   " (clear)     - Clear output pad before each command results
#   special()     - SQL for special database queries, index by code.
#   special_title() - Titles for special queries, indexed by code.
#   special_codes - A list of special*() indexes, ordered as they should
#         be displayed in the popup.

set version 1.2.1
package require Tk

# ===== Utility Routines =====

# Initialization:
proc initialize {} {
  global n_history history history_p history_q
  global db pwd option

  array set option {
    debug 0
    outstyle wide
    maxlook 20
    clear 1
  }

  # Initialize the history list:
  set n_history 25
  for {set i 1} {$i <= $n_history} {incr i} {
    set history($i) {}
  }
  set history_p 1
  set history_q 1
 
  set db {}
  set pwd [pwd]
  dbms_load
  font create monofont -family Courier
  font create boldfont -family Courier -weight bold
}

# Initialize the array of special database queries.
# This has to be done after connecting to the database, so we know if
# the schema-aware versions should be used. It can be called again as needed.
# special(c) contains the SQL for code 'c'.
# special_title(c) contains the displayed title for code 'c'.
# The index values 'c' are arbitrary codes.
# The list special_codes contains the ordered list of indexes.
#
# I mostly copied the SQL queries from psql. The 'schema-aware' queries are
# based on PostgreSQL-7.3.4; the 'non-schema' versions are from some older
# version. But in some cases, I took advantage of the special views.
#
# Note: The pre-7.3 queries are no longer updated/maintained because I don't
# have pre-7.3 server to test them on.
#
proc init_special {} {
  global dbinfo special special_title special_codes
  catch {unset special_codes special_title special}

  if {$dbinfo(has_schema)} init_special_new init_special_old
}

# Initialize special queries for PostgreSQL-7.3 and higher.
# See comments for init_special
proc init_special_new {} {
  global special special_title special_codes

  # This is the ordered list of codes whose titles will be displayed.
  set special_codes { dbs tables views index rules seqs rights user group }

  set special_title(dbs) "List Databases"
  set special(dbs) {
    select datname as "Database Name", usename as "Owner"
    from pg_database, pg_user
    where datdba=usesysid order by datname
  }

  set special_title(tables) "List Tables"
  set special(tables) {
    select schemaname as "Schema", tablename as "Table", tableowner as "Owner"
    from pg_catalog.pg_tables
    where schemaname not in ('pg_catalog', 'pg_toast', 'information_schema')
    order by 1,2
  }

  set special_title(views) "List Views"
  set special(views) {
    select schemaname as "Schema", viewname as "View", viewowner as "Owner",
      definition as "Definition"
    from pg_catalog.pg_views
    where schemaname not in ('pg_catalog', 'pg_toast', 'information_schema')
    order by 1,2
  }

  set special_title(index) "List Indexes"
  set special(index) {
    select schemaname as "Schema", indexname as "Index-Name",
      tablename as "Base-Table", indexdef as "Definition"
    from pg_catalog.pg_indexes
    where schemaname not in ('pg_catalog', 'pg_toast', 'information_schema')
    order by 1,2
  }

  set special_title(rules) "List Rules"
  set special(rules) {
    select schemaname as "Schema", rulename as "Rule",
      definition as "Definition"
    from pg_catalog.pg_rules
    where schemaname not in ('pg_catalog', 'pg_toast', 'information_schema')
    order by 1,2
  }

  # Sequences - no special view, so do it manually.
  set special_title(seqs) "List Sequences"
  set special(seqs) {
    select n.nspname as "Schema", c.relname as "Sequence",
      u.usename as "Owner"
    from pg_namespace n, pg_class c, pg_user u
    where n.oid = c.relnamespace and c.relowner = u.usesysid
      and relkind = 'S'
      and n.nspname not in ('pg_catalog', 'pg_toast', 'information_schema')
    order by 1, 2
  }

  set special_title(rights) "Show Permissions"
  set special(rights) {
    select n.nspname as "Schema", c.relname as "Relation",
        u.usename as "Owner", c.relacl as "Access Control List"
    from pg_class c, pg_user u, pg_namespace n
    where c.relowner = u.usesysid and c.relnamespace = n.oid
      and c.relkind in ('r', 'v', 'S')
      and pg_catalog.pg_table_is_visible(c.oid)
      and n.nspname not in ('pg_catalog', 'pg_toast', 'information_schema')
    order by 1, 2
  }

  set special_title(user) "List Users"
  set special(user) {
    select usename as "Username", usesysid as "User-ID",
      trim (leading ' ' from
        trim (trailing ',' from
           case when usesuper then ' Superuser,' else '' end
        || case when usecreatedb then ' Create Database,' else '' end
        || case when usecatupd then ' Update Catalogs,' else '' end))
      as "Rights"
    from pg_user order by usename
  }
 
  set special_title(group) "List Groups"
  set special(group) {
    select groname as "Groupname", grosysid as "Group-ID",
      grolist as "Member-IDs"
    from pg_group order by groname
  }
}

# Initialize special queries for PostgreSQL older than 7.3.
# See comments for init_special. This is UNMAINTAINED.
proc init_special_old {} {
  global special special_title special_codes

  # This is the ordered list of codes whose titles will be displayed.
  set special_codes { dbs tables index rights user group }

  set special_title(dbs) "List Databases"
  set special(dbs) {
    select datname as "Database Name", usename as "Owner"
    from pg_database, pg_user
    where datdba=usesysid order by datname
  }

  set special_title(tables) "List Tables"
  set special(tables) {
    select usename as username, relname as table, relkind as kind
    from pg_class, pg_user where relkind = 'r' and relname !~ '^pg_'
    and usesysid=relowner order by relname
  }

  set special_title(index) "List Indexes/Sequences"
  set special(index) {
    select usename as username, relname as name, relkind as kind
        from pg_class, pg_user where (relkind='i' or relkind='S') and
        relname !~ '^pg_' and usesysid=relowner order by relname
  }

  set special_title(rights) "Show Table/Sequence Rights"
  set special(rights) {
    select relname as table, usename as owner, relacl as acl from
        pg_class, pg_user where (relkind = 'r' or relkind = 'S') and
        relname !~ '^pg_' and usesysid=relowner order by relname
  }

  set special_title(user) "List Users"
  set special(user) {
    select usename as "Username", usesysid as "User-ID",
      usecreatedb as "Create-DB?",
      usesuper as "Superuser?",
      usecatupd as "Update-Catalogs?"
    from pg_user order by usename
  }
 
  set special_title(group) "List Groups"
  set special(group) {
    select groname as "Groupname", grosysid as "Group-ID",
      grolist as "Member-IDs"
    from pg_group order by groname
  }
}


# Initialize after connecting to a database
# If an error occurs querying the database, ignore the error and don't
# report it. (Will only report errors from user-issued queries.)
# This also inializes the special queries.
proc init_post_connect {} {
  global db dbinfo

  # Determine if the database supports schemas.
  set dbinfo(has_schema) 0
  if {![catch {pg_exec $db "select nspname from pg_namespace limit 1"} r]} {
    if {[pg_result $r -status] == "PGRES_TUPLES_OK"} {
      set dbinfo(has_schema) 1
    }
    pg_result $r -clear
  }
  debug_puts "has_schema: $dbinfo(has_schema)"
  init_special
}

# Pluralization
proc plural {n {s "s"}} {
  if {$n == 1} { return ""} else { return $s }
}

# Assign respective list elements to named variables:
proc setlist {list args} {
  foreach val $list var $args {
    upvar $var v
    set v $val
  }
}

# Output some text if debugging is on:
proc debug_puts {s} {
  global option
  if {$option(debug)} {
    puts "+debug: $s"
  }
}

# Load PostgreSQL support with library or emulator:
proc dbms_load {} {
  # If it is already loaded; e.g. running under pgtksh, nothing to do.
  if {[info commands pg_connect] != ""} return
  # Use my pgin.tcl interface library from the same directory:
  set cmd [list source [file join [file dirname [info script]] pgin.tcl]]
  if {[catch {uplevel #0 $cmd} msg]} {
    error "Error: Unable to load database support. $msg"
  }
}

# ===== GUI / Window Utilities =====

# Center a window over another window.
#   $win : Window to center
#   $over : What to center it over:
#     "ROOT" => center over the screen.
#     "PARENT" => center over $win's parent window.
#     Otherwise $over is the name of a window to center $win over.
# On return, the window will be mapped (de-iconified).
proc center_window {win over} {
  wm withdraw $win
  update
  if {$over == "ROOT"} {
    set base_x 0
    set base_y 0
    set base_w [winfo screenwidth $win]
    set base_h [winfo screenheight $win]
  } else {
    if {$over == "PARENT"} {
      set overwin [winfo parent $win]
    } else {
      set overwin $over
    }
    set base_x [winfo rootx $overwin]
    set base_y [winfo rooty $overwin]
    set base_w [winfo width $overwin]
    set base_h [winfo height $overwin]
  }
  set win_w [winfo reqwidth $win]
  set win_h [winfo reqheight $win]
  if {[set win_x [expr {$base_x + int(($base_w - $win_w) / 2)}]] < 0} {
    set win_x 0
  }
  if {[set win_y [expr {$base_y + int(($base_h - $win_h) / 2)}]] < 0} {
    set win_y 0
  }
  wm geometry $win +$win_x+$win_y
  wm deiconify $win
}

# Make a top-level window and return its name:
proc mk_window {name title} {
  catch {destroy $name}
  toplevel $name
  wm title $name $title
  wm transient $name .
  return $name
}

# Position and wait for grabbed popup window.
# Change with care; MS-Win is very sensitive to the command order.
proc window_wait {win focus_to varname} {
  global $varname
  set save_focus [focus]
  center_window $win PARENT
  focus $focus_to
  grab set $win
  tkwait variable $varname
  destroy $win
  catch {focus $save_focus}
}

# Build a button with key binding(s) and command. Returns widget name.
proc mk_button {widget label key command} {
  button $widget -text "$label $key" -command $command
  bind . $key "$widget invoke"
  return $widget
}

# Make a 'buttons' frame with OK and Cancel buttons.
proc mk_buttons {toplevel {ok_action {set form_status 1}}} {
  set f $toplevel.buttons
  frame $f
  button $f.ok -text OK -default active -command $ok_action
  bind $toplevel <Return> "$f.ok invoke"
  button $f.cancel -text Cancel -default normal -command {set form_status 0}
  bind $toplevel <Escape> "$f.cancel invoke"
  pack $f.ok $f.cancel -side left -padx 3 -pady 3
}

# ===== UI Support Routines =====

# Append a line to the output window:
proc oputs {s {tag ""}} {
  global widgets
  $widgets(output) insert end "$s\n" $tag
  $widgets(output) see end
}

# Clear the output window:
proc clear_output {} {
  global widgets
  $widgets(output) delete 1.0 end
}

# Display some text in the status window:
proc show_status {s} {
  global widgets
  $widgets(status) configure -text $s
  update
}

# Clear the input window and put the focus there; also clears the status.
# This is used when returning from a command so no update is needed.
proc clear_input {} {
  global widgets
  $widgets(input) delete 1.0 end
  focus $widgets(input)
  $widgets(status) configure -text {}
}

# Utility function used by build_format to update max lengths 
proc max_list {max_name list} {
  upvar $max_name max
  set i 0
  foreach s $list {
    set slen [string length $s]
    if {$slen > $max($i)} {
      set max($i) $slen
    }
    incr i
  }
}

# Create a format for output of query results. This decides how much space
# should be given to each column, and builds a format for {format} and
# returns it. $qr is the pgtcl query result handle. We look at the column
# headers and up to $option(maxlook) rows to find the longest field values.
# The result is a format string like {%-ns %-ns... %s}.
proc build_format {nrow ncol qr} {
  global option

  if {$nrow > $option(maxlook)} {
    set nrow $option(maxlook)
  }
  for {set i 0} {$i < $ncol} {incr i} {
    set max($i) 0
  }
  max_list max [pg_result $qr -attributes]
  for {set i 0} {$i < $nrow} {incr i} {
    max_list max [pg_result $qr -getTuple $i]
  }
  # Don't use the last column's width, just do "%s" for it.
  set fmt {}
  for {set i 0} {$i < $ncol-1} {incr i} {
    append fmt "%-$max($i)s "
  }
  append fmt "%s"
  debug_puts "build_format=$fmt"
  return $fmt
}

# Display query results in "narrow" format (one field per line):
proc show_results_narrow {nrow ncol qr} {
  set headers [pg_result $qr -attributes]
  for {set r 0} {$r < $nrow} {incr r} {
    foreach name $headers value [pg_result $qr -getTuple $r] {
      oputs "$name: $value"
    }
    if {$r % 10 == 0} {
      show_status "Reading reply...$r"
    }
    oputs ""
  }
}

# Display query results in "wide" format (one record per line):
proc show_results_wide {nrow ncol qr} {
  # Calculate field widths for output:
  set fmt [build_format $nrow $ncol $qr]

  # Output the column headers:
  oputs [eval format {$fmt} [pg_result $qr -attributes]] under

  # Output all of the rows:
  for {set r 0} {$r < $nrow} {incr r} {
    oputs [eval format {$fmt} [pg_result $qr -getTuple $r]]
    if {$r % 10 == 0} {
      show_status "Reading reply...$r"
    }
  }
}

# Send SQL to the backend and display the results. Optional title is
# displayed instead of the actual SQL (used for special queries).
proc run_sql {sql {title ""}} {
  global db option

  if {$db == ""} {
    tk_messageBox -title tkpsql -icon error -type ok \
        -message "Not connected to database"
    return
  }
  debug_puts "SQL: $sql"

  if {$option(clear)} clear_output

  if {$title != ""} {
    oputs $title bold
  } else {
    oputs $sql bold
  }
  show_status "Sending query..."
  # Run the SQL, catch a backend or connection failure.
  if {[catch {pg_exec $db $sql} reply]} {
    oputs "ERROR executing SQL:" bold
    oputs $reply bold
    return
  }
  set status [pg_result $reply -status]
  debug_puts "Query status $status"
  show_status ""
  if {$status == "PGRES_COMMAND_OK"} {
    # Command completed with no tuples (e.g. insert, update, etc.).
    # Show the OID, if available. (Not available should be 0, but there was
    # some confusion early about this and it might be an empty string.)
    set show OK
    if {[set oid [pg_result $reply -oid]] != 0 && $oid != ""} {
      append show ", OID=$oid"
    }
    # Show affected tuple count. Not all pgtcl's support this.
    if {![catch {pg_result $reply -cmdTuples} n] && $n != ""} {
      append show ", $n row[plural $n] affected"
    }
    oputs $show bold
    clear_input
  } elseif {$status != "PGRES_TUPLES_OK"} {
    # Generally this will be PGRES_FATAL_ERROR, but any other status
    # is also considered an error.
    set errmsg [pg_result $reply -error]
    oputs "ERROR ($status):" bold
    oputs $errmsg bold
  } else {
    # Result was PGRES_TUPLES_OK, so there are tuples to show.
    set ncol [pg_result $reply -numAttrs]
    set nrow [pg_result $reply -numTuples]
    oputs "OK with $nrow row[plural $nrow] and $ncol column[plural $ncol]." bold
    oputs ""
    show_status "Reading reply..."
    show_results_$option(outstyle) $nrow $ncol $reply
    clear_input
    show_status ""
  }
  pg_result $reply -clear
  oputs ""
}

# Return the string properly escaped for conninfo quoting:
proc conninfo_quote {s} {
  regsub -all {\\} $s {\\\\} s
  regsub -all {'} $s {\\'} s
  return $s
}

# Call-back for do_connect on OK. Check the form values and try to connect.
# If it worked, set form_status to 1 to finish window_wait; else raise an
# error and return with the connection dialog still up.
proc do_connect_done {toplevel} {
  global form_status dbinfo db
  if {$dbinfo(dbname) == "" || $dbinfo(user) == "" || $dbinfo(password) == ""} {
    tk_messageBox -title tkpsql -icon error -type ok \
        -parent $toplevel \
        -message "Missing information: must supply dbname, user, password"
    return
  }

  # Connect to the database:
  # Only password can contain spaces, and only strings with spaces must
  # be escape-quoted.
  set conninfo "dbname=$dbinfo(dbname) user=$dbinfo(user)\
      password='[conninfo_quote $dbinfo(password)]'"
  # Host is optional, because blank host means use localhost.
  # Apply port only if host is used, although technically it can be used
  # without a host over UDS.
  if {$dbinfo(host) != ""} {
    append conninfo " host=$dbinfo(host) port=$dbinfo(port)"
  }
  show_status "Connecting to $dbinfo(dbname)@$dbinfo(host)..."

  if {[catch {pg_connect -conninfo $conninfo} result]} {
    show_status ""
    tk_messageBox -title tkpsql -icon error -type ok \
        -parent $toplevel \
        -message "Failed to connect to database: $result"
    return
  }
  set db $result
  show_status "Connected to database $dbinfo(dbname)@$dbinfo(host)"
  init_post_connect
  set form_status 1
}

# Run special queries. See do_special and init_special.
proc run_special {code} {
  global form_status special special_title
  # Close the special query popup:
  set form_status 1
  update
  run_sql $special($code) $special_title($code)
}

# ===== Menu Command Routines =====

# Manage the history list.
# If op is + or -, step the history pointer, and replace the input
# window contents with the history value (if not empty). If op is
# something else, enter it into the history table.
# When storing into the history list, synchronize the read and write
# indexes.
proc do_history {op} {
  global history history_p history_q n_history
  global widgets
  if {$op == ""} return
  debug_puts "do_history '$op' p=$history_p q=$history_q"
  if {$op == "+"} {
    set n $history_q
    incr n
    if {$n > $n_history} {
      set n 1
    }
    if {$history($n) == ""} return
    set history_q $n
    clear_input
    $widgets(input) insert 1.0 $history($history_q)
  } elseif {$op == "-"} {
    set n $history_q
    incr n -1
    if {$n < 1} {
      set n $n_history
    }
    if {$history($n) == ""} return
    set history_q $n
    clear_input
    $widgets(input) insert 1.0 $history($history_q)
  } else {
    # Delete trailing newlines to keep it neat.
    set history($history_p) [string trimright $op]
    incr history_p
    if {$history_p > $n_history} {
      set history_p 1
    }
    set history_q $history_p
  }
}

# Connect to database:
proc do_connect {} {
  global db dbinfo form_status

  if {$db != ""} do_disconnect

  # Initialize if never done. pg_conndefaults returns list of {key - - - value}
  if {![info exists dbinfo(user)]} {
    array set dbinfo {user {} host {} dbname {} port {} password {}}
    foreach default [pg_conndefaults] {
      setlist $default key unused1 unused2 unused3 value
      if {[info exists dbinfo($key)]} {
        set dbinfo($key) $value
      }
    }
  }
  # Build the Connect to Database popup:
  set t [mk_window .dbconnect "Connect to DBMS"]
  set f $t.entry
  frame $f
  label $f.host_l -text "Database Host:"
  entry $f.host -width 24 -textvariable dbinfo(host)
  label $f.port_l -text "Database Port:"
  entry $f.port -width 12 -textvariable dbinfo(port)
  label $f.dbname_l -text "Database Name:"
  entry $f.dbname -width 16 -textvariable dbinfo(dbname)
  label $f.user_l -text "Username:"
  entry $f.user -width 12 -textvariable dbinfo(user)
  label $f.password_l -text "Password:"
  entry $f.password -width 24 -textvariable dbinfo(password) -show *
  foreach field {host port dbname user password} {
    grid $f.${field}_l $f.$field 
    grid configure $f.${field}_l -sticky e
    grid configure $f.${field} -sticky w
  }
  mk_buttons $t "do_connect_done $t"
  pack $t.entry $t.buttons -side top -fill x
  set form_status -1
  window_wait $t $t.entry.host form_status
  # At this point $form_status is 1 on OK, 0 on Cancel, but we really
  # don't care because do_connect_done did all the work on OK.
}

# Disconnect from the database:
proc do_disconnect {} {
  global db dbinfo
  if {$db == ""} return
  pg_disconnect $db
  show_status "Disconnected from database $dbinfo(dbname)@$dbinfo(host)"
  set db {}
}

# Load a file into the input window:
proc do_loadin {} {
  global widgets pwd

  set fname [tk_getOpenFile -initialdir $pwd -title "Load input window"]
  if {$fname == ""} return
  set pwd [file dirname $fname]
  if {[catch {open $fname} f]} {
    tk_messageBox -title tkpsql -icon error -type ok \
        -message "Failed to open $fname: $f"
    return
  }
  clear_input
  $widgets(input) insert end [read -nonewline $f]
  close $f
}

# Save Input or Output text areas to a file.
proc do_save {which} {
  global widgets pwd

  set fname [tk_getSaveFile -initialdir $pwd -title "Save $which window"]
  if {$fname == ""} return
  set pwd [file dirname $fname]
  if {[catch {open $fname w} f]} {
    tk_messageBox -title tkpsql -icon error -type ok \
        -message "Failed to open $fname: $f"
    return
  }
  show_status "Saving text..."
  puts -nonewline $f [$widgets($which) get 1.0 end]
  close $f
  show_status ""
}

# Exit the program:
proc do_exit {} {
  do_disconnect
  exit
}

# Run the SQL in the input window. First, remove any trailing newlines,
# spaces and ';' chars.
proc do_run {} {
  global widgets
  set sql [string trimright [$widgets(input) get 1.0 end] " \n;"]
  do_history $sql
  run_sql $sql
}

# Clear the input and output boxes:
proc do_clear {} {
  clear_input
  clear_output
}

# Display options dialog:
proc do_options {} {
  global form_status option
  # Save the current options to be restored if the form is Cancelled.
  array set copy_option [array get option]
  # Build the Options popup:
  set t [mk_window .options "Set Options"]
  set f $t.opt
  frame $f
  label $f.outstyle -text "Output Style:"
  radiobutton $f.outstyle1 -text Narrow -variable option(outstyle) -value narrow
  radiobutton $f.outstyle2 -text Wide -variable option(outstyle) -value wide
  label $f.maxlook_l -text "Max rows to look at for column widths:"
  entry $f.maxlook -width 5 -textvariable option(maxlook)
  checkbutton $f.clear -text "Clear output before results" -variable option(clear)
  checkbutton $f.debug -text Debug -variable option(debug)

  grid $f.outstyle $f.outstyle1 $f.outstyle2
  grid $f.maxlook_l - $f.maxlook
  grid $f.clear - x
  grid $f.debug x x
  mk_buttons $t

  pack $t.opt $t.buttons -side top -fill x
  set form_status -1
  window_wait $t $t.buttons.ok form_status

  # Restore the options on Cancel:
  if {!$form_status} {
    array set option [array get copy_option]
  }
  if {$option(debug)} {
    parray option
  }
}

# Special queries. See init_special for the data which drives this.
proc do_special {} {
  global form_status special special_title special_codes

  set t [mk_window .special "Special Queries"]
  set packme {}
  # Generate all the special query buttons:
  foreach code $special_codes {
    button $t.$code -text $special_title($code) -command "run_special $code"
    lappend packme $t.$code
  }
  button $t.cancel -text Cancel -command "set form_status 0"
  bind $t <Escape> "set form_status 0"
  eval pack $packme $t.cancel -side top -fill x -padx 2 -pady 2
  set form_status -1
  window_wait $t $t.cancel form_status
}

# ===== Main Window UI =====

# Build the main user interface:
proc build_ui {} {
  global widgets version

  set f .buttons
  frame $f
  set buttons [list \
      [mk_button $f.run       Run            <F1>  do_run] \
      [mk_button $f.clear     Clear          <F2>  do_clear] \
      [mk_button $f.next_hist {History Next} <F3>  {do_history +}] \
      [mk_button $f.prev_hist {History Prev} <F4>  {do_history -}] \
      [mk_button $f.loadin    {Load Input}   <F5>  do_loadin] \
      [mk_button $f.savein    {Save Input}   <F6>  {do_save input}] \
      [mk_button $f.saveout   {Save Output}  <F7>  {do_save output}] \
      [mk_button $f.connect   Connect        <F8>  do_connect] \
      [mk_button $f.disconn   Disconnect     <F9>  do_disconnect] \
      [mk_button $f.options   Options        <F10> do_options] \
      [mk_button $f.special   Special        <F11> do_special] \
      [mk_button $f.quit      Exit           <F12> do_exit] \
   ]
  eval pack $buttons -side top -fill x -padx 2 -pady 4

  # Alternate bindings for keyboard without F11 or F12:
  bind . <Alt-s> do_special
  bind . <Alt-q> do_exit
  # Forget bogus binding of F10 on unix platforms to traverse menus:
  bind all <F10> {}

  # Frame .r holds the right-hand side with input, output, and status.
  set f .r
  frame $f

  # Output text area with horizontal and vertical scrollers:
  # Must use monospace font so columns line up.
  set widgets(output) $f.output
  text $widgets(output) -relief sunken -borderwidth 2 -height 16 -width 64 \
    -wrap none -setgrid 1 -font monofont \
    -yscrollcommand "$f.oyscroll set" -xscrollcommand "$f.oxscroll set"
  scrollbar $f.oyscroll -command "$f.output yview"
  scrollbar $f.oxscroll -orient horizontal -command "$f.output xview"
  # Tags for output area for special text display:
  $widgets(output) tag configure under -underline on
  $widgets(output) tag configure bold -font boldfont

  # Input text area: vertical scroller only, word wrap.
  set widgets(input) $f.input
  text $widgets(input) -relief sunken -borderwidth 2 -height 5 -width 64 \
    -wrap word \
    -yscrollcommand "$f.iyscroll set"
  scrollbar $f.iyscroll -command "$f.input yview"

  # Status area:
  set widgets(status) $f.status
  label $widgets(status) -relief sunken -borderwidth 1 -anchor w

  # Grid up the output, input, and status with scroll bars:
  grid $f.output $f.oyscroll
  grid $f.oxscroll x
  grid $f.input $f.iyscroll
  grid $f.status -
  # ... Set stickiness:
  grid configure $f.input $f.output -sticky nsew
  grid configure $f.oxscroll $f.status -sticky ew
  grid configure $f.oyscroll $f.iyscroll -sticky ns
  # ... Indicate that the output and input rows expand:
  grid rowconfigure $f 0 -weight 3
  grid rowconfigure $f 2 -weight 1
  grid columnconfigure $f 0 -weight 1

  pack .buttons .r -side left -fill both
  pack configure .r -expand 1

  # Main window setup:
  wm title . "tkpsql $version"
  wm iconname . tkpsql
  wm protocol . WM_DELETE_WINDOW do_exit
  center_window . ROOT

  focus $widgets(input)
  # Needed on Windows, for some strange reason:
  raise .
}

# ===== Main program =====

initialize
build_ui
do_connect