#!/usr/local/bin/wishx -f

#  wisql
# 	
#  Copyright 1992 Tom Poindexter.
#
#  a windowing version of the sybase isql command  
#  uses extended tcl, tk, and sybtcl interface
#
#  usage: wisql
#
#  version 1.1 - change sql input to use tk2.2 text widget.
#                handle text columns a little better - break into lines.
#                add getObjs to view other objects.
#                allow comments '#' and 'go's in sql.
#                add count of all rows returned by server
#  version 1.2 - change showFields to display 30 chars for field name
#                using hand coded sql instead of sp_help.
#                add sybmsg(msgno) to error messages.
#                change .m.msg to a message (used to be a label) so that all
#                the text of a message will be displayed.
#                add some arrow key bindings for Entry and Text classes.
#                add shift-return and control-return binding to execute sql.
#                added a menu for selecting a server on signon window.
#                fix pickList OK command when nothing selected.
#                a few other cosmetics changes.
#  version 1.3 - change a few things for newer versions of Tk & TclX,
#                toplevel pathnames must start with lower case, wishx
#                command interpreter instead of wish.
#                if SYBASE environment variable is not set, check for 
#                user sybase home directory in "ypcat passwd" or /etc/passwd
#                make the execute button a cancel button while execing sql
#
#  version 2.0 - change a few things for newer versions of Tk & TclX,
#  version 2.1 - use sybnext ?commands? when possible; use Paul Raines (TkMail)
#                bindings for Entry and Text widgets.
#                


# define global names in use
global sybmsg
global uid
global syb
global currentFile
global server
global fontSize
global execCmd

# set what command Execute button should do
set execCmd doSql

set fontSize 14

set uid [id user]

set syb {}
set currentFile {}

wm title    . "Windowing ISQL"
wm iconname . "Wisql"


proc getSignOn {} {
  global uid
  global env
  global matchInfo

  # get valid servers from interfaces file
  set syb_home [lsearch [array names env] SYBASE] 

  if {$syb_home == -1} {
      set syb_home ""
      catch {set syb_home [exec ypcat passwd | egrep  ^sybase: ]}
      if {[string length $syb_home] > 0} {
	  set syb_home [lindex [split $syb_home :] 5]
      } else {
	  set syb_home [exec egrep ^sysbase: < /etc/passwd ]
	  if {[string length $syb_home] > 0} {
	      set syb_home [lindex [split $syb_home :] 5]
	  } else {
	      set syb_home ""
	  }
      }
  } else {
      set syb_home $env(SYBASE)
  }

  if {[string length $syb_home] > 0} {
    set intFile $syb_home/interfaces
    set serverList ""
    if [file isfile $intFile] {
      set fd [open $intFile]
      set sc [scancontext create]
      scanmatch -nocase $sc {^[a-z]} {lappend serverList $matchInfo(line)}
      scanfile $sc $fd
      close $fd
    } else {
      set serverList SYBASE
    }
  } else {
    set serverList SYBASE
  }
  
  wm geom     . 300x300
  frame .s
  message .s.m -justify center  -text "SQL Server Sign on" -aspect 2000 \
		-font -*-helvetica-bold-o-*-*-20-*-*-*-*-*-*-*
  frame .s.i
  entry .s.i.uid -relief sunken  -width 10 
  label .s.i.id  -text "  User Id" -anchor e
  frame .s.p
  entry .s.p.pw  -relief sunken -width 10 \
		 -font -*-symbol-*-r-*--20-*-*-*-*-*-*-*
  label .s.p.p   -text "  Password" -anchor e

  frame .s.s
  entry .s.s.ser -relief sunken -width 10 
  menubutton .s.s.s -text " Server  " -anchor e -menu .s.s.s.m -relief raised
  menu .s.s.s.m
  foreach s $serverList {
    .s.s.s.m add command -label $s \
		  -command ".s.s.ser delete 0 end; .s.s.ser insert 0 $s "
  }

  message .s.err -text " " -justify center -aspect 2000

  frame .s.b
  button .s.b.ok  -text "Sign on" \
      -command {tryConnect [.s.i.uid get] [.s.p.pw get] [.s.s.ser get]}
  button .s.b.can -text "Cancel" -command "destroy ."

  pack .s       -side top -expand 1 -fill both
  pack .s.m     -side top -fill x  -pady 20
  pack .s.i     -side top -pady 20 -anchor e
  pack .s.i.uid -side right -expand 1 -padx 20
  pack .s.i.id  -side left
  pack .s.p     -side top   -pady 20 -anchor e
  pack .s.p.pw  -side right -expand 1 -padx 20 
  pack .s.p.p   -side left

  pack .s.b     -side bottom -fill x -expand 1
  pack .s.b.ok  -side left -fill x -expand 1
  pack .s.b.can -side left -fill x -expand 1

  pack .s.s     -side bottom -pady 20 -anchor e
  pack .s.s.ser -side right  -expand 1 -padx 20 
  pack .s.s.s   -side left

  pack .s.err   -side top -fill x 

  .s.i.uid insert 0 $uid

  if {[lsearch [array names env] DSQUERY] >= 0} {
    .s.s.ser insert 0 $env(DSQUERY)
  } else {
    .s.s.ser insert 0 SYBASE
  }
  focus .s.p.pw

  bind .s.i.uid <KeyPress-Return> "focus .s.p.pw"
  bind .s.p.pw  <KeyPress-Return> ".s.b.ok invoke"
  bind .s.s.ser <KeyPress-Return> ".s.b.ok invoke"


}

############################################################################
# include bindings.tk from TkMail (Thanks Paul!)
############################################################################
#
#COPYRIGHT:
#     Copyright 1993 by Paul Raines (raines@bohr.physics.upenn.edu)
#
#     Permission to use, copy, modify, and distribute this
#     software and its documentation for any purpose and without
#     fee is hereby granted, provided that the above copyright
#     notice appear in all copies.  The University of Pennsylvania
#     makes no representations about the suitability of this
#     software for any purpose.  It is provided "as is" without
#     express or implied warranty.
#

# Gives more motif-like ands emacs-like bindings to Text and Entry Widgets
global bind_xnd btp

# USER SETTINGS

# maximum number of kills to save in ring
set btp(maxkill) 10
# maximum number of marks to save in ring
set btp(maxmark) 10
# syntax for letter not part of a "word"
set btp(not-word) {[^a-zA-Z_0-9]}
# procedure to use for errors
set btp(error) error
# procedure to use for beeping
set btp(beep) ""
# whether to bind Escape prefix commands also to the Meta modifier
set btp(use-meta) 1
# column at which to line wrap
set btp(fillcol) 0
# prefix for line wrapping (NOT REALLY WORKING YET)
set btp(fillprefix) ""

# PRIVATE SETTINGS

set btp(lastkill) 0.0
set btp(killring) ""
set btp(killptr) 0
set btp(killlen) 0
set btp(arg) def

proc tk_entryForwspace w {
     set x [expr [$w index insert] - 1]
     catch {$w delete $x}
}

# selection_if_any - return selection if it exists, else {}
#   this is from kjx@comp.vuw.ac.nz (R. James Noble)
proc selection_if_any {} {
  if {[catch {selection get} s]} {return ""} {return $s}
}

proc bind_cleanup { w } {
    global btp
    catch {unset btp($w,markring)}
}

proc bt:current-line { w } {
    return [lindex [split [$w index insert] .] 0]
}

proc bt:current-col { w } {
    return [lindex [split [$w index insert] .] 1]
}

proc bt:move-line { w {num 1} } {
    global btp
    set btp(lastkill) 0.0
    if {$btp(arg) != "def"} {
	set num [expr $num*$btp(arg)]
	set btp(arg) def
    }
    if {$btp(prevcmd) != "move-line"} {
        set btp(goalcol) [lindex [split [$w index insert] .] 1]
    }
    if {$num > -1} {set num "+$num"}
    $w tag remove sel 1.0 end
    set ndx [$w index "insert $num line lineend"]
    set goalndx [lindex [split $ndx .] 0].$btp(goalcol)
    if {$btp(goalcol) < [lindex [split $ndx .] 1]} {
        $w mark set insert $goalndx
    } else {
        $w mark set insert $ndx
    }
    $w yview -pickplace insert
    set btp(prevcmd) move-line
}

proc bt:move-char { w {num 1} } {
    global btp
    set btp(lastkill) 0.0
    if {$btp(arg) != "def"} {
	set num [expr $num*$btp(arg)]
	set btp(arg) def
    }
    if {$num > -1} {set num "+$num"}
    $w tag remove sel 1.0 end
    $w mark set insert "insert $num char"
    $w yview -pickplace insert
    set btp(prevcmd) "move-char"
}

proc bt:move-word {w {num 1}} {
    global btp
    set btp(lastkill) 0.0
    $w tag remove sel 1.0 end
    if {$btp(arg) != "def"} {
	set num [expr $num*$btp(arg)]
	set btp(arg) def
    }
    if {$num > 0} {
        for {set i 0} {$i < $num } {incr i} {
	    while {[regexp $btp(not-word) [$w get insert]]} {
	        $w mark set insert insert+1c
	    } 
	    $w mark set insert {insert wordend}
	}
    } else {
        for {set i 0} {$i > $num } {incr i -1} {
	    $w mark set insert insert-1c
	    while {[regexp $btp(not-word) [$w get insert]]} {
	        $w mark set insert insert-1c
	    } 
	    $w mark set insert {insert wordstart}
	}
    }
    $w yview -pickplace insert
    set btp(prevcmd) "move-word"
}

proc bt:begin-line { w {num 0}} {
    global btp
    set btp(lastkill) 0.0
    if {$btp(arg) != "def"} {
	set num $btp(arg)
	set btp(arg) def
    }
    if {$num != 0} {set num [expr $num-1]}
    bt:move-line $w $num
    $w mark set insert {insert linestart}
    $w tag remove sel 1.0 end
    $w yview -pickplace insert
    set btp(prevcmd) "begin-line"
}

proc bt:end-line { w {num 0}} {
    global btp
    set btp(lastkill) 0.0
    if {$btp(arg) != "def"} {
	set num $btp(arg)
	set btp(arg) def
    }
    if {$num != 0} {set num [expr $num-1]}
    bt:move-line $w $num
    $w mark set insert {insert lineend}
    $w tag remove sel 1.0 end
    $w yview -pickplace insert
    set btp(prevcmd) end-line
}

proc bt:begin-buffer { w {num 0}} {
    global btp
    set btp(lastkill) 0.0
    if {$btp(arg) != "def"} {
	set num $btp(arg)
	set btp(arg) def
    }
    bt:set-mark $w
    set ndx [expr 1+[lindex [split [$w index end] .] 0]*$num/10]
    $w mark set insert $ndx.0
    $w tag remove sel 1.0 end
    $w yview -pickplace insert
    set btp(prevcmd) begin-buffer
}

proc bt:end-buffer { w {num 0}} {
    global btp
    set btp(lastkill) 0.0
    if {$btp(arg) != "def"} {
	set num $btp(arg)
	set btp(arg) def
    }
    bt:set-mark $w
    set ndx [expr [lindex [split [$w index end] .] 0]*$num/10]
    $w mark set insert "end - $ndx lines"
    $w tag remove sel 1.0 end
    $w yview -pickplace insert
    set btp(prevcmd) end-buffer
}

proc bt:scroll-next { w {num 1}} {
    global  btp
    set btp(lastkill) 0.0
    if {$btp(arg) != "def"} {
	set num $btp(arg)
	set btp(arg) def
    }
    $w tag remove sel 1.0 end
    set scr [lindex [lindex [$w configure -yscroll] 4] 0]
    $w mark set insert [lindex [$scr get] 3].0
    $w yview insert-1l
    set btp(prevcmd) scroll-next
}

proc bt:scroll-prior { w {num 1}} {
    global btp
    set btp(lastkill) 0.0
    if {$btp(arg) != "def"} {
	set num $btp(arg)
	set btp(arg) def
    }
    $w tag remove sel 1.0 end
    set scr [lindex [lindex [$w configure -yscroll] 4] 0]
    set tndx [expr [lindex [$scr get] 2]-[lindex [$scr get] 1]+5].0
    if {$tndx < 1.0} {set tndx 1.0}
    $w mark set insert $tndx
    $w yview insert-1l
    set btp(prevcmd) scroll-prior
}

proc bt:delete-word { w {num 1}} {
    global btp
    $w tag remove sel 1.0 end
    if {[$w compare $btp(lastkill) == insert]} {
	set lastcut [bt:pop-cut]
    } else { set lastcut "" }
    set beg [$w index insert]
    if {$btp(arg) != "def"} {
	set num $btp(arg)
	set btp(arg) def
    }
    bt:move-word $w $num
    puts "$num : $beg [$w index insert]"
    if {$beg < [$w index insert]} {
        bt:push-cut "$lastcut[$w get $beg insert]"
        $w delete $beg insert
    } else {
        bt:push-cut "[$w get insert $beg]$lastcut"
        $w delete insert $beg
    }
    set btp(lastkill) [$w index insert]
    $w yview -pickplace insert
    set btp(prevcmd) delete-word
}

proc bt:delete-line { w {num 0}} {
    global btp
    $w tag remove sel 1.0 end
    if {$btp(arg) != "def"} {
	set num $btp(arg)
	set btp(arg) def
    }
    if {[$w compare $btp(lastkill) == insert]} {
	set lastcut [bt:pop-cut]
    } else { set lastcut ""}
    while {[$w get insert] == " "} {
	$w mark set insert insert+1c
    } 
    if {[$w compare insert == "insert lineend"] && $num == 0} { set num 1 }
    set beg [$w index insert]
    if {$num != 0} {
	bt:move-line $w $num
	bt:begin-line $w
	if {$beg < [$w index insert]} {
	    bt:push-cut "$lastcut[$w get $beg insert]"
	    $w delete $beg insert
	} else {
	    bt:push-cut "[$w get insert $beg]$lastcut"
	    $w delete insert $beg
	}
    } else {
      bt:push-cut "$lastcut[$w get insert {insert lineend}]"
      $w delete insert {insert lineend};
      $w yview -pickplace insert
    }
    $w yview -pickplace insert
    set btp(lastkill) [$w index insert]
    set btp(prevcmd) delete-line
}

proc bt:delete-back-char-or-sel { w {num 1} } {
    global btp
    if {$btp(arg) != "def"} {
        set num $btp(arg)
    } else {set btp(lastkill) 0.0}
    set num [expr -1*$num]
    if {$num > -1} {set num "+$num"}
    if {[$w compare $btp(lastkill) == insert]} {
	set lastcut [bt:pop-cut]
    } else { set lastcut ""}
    if [catch {set tmp [$w get sel.first sel.last]}] {
        if {$btp(arg) != "def"} {
	    if {$num < 0} {
		bt:push-cut "[$w get "insert $num char" insert]$lastcut"
	        $w delete "insert $num char" insert
	    } else {
		bt:push-cut "$lastcut[$w get insert "insert $num char"]"
	        $w delete insert "insert $num char"
	    }
	    set btp(lastkill) [$w index insert]
        } else {
	    if {$num < 0} {
	        $w delete "insert $num char" insert
	    } else {
	        $w delete insert "insert $num char"
	    }
	    set btp(lastkill) 0.0
        }
    } else {
	$w delete sel.first sel.last
	bt:push-cut $tmp
        set btp(lastkill) 0.0
    }
    set btp(arg) def
    $w yview -pickplace insert
    set btp(prevcmd) delete-back-char-or-sel
}

proc bt:delete-region-or-sel { w } {
    global btp

    if {[catch {set tmp [$w get sel.first sel.last]}]} {
	if {[catch "$w index emacs"]} {
	    $btp(error) "No emacs mark has been set yet!"
	}
        if {[$w compare $btp(lastkill) == insert]} {
	    set lastcut [bt:pop-cut]
        } else { set lastcut ""}
	if {[$w compare emacs < insert]} {
	    bt:push-cut "$lastcut[$w get emacs insert]"
	    $w delete emacs insert
	} else {
	    bt:push-cut "[$w get insert emacs]$lastcut"
	    $w delete insert emacs
	}
        set btp(lastkill) [$w index insert]
    } else {
	$w delete sel.first sel.last
	bt:push-cut $tmp
        set btp(lastkill) 0.0
    }
    set btp(arg) def
    set btp(prevcmd) delete-region-or-sel
}

proc bt:copy-region-or-sel { w } {
    global btp

    if {[catch {set tmp [$w get sel.first sel.last]}]} {
	if {[catch "$w index emacs"]} {
	    $btp(error) "No emacs mark has been set yet!"
	}
        if {[$w compare $btp(lastkill) == insert]} {
	    set lastcut [bt:pop-cut]
        } else { set lastcut ""}
	if {[$w compare emacs < insert]} {
	    bt:push-cut "$lastcut[$w get emacs insert]"
	} else {
	    bt:push-cut "[$w get insert emacs]$lastcut"
	}
	bt:exchange-point-and-mark $w
	after 200 bt:exchange-point-and-mark $w
    } else {
	bt:push-cut $tmp
    }
    set btp(arg) def
    set btp(lastkill) 0.0
    set btp(prevcmd) copy-region-or-sel
}

proc bt:append-next-kill { w } {
    global btp
    set btp(lastkill) [$w index insert]
}

proc bt:push-cut { txt } {
    global btp

    set btp(killlen) [llength [lappend btp(killring) $txt]]
    if { $btp(killlen) > $btp(maxkill)} {
	set btp(killring) [lreplace $btp(killring) 0 0]
	incr btp(killlen) -1
    }
    set btp(killptr) 0
}

proc bt:pop-cut { } {
    global btp

    if {$btp(killlen) == 0} {return ""}
    set txt [bt:get-cut 1]
    set ndx [expr $btp(killlen)-1]
    set btp(killring) [lreplace $btp(killring) $ndx $ndx ]
    incr btp(killlen) -1
    set btp(killptr) 0
    return $txt
}

proc bt:get-cut { {ndx 1} } {
    global btp

    set ndx [expr $ndx+$btp(killptr)]
    set btp(killptr) [expr $ndx-1]
    set ndx [expr $ndx%$btp(killlen)]
    if {$ndx == 0} {set ndx $btp(killlen)}
    return [lindex $btp(killring) [expr $btp(killlen)-$ndx]]

}

proc bt:yank { w {num 1}} {
    global btp
    $w tag remove sel 1.0 end
    if {$btp(arg) != "def"} {
	set num $btp(arg)
	set btp(arg) def
    }
    set btp(lastkill) 0.0
    set tmp [$w index insert]
    $w insert insert [bt:get-cut $num]
    $w mark set emacs $tmp
    $w yview -pickplace insert
    set btp(prevcmd) yank
}

proc bt:yank-pop { w {num 1}} {
    global btp
    if {$btp(arg) != "def"} {
	set num $btp(arg)
	set btp(arg) def
    }
    if {$btp(prevcmd) != "yank"} return
    $w tag remove sel 1.0 end
    $w delete emacs insert
    set tmp [$w index insert]
    $w insert insert [bt:get-cut [expr $num+1]]
    $w mark set emacs $tmp
    $w yview -pickplace insert
}

proc bt:pop-mark { w } {
    global btp
    set ndx [expr [llength $btp($w,markring)]-1]
    set oldmark [lindex $btp($w,markring) $ndx]
    $w mark set emacs $oldmark
    set btp($w,markring) [concat $oldmark [lreplace $btp($w,markring) $ndx $ndx]]
}

proc bt:push-mark { w ndx } {
    global btp
    lappend btp($w,markring) $ndx
}
 
proc bt:set-mark { w {num def}} {
    global btp
    $w tag remove sel 1.0 end
    if {$btp(arg) != "def"} {
	set num $btp(arg)
	set btp(arg) def
    }
    if {$num != "def"} {
	if {[catch "$w index emacs"]} {
	    $btp(error) "No emacs mark has been set yet!"
	}
        $w yview -pickplace insert
        bt:pop-mark $w
        $w mark set insert emacs
    } else {
	bt:push-mark $w [$w index insert]
        $w mark set emacs insert
    }
    set btp(lastkill) 0.0
    set btp(prevcmd) set-mark
}

proc bt:exchange-point-and-mark { w } {
    global btp
    if {[catch "$w index emacs"]} {
	$btp(error) "No emacs mark has been set yet!"
    }
    set tmp [$w index insert]
    $w mark set insert emacs
    $w mark set emacs $tmp
    set btp(lastkill) 0.0
    set btp(prevcmd) set-mark
}

proc bt:open-line {w {num 1}} {
    global btp
    if {$btp(arg) != "def"} {
	set num $btp(arg)
	set btp(arg) def
    }
    catch {$w delete sel.first sel.last}
    for {set i 0} {$i < $num } {incr i} {
        $w insert insert \n
    }
    $w mark set insert insert-1c
    $w yview -pickplace insert
    set btp(prevcmd) open-line
}

proc bt:argkey { w a } {
    global btp
    set btp(arg) $a
} 

proc bt:numkey { w a } {
    global btp
    if {$btp(arg) == "def"} {
	catch {%W delete sel.first sel.last}
	$w insert insert $a
	if {$btp(fillcol) && [bt:current-col $w] >= $btp(fillcol)} {
	    bt:wrap-word $w
	}
	$w yview -pickplace insert
	set btp(lastkill) 0.0
	set btp(prevcmd) self-insert
    } else {
	if {$a == "-"} {
	    if {$btp(arg) == "-"} { 
		set btp(arg) "0" 
	    } elseif {$btp(arg) == "0"} {
		set btp(arg) "-"
	    } else {
		set btp(arg) [expr -1*$btp(arg)]
	    }
	} else {
	    append btp(arg) $a
	}
    }
} 

proc bt:univ-arg { w } {
    global btp
    if {$btp(arg) == "def"} {
	set btp(arg) 4
    } else {
	if {$btp(arg) == "-"} { 
	    set btp(arg) "-4" 
	} else {
	    set btp(arg) [expr 4*$btp(arg)]
	}
    }
}

proc bt:wrap-word { w } {
    global btp

    bt:move-word $w -1
    $w insert insert \n
    bt:end-line $w
}

proc bt:set-fill-col { w {num 0}} {
    global btp
    if {$btp(arg) == "def"} {
	if {$num < 1} {
	    set btp(fillcol) [bt:current-col $w]
	} else {
	    set btp(fillcol) $num
	}
    } else {
	if {$btp(arg) < 1} {
	    set btp(fillcol) [bt:current-col $w]
	} else {
	    set btp(fillcol) $btp(arg)
	}
    }
    set btp(arg) def
    set btp(lastkill) 0.0
    set btp(prevcmd) set-fill-col
}

proc bind_motiftext { tw } {
    global bind_xnd

    bind $tw <Control-KeyPress> {
        global btp
	if {"%A" != ""} {eval $btp(beep) }
    }

    # Some better bindings for text and entry
    bind $tw <Up> {bt:move-line %W -1}
    bind $tw <Down> {bt:move-line %W 1}
    bind $tw <Left> {bt:move-char %W -1}
    bind $tw <Right> {bt:move-char %W 1}
    bind $tw <Home> {bt:begin-line %W}
    bind $tw <End> {bt:end-line %W}
    bind $tw <Control-Home> {bt:begin-buffer %W}
    bind $tw <Control-End> {bt:end-buffer %W}
    bind $tw <Control-Left> {bt:move-word %W -1}
    bind $tw <Control-Right> {bt:move-word %W 1}
    bind $tw <Next> {bt:scroll-next %W}
    bind $tw <Prior> {bt:scroll-prior %W}

    bind $tw <Any-KeyPress> {
	global btp
	set num 1
	if {"%A" != ""} {
	    if {$btp(arg) != "def"} {
		set num $btp(arg)
		set btp(arg) def
	    }
	    catch {%W delete sel.first sel.last}
	    for {set i 0} { $i < $num} {incr i} {%W insert insert %A}
	    if {$btp(fillcol) && [bt:current-col %W] >= $btp(fillcol)} {
		if {"%A" == " "} {
		    %W insert insert \n
		} elseif {"%A" == "\t"} {
		    %W insert insert \n\t
		} else {
		    bt:wrap-word %W
		}
	    }
	    %W yview -pickplace insert
	    set btp(lastkill) 0.0
	    set btp(prevcmd) self-insert
	}
    }

    bind $tw <KeyPress-Return> {
	global btp
        catch {%W delete sel.first sel.last}
	set num 1
	if {$btp(arg) != "def"} {
	    set num $btp(arg)
	    set btp(arg) def
	}
        for {set i 0} { $i < $num} {incr i} {%W insert insert "\n"}
        %W yview -pickplace insert
	set btp(lastkill) 0.0
	set btp(prevcmd) newline
    }

    bind $tw <KeyPress-Delete> {bt:delete-back-char-or-sel %W 1}
    bind $tw <KeyPress-BackSpace> {bt:delete-back-char-or-sel %W 1}

    bind $tw <1> "[bind Text <1>]; \
                  global btp; set btp(lastkill) 0.0; \
		  set btp(prevcmd) mouse-set"
    bind $tw <3> {%W tag remove sel 1.0 end}
    bind $tw <B1-Motion> {bind_textB1motion %W @%x,%y}

    set bind_xnd(b2-time) 0
    set bind_xnd(b2-y) 0
    bind $tw <2> {
        global bind_xnd
        %W scan mark %y
        set bind_xnd(b2-time) %t
        set bind_xnd(b2-y) %y
    }
    bind $tw <ButtonRelease-2> {
        global bind_xnd
	if {[expr %t-$bind_xnd(b2-time)]<1000} {
	    %W insert insert [selection_if_any]
 	    global btp
	    set btp(lastkill) 0.0
	    set btp(prevcmd) mouse-insert
        }
    }

    # only one mouse, so no need have separate vars for each widget
    set bind_xnd(txnd) 0
    set bind_xnd(xdelay) 100
    proc bind_textB1motion  { w loc } {
	global bind_xnd

	set ypos [lindex [split $loc ","] 1]
	if {$ypos > [winfo height $w]} {
		if {!$bind_xnd(txnd)} {after $bind_xnd(xdelay) bind_textExtend $w}
		set bind_xnd(txnd) 1
		set bind_xnd(direction) down
	} elseif {$ypos < 0} {
		if {!$bind_xnd(txnd)} {after $bind_xnd(xdelay) bind_textExtend $w}
		set bind_xnd(txnd) 1
		set bind_xnd(direction) up
	} else {
		set bind_xnd(txnd) 0
		set bind_xnd(direction) 0
	}

	if {!$bind_xnd(txnd)} {
		tk_textSelectTo $w $loc
	}

    }

    bind $tw <ButtonRelease-1> { 
        global bind_xnd btp
        set bind_xnd(txnd) 0
	set btp(lastkill) 0.0
	set btp(prevcmd) mouse-select
    }

    proc bind_textExtend { w } {
	 global bind_xnd

	 if {$bind_xnd(txnd)} {
	     if {$bind_xnd(direction) == "down"} {
		 tk_textSelectTo $w sel.last+1l
		 $w yview -pickplace sel.last+1l
	     } elseif {$bind_xnd(direction) == "up"} {
		 tk_textSelectTo $w sel.first-1l
		 $w yview -pickplace sel.first-1l
	     } else { return }
	     after $bind_xnd(xdelay) bind_textExtend $w
	 }
    }

}

proc bind_emacstext { tw } {
    global btp

    # make Escape key simulate a state Alt key
    bind $tw <Escape> { }
    bind $tw <Escape><Any-KeyPress> {
        global btp
	if {"%A" != ""} {eval $btp(beep) }
    }

    bind $tw <Control-a> {bt:begin-line %W}
    bind $tw <Control-e> {bt:end-line %W}
    bind $tw <Control-f> {bt:move-char %W 1}
    bind $tw <Control-b> {bt:move-char %W -1}
    bind $tw <Escape><f> {bt:move-word %W 1}
    bind $tw <Escape><b> {bt:move-word %W -1}

    bind $tw <Control-n> {bt:move-line %W 1}
    bind $tw <Control-p> {bt:move-line %W -1}
    bind $tw <Control-l> {
	%W yview -pickplace insert
    }
    bind $tw <Control-o> {bt:open-line %W 1}
    bind $tw <Control-d> {bt:delete-back-char-or-sel %W -1}
    bind $tw <Escape><d> {bt:delete-word %W 1}

    bind $tw <Control-h> {bt:delete-back-char-or-sel %W -1}

    bind $tw <Control-k> {bt:delete-line %W 0}
    bind $tw <Control-w> {bt:delete-region-or-sel %W}
    bind $tw <Escape><w> {bt:copy-region-or-sel %W}
    bind $tw <Control-y> {bt:yank %W}
    bind $tw <Escape><y> {bt:yank-pop %W}
    bind $tw <Control-space> {bt:set-mark %W}

    bind $tw <Control-u> {bt:univ-arg %W}
    bind $tw <KeyPress-0> {bt:numkey %W %A}
    bind $tw <KeyPress-1> {bt:numkey %W %A}
    bind $tw <KeyPress-2> {bt:numkey %W %A}
    bind $tw <KeyPress-3> {bt:numkey %W %A}
    bind $tw <KeyPress-4> {bt:numkey %W %A}
    bind $tw <KeyPress-5> {bt:numkey %W %A}
    bind $tw <KeyPress-6> {bt:numkey %W %A}
    bind $tw <KeyPress-7> {bt:numkey %W %A}
    bind $tw <KeyPress-8> {bt:numkey %W %A}
    bind $tw <KeyPress-9> {bt:numkey %W %A}

    bind $tw <Escape><KeyPress-0> {bt:argkey %W %A}
    bind $tw <Escape><KeyPress-1> {bt:argkey %W %A}
    bind $tw <Escape><KeyPress-2> {bt:argkey %W %A}
    bind $tw <Escape><KeyPress-3> {bt:argkey %W %A}
    bind $tw <Escape><KeyPress-4> {bt:argkey %W %A}
    bind $tw <Escape><KeyPress-5> {bt:argkey %W %A}
    bind $tw <Escape><KeyPress-6> {bt:argkey %W %A}
    bind $tw <Escape><KeyPress-7> {bt:argkey %W %A}
    bind $tw <Escape><KeyPress-8> {bt:argkey %W %A}
    bind $tw <Escape><KeyPress-9> {bt:argkey %W %A}
    bind $tw <Escape><KeyPress-minus> {bt:argkey %W %A}

    # make C-x key a state
    bind $tw <Control-x> { }
    bind $tw <Control-x><Any-KeyPress> {
        global btp
	if {"%A" != ""} {eval $btp(beep) }
    }
    bind $tw <Control-x><Control-x> {bt:exchange-point-and-mark %W}
    bind $tw <Control-x><KeyPress-f> {bt:set-fill-col %W}

    # Make Meta key like and Escape prefix
    if {$btp(use-meta)} {
	bind $tw <Meta-KeyPress> {
	    global btp
	    if {"%A" != ""} {eval $btp(beep) }
	}
	bind $tw <Control-Meta-KeyPress> {
	    global btp
	    if {"%A" != ""} {eval $btp(beep) }
	}

	bind $tw <Meta-f> {bt:move-word %W 1}
	bind $tw <Meta-b> {bt:move-word %W -1}
	bind $tw <Meta-d> {bt:delete-word %W 1}
	bind $tw <Meta-w> {bt:copy-region-or-sel %W}
	bind $tw <Meta-y> {bt:yank-pop %W}

	bind $tw <Meta-0> {bt:argkey %W %A}
	bind $tw <Meta-1> {bt:argkey %W %A}
	bind $tw <Meta-2> {bt:argkey %W %A}
	bind $tw <Meta-3> {bt:argkey %W %A}
	bind $tw <Meta-4> {bt:argkey %W %A}
	bind $tw <Meta-5> {bt:argkey %W %A}
	bind $tw <Meta-6> {bt:argkey %W %A}
	bind $tw <Meta-7> {bt:argkey %W %A}
	bind $tw <Meta-8> {bt:argkey %W %A}
	bind $tw <Meta-9> {bt:argkey %W %A}
	bind $tw <Meta-minus> {bt:argkey %W %A}
    }
}

##############
# ENTRY WIDGET
##############

proc be:move-char {w {num 1} } {
    global btp
    set btp(lastkill-entry) -1
    if {$btp(arg) != "def"} {
	set num [expr $num*$btp(arg)]
	set btp(arg) def
    }
    $w select clear
    $w icursor [expr {[$w index insert] + $num}]
    tk_entrySeeCaret $w
    set btp(prevcmd) move-char
}

proc be:move-word {w {num 1}} {
    global btp
    set btp(lastkill-entry) -1
    $w select clear
    if {$btp(arg) != "def"} {
	set num [expr $num*$btp(arg)]
	set btp(arg) def
    }
    if {$num > 0} {
        for {set i 0} {$i < $num } {incr i} {
	    set endx [expr [$w index insert]+1]
	    set estr [$w get]
	    while {$endx < [string length $estr] &&
	      [regexp $btp(not-word) [string index $estr $endx]]} {
	        incr endx
	    }
	    while {$endx < [string length $estr] &&
	      ![regexp $btp(not-word) [string index $estr $endx]]} {
	        incr endx
	    } 
	    $w icursor $endx
	}
    } else {
        for {set i 0} {$i > $num } {incr i -1} {
	    set endx [expr [$w index insert]-2]
	    set estr [$w get]
	    while {$endx > 0 &&
	       [regexp $btp(not-word) [string index $estr $endx]]} {
	        incr endx -1
	    }
	    while {$endx > 0 &&
	       ![regexp $btp(not-word) [string index $estr $endx]]} {
	        incr endx -1
	    }
	    if {$endx > 1} {incr endx}
	    $w icursor $endx
	}
    }
    tk_entrySeeCaret $w
    set btp(prevcmd) "move-word"
}

proc be:begin-line { w } {
    global btp
    set btp(lastkill-entry) -1
    $w select clear
    $w icursor 0
    tk_entrySeeCaret $w
    set btp(arg) def
    set btp(prevcmd) begin-line
}

proc be:end-line { w } {
    global btp
    set btp(lastkill-entry) -1
    $w select clear
    $w icursor end
    tk_entrySeeCaret $w
    set btp(arg) def
    set btp(prevcmd) end-line
}

proc be:delete-back-char-or-sel { w {num 1} } {
    global btp
    set btp(lastkill-entry) -1
    if {$btp(arg) != "def"} {
	set num [expr $num*$btp(arg)]
	set btp(arg) def
    }
    if {[catch {$w delete sel.first sel.last}] != 0} {
        set x [expr [$w index insert] - $num]
        catch {$w delete $x}
	tk_entrySeeCaret $w
    }
    set btp(prevcmd) delete-back-char-or-sel
}

proc be:delete-word { w {num 1}} {
    global btp
    $w select clear
    if {$btp(lastkill-entry) == [$w index insert]} {
	set lastcut [bt:pop-cut]
    } else { set lastcut "" }
    set beg [$w index insert]
    if {$btp(arg) != "def"} {
	set num $btp(arg)
	set btp(arg) def
    }
    be:move-word $w $num
    set endx [$w index insert]
    if {$beg < $endx} {
	incr endx -1
	bt:push-cut "$lastcut[string range [$w get] $beg $endx]"
	$w delete $beg $endx
    } else {
	incr beg -1
	bt:push-cut "[string range [$w get] $endx $beg]$lastcut"
	$w delete $endx $beg
    }
    set btp(lastkill-entry) [$w index insert]
    tk_entrySeeCaret $w
    set btp(prevcmd) delete-word
}

proc be:delete-line { w } {
    global btp
    if {$btp(lastkill-entry) == [$w index insert]} {
	set lastcut [bt:pop-cut]
    } else { set lastcut "" }
    $w select clear
    bt:push-cut "$lastcut[string range [$w get] [$w index insert] end]"
    $w delete [$w index insert] end
    set btp(lastkill-entry) [$w index insert]
    tk_entrySeeCaret $w
    set btp(arg) def
    set btp(prevcmd) delete-line
}

proc be:delete-region-or-sel { w } {
    global btp
    if {[catch "$w index sel.first"]} {
	$btp(error) "Sorry! No emacs mark for entries yet!"
    } else {
	bt:push-cut [selection_if_any]
	$w delete sel.first sel.last
    }
    tk_entrySeeCaret $w
    set btp(lastkill-entry) -1
    set btp(arg) def
    set btp(prevcmd) delete-region-or-sel
}

proc be:copy-region-or-sel { w } {
    global btp
    if {[catch "$w index sel.first"]} {
	$btp(error) "Sorry! No emacs mark for entries yet!"
    } else {
	bt:push-cut [selection_if_any]
	$w select clear
    }
    tk_entrySeeCaret $w
    set btp(lastkill-entry) -1
    set btp(arg) def
    set btp(prevcmd) copy-region-or-sel
}

proc be:append-next-kill { w } {
    global btp
    set btp(lastkill-entry) [$w index insert]
}

proc be:yank { w {num 1}} {
    global btp
    $w select clear
    if {$btp(arg) != "def"} {
	set num $btp(arg)
	set btp(arg) def
    }
    set btp(lastkill-entry) -1
    set btp(entry-yank-mark) [$w index insert]
    $w insert insert [bt:get-cut $num]
    tk_entrySeeCaret $w
    set btp(prevcmd) yank
}

proc be:yank-pop { w {num 1}} {
    global btp
    if {$btp(arg) != "def"} {
	set num $btp(arg)
	set btp(arg) def
    }
    if {$btp(prevcmd) != "yank"} return
    $w select clear
    $w delete $btp(entry-yank-mark) [expr [$w index insert]-1]
    $w insert insert [bt:get-cut [expr $num+1]]
    tk_entrySeeCaret $w
}

proc be:set-mark { w } {
    global btp
    $btp(error) "Sorry! No emacs mark for entries yet!"
}


proc be:exchange-point-and-mark { w } {
    global btp
    $btp(error) "Sorry! No emacs mark for entries yet!"
}

proc be:argkey { w a } {
    global btp
    set btp(arg) $a
} 

proc be:numkey { w a } {
    global btp
    if {$btp(arg) == "def"} {
	catch {%W delete sel.first sel.last}
	$w insert insert $a
	tk_entrySeeCaret $w
	set btp(lastkill-entry) -1
	set btp(prevcmd) self-insert
    } else {
	if {$a == "-"} {
	    if {$btp(arg) == "-"} { 
		set btp(arg) "0" 
	    } elseif {$btp(arg) == "0"} {
		set btp(arg) "-"
	    } else {
		set btp(arg) [expr -1*$btp(arg)]
	    }
	} else {
	    append btp(arg) $a
	}
    }
} 

proc be:univ-arg { w } {
    global btp
    if {$btp(arg) == "def"} {
	set btp(arg) 4
    } else {
	if {$btp(arg) == "-"} { 
	    set btp(arg) "-4" 
	} else {
	    set btp(arg) [expr 4*$btp(arg)]
	}
    }
}

proc bind_motifentry { ew } {
    global bind_xnd

    bind $ew <Control-KeyPress> {
        global btp
	if {"%A" != ""} {eval $btp(beep) }
    }

    bind $ew <Delete> {be:delete-back-char-or-sel %W 1}
    bind $ew <BackSpace> {be:delete-back-char-or-sel %W 1}
    bind $ew <Left> {be:move-char %W -1}
    bind $ew <Right> {be:move-char %W 1}
    bind $ew <Control-Left> {be:move-word %W -1}
    bind $ew <Control-Right> {be:move-word %W 1}
    bind $ew <Home> {be:begin-line %W}
    bind $ew <End> {be:end-line %W}

    bind $ew <Any-KeyPress> {
        global btp
	if {"%A" != ""} {
	    catch {%W delete sel.first sel.last}
	    %W insert insert %A
	    tk_entrySeeCaret %W
	    set btp(lastkill-entry) -1
	    set btp(prevcmd) self-insert
	}
    }

    bind $ew <1> "[bind Entry <1>]; \
                  global btp; set btp(lastkill-entry) -1; \
		  set btp(prevcmd) mouse-set"
    bind $ew <Double-Button-1> {%W select from 0; %W select to end}
    bind $ew <3> {%W select clear}
    bind $ew <Shift-2> {%W scan mark %x}
    bind $ew <Shift-B2-Motion> {%W scan dragto %x}

    set bind_xnd(b2-time) 0
    bind $ew <2> {
        global bind_xnd
        %W scan mark %x
        set bind_xnd(b2-time) %t
    }
    bind $ew <ButtonRelease-2> {
        global bind_xnd btp
	if {[expr %t-$bind_xnd(b2-time)]<1000} {
	    set btp(lastkill-entry) -1
	    %W insert insert [selection_if_any]
 	    set btp(prevcmd) mouse-insert
        }
    }

}

proc bind_emacsentry { ew } {
    global btp

    # make Escape key simulate Alt key
    bind $ew <Escape> { }
    bind $ew <Escape><Any-KeyPress> {
        global btp
	if {"%A" != ""} {eval $btp(beep) }
    }

    bind $ew <KeyPress-0> {be:numkey %W %A}
    bind $ew <KeyPress-1> {be:numkey %W %A}
    bind $ew <KeyPress-2> {be:numkey %W %A}
    bind $ew <KeyPress-3> {be:numkey %W %A}
    bind $ew <KeyPress-4> {be:numkey %W %A}
    bind $ew <KeyPress-5> {be:numkey %W %A}
    bind $ew <KeyPress-6> {be:numkey %W %A}
    bind $ew <KeyPress-7> {be:numkey %W %A}
    bind $ew <KeyPress-8> {be:numkey %W %A}
    bind $ew <KeyPress-9> {be:numkey %W %A}

    bind $ew <Control-u> {be:univ-arg %W}
    bind $ew <Escape><KeyPress-0> {be:argkey %W %A}
    bind $ew <Escape><KeyPress-1> {be:argkey %W %A}
    bind $ew <Escape><KeyPress-2> {be:argkey %W %A}
    bind $ew <Escape><KeyPress-3> {be:argkey %W %A}
    bind $ew <Escape><KeyPress-4> {be:argkey %W %A}
    bind $ew <Escape><KeyPress-5> {be:argkey %W %A}
    bind $ew <Escape><KeyPress-6> {be:argkey %W %A}
    bind $ew <Escape><KeyPress-7> {be:argkey %W %A}
    bind $ew <Escape><KeyPress-8> {be:argkey %W %A}
    bind $ew <Escape><KeyPress-9> {be:argkey %W %A}
    bind $ew <Escape><KeyPress-minus> {be:argkey %W %A}

    bind $ew <Control-a> {be:begin-line %W}
    bind $ew <Control-e> {be:end-line %W}
    bind $ew <Control-b> {be:move-char %W -1}
    bind $ew <Control-f> {be:move-char %W 1}
    bind $ew <Escape><b> {be:move-word %W -1}
    bind $ew <Escape><f> {be:move-word %W 1}

    bind $ew <Control-l> {
	tk_entrySeeCaret %W
    }

    bind $ew <Control-d> {be:delete-back-char-or-sel %W 0}
    bind $ew <Escape><KeyPress-d> {be:delete-word %W 1}
    bind $ew <Control-k> {be:delete-line %W}
    bind $ew <Control-w> {be:delete-region-or-sel %W}
    bind $ew <Escape><KeyPress-w> {be:copy-region-or-sel %W}
    bind $ew <Control-y> {be:yank %W}
    bind $ew <Escape><KeyPress-y> {be:yank-pop %W}
    bind $ew <Control-space> {be:set-mark %W}

    bind $ew <Control-h> {be:delete-back-char-or-sel %W 1}

    # make C-x key a state
    bind $ew <Control-x> { }
    bind $ew <Control-x><Any-KeyPress> {
        global btp
	if {"%A" != ""} {eval $btp(beep) }
    }
    bind $ew <Control-x><Control-x> {be:exchange-point-and-mark %W}

    # Make Meta key like and Escape prefix
    if {$btp(use-meta)} {
	bind $ew <Meta-KeyPress> {
	    global btp
	    if {"%A" != ""} {eval $btp(beep) }
	}
	bind $ew <Control-Meta-KeyPress> {
	    global btp
	    if {"%A" != ""} {eval $btp(beep) }
	}
        bind $ew <Meta-b> {be:move-word %W -1}
        bind $ew <Meta-f> {be:move-word %W 1}
        bind $ew <Meta-d> {be:delete-word %W 1}
	bind $ew <Meta-w> {be:copy-region-or-sel %W}
	bind $ew <Meta-y> {be:yank-pop %W}

	bind $ew <Meta-0> {be:argkey %W %A}
	bind $ew <Meta-1> {be:argkey %W %A}
	bind $ew <Meta-2> {be:argkey %W %A}
	bind $ew <Meta-3> {be:argkey %W %A}
	bind $ew <Meta-4> {be:argkey %W %A}
	bind $ew <Meta-5> {be:argkey %W %A}
	bind $ew <Meta-6> {be:argkey %W %A}
	bind $ew <Meta-7> {be:argkey %W %A}
	bind $ew <Meta-8> {be:argkey %W %A}
	bind $ew <Meta-9> {be:argkey %W %A}
	bind $ew <Meta-minus> {be:argkey %W %A}
    }
}

############################################################################
############################################################################
############################################################################
# kick off the entire process

bind_motifentry Entry
bind_motiftext  Text


getSignOn


############################################################################
# all procs follow

########################
#
# tryConnect
#
#   try a connection to the sybase server
#

proc tryConnect {id pw ser} {
  global sybmsg
  global syb
  global server

  set server $ser

  set retcode [catch {set syb [sybconnect $id $pw $ser]}]

  if $retcode==0 {
    destroy .s
    createMain
  } else  {
    .s.err configure -text $sybmsg(dberrstr)
    focus .s.p.pw
  }
}


########################
#
# createMain
#
#   create the main window
#

proc createMain {} {
  global syb
  global sybmsg
  global currentFile

  wm geom    . 600x500
  wm minsize . 400 370

  # create a top level frame

  frame .m -relief flat

  pack .m -side top -fill both -expand 1

  # create a menu bar with some menu buttons

  frame .m.mb -relief raised -borderwidth 2
  menubutton .m.mb.file -text "File" -menu .m.mb.file.m
  menu .m.mb.file.m
  .m.mb.file.m add command -label "New" -command doNew
  .m.mb.file.m add command -label "Open..." \
			   -command "fileBox .Open * \"\" \"\" tryOpen"
  .m.mb.file.m add command -label "Save" -command doSave 
  .m.mb.file.m add command -label "Save as..." \
			   -command "fileBox .Save * \"\" \"\" doSaveAs"
  .m.mb.file.m add separator
  .m.mb.file.m add command -label "Exit"  -command confirmExit 

  menubutton .m.mb.out -text "Results" -menu .m.mb.out.m
  menu .m.mb.out.m
  .m.mb.out.m add command -label "Clear" -command clearoutput
  .m.mb.out.m add command -label "Save as..." \
		  -command "fileBox .Save_Results * \"\" \"\" doSaveOut"
  .m.mb.out.m add command -label "Print" -command doPrint
  .m.mb.out.m add cascade -label "Font Size  " -menu .m.mb.out.m.f
  menu .m.mb.out.m.f
  .m.mb.out.m.f add radiobutton -variable fontSize -value  8 -label " 8" \
   -command ".m.o.out configure -font -*-courier-*-r-*-*-8-*-*-*-*-*-*-*"
  .m.mb.out.m.f add radiobutton -variable fontSize -value 10 -label "10" \
   -command ".m.o.out configure -font -*-courier-*-r-*-*-10-*-*-*-*-*-*-*"
  .m.mb.out.m.f add radiobutton -variable fontSize -value 12 -label "12" \
   -command ".m.o.out configure -font -*-courier-*-r-*-*-12-*-*-*-*-*-*-*"
  .m.mb.out.m.f add radiobutton -variable fontSize -value 14 -label "14" \
   -command ".m.o.out configure -font -*-courier-*-r-*-*-14-*-*-*-*-*-*-*"
  .m.mb.out.m.f add radiobutton -variable fontSize -value 17 -label "17" \
   -command ".m.o.out configure -font -*-courier-*-r-*-*-17-*-*-*-*-*-*-*"
  .m.mb.out.m.f add radiobutton -variable fontSize -value 20 -label "20" \
   -command ".m.o.out configure -font -*-courier-*-r-*-*-20-*-*-*-*-*-*-*"

  menubutton .m.mb.db -text "Databases" -menu .m.mb.db.m
  menu .m.mb.db.m
  sybsql $syb "sp_helpdb"
  set dbname [lindex [sybnext $syb] 0]
  while {[string compare $sybmsg(nextrow) REG_ROW] == 0} {
    if {[string match model $dbname] == 0} {
      .m.mb.db.m add command -label $dbname -command "useDB $dbname"
    }
    set dbname [lindex [sybnext $syb] 0]
  }

  menubutton .m.mb.ob -text "Objects" -menu .m.mb.ob.m
  menu .m.mb.ob.m
  .m.mb.ob.m add command  -label "Tables"   -command showTables
  .m.mb.ob.m add command  -label "Views"    -command "showObjs Views V"
  .m.mb.ob.m add command  -label "Procs"    -command "showObjs Procedures P"
  .m.mb.ob.m add command  -label "Rules"    -command "showObjs Rules R"
  .m.mb.ob.m add command  -label "Triggers" -command "showObjs Triggers TR"

  # execCmd is normally "doSql", except while in doSql, then it is Cancel
  button .m.mb.exec  -text "Execute" -command {eval $execCmd}   -relief flat

  menubutton .m.mb.help -text "Help" -menu .m.mb.help.m
  menu .m.mb.help.m
  .m.mb.help.m add command -label "General" -command generalHelp
  .m.mb.help.m add cascade -label "Menus  "   -menu .m.mb.help.m.m
  .m.mb.help.m add command -label "About"   -command aboutHelp

  menu .m.mb.help.m.m
  .m.mb.help.m.m add command -label "File"   -command menuHelpFile
  .m.mb.help.m.m add command -label "Results"   -command menuHelpOut
  .m.mb.help.m.m add command -label "Databases" -command menuHelpDB
  .m.mb.help.m.m add command -label "Objects" -command menuHelpObjs
  .m.mb.help.m.m add command -label "Execute" -command menuHelpExec

  pack .m.mb      -side top -fill x
  pack .m.mb.file  .m.mb.out  .m.mb.db  .m.mb.ob  .m.mb.exec -side left 
  pack .m.mb.help -side right

  tk_bindForTraversal .m.mb
  tk_menuBar .m.mb .m.mb.file .m.mb.out .m.mb.db \
		    .m.mb.ob .m.mb.exec .m.mb.help 

  # create a top title

  label .m.title -text "dbname" -relief raised \
		-font -*-helvetica-bold-o-*-*-20-*-*-*-*-*-*-*

  pack .m.title -side top

  # create a frame listing sql code

  frame .m.s -relief raised -borderwidth 2
  pack .m.s -side top -fill both

  label .m.s.l -text "SQL (noname)" 
  scrollbar .m.s.vert -relief sunken -command ".m.s.sql yview" \
	  -orient vertical
  text .m.s.sql -font -*-courier-*-r-*-*-14-*-*-*-*-*-*-* -relief sunken \
	  -height 8 -width 80 -yscroll ".m.s.vert set"  -wrap word \
	  -borderwidth 2
  bind .m.s.sql <Control-Return> ".m.mb.exec invoke"
  bind .m.s.sql <Shift-Return>   ".m.mb.exec invoke"
  pack .m.s.l    -side top -fill x
  pack .m.s.vert -side right -fill y
  pack .m.s.sql  -side left -fill both  -expand 1


  # create a frame listing sql output

  frame .m.o -relief raised
  pack .m.o -side top -fill both -expand 1

  label .m.o.l -text "Results"
  scrollbar .m.o.vert -relief sunken -command ".m.o.out yview" \
	  -orient vertical
  scrollbar .m.o.horz -relief sunken -command ".m.o.out xview" \
	  -orient horizontal
  listbox .m.o.out -relief sunken \
          -font -*-courier-*-r-*-*-14-*-*-*-*-*-*-*  \
	  -yscroll ".m.o.vert set" -xscroll ".m.o.horz set"
  pack .m.o.l    -side top -fill x
  pack .m.o.vert -side right -fill y
  pack .m.o.horz -side bottom -fill x
  pack .m.o.out  -side left -fill both -expand 1


  # create a message at the bottom

  #label .m.msg -text "" -width 40 -relief sunken 
  message .m.msg -text "" -justify center -aspect 1000 -relief sunken \
	-font -*-helvetica-bold-o-*-*-17-*-*-*-*-*-*-*
    
  pack .m.msg -side bottom -fill x

  focus .m.s.sql

  useDB [sybuse $syb]

  .m.msg configure -text "At your service....."

}



########################
#
# useDB
#
#   use a database
#

proc useDB {dbname} {
  global syb
  global server

  catch {sybuse $syb $dbname}
  set dbname [sybuse $syb]
  .m.title configure -text "server: $server - database: $dbname"
  setMsg "database changed to $dbname"

}


########################
#
# setMsg
#
#   set the text for the label at bottom of results window
#

proc setMsg {msg_text}  {
  .m.msg configure -text $msg_text
  update
}


########################
#
# confirmExit
#
#   really exit
#
proc confirmExit {} {

  mkDialog .Confirm_Exit {-text "Really Exit?"} \
	     "{Yes, damnit}  {destroy . ; exit}" "Cancel {}"
}

########################
#
# clearsql
#
#   clear the sql code window
#
proc clearsql {} {
  global currentFile

  .m.s.sql delete 1.0 end
  .m.s.l   configure -text "SQL (noname)"
  set currentFile ""
  setMsg ""
  focus .m.s.sql
}


########################
#
# clearoutput
#
#   clear the output listbox
#
proc clearoutput {} {

  .m.o.out delete 0 end
  setMsg ""
  focus .m.s.sql
}


########################
#
# tryOpen
#
#    try to open the file passed by fileBox stuff
#

proc tryOpen {win filename} {

  global currentFile

  if [file isfile $filename] {
    clearsql
    clearoutput
    set currentFile [file tail $filename]
    .m.s.l   configure -text "SQL (${currentFile})"
    set result_lines [exec cat -s $filename]
    .m.s.sql insert 1.0 "$result_lines"
    setMsg "$filename loaded"
    destroy $win
  } else {
    setMsg "$filename not found"
  }
  focus .m.s.sql

}




########################
#
# doSaveAs
#
#    save the sql code
#

proc doSaveAs {win filename} {
  global currentFile

  set openrc [catch {set f [open $filename w]}]
  
  if $openrc==1 {
    setMsg "Error: $filename could not be opened, not saved"
    return
  }

  set currentFile $filename
  .m.s.l   configure -text "SQL (${currentFile})"

  puts $f [.m.s.sql get 1.0 end]
  close $f
  setMsg "SQL saved to $currentFile"

  destroy $win
}



########################
#
# doSaveOut
#
#    save the sql results
#

proc doSaveOut {win filename} {

  set openrc [catch {set f [open $filename w]}]
  
  if $openrc==1 {
    setMsg "Error: $filename could not be opened, not saved"
    return
  }

  if [.m.o.out size]==0 {
    setMsg "No output to save"
    close $f
    return
  }

  for {set i 0} {$i < [.m.o.out size]} {incr i} {
    puts $f [.m.o.out get $i]
  }
  close $f
  setMsg "Results saved to $filename"
  destroy $win
}




########################
#
# doPrint
#
#    print the sql results
#

proc doPrint {} {

  
  if [.m.o.out size]==0 {
    setMsg "No output to print"
    return
  }

  for {set i 0} {$i < [.m.o.out size]} {incr i} {
    append out_lines "[.m.o.out get $i]\n"
  }
  
  setMsg [exec lp << $out_lines]

}



########################
#
# doSave
#
#    save the sql code to currentFile or use filebox
#

proc doSave {} {
  global currentFile


  if {[string length $currentFile] == 0} {
    fileBox .Save * "" "" doSaveAs
  } else {
    set f [open $currentFile w]
    puts $f [.m.s.sql get 1.0 end]
    close $f
    setMsg "saved to $currentFile"
  }

}




#######################################################################
# procs to support a file selection dialog box

########################
#
# fillLst
#
#    fill the fillBox listbox with selection entries
#

proc fillLst {win filt dir} {
  
  $win.l.lst delete 0 end

  cd $dir

  set dir [pwd]
  
  if {[string length $filt] == 0} {
    set filt *
  }
  set all_list [lsort [glob -nocomplain $dir/$filt]]

  set dlist  "$dir/../"
  set flist ""

  foreach f $all_list {
    if [file isfile $f] {
      lappend flist $f
    }
    if [file isdirectory $f] {
      lappend dlist ${f}/
    }
  }

  foreach d $dlist {
    $win.l.lst insert end $d
  }
  foreach f $flist {
    $win.l.lst insert end $f
  }

  $win.l.lst yview 0

  set idx [expr [string length [file dirname [file dirname $dir]] ]+1]

  $win.l.lst xview $idx
}


########################
#
# selInsert
#
#   insert into a selection entry, scroll to root name
#
proc selInsert {win pathname} {
  $win.sel delete 0 end
  $win.sel insert 0 $pathname
  set idx [expr [string length [file dirname [file dirname $pathname]] ]+1]
  $win.sel view $idx
  $win.sel select from 0
}


########################
#
# fileOK
#
#   do the OK processing for fileBox
#

proc fileOK {win execproc} {
  
  # might not have a valid selection, so catch the selection
  catch {  selInsert $win [lindex [selection get] 0] }

  set f [lindex [$win.sel get] 0]
  if [file isdirectory $f] {
    #set f [file dirname $f]
    #set f [file dirname $f]
    cd $f
    set f [pwd]
    fillLst $win [$win.fil get] $f
  } else {
    # we don't know if a file is really there or not, let the execproc
    # figure it out.  also, window is passed if execproc wants to kill it.
    $execproc $win $f 
  }
}

########################
#
# fileBox
#
#   put up a file selection box
#    win - name of toplevel to use
#    filt - initial file selection filter 
#    initfile - initial file selection 
#    startdir - initial starting dir
#    execproc - proc to exec with selected file name
#
proc fileBox {win filt initfile startdir execproc} {

  set win_title $win
  regsub -all {_} $win_title " " win_title
  set win [translit A-Z a-z $win]
  
  catch {destroy $win}
  toplevel $win
  wm title $win [string range $win_title 1 end]

  wm transient $win .
  set xpos [expr [winfo rootx .]+[winfo width .]/6]
  set ypos [expr [winfo rooty .]+[winfo height .]/6]

  wm geom $win 300x500+${xpos}+$ypos
  wm minsize $win 300 500

  if {[string length $startdir] == 0} {
    set startdir [pwd]
  }

  label $win.l1   -text "File Filter" -anchor w
  entry $win.fil  -relief sunken
  $win.fil insert 0 $filt
  label $win.l2   -text "Files" -anchor w
  frame $win.l  -bg red
  scrollbar $win.l.hor -orient horizontal -command "$win.l.lst xview" \
	    -relief sunken
  scrollbar $win.l.ver -orient vertical   -command "$win.l.lst yview" \
	    -relief sunken
  listbox $win.l.lst -yscroll "$win.l.ver set" -xscroll "$win.l.hor set" \
	    -relief sunken
  label $win.l3   -text "Selection" -anchor w
  scrollbar $win.scrl -orient horizontal -relief sunken \
                      -command "$win.sel view"
  entry $win.sel  -relief sunken -scroll "$win.scrl set"
  selInsert $win $initfile
  frame $win.o  -relief sunken -border 1
  button $win.o.ok -text "Ok" -command "fileOK $win $execproc"
  button $win.filter -text "Filter" \
	  -command "fillLst $win \[$win.fil get\] \[pwd\]"
  button $win.can    -text "Cancel" -command "destroy $win"

  pack $win.l1   -side top -fill x
  pack $win.fil  -side top -pady 15 -fill x
  pack $win.l2 $win.l $win.l3 -side top -fill x
  pack $win.sel  -side top -pady 15 -fill x
  pack $win.scrl -side top -fill x
  pack $win.o $win.filter $win.can   -side left -expand 1 -padx 20

  pack $win.l.ver -side right -fill y
  pack $win.l.hor -side bottom -fill x
  pack $win.l.lst -side left -fill both -expand 1

  pack $win.o.ok  -side left -expand 1 -padx 20 -pady 20

  bind $win.fil <KeyPress-Return> "$win.filter invoke"
  bind $win.sel <KeyPress-Return> "$win.o.ok   invoke"
  bind $win.l.lst <ButtonRelease-1> \
   "+selInsert $win \[%W get \[ %W nearest %y \] \] "
  bind $win.l.lst <Double-1> \
   "selInsert $win \[lindex \[selection get\] 0\];  $win.o.ok invoke"
  bind $win.l.lst <Button1-Motion> ""
  bind $win.l.lst <Shift-Button1-Motion> ""
  #bogus any-button1-motion, "" does not seem to work (bind patch might fix)
  bind $win.l.lst <Any-Button1-Motion> "$win.l.lst size"
  bind $win <1> "$win.o.ok config -relief sunken"
  bind $win <ButtonRelease-1> \
	"$win.o.ok invoke ; $win.o.ok deactivate"
  bind $win <Return> "$win.o.ok invoke "
  bind $win.o <Enter> "$win.o.ok activate"
  bind $win.o <Leave> "$win.o.ok deactivate"


  fillLst $win $filt $startdir
  selection own $win
  focus $win

}

#
# end of the file selection box stuff
###########################################################################



########################
#
# doNew
#
#   clear windows
#
proc doNew {} {
  global currentFile

  clearoutput
  clearsql

  setMsg ""
  focus .m.s.sql

  set currentFile ""
}



########################
#
# chkMsg
#
#   check for server message, add to result window if not null
#

proc chkMsg {} {
  global sybmsg

  if {[string length $sybmsg(msgtext)] > 0} {
    set msgs [split $sybmsg(msgtext) \n]
    set msgn [split $sybmsg(msgno)   \n]
    set i 0
    foreach f $msgs {
      set msgno ""
      catch {set msgno [lindex $msgn $i]}
      .m.o.out insert end "$msgno: $f"
      incr i
    }
  }

}



########################
#
# doSql
#
#   exec existing sql source
#
proc doSql {} {
  global syb
  global sybmsg
  global execCmd
  global contFlag

  set contFlag 1

  set execCmd "set contFlag 0"
  .m.mb.exec configure -text "Cancel" -state active
 
  # first make a dash line, 256 chars long
  set d [replicate "----------------" 16]

  set txtindx ""
  set txtcols ""
  set txtdata ""
  set txtlens ""
  set row ""
  set cnt 0
  set sql_str [.m.s.sql get 1.0 end]
  set sql_filt ""

  clearoutput

  # filter out lines beginning with "#" or lines with "go"
  foreach f [split $sql_str \n] {
    # filter out comments
    set  ex1 [regexp -nocase "^#.*$|^ *#.*$" $f]
    # filter out "go"s
    set  ex2 [regexp -nocase "^go.*$|^ *go.*$" $f]
    if !$ex1$ex2 {
      append sql_filt "$f\n"
    } else {
      append sql_filt "\n"
    }
  }

  if {[string length $sql_filt] == 0} {
    setMsg "No SQL to execute"
    set execCmd doSql
    .m.mb.exec configure -text "Execute" -state active
    return
  }

  setMsg "Running SQL"
  set dbret [catch {sybsql $syb $sql_filt}]

  if $dbret==1 {
    setMsg "Error: line $sybmsg(line): $sybmsg(msgno) : $sybmsg(msgtext)"
    set execCmd doSql
    .m.mb.exec configure -text "Execute" -state active
    return
  } else {
    setMsg "SQL finished, getting results"
    chkMsg
  }

  set fmt ""
  if {[string compare $sybmsg(nextrow) NO_MORE_ROWS] != 0} {
    set row [sybnext $syb]
    chkMsg
  }
  set lastnext $sybmsg(nextrow)

  while {$contFlag && \
	 (([string compare $sybmsg(nextrow) NO_MORE_RESULTS] != 0) || \
          ([string length $sybmsg(retstatus)] > 0) ) }  {

    if {[string length $sybmsg(retstatus)] > 0} {
      set row [sybretval $syb]
      chkMsg
      set fmt ""
    }

    if {[string length $fmt] == 0} {
      set col_names [sybcols $syb]
      chkMsg
      # extract text columns into separate areas
      set i [lsearch $sybmsg(coltypes) text]
      while {$i >= 0} {
	lappend txtindx $i
	lappend txtcols [lvarpop col_names $i]
	lappend txtlens [lvarpop sybmsg(collengths) $i]
	lvarpop sybmsg(coltypes) $i
        set i [lsearch $sybmsg(coltypes) text]
      }
      set fmt [formatCols $col_names $sybmsg(coltypes) $sybmsg(collengths)]
      .m.o.out insert end [eval format \"$fmt\" $col_names]
      set dash $col_names
      for {set i 0} {$i < [llength $dash]} {incr i} {
	set dash [lreplace $dash $i $i $d]
      }
      .m.o.out insert end [eval format \"$fmt\" $dash]
    }

    if {[string length $row] == 0} {
      set fmt ""
    }  else {
      set txtdata ""
      foreach i $txtindx {
        lappend txtdata [lvarpop row $i]
      }
      .m.o.out insert end [eval format \"$fmt\" $row]
      incr cnt
      if {[llength $txtindx] > 0} {
	set i 0
	foreach t $txtcols {
	  .m.o.out insert end "" [lindex $txtcols $i]
	  .m.o.out insert end [string range $d 0 30]
	  eval .m.o.out insert end [split [lindex $txtdata $i] \n]
	  .m.o.out insert end "" 
	}
      }
    }

    set row [sybnext $syb]  
    chkMsg
    if {[string compare $lastnext $sybmsg(nextrow)] != 0} {
      set fmt ""
      set txtindx ""
      set txtcols ""
      set txtdata ""
      set txtlens ""
      set lastnext $sybmsg(nextrow)
    }

    if {$cnt % 20 == 0} {
      setMsg "$cnt rows so far..."
      update
    }


  }

  if {$contFlag == 1} {
    setMsg "SQL finished, $cnt rows returned "
  } else {
    setMsg "SQL interrupted, $cnt rows returned "
  }

  set execCmd doSql
  .m.mb.exec configure -text "Execute" -state active

}



########################
#
# formatCols
#
#   return a format to use in column printing
#   names, types, and lengths are lists of equal size
#
proc formatCols {names types lengths} {

  set fmt ""
 
  while {! [lempty $names] } {
    set t [lvarpop types]
    set l [lvarpop lengths]
    set n [lvarpop names]

    # set a length based on type
    # text, image, and binary get defaults

    case $t {
      {int}   {set len 12 ; set just "" }
      {tinyint}   {set len 4 ; set just "" }
      {smallint}   {set len 6 ; set just "" }
      {float real}   {set len 12 ; set just "" }
      {*money} {set len 17 ; set just "" }
      {*date}  {set len 26 ; set just - }
      {*char}  {set len $l ; set just - }
      {default} {set len 32 ; set just - }
    }

    # make sure length is as long as colunm name 
    set len [max $len [string length $n]]

    append fmt "%${just}${len}.${len}s "

  }
  return $fmt
}


########################
#
# showFields
#
#   create a toplevel window with a table's fields
#
proc showFields {tab} {
  global syb
  global sybmsg

  set plist ""
  set dbname [sybuse $syb]

  # use to use "sp_help tabname", changed to get the info directly from
  # system tables, now shows full column name to 30 characters
  # (thanks to Paul Friberg for this change)

  sybsql $syb "select syscolumns.name, systypes.name, syscolumns.length \
	       from syscolumns, sysobjects, systypes \
	       where  syscolumns.id=sysobjects.id and sysobjects.name= '$tab' \
	       and syscolumns.usertype= systypes.usertype "


  sybnext $syb {
    set n @1
    set t @2
    if {[string match "*char" $t]} {
      set t ${t}([lindex @0 2])
    }
    lappend plist [format "%-30.30s %-15.15s" $n $t]
  }

  if {[llength $plist] == 0} {
    setMsg "No fields in table $tab"
    return
  }
  pickList .$dbname:$tab Fields 430x300 $plist ""
}



########################
#
# showTables
#
#   create a toplevel window with user tables
#
proc showTables {} {
  global syb
  global sybmsg

  set plist ""
  set dbname [sybuse $syb]
  sybsql $syb "select name from sysobjects where type = 'U'"

  sybnext $syb {lappend plist @0}

  if {[llength $plist] == 0} {
    setMsg "No user tables in $dbname"
    return
  }
  pickList .$dbname:Tables Tables 200x400 [lsort $plist] showFields
}



########################
#
# getObj
#
#   create a toplevel window with user object text
#
proc getObj {objname} {
  global syb
  global sybmsg

  set dbname [sybuse $syb]
  sybsql $syb "select text from syscomments \
		      where id = object_id(\"$objname\")"

  set plist ""
  set row [lindex [sybnext $syb] 0]
  while {[string compare $sybmsg(nextrow) REG_ROW] == 0} {
    eval lappend plist [split $row \n]
    set row [lindex [sybnext $syb] 0]
  }
  pickList .$dbname:$objname "Object Text" 600x300 $plist ""
}



########################
#
# showObjs
#
#   create a toplevel window with user objects
#
proc showObjs {objclass objtype} {
  global syb
  global sybmsg

  setMsg ""
  set plist ""
  set dbname [sybuse $syb]
  sybsql $syb "select name from sysobjects where type= '$objtype' order by name"

  sybnext $syb {lappend plist @0}

  if {[llength $plist] == 0} {
    setMsg "No $objclass in $dbname"
    return
  }
  pickList .$dbname:$objclass $objclass 200x250 $plist getObj
}



proc generalHelp {} {
  mkDialog .General_Help {-text "Windowing ISQL is a subset of the \
  Sybase ISQL command. "} {OK {}}
}

proc menuHelpFile {} {
  mkDialog .General_Help {-text "File Menu\n\n\
  New - Clears SQL and Result windows, allows entry of SQL code. \n \
  Open - Prompts for a file containing SQL code.\n \
  Save - Saves the contents of the SQL window into the current filename.\n \
  Save As - Saves the contents of the SQL window, prompting for filename.\n\n \
  Exit - Exits Windowing ISQL with confirmation.\n\
  "} {OK {}}
}

proc menuHelpOut {} {
  mkDialog .General_Help {-text "Results Menu\n\n\
  Clear - Clears the Results window.\n\
  Save As - Saves the contents of the Results window into a file.\n\
  Print - Prints the contents of the Results window to the 'lp' command.\n\
  Font Size - Set the size of the Results window font.\n\
  "} {OK {}}
}


proc menuHelpDB {} {
  mkDialog .General_Help {-text "Database Menu\n\n\
  All available databases in the server are displayed.  Selecting a \
  database will cause that database to be used. \
  "} {OK {}}
}

proc menuHelpObjs {} {
  mkDialog .General_Help {-text "Objects Menu\n\n\
  Selecting a object type will display a list of objects \
  present in the database. \n\n\
  Selecting an object in the display list will display the detail of \
  the selected object. \
  "} {OK {}}
}

proc menuHelpExec {} {
  mkDialog .General_Help {-text "Execute Menu\n\n\
  The currently displayed SQL code is executed.  Results are displayed \
  in the Results window.\n\nLines beginning with \
  a pound sign \"#\" are treated as comments.  \"go\" is not required \
  and is treated as a comment.\n\n\
  Any error messages associated with the \
  SQL code is displayed in the message area. \n\n\
  Control-Return and Shift-Return in the SQL window are bound as accelerator \
  keys for Execute. \
  "} {OK {}}
}

proc aboutHelp {} {
  mkDialog .General_Help {-text "Windowing ISQL\nVersion 2.0\n \
  \nNovember, 1993\n\nTom Poindexter"} {OK {}}
}



########################
#
# pickList
#
#   return a selection from a listbox by calling a proc
#

proc pickList {win heading geom plist callproc} {
  set win_title $win
  regsub -all {_} $win_title " " win_title
  set win [translit A-Z a-z $win]
  
  catch {destroy $win}
  toplevel $win
  wm title $win [string range $win_title 1 end]

  set doproc [string length [info commands $callproc]]
 
  # try to place window away from the main toplevel
  set topgeom [split [split [winfo geom .] x] +]
  set newx [expr {[lindex $topgeom 1] + [lindex [lindex $topgeom 0] 0]} ]
  set newy [expr {[lindex $topgeom 2] + 10}]
  #set newy [expr {[lindex $topgeom 2] + [lindex [lindex $topgeom 0] 1]} ]

  wm geom $win ${geom}+${newx}+$newy
  set w [lindex [split $geom x] 0]
  set h [lindex [split $geom x] 1]
  wm minsize $win $w $h

  frame $win.l 
  frame $win.f 
  frame $win.b -relief sunken -borderwidth 1 -bg blue

  label $win.l.l -text $heading -anchor w \
		 -font "-*-courier-*-r-*-*-14-*-*-*-*-*-*-*" 
  scrollbar $win.f.vert -orient vertical -command "$win.f.box yview" \
			-relief sunken
  listbox $win.f.box -yscroll "$win.f.vert set"  -relief sunken \
	 -font "-*-courier-*-r-*-*-14-*-*-*-*-*-*-*" 
  
  if $doproc {
    bind $win.f.box <Double-1> "$win.b.ok invoke"
  }

  foreach lem $plist {
    $win.f.box insert end $lem
  }

  if $doproc {
    button $win.b.ok  -text "OK"     -relief raised -borderwidth 2 \
		-command "catch \{ $callproc \[selection get\]  \} "
		# -command "$callproc \[selection get\] "
		# -command "$callproc \[selection get\] ; destroy $win "
  }
  button $win.b.can -text "Cancel" -relief raised -borderwidth 2 \
		-command "destroy $win"

  pack $win.l -side top -fill x
  pack $win.f -side top -fill both -expand 1
  pack $win.b -side bottom -fill x

  pack $win.l.l    -side top -fill x -anchor nw
  pack $win.f.vert -side right -fill both 
  pack $win.f.box  -side left -fill both -expand 1

  if $doproc {
    pack $win.b.ok -side left -fill x -expand 1
  }
  pack $win.b.can  -side right -fill x -expand 1

  $win.f.box select from 0

  bind $win.f.box <Any-Button1-Motion> "$win.f.box size"
  bind $win.f.box <Any-Button2-Motion> "$win.f.box size"
}



###########################################################################
#
# stolen from ousterhout's widget demo
#


# mkDialog w msgArgs list list ...
#
# Create a dialog box with a message and any number of buttons at
# the bottom.
#
# Arguments:
#    w -	Name to use for new top-level window.
#    msgArgs -	List of arguments to use when creating the message of the
#		dialog box (e.g. text, justifcation, etc.)
#    list -	A two-element list that describes one of the buttons that
#		will appear at the bottom of the dialog.  The first element
#		gives the text to be displayed in the button and the second
#		gives the command to be invoked when the button is invoked.

proc mkDialog {w msgArgs args} {
  set win_title $w
  regsub -all {_} $win_title " " win_title
  set w [translit A-Z a-z $w]
  
  catch {destroy $w}
  toplevel $w -class Dialog
  wm title $w [string range $win_title 1 end]
  wm transient $w .
  set xpos [expr [winfo rootx .]+[winfo width .]/3]
  set ypos [expr [winfo rooty .]+[winfo height .]/3]
  wm geom $w +${xpos}+$ypos


    # Create two frames in the main window. The top frame will hold the
    # message and the bottom one will hold the buttons.  Arrange them
    # one above the other, with any extra vertical space split between
    # them.

    frame $w.top -relief raised -border 1
    frame $w.bot -relief raised -border 1
    pack $w.top $w.bot -side top -fill both -expand 1
    
    # Create the message widget and arrange for it to be centered in the
    # top frame.
    
    eval message $w.top.msg -justify center \
	    -font -*-times-medium-r-normal--*-180* $msgArgs
    pack $w.top.msg -side top -expand 1 -padx 5 -pady 5
    
    # Create as many buttons as needed and arrange them from left to right
    # in the bottom frame.  Embed the left button in an additional sunken
    # frame to indicate that it is the default button, and arrange for that
    # button to be invoked as the default action for clicks and returns in
    # the dialog.

    if {[llength $args] > 0} {
	set arg [lindex $args 0]
	frame $w.bot.0 -relief sunken -border 1
	pack $w.bot.0 -side left -expand 1 -padx 20 -pady 20
	button $w.bot.0.button -text [lindex $arg 0] \
		-command "[lindex $arg 1]; destroy $w"
	pack $w.bot.0.button -expand 1 -padx 12 -pady 12
	bind $w.top <Enter> "$w.bot.0.button activate"
	bind $w.top.msg <Enter> "$w.bot.0.button activate"
	bind $w.bot <Enter> "$w.bot.0.button activate"
	bind $w.top <Leave> "$w.bot.0.button deactivate"
	bind $w.top.msg <Leave> "$w.bot.0.button deactivate"
	bind $w.bot <Leave> "$w.bot.0.button deactivate"
	bind $w <1> "$w.bot.0.button config -relief sunken"
	bind $w <ButtonRelease-1> \
		"[lindex $arg 1]; $w.bot.0.button deactivate; destroy $w"
	bind $w <Return> "[lindex $arg 1]; destroy $w"
	focus $w

	set i 1
	foreach arg [lrange $args 1 end] {
	    button $w.bot.$i -text [lindex $arg 0] \
		    -command "[lindex $arg 1]; destroy $w"
	    pack $w.bot.$i -side left -expand 1 -padx 20
	    set i [expr $i+1]
	}
    }
}

