#!/usr/local/bin/wish8.0

#  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.
#  version 2.2 - add dialog to set nullvalue; appendclear and command ring 
#                buffer from oratcl's wosql
#  version 2.3 - add selection handler code from wosql.
#                change pack order so broken window managers won't cut off
#                widgets on the bottom.
#                many small tweaks for tk4.0, remove hard coded bindings for
#                native tk4.0 bindings (text & entry)
#                add option value to set float return precision
#  version 2.4 - add package require command, use sybmsg(fixedchar) to
#                ensure procedure and trigger text retrieved fully
#  version 2.5 - use Tk 4.2 builtin procs for dialog, file handling, elminate
#                dependence on tclx
#  version 3.0 - replace sybmsg(floatprec) with tcl_precision
#                add FileOut dialog to save results to files with or without
#		 screen output, options for separators, column headers.
#		 add sybmsg(bgevents) all, break long lists of server and
#                databases into multiple columns; put server and dbname in
#                window title; change pickList to  use text widget if
#                displaying detail info (no callback proc)
#                

package require Tk 
package require Sybtcl

# define global names in use
global sybmsg
global uid
global syb
global currentFile
global server
global fontSize
global execCmd
global cmdRing
global cmdIdx
global cmdLast
global appendclear
# default result append or clear
set appendclear 1

# set what command Execute button should do
set execCmd doSql

# control whether output goes to screen, file, filename, columnar output
global scrnOut
global fileOut
global fileOutName
global fileOutFd
global colOut
global sepChar
global colHdrs
global scrnHdrs
global appendFileOut
set scrnOut 1
set fileOut 0
set fileOutName ""
set fileOutFd ""
set colOut 1
set sepChar \t
set colHdrs 1
set scrnHdrs 1
set appendFileOut 1

# allow screens updates during sybtcl processing.
set sybmsg(bgevents) idletasks

set fontSize 14

if {[info exist env(USER)]} {
  set uid $env(USER)
} else {
  if {[info exist env(HOME)]} {
    set uid [file tail $env(HOME)]
  } else {
    set uid ""
  }
}

set syb {}
set currentFile {}

set cmdIdx  0
set cmdLast 0
for {set i 0} {$i < 10} {incr i} {
  set cmdRing($i) ""
}

wm title    . "Wisqlite"
wm iconname . "Wisql"


########################
#
# getFile
#
#  read a file, return contents as string

proc getFile {afile} {
  set contents ""
  catch { set fd [open $afile]
	set contents [read $fd]
	close $fd }
  return $contents
}


########################
#
# putFile
#
#  write a file from a string

proc putFile {afile contents} {
  catch { set fd [open $afile w]
	puts -nonewline $fd $contents
	close $fd }
}


########################
#
# handleList
#
#  called during a request for primary selection for listboxes and text
#  that bind the "selection get" command for button-2
#
 
proc handleList {w filtproc offset max} {
  set doproc [string length [info commands $filtproc]]
  if {$doproc} {
    set s "[$filtproc $w]"
  } else {
    # set s [$w get [lindex [$w curselection] 0] ]
    set i [$w curselection]
    set n ""
    set s ""
    foreach r $i {
      set l [$w get $r]
      append s "${n}$l"
      set n "\n"
    }
 
  }
  return [string range $s $offset $max]
}
 
########################
#
# filtCols
#
#  a special filtproc to return a column list
#
 
proc filtCols {w} {
  set i [$w curselection]
  set n ""
  set s ""
  foreach r $i {
    set l [$w get $r]
    set l [eval list $l]
    append s "${n}[lindex $l 0]"
    set n ", "
  }
  return "$s"
}
 
########################
#
# filtTab
#
#  a special filtproc to return word 1 "." word 2
#
 
proc filtTab {w} {
  set s [$w get [lindex [$w curselection] 0] ]
  set s [eval list $s]
  return [string trim [lindex $s 0].[lindex $s 1]]
}



########################
#
# getSignOn
#
#   start it off
#

proc getSignOn {} {
  global uid
  global env
  global matchInfo
  global tcl_platform
  global syb

  if {"$syb" != ""} {
    set reconnect 1
  } else {
    set reconnect 0
  }

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

  if {$syb_home == -1} {
      set syb_home ""
      if {$tcl_platform(platform) == "unix"} {
        catch {set syb_home [exec ypcat passwd | egrep  ^sybase: ]}
      }
      if {[string length $syb_home] > 0} {
	  set syb_home [lindex [split $syb_home :] 5]
      } else {
          if {$tcl_platform(platform) == "unix"} {
	    set syb_home [exec egrep ^sybase: < /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 ifile [split [getFile $intFile] \n]
      foreach line $ifile {
        if {[regexp -nocase "(^\[a-z_]\[^ \t\r]*).*$" $line m s1]} {
	  lappend serverList $s1
	}
      }
    } else {
      set serverList SYBASE
    }
  } else {
    set serverList SYBASE
  }

  if {$reconnect} {
    catch {destroy .r}
    toplevel .r
    set win .r
  } else {
    set win .
  }

  
  wm geom     $win 300x330
  wm minsize  $win 300 300
  wm title $win "Wisqlite: Sign On"

  if {"$win" == "."} {set win ""}

  frame $win.s
  message $win.s.m -justify center  -text "SQL Server Sign on" -aspect 2000 \
		-font -*-helvetica-bold-o-*-*-20-*-*-*-*-*-*-*
  frame $win.s.i
  entry $win.s.i.uid -relief sunken  -width 10 
  label $win.s.i.id  -text "  User Id" -anchor e
  frame $win.s.p
  entry $win.s.p.pw  -relief sunken -width 10 -show * -exportselection false
  label $win.s.p.p   -text "  Password" -anchor e

  frame $win.s.s
  entry $win.s.s.ser -relief sunken -width 10 
  menubutton $win.s.s.s -text " Server  " -anchor e -menu $win.s.s.s.m -relief raised
  menu $win.s.s.s.m
  set cnt 0
  foreach s $serverList {
    if {[incr cnt] == 25} {
	set cnt 0
	set col_break 1
    } else {
	set col_break 0
    }
    $win.s.s.s.m add command -columnbreak $col_break -label $s \
		  -command "$win.s.s.ser delete 0 end; $win.s.s.ser insert 0 $s "
  }

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

  frame $win.s.b
  button $win.s.b.ok  -text "Sign on" \
      -command "tryConnect \[$win.s.i.uid get\] \[$win.s.p.pw get\] \[$win.s.s.ser get\]"

  if {$reconnect} {
    button $win.s.b.can -text "Cancel" -command "destroy $win"
  } else {
    button $win.s.b.can -text "Cancel" -command "destroy ."
  }

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

  pack $win.s.err   -side top -fill x -expand 1

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

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

  $win.s.i.uid insert 0 $uid

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

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


}


getSignOn


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

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

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

  if {"$syb" != ""} {
    set reconnect 1
  } else {
    set reconnect 0
  }

  set server $ser

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

  if {$reconnect} {
    set win .r
  } else {
    set win ""
  }

  if {$retcode==0} {
    if {$reconnect} {
      sybclose $syb
    }
    set syb $syb_tmp
    if {$reconnect} {
      destroy $win
      catch {sybuse $syb $dbname}
      set dbname [sybuse $syb]
      # .m.title configure -text "server: $server - database: $dbname"
      wm title    . "Wisqlite: $server.$dbname"
    } else {
      destroy .s
      createMain
    }
    set dbname ""
    catch {set dbname [sybuse $syb]}
    wm iconname . "Wisqlite-$ser"
    wm title    . "Wisqlite: $server.$dbname"
    wm iconname . "Wisql"
  } else  {
    $win.s.err configure -text $sybmsg(dberrstr)
    focus $win.s.p.pw
  }
}




########################
#
# checkIfOutput
#

proc checkIfOutput {} {
  global fileOut
  global scrnOut
 
  if {$fileOut + $scrnOut == 0} {
    setMsg "No output mode selected.  That's not very productive, is it?"
  }  else {
    setMsg ""
  }
}


###############
#
# setEntr - set separator entry on and off
#
proc setEntr {} {
  global colOut
  if {$colOut} {
    .fout.f3.sepl configure -fg gray50
    .fout.f3.entr configure -state disabled
  } else {
    .fout.f3.sepl configure -fg black
    .fout.f3.entr configure -state normal
  }
}


########################
#
# setFileOut
#
#   create the to do the File out dialog
#

proc setFileOut {} {
  global fileOut
  global fileOutName
  global fileOutFd
  global colOut
  global sepChar
  global colHdrs
  global doExp
  global appendFileOut

  set prevValues [list $sepChar $colOut $fileOutName $colHdrs $appendFileOut]
  
  if {! $fileOut} {
      if {"$fileOutFd" != ""} {
        catch {close $fileOutFd}
	set fileOutFd ""
        setMsg "File $fileOutName closed"
      } else {
        checkIfOutput
      }
      return
  }

  catch {destroy .fout}
  toplevel .fout -class Dialog

  wm transient .fout .
  set xpos [expr [winfo rootx .]+[winfo width .]/3]
  set ypos [expr [winfo rooty .]+[winfo height .]/3]
  wm geom .fout +${xpos}+$ypos
  wm title .fout "Set File Output"

  frame .fout.f1 -relief sunken -borderwidth 1

  label .fout.f1.l -text "File Name "
  entry .fout.f1.e -width 30 -relief sunken -textvariable fileOutName
  button .fout.f1.br -text Browse \
	-command {set fileOutName [tk_getSaveFile -title "File Out"]}

  pack .fout.f1.l -side left 
  pack .fout.f1.e -side left -fill x -expand 1
  pack .fout.f1.br -side left -padx 5

  frame .fout.f2 -relief sunken -borderwidth 1
  radiobutton .fout.f2.append -text "Append" -value 1 -variable appendFileOut
  radiobutton .fout.f2.clear  -text "Overwrite" -value 0 -variable appendFileOut
  pack .fout.f2.append .fout.f2.clear -side left -padx 10 -expand 1 -fill x

  if {[string compare $sepChar \t] == 0} {set sepChar \\t}
  frame .fout.f3 -relief sunken -borderwidth 1
  checkbutton .fout.f3.hdr -text "Column Headers" -variable colHdrs
  checkbutton .fout.f3.col -text "Columnar output" -variable colOut \
		-command setEntr
  label .fout.f3.sepl -text "Column Separator:" -width 19 -anchor e
  entry .fout.f3.entr -width 4 -textvariable sepChar
  
  pack .fout.f3.hdr .fout.f3.col .fout.f3.sepl .fout.f3.entr \
		-side left -padx 3  -expand 1 -fill x
  
  frame .fout.f4 -relief sunken -borderwidth 1
  label .fout.f4.l -text \
	"Separators: \\t = tab, (blank) = single space, other"

  pack .fout.f4.l -side left -expand 1 -fill x

  setEntr

  frame .fout.f5 -relief sunken -borderwidth 1
  button .fout.f5.app -width 10 -text " Ok " \
                                      -command { set doExp 1 ; destroy .fout}
  button .fout.f5.can -width 10 -text "Cancel" \
                                      -command {set doExp 0 ; destroy .fout}

  pack .fout.f5.app .fout.f5.can -side left -expand 1 -fill x

  pack  .fout.f1 .fout.f2 .fout.f3 .fout.f4 .fout.f5  \
		-side top -padx 10 -pady 1 -fill both

  grab .fout
  tkwait window .fout
  
  set fileOutName [string trim $fileOutName]

  if {$doExp == 0 || [string length $fileOutName] == 0} {
    set fileOut 0
    foreach {sepChar colOut fileOutName colHdrs appendFileOut} $prevValues {}
    return
  }

  set sepChar [string trim $sepChar]
  if {"$sepChar" == ""} {
    set sepChar " "
  } elseif {"$sepChar" == "\\t"} {
    set sepChar \t
  } 
 
  # open file
  if {$appendFileOut} {
    set mode a
  } else {
    set mode w
  }

  setMsg ""

  if {[catch {open $fileOutName $mode} fileOutFd] != 0} {
    setMsg "Error: File $fileOutName cannot be opened"
    foreach {sepChar colOut fileOutName colHdrs appendFileOut} $prevValues {}
    set fileOutName ""
    set fileOutFd ""
    set fileOut 0
  }
  setMsg "File $fileOutName opened"

}

  

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

  # 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 -underline 0
  menu .m.mb.file.m
  .m.mb.file.m add command -label "New" -command doNew -underline 0
  .m.mb.file.m add command -label "Open..." \
		   -command "tryOpen" -underline 0
  .m.mb.file.m add command -label "Save" -command doSave  -underline 0
  .m.mb.file.m add command -label "Save as..." \
		   -command "doSaveAs" -underline 5
  .m.mb.file.m add separator
  .m.mb.file.m add command  -label "ReConnect" -command getSignOn   -underline 0
  global edwin
  set edwin 8
  .m.mb.file.m add radio -label "Small Edit Window" -variable edwin -value 8 -command ".m.s.sql configure -height 8" -underline 1
  .m.mb.file.m add radio -label "Large Edit Window" -variable edwin -value 16 -command ".m.s.sql configure -height 16" -underline 0
  .m.mb.file.m add separator

  .m.mb.file.m add command -label "Exit"  -command confirmExit  -underline 0

  menubutton .m.mb.out -text "Results" -menu .m.mb.out.m -underline 0
  menu .m.mb.out.m
  .m.mb.out.m add check -label "Window output" -variable scrnOut \
			-command checkIfOutput
  .m.mb.out.m add checkbutton -label " Column Headers" -variable scrnHdrs \
	-onvalue 1 -offvalue 0
  .m.mb.out.m add radiobutton -label " Append results" -variable appendclear \
   	-value 0  -command "set appendclear 0" 
  .m.mb.out.m add radiobutton -label " Clear results" -variable appendclear \
   	-value 1  -command "set appendclear 1" 
  .m.mb.out.m add separator

  .m.mb.out.m add check -label "File output..."   -variable fileOut \
			-command setFileOut

  .m.mb.out.m add separator

  .m.mb.out.m add command -label "Clear" -command clearoutput -underline 0
  .m.mb.out.m add command -label "Save as..." \
	  -command "doSaveOut" -underline 0
  .m.mb.out.m add command -label "Print" -command doPrint -underline 0
  .m.mb.out.m add cascade -label "Font Size  " -menu .m.mb.out.m.f -underline 0
  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.op -text "Options" -menu .m.mb.op.m -underline 1
  menu .m.mb.op.m
  .m.mb.op.m add command -label "Set Null Value..."  -command setNull \
                         -underline 4
  .m.mb.op.m add command -label "Set Float Precision..."  -command setFloat \
                         -underline 4


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

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

  # 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  -underline 0
  menu .m.mb.help.m
  .m.mb.help.m add command -label "General" -command generalHelp -underline 0
  .m.mb.help.m add cascade -label "Menus  "   -menu .m.mb.help.m.m -underline 0
  .m.mb.help.m add command -label "About"   -command aboutHelp -underline 0

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

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


  # 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

  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; break"
  bind .m.s.sql <Shift-Return>   ".m.mb.exec invoke; break"
  bind .m.s.sql <Shift-Up>       "prevSql -1; break"
  bind .m.s.sql <Control-Up>     "prevSql -1; break"
  bind .m.s.sql <Shift-Down>     "prevSql  1; break"
  bind .m.s.sql <Control-Down>   "prevSql  1; break"

  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

  pack .m.s -side top -fill both

  # create a frame listing sql output

  frame .m.o -relief raised

  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 -selectmode extended \
          -font -*-courier-*-r-*-*-14-*-*-*-*-*-*-*  \
	  -yscroll ".m.o.vert set" -xscroll ".m.o.horz set"
  selection handle .m.o.out "handleList .m.o.out NoFilterProc"
  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
  message .m.msg -text "" -justify center -aspect 1000 -relief sunken \
	-font -*-helvetica-bold-o-*-*-17-*-*-*-*-*-*-*
    
  pack .m.msg -side bottom -fill x

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

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

  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"
  wm title . "Wisqlite: $server.$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 {} {
  global fileOutFd

  if {[tk_dialog .confirm  "Confirm Exit" "Really Exit?"  "" 0 \
	     "Sure, why not?"  "Cancel" ] == 0} {

    catch {close $fileOutFd}
    destroy .
  }
}

########################
#
# clearsql
#
#   clear the sql code window
#
proc clearsql {} {
  global currentFile
  global cmdIdx
  global cmdLast
  set cmdIdx $cmdLast

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

proc tryOpen {} {

  global currentFile
  global cmdIdx
  global cmdLast
  set cmdIdx $cmdLast

  set types {
	{{SQL Files}     {*.sql} }
	{{All Files}     {*} }
  }
  set filename [tk_getOpenFile -title Open -filetypes $types]
  if {$filename == ""} return

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

}




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

proc doSaveAs {} {
  global currentFile
  global cmdIdx
  global cmdLast
  set cmdIdx $cmdLast

  set types {
	{{SQL Files}     {*.sql} }
	{{All Files}     {*} }
  }
  set filename [tk_getSaveFile -title "Save As" -initialfile $currentFile -filetypes $types]
  if {$filename == ""} return

  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"

}



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

proc doSaveOut {} {
  global cmdIdx
  global cmdLast
  global currentFile
  set cmdIdx $cmdLast

  set resFile ""
  if {[string length $currentFile] > 0} {
    set resFile [split $currentFile .]
    if {[llength $resFile] > 1} {
      set resFile "[lindex $resFile 0].out"
    } else {
      set resFile ${currentFile}.out
    }
  }

  set types {
	{{Out Files}     {*.out} }
	{{Text Files}    {*.txt} }
	{{All Files}     {*} }
  }
  set filename [tk_getSaveFile -title "Save Results" -initialfile $resFile -filetypes $types]
  if {$filename == ""} return

  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"
}




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

proc doPrint {} {

  global tcl_platform
  
  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"
  }
  
  switch $tcl_platform(platform) {
    unix {setMsg [exec lp << $out_lines]}
    windows  {putFile wosql.prn $out_lines; 
	      catch {exec print wosql.prn};
	      setMsg printed}
    default {setMsg "don't know how to print on $tcl_platform(platform)";return}
  }

}



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

proc doSave {} {
  global currentFile
  global cmdIdx
  global cmdLast
  set cmdIdx $cmdLast

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

}





########################
#
# doNew
#
#   clear windows
#
proc doNew {} {
  global currentFile
  global cmdIdx
  global cmdLast
  set cmdIdx $cmdLast

  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
    }
  }

}


########################
#
# insSql
#
#   insert the current Sql into the cmdRing
#

proc insSql {} {
  global cmdRing
  global cmdIdx
  global cmdLast

  set currentSql [.m.s.sql get 1.0 end]

  # don't save null buffers
  if {[string length [string trim $currentSql]] == 0} {
    return
  }

  set cmdRing($cmdLast) $currentSql

  set cmdIdx $cmdLast

  incr cmdLast
  if {$cmdLast > 9} {
    set cmdLast 0
  }

}

########################
#
# prevSql
#
#   save current sql window, replace with previous (dir=-1) or next (dir=1)
#

proc prevSql {dir} {
  global cmdRing
  global cmdIdx
  global cmdLast


  set i 0
  set result_lines ""

  while {$i < 10 && [string length $result_lines] == 0} {
    incr cmdIdx $dir

    if {$cmdIdx < 0} {
      set cmdIdx 9
    }
    if {$cmdIdx > 9} {
      set cmdIdx 0
    }
    set result_lines $cmdRing($cmdIdx)
    incr i
  }

  if {[string length $result_lines] > 0} {
    .m.s.sql delete 1.0 end
    .m.s.sql insert 1.0 "$result_lines"
  }

}


########################
#
# repl_str
#
#   replicate a string n times
#
proc repl_str {str n} {
  set s $str
  for {set i 1} {$i < $n} {incr i} {
    append s $str
  }
  return $s
}


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


  # vars related to file out
  global fileOut
  global fileOutFd
  global colOut
  global scrnOut
  global sepChar
  global colHdrs
  global scrnHdrs

  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 [repl_str "----------------" 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 ""
  set lastfmt ""

  if {$appendclear} {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
  }

  insSql
  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)]
      if {[string compare $lastfmt $fmt] != 0} { 
	set lastfmt $fmt
	if {$scrnOut && $scrnHdrs} {
          .m.o.out insert end [eval format \"$fmt\" $col_names]
	}
	if {$fileOut && $colHdrs} {
          if {$colOut} {
	    catch {puts $fileOutFd [eval format \"$fmt\" $col_names]}
	  } else {
            catch {puts $fileOutFd [join $col_names $sepChar]}
	  }
	}
        set dash $col_names
        for {set i 0} {$i < [llength $dash]} {incr i} {
	  set dash [lreplace $dash $i $i $d]
        }
	if {$scrnOut && $scrnHdrs} {
          .m.o.out insert end [eval format \"$fmt\" $dash]
	}
	if {$fileOut && $colHdrs && $colOut} {
	   catch {puts $fileOutFd [eval format \"$fmt\" $dash]}
	}
      }
    }

    if {[string length $row] == 0} {
      set fmt ""
    }  else {
      set txtdata ""
      foreach i $txtindx {
        lappend txtdata [lvarpop row $i]
      }
      if {$scrnOut} {
        .m.o.out insert end [eval format \"$fmt\" $row]
      }
      if {$fileOut} {
        if {$colOut} {
          catch {puts $fileOutFd [eval format \"$fmt\" $row]}
	} else {
          catch {puts $fileOutFd [join $row $sepChar]}
	}
      }
      incr cnt
      if {[llength $txtindx] > 0} {
	set i 0
	foreach t $txtcols {
	  if {$scrnOut} {
	    .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 "" 
	  }
	  if {$fileOut} {
	    catch {puts $fileOutFd [lindex $txtdata $i]}
	  }
	}
      }
    }

    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 "
    sybcancel $syb
  }

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

}

########################
#
# lempty and lvarpop tcl-only implementations
#

proc lempty {l} {
  return [expr [llength $l] == 0 ? 1 : 0] 
}
 
proc lvarpop {v args} {
  upvar $v mylist
  set argl [llength $args]
  if {$argl >=1} {
      set idx [lindex $args 0]
  } else {
      set idx 0
  }
  set ret [lindex $mylist $idx]
  if {$argl >= 2} {
      set mylist [lreplace $mylist $idx $idx [lindex $args 1]]
  } else {
      set mylist [lreplace $mylist $idx $idx]
  }
  return $ret
}

proc max {x y} {
  return [expr $x > $y ? $x : $y]
}


########################
#
# formatCols
#
#   return a format to use in column printing
#   names, types, and lengths are lists of equal size
#
proc formatCols {names types lengths} {
  global sybmsg
  global tcl_precision
  
  set floatprec 20 
  set floatprec [expr {$tcl_precision + 3}]
  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 $floatprec ; set just "" }
      {numeric decimal}   {set len 38 ; 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, \
		nulls=convert(bit,(syscolumns.status & 8)) \
	       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])
    }
    if {@4 == 1} {
      set notnull ""
    } else {
      set notnull "not null"
    }
    lappend plist [format "%-30.30s %-15.15s %s" $n $t $notnull]
  }

  if {[llength $plist] == 0} {
    setMsg "No fields in table $tab"
    return
  }
  pickList .$dbname:$tab Columns 530x330 $plist "" list filtCols
}



########################
#
# 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 300x400 [lsort $plist] showFields list
}



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

  set sybmsg(fixedchar) "yes"
  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} {
    append  rows $row 
    set row [lindex [sybnext $syb] 0]
  }
  eval lappend plist [split $rows \n]
  pickList .$dbname:$objname "Object Text" 600x600 $plist "" text
  set sybmsg(fixedchar) ""
}



########################
#
# 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 300x400 $plist getObj list
}



proc generalHelp {} {
  tk_dialog .general_help "General Help" "Windowing ISQL is a subset of the \
  Sybase ISQL command. "  "" 0 OK
}

proc menuHelpFile {} {
  tk_dialog .general_help "Help - File Menu" "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\
  " "" 0 OK
}

proc menuHelpOut {} {
  tk_dialog .general_help "Help - Results Menu" "Results Menu\n\n\
  Window Output - write SQL rows to results window\n\
  File Output - write SQL rows to a file\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\
  " "" 0 OK
}

proc menuHelpOpt {} {
  tk_dialog .general_help "Help - Options Menu" "Options Menu\n\n\
  Set Null Value - starts dialog to set value to return for NULL.\n\
  " "" 0 OK
}


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

proc menuHelpObjs {} {
  tk_dialog .general_help "Help - Objects Menu" "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. \
  " "" 0 OK
}

proc menuHelpExec {} {
  tk_dialog .general_help "Help - Execute Menu" "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. \
  Control-Up, Shift-Up, Control-Down, Shift-Down access\
  the SQL save buffer to recall previous commands.\
  " "" 0 OK
}

proc aboutHelp {} {
  tk_dialog .general_help "Help - About" "Windowing ISQL\nVersion 3.0\n \
  \nApril, 1999\n\nTom Poindexter" "" 0 OK
}



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

proc pickList {win heading geom plist callproc type {filtproc NoFilterProc}} {
  set win_title $win
  regsub -all {_} $win_title " " win_title
  set win [string tolower $win]
  
  catch {destroy $win}
  toplevel $win
  wm title $win [string range $win 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
  if {"$type" == "list"} {
    listbox $win.f.box -yscroll "$win.f.vert set"  -relief sunken \
	 -selectmode extended \
	 -font "-*-courier-*-r-*-*-14-*-*-*-*-*-*-*" 
    selection handle $win.f.box "handleList $win.f.box $filtproc"
  } else {
    text $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 {
    if {"$type" == "list"} {
      $win.f.box insert end $lem
    } else {
      regsub -all "\r\n|\n\r" $lem "\n" lem
      regsub -all "\r" $lem "\n" lem
      if {[string range $lem end end] == "\n"} {
	set nl ""
      } else {
	set nl "\n"
      }
      $win.f.box insert end "$lem$nl"
    }
  }

  if {$doproc} {
    button $win.b.ok  -text "Details" -relief raised -borderwidth 2 -command \
        "catch \{ $callproc \[$win.f.box get \[$win.f.box curselection\]\] \}"
  } 
  button $win.b.can -text "Cancel" -relief raised -borderwidth 2 \
		-command "destroy $win"

  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

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

  if {"$type" == "text"} {
    # $win.f.box configure -state disabled
  } else {
    $win.f.box select set 0
  }
}


proc setNull {} {
  global sybmsg
  global doExp
  global nullVal
  set doExp 0

  set nullVal $sybmsg(nullvalue)

  catch {destroy .snull}
  toplevel .snull -class Dialog

  wm transient .snull .
  set xpos [expr [winfo rootx .]+[winfo width .]/3]
  set ypos [expr [winfo rooty .]+[winfo height .]/3]
  wm geom .snull +${xpos}+$ypos
  wm title .snull "Set Null Value"

  frame .snull.f1 -relief sunken -borderwidth 1

  label .snull.f1.l -text " Value "
  entry .snull.f1.e -width 30 -relief sunken -textvariable nullVal
  bind  .snull.f1.e <KeyPress-Return> ".snull.f3.app invoke"

  pack .snull.f1.l -side left 
  pack .snull.f1.e -side left -fill x -expand 1

  message .snull.f2 -text {(use "default" for default behavior)} -aspect 1200

  frame .snull.f3 -relief sunken -borderwidth 1
  button .snull.f3.app -width 10 -text "Set" \
                                      -command { set doExp 1 ; destroy .snull}
  button .snull.f3.can -width 10 -text "Cancel" \
                                      -command {set doExp 0 ; destroy .snull}

  pack .snull.f3.app .snull.f3.can -side left -expand 1 -fill x

  pack  .snull.f1 .snull.f2 .snull.f3  -side top -padx 10 -pady 5 -fill both

  grab .snull
  tkwait window .snull


  if {$doExp == 0} return

  set sybmsg(nullvalue) [string trim $nullVal]

}



proc setFloat {} {
  global sybmsg
  global doExp
  global floatprec
  global tcl_precision
  set doExp 0

  set floatprec $tcl_precision

  catch {destroy .sfloat}
  toplevel .sfloat -class Dialog

  wm transient .sfloat .
  set xpos [expr [winfo rootx .]+[winfo width .]/3]
  set ypos [expr [winfo rooty .]+[winfo height .]/3]
  wm geom .sfloat +${xpos}+$ypos
  wm title .sfloat "Set Float Precision"

  frame .sfloat.f1 -relief sunken -borderwidth 1

  label .sfloat.f1.l -text " Value "
  entry .sfloat.f1.e -width 30 -relief sunken -textvariable floatprec
  bind  .sfloat.f1.e <KeyPress-Return> ".sfloat.f3.app invoke"

  pack .sfloat.f1.l -side left 
  pack .sfloat.f1.e -side left -fill x -expand 1

  message .sfloat.f2 -text {(blank for default precision)} -aspect 1200

  frame .sfloat.f3 -relief sunken -borderwidth 1
  button .sfloat.f3.app -width 10 -text "Set" \
                                      -command { set doExp 1 ; destroy .sfloat}
  button .sfloat.f3.can -width 10 -text "Cancel" \
                                      -command {set doExp 0 ; destroy .sfloat}

  pack .sfloat.f3.app .sfloat.f3.can -side left -expand 1 -fill x

  pack  .sfloat.f1 .sfloat.f2 .sfloat.f3  -side top -padx 10 -pady 5 -fill both

  grab .sfloat
  tkwait window .sfloat


  if {$doExp == 0} return

  if {[scan $floatprec %d fp] == 1} {
    if {$fp >=0 && $fp <= 17} {
      catch {set tcl_precision  $fp}
    }
  } else {
    return
  }

}