#
# UCODB tlib -- basic shareable code for sybase, oracle, pg95 support
# shareable code for wisql and fosql (and wisqr)
#
# Current Release Version: $Version$
#
# Copyright Tom Poindexter (code from wisql 1.3)
# Copyright the UC Regents (code by De Clarke from wisql 1.4.0 and later)
#

#@package: DBUI fileBox fileOK fillLst handleList1 pickList2 \
	getFont noOp pickList setMsg dataHelp dictDisp setMeta \
	showError mailText proFile printBox saveEdit selInsert \
	showText startMsg findExpr dumpLB termCheck mailMaven \
	saveText editFile isXess whichFY cryWolf doUserCmd rotCmd sigTrap \
	stopScript



proc cryWolf {newmsgs} {

	global mfname mfdir msgtbl 
	global Banner RemindDay Mavens Facility Mail LogFiles AllsWell

#	globals
#	mfname 	   : name of mailfile
#	mfdir      : writable dir in which to build it
#	Mavens     : list of recipients
#	msgtbl     : database table of message sending info
#	RemindDay  : day of week (Mon Tue) on which to send persistent messages
#	Facility   : facility code of message (arbitrary string)
#	Mail	   : explicit path of correct mail sender
# 	LogFiles   : paths of any relevant logfiles to read
# 	Banner     : banner string
#	AllsWell   : flag;  if 1, send an All's Well if no msgs --
#	 	   : otherwise, no news is good news.

	if {![info exists AllsWell]} {set AllsWell 0}

	set mailmsg ""
	set today [clock format [clock seconds] -format "%m/%d/%Y"]
	set weekday [clock format [clock seconds] -format %a]
#
#	We have a database table called messages, whose fields are
#	msgtxt, msgdate, sendct, lastsend, facility...
#	the pkey is the msgtext, so be careful what you log.
#
#	We have list of lines of text incoming, and
#	we are building a mail message body to be sent to Mavens.
#	We don't have to worry about preserving history (except
#	for regulating message delivery) since the logfiles keep all
#	occurrences of every message.
#
#	If a message in messages was NOT found today, it is resolved
#		and must vanish from the messages list, with a
#		confirming message in the output.
#	If a message in messages IS found today, we need to figure out
#		its history and mail or not mail it....
#		If the sendct is < 3 then mail it.
#		If the sendct is >= 3 and today is "remind day", send the message.
#		Flag it if it's been sent more than 6 times already.
#		If a message found today is NOT in messages, then it must
#			be added and sent for the first time.
#
#
	set oldmsgs ""
	set sqlcmd "select msgtxt from $msgtbl where facility = '$Facility'"
	set sqt $msgtbl
	doSQL 1
	while {1} {
		set mt [sybNext 1]
		if {$mt == ""} {break}
		lappend oldmsgs [stringFix2 $mt out]
	}
	
#
#	First weed out the resolved errors
#

	lassign [intersect3 $oldmsgs $newmsgs] killem sameold addem

	puts stderr "oldmsgs : $oldmsgs"
	puts stderr "newmsgs : $newmsgs"
	puts stderr "sameold : $sameold"
	puts stderr "addem : $addem"
	puts stderr "killem : $killem"

	set resolved ""
	foreach k $killem {
		lappend resolved "RESOLVED $today : $k"
		set k [stringFix2 $k in]
		set sqlcmd "delete from $msgtbl where msgtxt = '$k'"
		doSQL 1
	}
#
# 	now insert the new errors
#

	foreach a $addem {
		set sqlcmd "insert into $msgtbl values ('$a','$today',0,NULL,'$Facility')"
		doSQL 1
	}
#
#	now process the msg table to add lines to our mail message
# 
#

	set sqlcmd "select * from $msgtbl where sendct < 3 and facility = '$Facility' order by sendct, msgtxt"
	doSQL 1
	set cols [sybCols 1]
	while {1} {
		set line [sybNext 1]
		if {$line == ""} {break}
		eval lassign \$line $cols
		if {$sendct == 0} {
			set flag "  NEW     :"
		} else {
			set flag "  RECENT  :"
		}
		lappend mailmsg  "$flag [crange $msgdate 0 11] $msgtxt"	
	}
#
	if {$weekday == "$RemindDay"} {
	set sqlcmd "select * from $msgtbl where sendct >= 3 and facility = '$Facility' order by sendct, msgtxt"
	doSQL 1
	set cols [sybCols 1]
	while {1} {
		set line [sybNext 1]
                if {$line == ""} {break}
                eval lassign \$line $cols
		set flag "  "
		if {$sendct > 6} {
			set flag **
		}
		lappend mailmsg "$flag RECURRING: [crange $msgdate 0 11] $msgtxt"
	}
	}
#	
#
#	Old messages
#
	if {$weekday == "$RemindDay"} {
	set sqlcmd "update $msgtbl set sendct = sendct+1, lastsend = '$today' where sendct >= 3 and facility = '$Facility'"
	doSQL 1
	}
#	
#	Recent messages
#
	set sqlcmd "update $msgtbl set sendct = sendct+1, lastsend = '$today' where sendct < 3 and facility = '$Facility'"
	doSQL 1

## now put the message together and send it

	if {$mailmsg != ""} {
	lappend mailmsg "----------\nFor more info check the log files : $LogFiles"
	}

	if {$AllsWell} {
		if {$mailmsg == ""} {
			lappend mailmsg ""
			lappend mailmsg "All is Well"
			lappend mailmsg ""
		}
	}

	if {$mailmsg != ""} {
	set ofp [open $mfdir/$mfname w]
	puts $ofp "\n----------------\n$Banner\n----------------\n"
	foreach l $mailmsg {
		puts $ofp "$l"
	}
	puts $ofp "---------------------------------------------------------"
	foreach l $resolved {
		puts $ofp "$l"
	}
	close $ofp

	system "$Mail -s Messages_from_$Facility $Mavens < $mfdir/$mfname"
	}

}
# $Header: /home/cvsroot/tcldb/ucodb/Tlib/dataHelp,v 1.1.1.1 1996/10/12 01:08:25 de Exp $
# tcl procs saved on Sun Sep 03 16:18:58 PDT 1995

proc dataHelp {table fld} {
	

	global dictionary
#	global datahelping

#	set datahelping 1

	if {$fld == ""} {set fld "TABLEDEF"}

#	The ddict format was changed on Jan 20 1994, so that base, owner
#	and table are separate fields (dbase, owner, tbln).  We ignore
#	dbase at this point, because of the unique nomenclature of our
#	tables.  We assume dbo if no owner is specified.  We could at
#	some future date insist on FQ object names and use the base
#	value as well.  

	set base ""
	set temp [split $table .]
	case [llength $temp] in {
	{3} {
		lassign $temp base owner table
	}
	{2} {
		lassign $temp owner table
	}
	{1} {
		set table $temp
		set owner "dbo"
	}
	}

	if {$dictionary == "NONE"} {
		set title "No Dictionary"
		set text "Sorry, there is no Data Dictionary."
	} else {

	set sqlcmd "select ddesc from $dictionary where ((owner = '$owner' and tbln = '$table') or tbln = 'ANYTABLE') and fldn = '$fld'"

	set sqt "$dictionary"
	
	set res [doSQL 1]
	if {[lindex $res 0] == "ERROR"} {
		echo "Serious problem here"
		echo "$sqlcmd"
		echo "$res"
		exit 1
	}

	set text "[stringFix [sybNext 1]]"

	set hdr "Table $table - Field $fld"

	if {$text == ""} {	
		set title "No Dictionary Info"
		set text "Sorry, there is no Data Dictionary entry for table $table, field $fld in the dictionary table $dictionary."
	} else {
		set title "Data Dictionary Info"
	}

	}

	
	dictDisp "$title" "$text" "Done" l "$hdr"

}

# $Header: /home/cvsroot/tcldb/ucodb/Tlib/dictDisp,v 1.2 1998/05/14 01:35:30 de Exp $
# tcl procs saved on Sun Sep 03 16:18:59 PDT 1995

proc dictDisp {tt at bt ju ht} {

    set w .ddictbox
    catch {destroy $w}
    toplevel $w -class Dialog
    wm title $w "$tt"
    wm geometry $w "+150+150"
    wm iconname $w "DataDict"

    frame $w.top -relief raised -border 1
    frame $w.bot -relief raised -border 1
    pack $w.top -side top -fill both -expand true 
    pack $w.bot -side top -fill both -expand true

    case $ju in {
        {l} {
                set just left
        }
        {r} {
                set just right
        }
        {default} {
                set just center
        }
    }

    set font [getFont $w mediumhel]

    message $w.top.hdr -font "$font" -text "$ht" -relief raised -border 0  -aspect 1000 -background antiquewhite
    message $w.top.msg -justify $just -font "$font" -text "$at"  -aspect 500 -background ivory

    pack $w.top.hdr -side top -expand true -ipadx 5 -ipady 5  
    pack $w.top.msg -side top -expand true -ipadx 5 -ipady 5


    button $w.bot.dismiss -text $bt -command "destroy $w" -padx 0 -pady 0 -background white -foreground red -activebackground black -activeforeground yellow

    pack $w.bot.dismiss -expand true -ipadx 12 -ipady 12

    bind $w <Return> "destroy $w"
    focus $w

}

proc doUserCmd {{cmd {}} {t {}}} {

#$Header: /home/cvsroot/tcldb/ucodb/Tlib/doUserCmd,v 1.5 1999/03/09 22:43:04 de Exp $

	global UserCmd lfp CmdRing CmdPtr LastPtr 
	global errorCode errorInfo

	set stamp [clock format [clock seconds]]
	
	if {$t == ""} {set t .cmdEdit.top.txt}

	if {$cmd == ""} {
	 	if {$UserCmd != ""} {
		set cmd "$UserCmd"
		} else {
		mkMsg "No command to execute"
		return
		}
	}

	incr CmdPtr	
	if {$CmdPtr == 10} {set CmdPtr 0}
#	puts stderr "delete first line and replace : $t delete 1.0 1.end"
	set err [catch {$t delete 1.0 1.end}]
	if {!$err} {
		eval $t insert 1.0 \{# User Command $CmdPtr\}
		set cmd [$t get 1.0 end]
	}
	set CmdRing($CmdPtr) "$cmd"
	set LastPtr $CmdPtr

	set err [catch {$t configure -foreground red} res]
	mkMsg "Script is Executing"

	set err [catch {uplevel #0 eval $cmd} res]

	if {$err} {

		set ec $errorCode
		set ei $errorInfo
		set er $res

		set err [catch {$t configure -background yellow} res]

		if {!$err} {
		update idletasks

		puts stderr "$er"
		mkMsg "Error(s) in your command indicated by yellow command area"
		mkAlert "ERROR" "\{$er\}" "OK" v showerr

		} else {

		puts stderr "$er"

		}

		catch {puts $lfp "$stamp : CMDFAIL\n\t[join [split "$cmd\nERR: $er" \n] "\n\t"]"}

	} else {

		catch {puts $lfp "$stamp CMD OK\t\n\t[join [split $cmd \n] "\n\t"]"}
		catch {$t configure -background ivory}

	}

	set err [catch {$t configure -foreground black} res]

}

# $Header: /home/cvsroot/tcldb/ucodb/Tlib/dumpLB,v 1.1.1.1 1996/10/12 01:08:25 de Exp $
# tcl procs saved on Sun Sep 03 16:19:07 PDT 1995

proc dumpLB {lbwidget txwidget} {

#	Given the names of a list box and a text widget, dump the
# 	contents of the listbox into the text widget.
#	(How do we know whether to clear or not?  Well, let's just
#	 always clear for now.)


	$txwidget delete 1.0 end

	loop i 0 [$lbwidget size] {

		$txwidget insert end "[$lbwidget get $i]\n"

	}

	update

}

proc editFile {box tfile ext op} {

# $Header: /home/cvsroot/tcldb/ucodb/Tlib/editFile,v 1.3 1999/03/27 01:19:19 de Exp $
# tcl procs saved on Sun Sep 03 16:19:14 PDT 1995

	global env

	set win .[lindex [split $box .] 1]
	set wlist [winfo children $win]
	$win configure -cursor watch
	foreach child $wlist {
		$child configure -cursor watch
	}

	set unique [getclock]
        set uname [id user]

	if {[info exists env(HOME)]} {
	set hdir $env(HOME)
	} else {
        set hdir /u/$uname
	}

        if {![file isdirectory $hdir]} {
                puts stderr "Cannot find user $uname home directory $hdir."
                puts stderr "using /tmp"
                set hdir /tmp
        }

	if {$ext == ""} {
		set fdir $hdir
		set ext $unique
	} else {
		set fdir $hdir/.$ext
	}

	if {![file isdirectory $fdir]} {
		if {[file exists $fdir]} {
			set fdir /tmp
			puts stderr "using /tmp"
		} else {
			system "mkdir $fdir"
		}
	}

	set fe [lindex [split $tfile .] [expr [llength [split $tfile .]] - 1]]	

	if {$fe != "$ext"} {
		set tfile $tfile.$ext
	}

#	give priority to file in current dir
	set tf $tfile
	if {![info exists $tfile]} {
	set tf $fdir/$tfile
	}
	
	set err [catch {set tfp [open $tf $op]}]

	if {$err} {
		puts stderr "Cannot open file $tf for operation $op"
		return
	}

	if {$err} {
		set of "/tmp/$tfile.$unique"	
		set tfp [open $tf w]
	}

	case $op in {
	{w} {
	set lines [split [$box get 1.0 end] \n]

	foreach line $lines {
	
		puts $tfp "[stringFix2 $line out]"

	}
		puts stderr "Output is in file $tf"
	}
        {r} {
                $box delete 1.0 end
                for_file line $fdir/$tfile {
                        $box insert end "$line \n"
                }
        }
	}

	close $tfp

	$win configure -cursor {}
	foreach child $wlist {
		$child configure -cursor {}
	}

}
# tcl procs saved on Fri Nov 08 18:11:48 PST 1996

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 350x400+${xpos}+$ypos
  wm minsize $win 350 200

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

#	text, data (side by side) then list below

  frame $win.td -background antiquewhite
  frame $win.td.t -background antiquewhite
  frame $win.td.d -background antiquewhite
  frame $win.l   -background antiquewhite

  label $win.td.t.l4   -text "Directory:" -anchor w -background antiquewhite
  button $win.td.md -text "Create\nDir" -command "mkDirectory \[$win.td.d.dir get\]" -background lavender -activebackground lavender -activeforeground magenta2
  entry $win.td.d.dir -relief sunken -width 30 -background ivory
  $win.td.d.dir insert 0 $startdir

  label $win.td.t.l1   -text "Filter:" -anchor w -background antiquewhite
  entry $win.td.d.fil  -relief sunken -width 30 -background ivory
  $win.td.d.fil insert 0 $filt

  label $win.l2   -text "Files:" -anchor w -background antiquewhite

  scrollbar $win.l.hor -orient horizontal -command "$win.l.lst xview"  -relief sunken -troughcolor bisque -background ivory -activebackground mistyrose
  scrollbar $win.l.ver -orient vertical   -command "$win.l.lst yview"  -relief sunken -troughcolor bisque -background ivory -activebackground mistyrose
  listbox $win.l.lst -yscroll "$win.l.ver set" -xscroll "$win.l.hor set"  -relief sunken -selectmode single -height 12 -background azure
  selection handle $win.l.lst "handleList1 $win.l.lst NoFilterProc"
  label $win.l3   -text "Selection:" -anchor w -background antiquewhite
  scrollbar $win.scrl -orient horizontal -relief sunken  -command "$win.sel xview" -troughcolor bisque -background ivory -activebackground mistyrose
  entry $win.sel  -relief sunken -xscroll "$win.scrl set" -background ivory
  selInsert $win $initfile
  frame $win.o  -relief sunken -border 1
  button $win.o.ok -text "Ok" -command "fileOK $win \"$execproc\"" -background lavender -activebackground lavender -activeforeground magenta2
  button $win.filter -text "Filter"  -command "fillLst $win \[$win.td.d.fil get\] \[pwd\]" -background lavender -activebackground lavender -activeforeground magenta2
  button $win.can    -text "Cancel" -command "destroy $win" -background white -foreground red -activebackground black -activeforeground yellow

  pack $win.td.t.l4 -side top -fill x
  pack $win.td.t.l1 -side top -fill x
  pack $win.td.d.dir -side top -fill x
  pack $win.td.d.fil -side top -fill x
  pack $win.td.t -side left
  pack $win.td.md -side right 
  pack $win.td.d -side right
  pack $win.td -side top
  
  pack $win.l2 $win.l  $win.l3 -side top -fill x
  
  pack $win.sel -side top -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 5

  bind $win.td.d.fil <KeyPress-Return> "$win.filter invoke; break"
  bind $win.td.d.dir <KeyPress-Return> "catch \{cd \[$win.td.d.dir get\]\}; $win.filter invoke; break"
  bind $win.sel <KeyPress-Return> "$win.o.ok   invoke; break"
  bind $win.l.lst <ButtonRelease-1>  "+selInsert $win \"\[$win.td.d.dir get\]/\[%W get \[ %W nearest %y \] \]\" "
  bind $win.l.lst <Double-1>  "selInsert $win \[lindex \[selection get\] 0\];  $win.o.ok invoke; break"
  bind $win <Return> "$win.o.ok invoke; break"

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

}

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]
    $win.td.d.dir delete 0 end
    $win.td.d.dir insert 0 $f
    fillLst $win [$win.td.d.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 can have arg(s) appended, as long as they are single or
    # properly escaped
    eval $execproc $win $f 
  }
}

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  "../"
  set flist ""

  foreach f $all_list {
    if {[file size $f] == 0} {continue}
    if [file isfile $f] {
      lappend flist [file tail $f]
    }
    if [file isdirectory $f] {
      lappend dlist [file tail $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
}

# $Header: /home/cvsroot/tcldb/ucodb/Tlib/findExpr,v 1.1.1.1 1996/10/12 01:08:25 de Exp $
# tcl procs saved on Sun Sep 03 16:19:07 PDT 1995

proc findExpr {ind line} {

#	Note:  arg line must have been Tokenized!
#	returns 2 inds to use in an lrange expression

#	we know where we think the expression begins, but it might be a
#	a multi-word delimited expression:  we will lose all BSL QQ 
#	and LCB that begin it, but save any [] or () delimited strings

	set junk "BSL LCB RCB QQ"
	set odelim "LSB LPA"
	set cdelim "RSB RPA"

#	strip out all extraneous chars
	foreach j $junk {
		regsub -all "$j" $line "" line
	}

#	kill leading spaces
	set line [string trimleft $line]

#	Now get the word we think is the expr
	set temp [lindex $line $ind]

#	if the word contains a known open delim, then find the index of the
#	word containing the close delim matching it  (making an assumption
#	here that there are not nested delims of same type in the expr!)

	foreach o $odelim {
		set of [string first $o $temp]
		if {$of	>= 0} {
			break
		}
	}

	set c [lindex $cdelim [lsearch $odelim $o]]
	set cloc [string first $c $line]

	if {$cloc >= 0} {
		set cend [expr {$cloc + 2}]
		set sub [crange $line 0 $cend]
		set slen [llength $sub]
		return "[lrange $line $ind [expr {$ind + $slen - 1}]]"
	} else {
		return "[lrange $line $ind $ind]"
	}

}

# $Header: /home/cvsroot/tcldb/ucodb/Tlib/getFont,v 1.1.1.1 1996/10/12 01:08:25 de Exp $
# tcl procs saved on Sun Sep 03 16:18:49 PDT 1995

proc getFont {w name} {
  


  case $name in {
  {banner} {
	set desired "-*-helvetica-bold-o-*-*-20-*-*-*-*-*-*-*"
	set fallback "-*-helvetica-bold-o-*-*-18-*-*-*-*-*-*-*"
  }
  {banneri} {
	set desired "-*-helvetica-bold-o-*-*-17-*-*-*-*-*-*-*"
	set fallback "-*-helvetica-bold-o-*-*-18-*-*-*-*-*-*-*"
  }
  {mediumcou} {
	set desired "-*-courier-*-r-*-*-14-*-*-*-*-*-*-*"
        set fallback "-*-courier-*-r-*-*-12-*-*-*-*-*-*-*"
  }
  {mediumcoui} {
	set desired "-*-courier-*-o-*-*-14-*-*-*-*-*-*-*"
        set fallback "-*-courier-*-o-*-*-12-*-*-*-*-*-*-*"
  }
  {mediumhelb} {
	set desired "-*-helvetica-bold-r-*-*-14-*-*-*-*-*-*-*"
	set fallback "-*-helvetica-bold-r-*-*-12-*-*-*-*-*-*-*"
  }
  {mediumhel} {
        set desired "-*-helvetica-medium-r-*-*-14-*-*-*-*-*-*-*"
        set fallback "-*-helvetica-medium-r-*-*-12-*-*-*-*-*-*-*"
  }
  {messagehel} {
	set desired "-*-helvetica-medium-r-*-*-12-*-*-*-*-*-*-*"
  }
  {messageheli} {
	set desired "-*-helvetica-medium-o-*-*-12-*-*-*-*-*-*-*"
  }
  {mediumtim} {
	set desired "-*-times-medium-r-normal-*-*-180*" 
  	set fallback "-*-helvetica-bold-r-*-*-12-*-*-*-*-*-*-*"
  }
  {courier} {
	set desired "-*-courier-*-r-*-*-12-*-*-*-*-*-*-*"
	set fallback "-*-courier-*-r-*-*-10-*-*-*-*-*-*-*"
  }
  {helvetica} {
	set desired "-*-helvetica-medium-r-*-*-12-*-*-*-*-*-*-*"
  }
  {smallcou} {
	set desired "-*-courier-*-r-*-*-9-*-*-*-*-*-*-*"
        set fallback "-*-courier-*-r-*-*-10-*-*-*-*-*-*-*"
  }
  {smallhel} {
	set desired "-*-helvetica-medium-r-*-*-9-*-*-*-*-*-*-*"
	set fallback "-*-helvetica-medium-r-*-*-10-*-*-*-*-*-*-*"
  }
  {smallhelb} {
	set desired "-*-helvetica-bold-r-*-*-9-*-*-*-*-*-*-*"
	set fallback "-*-helvetica-bold-r-*-*-10-*-*-*-*-*-*-*"
  }
  {secure} {
	set desired "-misc-secure-*-*-*-*-16-160-*-*-*-*-*-*"
	set fallback "-*-symbol-*-r-*--18-*-*-*-*-*-*-*"
  }
  {default} {
	set desired "-*-helvetica-medium-r-*-*-12-*-*-*-*-*-*-*"
  }
  }

   set err [catch {message $w.notawindow -font $desired -text "NOT"}]
   if {$err} {
	echo "Could not find font $desired\nusing $fallback"
	set ret $fallback	
   } else {
	set ret $desired
   }

   catch {destroy $w.notawindow}
   return $ret
}

########################
#
# handleList1
# $Header: /home/cvsroot/tcldb/ucodb/Tlib/handleList1,v 1.1.1.1 1996/10/12 01:08:27 de Exp $
#
#  called during a request for primary selection for listboxes and text
#  that bind the "selection get" command for button-2
#
proc handleList1 {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]
}


# $Header: /home/cvsroot/tcldb/ucodb/Tlib/isXess,v 1.1.1.1 1996/10/12 01:08:26 de Exp $
# tcl procs saved on Sun Sep 03 16:19:16 PDT 1995

proc isXess {} {

  global xess_connection

  set xess_connection 0
  set isxess [info commands xess]

  if {$isxess != ""} {

        set xess_running [xess scan]
        if {$xess_running != ""} {
                set err [catch {xess connect xs}]
                if {$err} {
			.msg configure -text "Problem connecting to Xess"
                } else {
                        .msg configure -text "Xess connection enabled!"
                        set xess_connection 1
                }
        } else {
		.msg configure -text "Xess spreadsheet not running"
        }

  } else {
	.msg configure -text "This Tk does not have the Xess extension."
  }

}

# $Header: /home/cvsroot/tcldb/ucodb/Tlib/mailMaven,v 1.1.1.1 1996/10/12 01:08:26 de Exp $
# tcl procs saved on Sun Sep 03 16:19:10 PDT 1995

proc mailMaven {subject text} {

	global maven

        set unique [getclock]
        set tmpf [open /tmp/mail.$unique w]

        puts $tmpf $text

        close $tmpf

        catch {exec mail -s $subject $maven < /tmp/mail.$unique}

	exec rm /tmp/mail.$unique

}

# $Header: /home/cvsroot/tcldb/ucodb/Tlib/mailText,v 1.3 1998/12/07 20:18:33 de Exp $
# tcl procs saved on Sun Sep 03 16:19:01 PDT 1995

proc mailText {box username} {

        set win .[lindex [split $box .] 1]
        set wlist [winfo children $win]
        $win configure -cursor watch
        foreach child $wlist {
                $child configure -cursor watch
        }

	set self 0

	if {$username == ""} {
		set username [id user]
		set self 1
	}

	set unique [getclock]

	set of "/tmp/fmail.$unique"	

	set ofp [open $of w]

	if {$self} {
		puts $ofp "Because you left the recipient blank, you mailed this report to yourself.\n\n"
	}

#	if you can't get a size, then it must be a text box not a list box
	set err [catch {set len [$box size]} res]

	if {!$err} {
	loop i 0 $len {
		puts $ofp "[stringFix2 [$box get $i] out]"
	}
	} else {
		set text "[$box get 1.0 end]"
		puts $ofp "$text"
	}

	close $ofp

	system "/usr/ucb/Mail -s Sybase_Report $username < $of"

	system "/bin/rm -f $of"

        $win configure -cursor {}
        foreach child $wlist {
                $child configure -cursor {}
        }
}

# $Header: /home/cvsroot/tcldb/ucodb/Tlib/noOp,v 1.1.1.1 1996/10/12 01:08:25 de Exp $
# tcl procs saved on Sun Sep 03 16:18:51 PDT 1995

proc noOp args {

	set tmp [lindex $args 0]

}

# $Header: /home/cvsroot/tcldb/ucodb/Tlib/pickList,v 1.4 1998/03/22 21:44:01 de Exp $
# tcl procs saved on Sun Sep 03 16:18:52 PDT 1995

proc pickList {win heading geom plist callproc} {

	global  bitmapdir


#  puts stderr "Entering pickList window name $win callproc $callproc..."

# make sure we do NOT create windows whose names start with upcase
# letters (illegal in Tk 3.2)
  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 iconbitmap $win @$bitmapdir/picklist.xbm

# try to use appropriate string processing when selected text is pasted
  selection handle $win "handleList $win 0 end"

# catch-22 ! the proc is not in info commands until it is
# loaded and it isn't loaded until it is called.  HACK
# try catching a call with no args, in the hope that it will
# error out and do nothing (DANGER Will Robinson, DANGER)
  set err [catch $callproc]
  set doproc [string length [info commands $callproc]]
#  puts stderr "pickList doproc is $doproc for callproc $callproc"
#  puts stderr "info commands $callproc is [info commands $callproc]"
 
  # FIX THIS  -- this is a mistake
  # try to place window away from the main toplevel
  set tg [winfo geom .]
  set temp ""
  set ptr 0
  while {$ptr < [clength $tg]} {
	set curchar [crange $tg $ptr $ptr]
	case $curchar in {
	{1 2 3 4 5 6 7 8 9 0} {
		append temp $curchar
	}
	{x} {
		set xsiz $temp
		set temp ""
		set lookingfor ysiz
	}
	{+ -} {
		case $lookingfor in {
		{ysiz} {
			set ysiz $temp
			set temp ""
			set xpsign $curchar
			set lookingfor "xpos"
			continue
		}		
		{xpos} {
			set xpos $temp
			set temp ""
			set ypsign $curchar
		}
		}
	}
	}
	incr ptr
   }
   set ypos $temp
	
#  set topgeom [split [split [winfo geom .] x] +]
   if {$xpsign == "+"} {
	set newx [lindex [split [expr {$xpos + $xsiz * .80}] .] 0]
   } else {
	set newx [expr {$xpos - 10}]
   }

   if {$ypsign == "+"} {
	set newy [lindex [split [expr {$ypos + $ysiz * .25}] .] 0]
   } else {
	set newy [expr {$ypos - 10}]
   }
#  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 -background antiquewhite
  frame $win.f -background antiquewhite
  frame $win.b -relief sunken -borderwidth 1 -bg bisque

  set font [getFont $win mediumcou]
  label $win.l.l -text $heading -anchor w -font $font -background antiquewhite
  scrollbar $win.f.vert -orient vertical -command "$win.f.box yview" 	-relief sunken -background ivory -activebackground mistyrose -troughcolor bisque
  listbox $win.f.box -yscroll "$win.f.vert set"  -relief sunken 	 -font $font -background ivory
  
  if $doproc {
    bind $win.f.box <Double-1> "$win.b.ok invoke"
  }

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

 
  if $doproc {
    if {[crange $callproc 0 0] == "."} {
	button $win.b.ok  -text "Transfer" -relief raised -borderwidth 2  -command "catch \{dumpLB $win.f.box $callproc\}" -padx 0 -pady 0 -background lemonchiffon -activebackground lemonchiffon -activeforeground magenta2
    } else {
    button $win.b.ok  -text "OK"     -relief raised -borderwidth 2  -command "catch \{ $callproc \[selection get\]  \} " -padx 0 -pady 0 -background lemonchiffon -activebackground lemonchiffon -activeforeground magenta2
		# -command "$callproc \[selection get\] "
		# -command "$callproc \[selection get\] ; destroy $win;break "
    } 
  }

  button $win.b.can -text "Cancel" -relief raised -borderwidth 2 -command "destroy $win" -padx 0 -pady 0 -background white -foreground red -activebackground black -activeforeground yellow

  pack $win.l -side top -fill x 		   
  pack $win.f -side top -fill both -expand true 		   
  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 true

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

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

# $Header: /home/cvsroot/tcldb/ucodb/Tlib/pickList,v 1.4 1998/03/22 21:44:01 de Exp $
# tcl procs saved on Sun Sep 03 16:18:52 PDT 1995

proc pickList2 {win heading geom plist callproc {exists {0}}} {

	global  bitmapdir

#  puts stderr "Entering pickList window name $win callproc $callproc..."

if {!$exists} {

# make sure we do NOT create windows whose names start with upcase
# letters (illegal in Tk 3.2)
  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 iconbitmap $win @$bitmapdir/picklist.xbm

}

# try to use appropriate string processing when selected text is pasted
  selection handle $win "handleList $win 0 end"

# catch-22 ! the proc is not in info commands until it is
# loaded and it isn't loaded until it is called.  HACK
# try catching a call with no args, in the hope that it will
# error out and do nothing (DANGER Will Robinson, DANGER)
  set err [catch $callproc]
  set doproc [string length [info commands $callproc]]
#  puts stderr "pickList doproc is $doproc for callproc $callproc"
#  puts stderr "info commands $callproc is [info commands $callproc]"
 
if {!$exists} {
  # FIX THIS  -- this is a mistake
  # try to place window away from the main toplevel
  set tg [winfo geom .]
  set temp ""
  set ptr 0
  while {$ptr < [clength $tg]} {
	set curchar [crange $tg $ptr $ptr]
	case $curchar in {
	{1 2 3 4 5 6 7 8 9 0} {
		append temp $curchar
	}
	{x} {
		set xsiz $temp
		set temp ""
		set lookingfor ysiz
	}
	{+ -} {
		case $lookingfor in {
		{ysiz} {
			set ysiz $temp
			set temp ""
			set xpsign $curchar
			set lookingfor "xpos"
			continue
		}		
		{xpos} {
			set xpos $temp
			set temp ""
			set ypsign $curchar
		}
		}
	}
	}
	incr ptr
   }
   set ypos $temp
	
#  set topgeom [split [split [winfo geom .] x] +]
   if {$xpsign == "+"} {
	set newx [lindex [split [expr {$xpos + $xsiz * .80}] .] 0]
   } else {
	set newx [expr {$xpos - 10}]
   }

   if {$ypsign == "+"} {
	set newy [lindex [split [expr {$ypos + $ysiz * .25}] .] 0]
   } else {
	set newy [expr {$ypos - 10}]
   }
#  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 -background antiquewhite
  frame $win.f -background antiquewhite
if {!$exists} {
  frame $win.b -relief sunken -borderwidth 1 -bg bisque
}

  set font [getFont $win mediumcou]
  label $win.l.l -text $heading -anchor w -font $font -background antiquewhite
  scrollbar $win.f.vert -orient vertical -command "$win.f.box yview" 	-relief sunken -background ivory -activebackground mistyrose -troughcolor bisque
  listbox $win.f.box -yscroll "$win.f.vert set"  -relief sunken 	 -font $font -background ivory
  
  foreach lem $plist {
    $win.f.box insert end $lem
  }

  if $doproc {
	if {!$exists} {
    if {[crange $callproc 0 0] == "."} {
	button $win.b.ok  -text "Transfer" -relief raised -borderwidth 2  -command "catch \{dumpLB $win.f.box $callproc\}" -padx 0 -pady 0 -background lemonchiffon -activebackground lemonchiffon -activeforeground magenta2
    } else {
    button $win.b.ok  -text "OK"     -relief raised -borderwidth 2  -command "catch \{ $callproc \[selection get\]  \} " -padx 0 -pady 0 -background lemonchiffon -activebackground lemonchiffon -activeforeground magenta2
		# -command "$callproc \[selection get\] "
		# -command "$callproc \[selection get\] ; destroy $win;break "
    } 
    bind $win.f.box <Double-1> "$win.b.ok invoke"
  button $win.b.can -text "Cancel" -relief raised -borderwidth 2 -command "destroy $win" -padx 0 -pady 0 -background white -foreground red -activebackground black -activeforeground yellow
    } else {
	 bind $win.f.box <Double-1> "catch \{ $callproc \[selection get\]  \}"
    }
  }


  pack $win.l -side top -fill x 		   
  pack $win.f -side top -fill both -expand true 		   
if {!$exists} {
  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 true

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

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

# $Header: /home/cvsroot/tcldb/ucodb/Tlib/printBox,v 1.3 1999/06/24 00:59:42 de Exp $
#
proc printBox box {

# box is the name of any listbox

	global exedir

	set len [$box size]
	set uniq [clock seconds]
	set file "/tmp/Box$uniq"

	set output ""
	loop i 0 $len {

		append output "[string trimright [string trimleft [$box get $i] \{ ] \} ]\n"

	}

	write_file $file "$output"
	puts stderr "Wrote box contents to $file"

	if [file exists $exedir/anyprint] {
  		exec $exedir/anyprint << $output
	} else {
		exec lpr << $output
		
	}


}
# $Header: /home/cvsroot/tcldb/ucodb/Tlib/proFile,v 1.1.1.1 1996/10/12 01:08:25 de Exp $
# tcl procs saved on Sun Sep 03 16:19:01 PDT 1995

proc proFile app {


        profile off profdata

        set fh [open prof.out w]
        foreach i [array names profdata] {
                puts $fh [list $i $profdata($i)]
        }
        close $fh

        profrep profdata cpu 1 $app.prof {$app.tlib profile}

}

proc rotCmd {{dir {}} {t {}}} {

#$Header: /home/cvsroot/tcldb/ucodb/Tlib/rotCmd,v 1.1 1997/05/14 17:37:25 de Exp $

	global UserCmd lfp CmdRing CmdPtr LastPtr

	if {$dir == ""} {set dir next}
	if {$t == ""} {set t .cmdEdit.top.txt}

	set ptr $LastPtr
	if {$dir == "next"} {
		incr ptr 
	} else {
		incr ptr -1
	}

#	ugly
	if {$ptr < 0} {set ptr 9}
	if {$ptr > 9} {set ptr 0}

	if {[info exists CmdRing($ptr)]} {
		puts stderr "Display command $ptr"
		set cmd $CmdRing($ptr)
		$t delete 1.0 end
		$t insert 1.0 "$cmd"
		set LastPtr $ptr

	}

}

# $Header: /home/cvsroot/tcldb/ucodb/Tlib/saveEdit,v 1.1.1.1 1996/10/12 01:08:26 de Exp $
#
proc saveEdit {box filename} {

	set unique [getclock]

	set win .[lindex [split $box .] 1]
	set wlist [winfo children $win]
	$win configure -cursor watch
	foreach child $wlist {
		$child configure -cursor watch
	}

	set of "$filename.$unique"
	set err [catch {set ofp [open $of w]}]
	if {$err} {
		set of "/tmp/$filename.$unique"	
		set ofp [open $of w]
	}

	set lines [split [$box get 1.0 end] \n]

	foreach line $lines {
	
		puts $ofp "[stringFix2 $line out]"

	}

	close $ofp

	$win configure -cursor {}
	foreach child $wlist {
		$child configure -cursor {}
	}
	echo "Output is in file $of"
}
# $Header: /home/cvsroot/tcldb/ucodb/Tlib/saveText,v 1.2 1998/03/14 08:17:57 de Exp $
# tcl procs saved on Sun Sep 03 16:19:11 PDT 1995

proc saveText {box filename} {

	set unique [getclock]

	set win .[lindex [split $box .] 1]
	set wlist [winfo children $win]
	$win configure -cursor watch
	foreach child $wlist {
		$child configure -cursor watch
	}

	set of "$filename.$unique"
	set err [catch {set ofp [open $of w]}]
	if {$err} {
		set of "/tmp/$filename.$unique"	
		set ofp [open $of w]
	}

	set err [catch {set len [$box size]} res]

	if {!$err} {
	loop i 0 $len {
		puts $ofp "[stringFix2 [$box get $i] out]"
	}
	} else {
		set text "[$box get 1.0 end]"
		puts $ofp "$text"
	}

	close $ofp

	$win configure -cursor {}
	foreach child $wlist {
		$child configure -cursor {}
	}
	echo "Output is in file $of"
}

########################
#
# selInsert
#
#   insert into a selection entry, scroll to root name
#
# $Header: /home/cvsroot/tcldb/ucodb/Tlib/selInsert,v 1.1.1.1 1996/10/12 01:08:26 de Exp $
#
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 xview $idx
  if {[info tclversion] < 7.4} {
  $win.sel select anchor 0
  } else {
  $win.sel get 
  }

}

# setMeta
# $Header: /home/cvsroot/tcldb/ucodb/Tlib/setMeta,v 1.2 1996/12/10 06:08:15 de Exp $
#
proc setMeta ser {
 
        global metabase base fys serfys
 
#       puts stderr "setMeta $ser"
	if {![info exists metabase($ser)]} {
		puts stderr "No metabase set for $ser, unable to setMeta."
		puts stderr "If you are running forms, prepare for failure."
		return
	}
        set mb $metabase($ser)
        set base $mb

	catch {set fys $serfys($ser)}
 
        foreach g [info globals] {
                upvar #0 $g $g
                set v ""
                catch {set v [set $g]}
                if {$v != ""} {
#                echo "check global $g value $v"
                if {[crange $v 0 4] == "META."} {
#                        puts stderr "$g\n  changed $v ..."
                        regsub META $v $mb $g
#                        puts stderr "       to [set $g]"
                }
                }
        }
}

# $Header: /home/cvsroot/tcldb/ucodb/Tlib/setMsg,v 1.1.1.1 1996/10/12 01:08:25 de Exp $
# tcl procs saved on Sun Sep 03 16:18:57 PDT 1995

proc setMsg {mwidget msg_text} {

  $mwidget configure -text "$msg_text"
  update
}

# $Header: /home/cvsroot/tcldb/ucodb/Tlib/showError,v 1.2 1998/12/16 21:44:33 de Exp $
# tcl procs saved on Sun Sep 03 16:19:00 PDT 1995

proc showError elist {

	global  bitmapdir


# make sure we do NOT create windows whose names start with upcase
# letters (illegal in Tk 3.2)

  set win .errorbox
  catch {destroy $win}
  toplevel $win
  wm title $win "Error Detected"
  wm iconbitmap $win @$bitmapdir/picklist.xbm

  wm geom $win 700x300+200+200
  wm minsize $win 400 300

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

  set font [getFont $win mediumhelb]
  label $win.l.l -text "Error output"  -anchor center -font $font 
  scrollbar $win.f.vert -orient vertical -command "$win.f.text yview" 	-relief sunken
  scrollbar $win.horz -orient horizontal -command "$win.f.text xview" 	-relief sunken
  set font [getFont $win mediumcou]

  listbox $win.f.text -yscroll "$win.f.vert set" -xscroll "$win.horz set"   -relief sunken -font $font
  
  set errtext "TEXT OF ERROR MESSAGE:\n"
  foreach lem $elist {
    $win.f.text insert end "\n$lem"
    append errtext "$lem\n"
  }

  button $win.b.ok -text "Done" -relief raised -borderwidth 2  -command "destroy $win" -padx 0 -pady 0
  button $win.b.prt -text "Print" -relief raised -border 2  -command "printBox $win.f.text" -padx 0 -pady 0
  eval button $win.b.mail -text \"Mail to DBA\" -relief  raised -border 2  -command \{mailMaven SYBASE_APPLICATION_ERROR \{$errtext\} \}

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

  pack $win.l.l -side top -fill x -anchor nw
  pack $win.f.vert -side right -fill y -fill x  
  pack $win.f.text  -side left -fill both -expand true

  pack $win.b.mail -side left -ipadx 40 -ipady 2
  pack $win.b.prt -side left -ipadx 40 -ipady 2
  pack $win.b.ok -side right -ipadx 40 -ipady 2
 

}

proc showText {win heading geom tlist {min {}} } {

	global  bitmapdir


# make sure we do NOT create windows whose names start with upcase
# letters (illegal in Tk 3.2)

  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 iconbitmap $win @$bitmapdir/picklist.xbm

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

  frame $win.l -background antiquewhite
  frame $win.f -background antiquewhite
  frame $win.b -relief sunken -borderwidth 1 -background antiquewhite

#	is this a minimal show box?
  if {$min == ""} {set min 0} else {set min 1}

  set font [getFont $win mediumhelb]
  label $win.l.l -text $heading -anchor center -font $font -background antiquewhite
  scrollbar $win.f.vert -orient vertical -command "$win.f.text yview" 	-relief sunken -background ivory -troughcolor bisque -activebackground mistyrose
  scrollbar $win.horz -orient horizontal -command "$win.f.text xview" 	-relief sunken -background ivory -troughcolor bisque -activebackground mistyrose
  set font [getFont $win mediumcou]
  set sfont [getFont $win courier]

  listbox $win.f.text -yscroll "$win.f.vert set" -xscroll "$win.horz set"   -relief sunken -font $font -background ivory
  
  foreach lem $tlist {
    $win.f.text insert end "$lem"
  }

  button $win.b.ok -text "Done" -relief raised -borderwidth 2  -command "destroy $win" -padx 0 -pady 0 -background white -foreground red -activebackground black -activeforeground yellow
  button $win.b.prt -text "Print" -relief raised -border 2  -command "printBox $win.f.text" -padx 0 -pady 0 -background lavender -activebackground lavender -activeforeground magenta2
  button $win.b.shrink -text "Smaller" -relief raised -border 2  -command "$win.f.text configure -font $sfont; $win.b.shrink configure -state disabled" -padx 0 -pady 0 -background lavender -activebackground lavender -activeforeground magenta2

  if !$min {
  button $win.b.mail -text "Mail to:" -relief raised -border 2  -command "mailText $win.f.text \[$win.b.recip get\]" -padx 0 -pady 0 -background lavender -activebackground lavender -activeforeground magenta2
  entry $win.b.recip -relief sunken -border 2 -width 20 -background ivory

  button $win.b.save -text "Save as:" -relief raised -border 2  -command "saveText $win.f.text \[$win.b.filen get\]" -padx 0 -pady 0 -background lavender -activebackground lavender -activeforeground magenta2
  entry $win.b.filen -relief sunken -border 2 -width 20 -background ivory
  }

  pack $win.l -side top -fill x
  pack $win.f -side top -fill both -expand true
  pack $win.horz -side top -fill x
  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.text -side left -fill both -expand true

  pack $win.b.shrink -side left -ipadx 20 -ipady 2
  pack $win.b.prt -side left -ipadx 20 -ipady 2
  if !$min {
  pack $win.b.mail -side left -ipadx 30 -ipady 2
  pack $win.b.recip -side left -ipady 2
  pack $win.b.save -side left -ipadx 20 -ipady 2
  pack $win.b.filen -side left -ipady 2
  }
  pack $win.b.ok -side right -ipadx 20 -ipady 2

}
proc sigTrap {} {

	global onStop

	puts stderr "Got Script Stop Interrupt SIGUSR1"

	stopScript

#	If the specific app needs some kind of cleanup after a script
# 	is aborted...
	if {[info exists onStop]} {
		foreach c $onStop {
			uplevel #0 $c
		}
	}

	return -code error -errorcode STOP -errorinfo "Script Interrupted"

}
# $Header: /home/cvsroot/tcldb/ucodb/Tlib/startMsg,v 1.1.1.1 1996/10/12 01:08:26 de Exp $

proc startMsg msg_text {

#	Try the forms version.
	set err [catch {.msg configure -text "$msg_text"}]
	if {$err} {
#		No? try the wisql version
		set err [catch {.m.msg configure -text "$msg_text"}]
		if {$err} {
			echo "$msg_text"
		}
	}
	update
}

proc stopScript {} {

#$Header: /home/cvsroot/tcldb/ucodb/Tlib/stopScript,v 1.1 1998/12/16 21:45:43 de Exp $

	global UserCmd lfp CmdRing CmdPtr LastPtr 
	global errorCode errorInfo Script

	set Script 0

	foreach a [after info] {
		after cancel $a
	}

	mkMsg "Script Interrupted!"

	set t .scriptEdit.top.txt

	set err [catch {$t configure -background yellow} res]

	if {!$err} {
		update idletasks
		after 250
		set err [catch {$t configure -background ivory} res]
		update idletasks
		set err [catch {$t configure -foreground black} res]
	} else {
		puts stderr "OUCH no such widget $t"
		puts stderr "stopScript is confused"
	}

}
# $Header: /home/cvsroot/tcldb/ucodb/Tlib/termCheck,v 1.1.1.1 1996/10/12 01:08:25 de Exp $
# tcl procs saved on Sun Sep 03 16:19:08 PDT 1995

proc termCheck {} {
#
global exedir
#
#
#	Do I have a controlling terminal, or have I been detached?
#	Return 1 if detached, 0 if all is well...
#	warning messages.
#
        set pid [fork]
        if {$pid == 0} {
           execl $exedir/detached
        }
        return [lindex [wait $pid] 2]
}

# $Header: /home/cvsroot/tcldb/ucodb/Tlib/whichFY,v 1.4 2000/01/03 18:40:18 de Exp $
# tcl procs saved on Sun Sep 03 16:19:18 PDT 1995

proc whichFY {} {

#	which fiscal year is it Right Now?

	lassign [fmtclock [getclock] "%m %y"] mon yr

	set mon [string trimleft $mon 0]
	set yr [string trimleft $yr 0]

	if {$yr == ""} {set yr 0}

	if {$mon > 6} {
		set yr [expr $yr + 1]
		if {$yr > 99} {
			set yr [expr $yr - 100]
		}
	} 
	return "f[format %02d $yr]"

}


#@package: Dot pgLayout processFlags


proc pgLayout {} {
# $Header: /home/cvsroot/tcldb/ucodb/Tlib/pgLayout,v 1.1 1998/07/15 22:01:00 de Exp $
# write out the digraph def

	global Page Lang Tile Stretch Rota Flags Grow
#
set res ""
# no, let dot order things for you
if {$Tile} {
#	We default to B size always on tiling.
	puts stderr "  This plot is just too big, I'm going to tile it."
	if {$Page == "A"} {
	append res "page=\"8.5,11\"\;\n"
	puts stderr "  You forced me to use A-size tiles, so I hope you"
	puts stderr "  have a lot of patience and sticky-tape."
	} else {
	puts stderr "  I'm also going to use 11x17 as the tile size, so"
	puts stderr "  you might start looking for an 11x17 printer :-)"
	append res "page=\"11,17\"\;\n"
	}
	append res "ranksep=1.0\;\n"
	append res "nodesep=0.5\;\n"
} else {
#	always assume A size unless lang is hpgl, in which case E size
	if {$Lang == "hpgl"} {
	puts stderr "  HPGL selected, E size 32x42 page..."
	puts stderr "  I'm going to warn you right now that this probably"
	puts stderr "  won't work.  dot seems to have trouble scaling "
	puts stderr "  HPGL plots, but you can fix it by editing the "
	puts stderr "  output file."
	append res "size=\"42,32\"\;\n"
	set rota 0
	} else {
#	assume PostScript for now, A size 8.5x11 with margins
	if {$Page == "B"} {
	if {$Rota} {
	append res "size=\"16,10\"\;\n"
	} else {
	append res "size=\"10,16\"\;\n"
	}
	} else {
	if {$Rota} {
	append res "size=\"10,7.5\"\;\n"
	} else {
	append res "size=\"7.5,10\"\;\n"
	}
	}
	}
	
	append res "ratio=compress\;\n"
	append res "nodesep=0.25\;\n"
	if {$Stretch} {
		puts stderr "  decided to stretch ranks"
		append res "ranksep=3.0\;\n"
	} else {
		append res "ranksep=0.5\;\n"
	}
}
#
if {$Rota} {
puts stderr "  decided to rotate plot"
append res "rotate=90\;\n"
}
#
if {$Grow == "H"} {
puts stderr "  ranks grow horizontally"
append res "rankdir=LR\;\n"
}
#
set res [string trimright $res \n]
return "$res"
#
}
proc processFlags {} {
# $Header: /home/cvsroot/tcldb/ucodb/Tlib/processFlags,v 1.1 1998/07/15 22:01:00 de Exp $

	global Lang Tile Stretch Rota Flags Grow
	global NumPath Quiet Describe Footer Page
#
# 	 Layout logic (oof).
#	returns a block of text to be placed in the body of the digraph def
#	
# check for override flags:
# L landscape 
# T tiled 
# C compressed (not tiled) 
# A force letter
# B force 11x17
# H force ranks to grow horizontally 
# X force HPGL
# D show description in box as well as agent name  (default off)
# N show Mpath numbers (default off)
# Q quiet: don't show anything but meme name (default off)
# F print footer (title) on plot (default off)
# n number 0 - 9 means something special, pass it back as return
# 

set res ""
# 
if {$Flags != ""} {
foreach f [split $Flags {}] {
	switch -- $f {
	{L} {set Rota 1}
	{C} {set Tile 0}
	{T} {set Tile 1}
	{F} {
	    set Footer 1
	}
	{H} {set Grow H}
	{X} {
		set Lang hpgl
		set Tile 0
		set Rota 1
	}
	{A} {set Page A}
	{B} {set Page B}
	{N} {set NumPath 1}
	{Q} {set Quiet 1}
	{D} {set Describe 1}
	{0} -
	{1} -
	{2} -
	{3} -
	{4} -
	{5} -
	{6} -
	{7} -
	{8} -
	{9} {lappend res $f}
	{default} {
		puts stderr "Unrecognized flag $Flags"
	}
	}
}
}
return $res
#
}

#@package: GenericDB getCols queryDB nextRec showCount


proc getCols {} {

	global DB pgHan pgCt sybmsg PGtypes

	set cols ""
	set found ""

	case $DB in {
	{SYB} {
		set flds [sybCols 1]
		set lens $sybmsg(collengths)
		set typs $sybmsg(coltypes)
		set i 0
		foreach c $flds {
			if {$c == ""} { set c C$i }
			if {[lsearch $found $c] >= 0} {
				set c ${c}_$i
			}
			set l [lvarpop lens]
			set t [lvarpop typs]
			keylset cols $c "$t $l"
			lappend found $c
			incr i
		}
	}
	{PG} {
      		set att_list [pgCols $pgHan]
		set i 0
		foreach a $att_list {
			set cn [lindex $a 0]
			if {$cn == ""} { set cn C$i }
                	if {[lsearch $found $c] >= 0} {
                		set c ${c}_$i
               	 	}
			set ct [keylget PGtypes([lindex $a 1]) typname]
			set cl [lindex $a 2]
#		TEMPORARY hardwire
			if {$cl < 0} {
				set cl 32
			}
			keylset cols $cn "$ct $cl"
			lappend found $c
			incr i
		}
	}
	{default} {
		puts stderr "Sorry, Oracle not supported yet."
	}
	}
#	puts stderr "returning cols: $cols"
	return "$cols"

}
proc nextRec {} {

	global pgHan pgCt DB table moreRec sybmsg

	case $DB in {
	{SYB} {
		set rec [sybNext 1]
		if {$sybmsg(nextrow) == "NO_MORE_RESULTS"} {
			set moreRec 0
		}
	}
	{PG} {
		set rec [pgNext $pgHan]
		if {[lindex $rec 0] == "ERROR"} {
			set moreRec 0
			set pgCt 0
			return ""
		}
		incr pgCt -1
		if {$pgCt == 0} {set moreRec 0}
	}
	{default} {
		puts stderr "Sorry, Oracle not yet supported."
	}
	}
	return "$rec"
}
proc queryDB sqlcmd {

	global pgHan pgCt DB table moreRec

	set sqt $table

	set moreRec 0

	case $DB in {
	{SYB} {
		set res [doSQL 1]
	}
	{PG} {
		lassign [pgSQL 1] pgCt pgHan res
#		puts stderr "queryDB res $res"
#		puts stderr "Got pgCt $pgCt pgHan $pgHan"
		if {[crange $res 0 3] == "WARN"} {
			set res "ERROR \"$res\""
		}
		if {$pgCt} {set moreRec 1}
	}
	{default} {
		puts stderr "Sorry, Oracle not yet supported."
	}
	}

	if {[lindex $res 0] == "ERROR"} {
		set moreRec 0
		return "$res"
	} else {
		set moreRec 1
		return "OK"
	}
}
proc showCount {} {
#
#	use the housekeeping channel dbpipe2
#
	global server table Qtable DB

#
#	Qtable is the form of the table name to be used in
#	query.  PG does not accept the qualified own.tbl form,
#	but Sybase does.

	if {$table == ""} {
	setMsg .m.msg "Sorry, you haven't selected a table yet."
	return
	}

	set Qtable $table
	if {$DB == "PG"} {
		set Qtable [lindex [split $table .] end]
	}
#
	set sqlcmd "select count(*) from $Qtable"
	set res [queryDB $sqlcmd]
	puts stderr "showCount query res $res"
	set rc [nextRec]
	puts stderr "showCount got count $rc"
	setMsg .m.msg "$server: selected table $table has $rc records"
	
}

#@package: GenericUI mkAlert mkDialog Prompt mkEdit mkMsg askUser


proc Prompt {args} {
#$Header: /home/cvsroot/tcldb/ucodb/Tlib/Prompt,v 1.1 1998/12/09 21:42:44 de Exp $

	global UserResp Mode

	if {[info exists Mode]} {
	if {$Mode == "batch"} {
		Error "You can't use Prompt in a batch exec"
		return
	}
	}

	set msg "[stringFix2 $args out]"

        eval mkDialog .confirm_Chg  \{ -text \"$msg\" \}   \"\{OK\}   \{set UserResp 1\}\"  \"\{Sorry No Can Do\} \{set UserResp 0\}\"

	vwait UserResp
	
	return $UserResp

}

proc askUser args {

#$Header: /home/cvsroot/tcldb/ucodb/Tlib/askUser,v 1.1 1999/01/15 00:32:38 de Exp $

        global UserInput UserResp Mode

        if {[info exists Mode]} {
        if {$Mode == "batch"} {
                Error "You can't use Prompt in a batch exec"
                return
        }
        }

	set UserInput ""

        set msg "[stringFix $args]"

        set w .ask
        catch {destroy $w}
        toplevel $w

        message $w.m -text "$msg" -background antiquewhite -aspect 5000 
        entry $w.e -textvariable UserInput -background ivory -relief sunken  -width 40
        button $w.b -text "OK" -background lavender -activebackground lavender  -activeforeground magenta2 -command "set UserResp \$UserInput; destroy $w"
        
        pack $w.m -side top -expand true -fill x
        pack $w.e -side top -expand true -fill x
        pack $w.b -side top -expand true -fill x

}
proc mkAlert {tt at bt ju nam {font {}}} {

#	global datahelping

    if {$nam == ""} {
    set w .alertbox
    } else {
    set w .nam
    }
    catch {destroy $w}
    toplevel $w -class Dialog
    wm title $w "$tt"
    wm geometry $w "+150+150"
    wm iconname $w "ReadMe"

    frame $w.top -relief raised -border 1 -background antiquewhite
    frame $w.bot -relief raised -border 1 -background antiquewhite
    pack $w.top -side top -fill both -expand true 
    pack $w.bot -side top -fill both -expand true

    case $ju in {
	{l} {
		set just left
	}
	{r} {
		set just right
	}
	{v} {
		set just verbatim
	}
	{default} {
		set just center
	}
    }

    if {$font == ""} {
    set font [getFont $w mediumhel]
    }
    if {$just == "verbatim"} {
    set l [expr [llength [split $at \n]] + 1]
    text $w.top.msg -width 60 -height $l -background ivory
    $w.top.msg insert 1.0 $at
    $w.top.msg configure -state disabled
    } else {
    eval message $w.top.msg -justify $just -font $font -text $at -background ivory
    }
    pack $w.top.msg -side top -expand true -fill both -ipadx 5


    button $w.bot.dismiss -text $bt -command "destroy $w" -padx 0 -pady 0  -background lavender -activebackground lavender -activeforeground magenta2

#	If called from wisql with ctrl-mouse-3, then ...

    if {$nam == "showsql"} {
	eval button $w.bot.tran -text "TRANSFER" -command \{.m.s.sql delete 1.0 end\; .m.s.sql insert 0.1 $at \}
	pack $w.bot.tran -side left -ipadx 10 
 	pack $w.bot.dismiss -side right -ipadx 15
    } else {
    pack $w.bot.dismiss -expand true -ipadx 20
    }

    bind $w <Return> "destroy $w"
    focus $w

}

# $Header: /home/cvsroot/tcldb/ucodb/Tlib/mkDialog,v 1.3 1998/10/26 21:17:52 de Exp $
# tcl procs saved on Sun Sep 03 16:18:51 PDT 1995

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 geom $w "+200+200"

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

    frame $w.top -relief raised -border 1 -background antiquewhite
    frame $w.bot -relief raised -border 1 -background antiquewhite
    pack $w.top -side top -fill both -expand true 
    pack $w.bot -side top -fill both -expand true
    
    # Create the message widget and arrange for it to be centered in the
    # top frame.
    
    set font [getFont $w mediumtim]
    eval message $w.top.msg -justify center 	    -font $font $msgArgs -background antiquewhite
    pack $w.top.msg -side top -expand true -ipadx 5 -ipady 5
    
    # the dialog.

    if {[llength $args] > 0} {
	set arg [lindex $args 0]
	frame $w.bot.0 -relief sunken -border 1 -background antiquewhite
	pack $w.bot.0 -side left -expand true -ipadx 5 -ipady 5
	button $w.bot.0.button -text [lindex $arg 0] 		-command "[lindex $arg 1]; destroy $w" -padx 0 -pady 0 -background lavender -activebackground lavender -activeforeground magenta2
	pack $w.bot.0.button -expand true -ipadx 5 -ipady 5
	bind $w <Return> "[lindex $arg 1]; destroy $w; break"
	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" -padx 0 -pady 0 -background white -foreground red -activebackground black -activeforeground yellow
	    pack $w.bot.$i -side left -expand true 
	    incr i 
	}
    }
}

proc mkEdit {tt at bt nam ext} {

# $Header: /home/cvsroot/tcldb/ucodb/Tlib/mkEdit,v 1.13 1999/06/16 20:09:13 de Exp $
#	global datahelping Retn

    global Script StopScript BugBoiler

    if {$nam == ""} {
    set w .alertbox
    } else {
    set w .$nam
    }
    catch {destroy $w}
    toplevel $w -class Dialog
    wm title $w "$tt"
    wm geometry $w "+150+150"
    wm iconname $w "SQLcmd"
    wm minsize $w 200 200
    wm maxsize $w 1000 900

    frame $w.top -relief raised -border 1 -background antiquewhite
    frame $w.bot -relief raised -border 1 -background antiquewhite
    pack $w.top -side top -fill both -expand true 
    pack $w.bot -side top -fill x -expand true

    set tl [clength $at]

#   cap the max text box height
    set hgt [expr {$tl/40 + 5}]
    if {$hgt > 40} {set hgt 40}
#   floor the min text box height
    if {$hgt < 15} {set hgt 15}

    set font [getFont $w mediumcou]
    scrollbar $w.top.vert -relief sunken -command "$w.top.txt yview"  -orient vertical
    eval text $w.top.txt -font $font -wrap word -height $hgt -border 2 -relief sunken -yscroll \"$w.top.vert set\" -background ivory
    pack $w.top.vert -side right -fill y  
    pack $w.top.txt -side left -expand true -fill both -ipadx 5 -ipady 5

    $w.top.txt insert 1.0 "$at\n"

    button $w.bot.save -text "Save as:"  -command "editFile $w.top.txt \[$w.bot.filew get\] \"$ext\" w" -padx 1 -pady 1 -background lavender -activebackground lavender -activeforeground magenta2
    entry $w.bot.filew -relief sunken -width 20 -background ivory
    button $w.bot.read -text "Read from:" -command "editFile $w.top.txt \[$w.bot.filer get\] \"$ext\" r" -padx 1 -pady 1 -background lavender -activebackground lavender -activeforeground magenta2
    entry $w.bot.filer -relief sunken -width 20  -background ivory

	
    button $w.bot.dismiss -text $bt -command "editFile $w.top.txt [clock seconds].etext \"$ext\" w; destroy $w" -padx 0 -pady 0 \
	-background white -foreground red -activebackground black -activeforeground yellow

    button $w.bot.mail -text "Mail to:" -relief raised -border 2  -command "mailText $w.top.txt \[$w.bot.recip get\]" -padx 1 -pady 1 -background lavender -activebackground lavender -activeforeground magenta2
    entry $w.bot.recip -relief sunken -border 2 -width 20 -background ivory


#	If called from fosql with ctrl-mouse-3 on genericFind, then ...

	
      case $nam in {
	{findsql} {
	upvar #0 xess_connection xess
	if {$xess == 0} {
		isXess
	}
	button $w.bot.show -text "View data"  -command "doShow {} \[$w.top.txt get 1.0 end\]" -padx 0 -pady 0
	if {$xess} {
	button $w.bot.xess -text "-> Xess" -command "doXess {} \[$w.top.txt get 1.0 end\]" -padx 0 -pady 0
        pack $w.bot.show -side left -ipadx 10 -ipady 2
        pack $w.bot.save -side left -ipadx 10 -ipady 2
  	pack $w.bot.filew -side left -ipady 2
  	pack $w.bot.read -side left -ipadx 10 -ipady 2
	pack $w.bot.filer -side left -ipady 2
 	pack $w.bot.show -side left -ipadx 20 -ipady 2
   	pack $w.bot.xess -side left -ipadx 20 -ipady 2
  	pack $w.bot.dismiss -side right -ipadx 20 -ipady 2
	} else {
	pack $w.bot.show -side left -ipadx 10 -ipady 2
 	pack $w.bot.save -side left -ipadx 10 -ipady 2
  	pack $w.bot.filew -side left -ipady 2
  	pack $w.bot.read -side left -ipadx 10 -ipady 2
 	pack $w.bot.filer -side left -ipady 2
 	pack $w.bot.dismiss -side right -ipadx 20 -ipady 2
	}
	}
	{help} {
	$w.top.txt configure -state disabled
 	pack $w.bot.save -side left -ipadx 10 -ipady 2
  	pack $w.bot.filew -side left -ipady 2
	pack $w.bot.dismiss -expand true -ipadx 15 -ipady 2
	}
	{scriptEdit} {
	button $w.bot.doit -text "GO"  \
		-command "set Script 1; set StopScript 0; doUserCmd \[$w.top.txt get 1.0 end\] $w.top.txt; set Script 0; set StopScript 0" \
		-background gold -activebackground yellow \
		-padx 0 -pady 0 
	button $w.bot.stop -text "STOP" -command "kill SIGUSR1 [id process]" \
		-background white \
		-foreground red -activebackground black -activeforeground yellow \
		-padx 0 -pady 0
	pack $w.bot.doit -side left -ipadx 10 -ipady 2
	pack $w.bot.stop -side left -ipadx 10 -ipady 2
 	pack $w.bot.save -side left -ipadx 10 -ipady 2
  	pack $w.bot.filew -side left -ipady 2
  	pack $w.bot.read -side left -ipadx 10 -ipady 2
 	pack $w.bot.filer -side left -ipady 2
 	pack $w.bot.dismiss -side right -ipadx 20 -ipady 2
	}
	{bugReport} {
	$w.bot.recip insert 0 de@ucolick.org
	if {![info exists BugBoiler]} {
		set BugBoiler "BUG REPORT [clock format [clock seconds]] by [id user]\n"
	}
	foreach l $BugBoiler {
	$w.top.txt insert end "$l\n"
	}
	pack $w.bot.mail -side left -ipadx 10 -ipady 2
	pack $w.bot.recip -side left -ipadx 10 -ipady 2
 	pack $w.bot.dismiss -side right -ipadx 20 -ipady 2
	}
	{cmdEdit} {
	button $w.bot.doit -text "Execute"  -command "doUserCmd \[$w.top.txt get 1.0 end\] $w.top.txt" -padx 0 -pady 0 -background gold -activebackground yellow
	bind $w.top.txt <Control-n> "rotCmd next"
	bind $w.top.txt <Control-p> "rotCmd prev"
	bind $w.top.txt <Shift-Return> "$w.bot.doit invoke"
	pack $w.bot.doit -side left -ipadx 10 -ipady 2
 	pack $w.bot.save -side left -ipadx 10 -ipady 2
  	pack $w.bot.filew -side left -ipady 2
  	pack $w.bot.read -side left -ipadx 10 -ipady 2
 	pack $w.bot.filer -side left -ipady 2
 	pack $w.bot.dismiss -side right -ipadx 20 -ipady 2
	}
    	{default} {
	pack $w.bot.dismiss -expand true -ipadx 15 -ipady 2
	pack $w.bot.mail -side left -ipadx 10 -ipady 2
	pack $w.bot.recip -side left -ipadx 10 -ipady 2
 	pack $w.bot.save -side left -ipadx 10 -ipady 2
  	pack $w.bot.filew -side left -ipady 2
  	pack $w.bot.read -side left -ipadx 10 -ipady 2
 	pack $w.bot.filer -side left -ipady 2
 	pack $w.bot.dismiss -side right -ipadx 20 -ipady 2
	}
    }
    update

#    bind $w <Return> "destroy $w"
    focus $w

}
proc mkMsg msg {

#$Header: /home/cvsroot/tcldb/ucodb/Tlib/mkMsg,v 1.3 1999/03/27 02:19:38 de Exp $

        global MsgBox MsgColours MsgColInd CurrMsg
	global Owner

	if {[info exists Owner]} {
		send $Owner mkMsg \"$msg\"
		return
	}

	if {![info exists MsgBox]} {
		puts stderr "MSG $msg"
		return
	}

        set mm [eval max [array names MsgColours]]

        incr MsgColInd

        if {$MsgColInd > $mm} {
                set MsgColInd 0
        }

        $MsgBox configure -state normal
        set CurrMsg "$msg"
#       $MsgBox delete 0 end
#       $MsgBox insert 0 "$msg"
        $MsgBox configure -state disabled -background $MsgColours($MsgColInd)

}


#@package: SpreadSheet mkSheet cellChange cellCommit cellEval \
	cellIndex cellSelect compSheet expandStat appendSelCV alphaIndex \
	doSaveSheet keySheet  avg sum mean addCell2Form clearSheet \
	doLoadSheet getHeads sheetWin


proc addCell2Form {which t} {

	global curCell CellValues CellFormulae curVal
	global SheetAddB

#	set t table 
        set win [sheetWin $t]
        set b $win.c.adds

#	which is A for add, anything else for Normal.

	if {$which == "A"} {

	bind $t <ButtonRelease-1> {}
	bind $t <ButtonRelease-1> {
    		if {[winfo exists %W]} {
        		tkCancelRepeat
			appendSelCV %W
			break
    		}
	}
	$b configure -text "NormalSelect" -command "addCell2Form N $t"  -background cyan

	} else {

	bind $t <ButtonRelease-1> {}
    		
	$b configure -text "Add2Formula" -command "addCell2Form A $t"  -background lavender

	}
}

proc alphaIndex ind {

	lassign [split $ind ,] r c
	set ca [ctype char [expr 64+$c]]
	return "$ca$r"

}
proc appendSelCV t {

	global curCell CellValues CellFormulae curVal

	set il [$t curselection]
	set first [alphaIndex [lindex $il 0]]
	set last [alphaIndex [lindex $il end]]
	if {$first == $last} {
	append curVal "\$$first"
	} else {
	append curVal "\$$first.$last"
	}
}
#
proc avg nl {

	set s 0
	set ll [llength $nl]
	foreach n $nl {
		set s [expr $s + $n]
	}
	return [expr $s/double($ll)]
}
#
proc cellChange {ind {n1 {}} {n2 {}} {op {}}} {

	global Procs 
	global CellFormulae CellValues

	set plist ""

	catch {set plist [set Procs($ind)]}

	if {$plist == ""} {return}

	foreach p $plist {
		eval $p
	}

}
proc cellCommit t {

	global CellValues CellFormulae curCell curVal AutoRecompute

	set ind $curCell

	if {$ind != $curCell} {
		puts stderr "Current cell $curCell does not match sel $ind"
		return
	}

	set res 1
	if {[cindex $curVal 0] == "="} {
		set CellFormulae($ind) "[crange $curVal 1 end]"
		set res [cellEval $t $ind]
	} else {
		set CellValues($ind) $curVal
	}

	if {$AutoRecompute} {
		compSheet $t
	}

	addCell2Form N $t

	return $res

}

proc cellEval {t ind {n1 {}} {n2 {}} {op {}}} {

	global CellValues CellFormulae Procs
#	We have an expression possibly containing cell addresses!
#	cell addresses are like $B2, $C66
#	we have to translate these into numeric indices

	lassign [split $ind ,] row col

	set form $CellFormulae($ind)

	set stats "sum avg min max cnt"

#	puts stderr "in cellEval:  formula $form"

	set depends ""
	while {![lempty $form]} {
#	if it's a func then it is followed by something in parens.
		set w [lvarpop form]
		if {[lsearch $stats [crange $w 0 2]] >= 0} {
			lassign [expandStat $w] v ilist
#			puts stderr "Got v $v from w $w"
			if {$v == "ERR"} {
				puts stderr "ERROR evaluating expression $w"
				$t tag cell error $ind
				set cellValues($ind) "<ERR>"
				return 0
			}
			append exp "$v "
			lvarcat depends $ilist
			continue
		}
#	if it's not a func then it's a constant or cell ref
		if {[cindex $w 0] == "\$"} {
			if {[string first . $w] < 0} {
			set rc [cellIndex [crange $w 1 end]]
			set v $CellValues($rc)
			lappend depends $rc
			} else {
			puts stderr "ERROR range without stat func: $w"
			$t tag cell error $ind
                        set cellValues($ind) "<ERR>"
                        return 0
#			lassign [cellIndex [crange $w 1 end]] i1 i2
#			set v "\{[$t get $i1 $i2]\}"
			}
			append exp "$v "
		} else {
			append exp "$w "
		}
	}

	set err [catch {eval set val \[expr \{$exp \} \] } res]

	if {$err} {
		puts stderr "ERROR evaluating expression $form"
		puts stderr "      $exp"
		$t tag cell error $ind
		set CellValues($ind) "<ERR>"
		return 0
	} else {
		set CellValues($ind) $val
		$t tag cell formula $ind
		foreach d $depends {
			set cmd "cellEval $t $ind"
			if {![info exists Procs($d)]} {
				lappend Procs($d) $cmd
#				puts stderr "$ind depends on $d, trace $d"
			} else {
				if {[lsearch $Procs($d) $cmd] < 0} {
					lappend Procs($d) $cmd
#					puts stderr "$ind depends on $d, trace $d"
				}
			}
			if {[trace vinfo CellValues($d)] == ""} {
				trace variable CellValues($d) w "cellChange $d"
			}
		}
		return 1
	}
}

proc cellIndex w {

#	puts stderr "alpha index is $w"

       	if {[string first . $w] < 0} {
        	set c [cindex $w 0]
                set c [expr [ctype ord $c] - 64]
                set r [crange $w 1 end]
		set ind "$r,$c"
        } else {
                set wl [split $w .]
                lassign $wl first last
                set c1 [cindex $first 0]
                set c1 [expr [ctype ord $c1] - 64]
                set r1 [crange $first 1 end]
                set c2 [cindex $last 0]
                set c2 [expr [ctype ord $c2] - 64]
                set r2 [crange $last 1 end]
		set ind "$r1,$c1 $r2,$c2"
	}

#	puts stderr "returning $ind"

	return $ind
}

proc cellSelect t {

	global curCell CellValues CellFormulae curVal

	set win [sheetWin $t]
	set msgw $win.msg
	set elab $win.c.clab
	set addb $win.c.adds

	set r [$t index active row]
	set c [$t index active col]
	set i "$r,$c"

#	puts stderr "cur ind of $t is $i"
#	puts stderr "row $r col $c"

	set ind "$r,$c"
	set ca [ctype char [expr 64+$c]]

	if {[info exists CellFormulae($ind)]} {
		set curVal "= $CellFormulae($ind)"
	} elseif {[info exists CellValues($ind)]} {
		set curVal $CellValues($ind)
	} else {
		set curVal "<empty>"
		set CellValues($ind) ""
	}

	$elab configure -text "$ca$r Edit :"
	set curCell $ind
	compSheet $t

}

proc clearSheet t {

	global CellValues CellFormulae curRow Procs

  	set tw [sheetWin $t]
  	set msgw $tw.msg

        foreach i [array names CellValues] {
		if {[info exists Procs($i)]} {
			trace vdelete CellValues($i) w "cellChange $t $i"
			unset Procs($i)
		}
                set CellValues($i) ""
        }

        foreach i [array names CellFormulae] {
                set CellFormulae($i) ""
        }

        foreach i [$t tag row heads] {
                $t tag row {} $i
        }
        foreach i [$t tag cell formula] {
                $t tag cell {} $i
        }
        foreach i [$t tag row error] {
                $t tag cell {} $i
        }
        foreach i [$t tag row separator] {
                $t tag row {} $i
        }

        keySheet $t
        set curRow 1

	setMsg $msgw "Erased Sheet"

}
proc compSheet t {

	global CellValues CellFormulae

	foreach ind [array names CellValues] {
		set v $CellValues($ind)
		if {[string first = $v] == 0} {
			set CellFormulae($ind) [crange $v 1 end]
			$t tag cell formula $ind
		}
	}

	set forms [$t tag cell formula]

#	one pass is not enough to propagate! seems we need some way
#	of knowing when we've got to the end -- a dependency map or 
#	an ordered list.

	foreach f $forms {
		cellEval $t $f
	}

	return 1

}

# $Header: /home/cvsroot/tcldb/ucodb/Tlib/doLoadSheet,v 1.4 1998/02/16 04:39:12 de Exp $
# tcl procs saved on Tue Sep 05 09:32:41 PDT 1995

proc doLoadSheet {t win filename} {

  global CellValues CellFormulae

#
#	future modes:  HTML, LaTeX
#

        set tw [sheetWin $t]
        set msgw $tw.msg

  set openrc [catch {set f [open $filename r]}]
  
  if $openrc==1 {
    setMsg $msgw "Sorry, cannot open $filename for writing."
    return -1
  }

  close $f

  set cells [$t curselection]

#       puts stderr "Got Cells $cells"
  set rows ""
  if {$cells == ""} {
        puts stderr "ingest whole sheet"
        set r1 1
        set c1 1
        set r2 [$t cget -rows]
        set c2 [$t cget -cols]
  } else {
        lassign [split [lindex $cells 0] ,] r1 c1
        lassign [split [lindex $cells end] ,] r2 c2
        puts stderr "position is $r1,$c1 extends to $r2,$c2"
  }


  set rs [$t cget -rows]
  set cs [$t cget -cols]

  set i $r1
  set c $c1
  for_file line $filename {
	set line [split $line \t]
	set ll [llength $line]
	loop j 1 [expr $ll+1] {
		set v [lvarpop line]
		if {$v == ""} {continue}
		if {[string first = $v] == 0} {
			set CellFormulae($i,$j) [crange $v 1 end]
			cellEval $t $i,$j
		} else {
			catch {set CellValues($i,$j) $v}
		}
	}
	incr i
  }
  setMsg $msgw "Loaded sheet contents from TSV $filename"
  destroy $win

}

# $Header: /home/cvsroot/tcldb/ucodb/Tlib/doSaveSheet,v 1.5 1998/02/16 04:39:12 de Exp $
# tcl procs saved on Tue Sep 05 09:32:41 PDT 1995

proc doSaveSheet {t mode win filename} {

  global CellValues CellFormulae

#
#	future modes:  HTML, LaTeX, formula
#	HTM LTX FOR
#

  set openrc [catch {set f [open $filename w]}]
  
  if $openrc==1 {
    setMsg $SheetM "Sorry, cannot open $filename for writing."
    return -1
  }

  set tw [sheetWin $t]
  set msgw $tw.msg

  set cells [$t curselection]

#       puts stderr "Got Cells $cells"
  set rows ""
  if {$cells == ""} {
        puts stderr "save whole sheet"
        set r1 1
        set c1 1
        set r2 [$t cget -rows]
        set c2 [$t cget -cols]
  } else {
        lassign [split [lindex $cells 0] ,] r1 c1
        lassign [split [lindex $cells end] ,] r2 c2
        puts stderr "ingest $r1,$c1 through $r2,$c2"
#       it's meaningless to plot one row.
        if {$r1 == $r2} {set c2 $c1}
  }

  set rs [$t cget -rows]
  set cs [$t cget -cols]

#	find the last row with any data in it
  set lastrow 1
  loop i 1 $rs {
	set inds [array names CellValues $i,*]
#	puts stderr "for row $i, inds are $inds"
	if {[llength $inds] > 1} {
		set lastrow $i
	}
  }
#
  loop j 1 $cs {
	set cw($j) 12
	catch {set cw($j) [$t width $j]}
  }
  loop i 1 [expr $lastrow + 1] {
	set out ""
	loop j 1 $cs {
		set v ""
		catch {set v $CellValues($i,$j)}
		switch $mode {
		TSV { lappend out $v }
		ARF { 
			regsub -all , $v " " v
			lappend out $v 
		}
		FOR {
			if {[info exists CellFormulae($i,$j)]} {
			set v "=$CellFormulae($i,$j)"
			}
			lappend out "$v"
		}
		TXT {
			set w $cw($j)
			append out "[format %-$w.${w}s $v] "
		}
		}
	}
	switch -regexp $mode {
	{TSV|FOR} {
		puts $f "[join $out \t]"
	} 
	ARF {
		puts $f "[join $out ,]"
	}
	TXT { puts $f "$out" }
	}
  }

  close $f
  setMsg $msgw "Saved sheet contents in $mode to $filename"
  destroy $win

}

proc expandStat f {

	global CellValues CellFormulae
#	We have an expression possibly containing a cell range!
#	sum($E6.$E8)
#	avg($A8.$C10)
#	we have to translate these into a legit expression

	set p [cindex $f 3]
	if {$p != "("} {
		return ERR
	}

	set func [crange $f 0 2]
	set range [crange $f 4 end-1]

	lassign [split $range .] cr1 cr2
	if {[cindex $cr1 0] != "\$"} {
		return ERR
	}

#	get beginning and ending cell indices

	set rcb [cellIndex [crange $cr1 1 end]]
	set rce [cellIndex $cr2]
	lassign [split $rcb ,] r1 c1
	lassign [split $rce ,] r2 c2
	set ct 0
	set sum 0

	loop i $r1 [expr $r2 + 1] {
		loop j $c1 [expr $c2 + 1] {
			set v ""
			set ind "$i,$j"
			catch {[set v $CellValues($ind)]}
			lappend depends $ind
			if {$v != "<empty>"} {
				set err [catch {expr $v}]
				if !$err {
					set sum [expr $sum + $v]	
					incr ct
				}
			}
		}
	}

	set avg [expr $sum / [double $ct]]
	
	if {$func == "sum"} {
		return [list $sum $depends]
	} else {
		return [list $avg $depends]
	}
}

proc getHeads {r1} {

	global SheetT
#	proc to get last prev header row in sheet

        set hc [$SheetT tag row heads]
#        puts stderr "list of col head rows is $hc"
        set lr [lindex $hc 0]
        set hr $lr
        foreach r $hc {
                if {$r >= $r1} {
                        set hr $lr
                        break
                }
                set lr $r
        }

	return $hr

}
proc keySheet t {

	global CellValues

	set cols [$t cget -cols]
	set rows [$t cget -rows]

	loop i 1 $cols {
		set CellValues(0,$i) [ctype char [expr 64 + $i]]
	}

	loop j 1 $rows {
		set CellValues($j,0) $j
	}

}

#
proc mean nl {

	eval set max \[max $nl\]
	eval set min \[min $nl\]
	return [expr $min + ($max - $min) / 2.0]
}
#
proc mkSheet {w {flag {}}} {

#	builds a spreadsheet inside any frame handed to it

   global CellValues CellFormulae SheetT

#  just in case it is a toplevel

   set wn $w
   if {$w == "."} {set w ""}
   if {$w == ""} {set wn "."}

#   puts stderr "W is $w   WN is $wn"

   frame $w.mb -background bisque
   frame $w.ss -background bisque

#	the sheet widget will be SheetT
  set SheetT $w.ss.grid
  set cfont [getFont {} mediumcou]
  set tfont [getFont {} mediumhelb]


  scrollbar $w.ss.vert -relief sunken -command "$SheetT yview"  -orient vertical \
	-troughcolor bisque -background ivory -activebackground mistyrose
  scrollbar $w.ss.horz -relief sunken -command "$SheetT xview"  -orient horizontal \
	-troughcolor bisque -background ivory -activebackground mistyrose

#	menubar frame is mb (at top)
  menubutton $w.mb.data -menu $w.mb.data.m -text "File..." -background lavender -border 2 -relief raised -activebackground lavender -activeforeground magenta3
  set m [menu $w.mb.data.m -background lavender]
  $m add command -label "Recompute" -command "compSheet $SheetT" -background lavender -activebackground lavender -activeforeground magenta3
  $m add command -label "Export TSV..." -command "fileBox .save_Results * \"\" \"\" \"doSaveSheet $SheetT TSV\"" -background lavender -activebackground lavender -activeforeground magenta3
  $m add command -label "Export TXT..." -command "fileBox .save_Results * \"\" \"\" \"doSaveSheet $SheetT TXT\"" -background lavender -activebackground lavender -activeforeground magenta3
  $m add command -label "Save w/Calc..." -command "fileBox .save_Results * \"\" \"\" \"doSaveSheet $SheetT FOR\"" -background lavender -activebackground lavender -activeforeground magenta3
  $m add command -label "Import TSV..." -command "fileBox .save_Results * \"\" \"\" \"doLoadSheet $SheetT\"" -background lavender -activebackground lavender -activeforeground magenta3

  button $w.mb.eras -text Clear -command "clearSheet $SheetT" -background lemonchiffon -activebackground lemonchiffon -activeforeground red
  button $w.mb.quit -text Quit -command "destroy $wn" -background white -foreground red -activebackground black -activeforeground yellow

  frame $w.ss.c -background bisque
  label $w.ss.c.clab -relief sunken -background ivory -font $tfont \
	-text "Cell Edit:" -width 20
  set SheetEdLab $w.ss.c.clab
  entry $w.ss.c.cell -relief sunken -background white -foreground red \
	-textvariable curVal -border 2 
  button $w.ss.c.adds -background lavender -text "Add2Formula" \
	-command "addCell2Form A $SheetT"
  set SheetAddB $w.ss.c.adds
  bind $w.ss.c.cell <Return> "cellCommit $SheetT"
  table $SheetT -relief sunken -background ivory \
	 -yscroll "$w.ss.vert set" -xscroll "$w.ss.horz set" \
	-cols 10 -rows 25 -variable CellValues -font $cfont \
	-browsecommand "cellSelect %W" -anchor w -titlerows 1 \
	-titlecols 1 -exportselection 1 -selectmode extended 
  $SheetT tag config separator -bg gray
  $SheetT tag config active -fg red -bg yellow
  $SheetT tag config sel -bg yellow
  $SheetT tag config formula -bg seashell
  $SheetT tag config error -bg mistyrose
  $SheetT tag config title -bg papayawhip -font $tfont -fg black \
	-anchor center
  $SheetT tag config heads -bg azure -font $tfont 
  $SheetT width 0 6
  set curRow 1
  keySheet $SheetT
  
  bind $SheetT <Control-u> "clearSheet $SheetT; break"

  set font [getFont {} mediumhelb]
  message $w.ss.msg -text "Spreadsheet ready for use" -justify center -aspect 2000  -width 700 -relief sunken -font $font -background ivory
  pack $w.ss.msg -side bottom -fill x

  pack $w.ss.c.clab -side left
  pack $w.ss.c.adds -side right 
  pack $w.ss.c.cell -side left -fill x -expand true
  pack $w.ss.c -side top -fill x -expand true
  pack $w.ss.vert -side right -fill y
  pack $w.ss.horz -side bottom -fill x
  pack $SheetT -side top -fill both -expand true
  bind $SheetT <Control-x> "clearSheet $SheetT; break"

  pack $w.mb.data -side left
  pack $w.mb.quit -side right
  pack $w.mb.eras -side right
  pack $w.mb -side top -expand true -fill x
  pack $w.ss -side top -expand true -fill both

}
proc sheetWin {t} {

#	get parent frame of sheet

#        puts stderr "Got t $t"
        set wl [split $t .] 
        set ll [llength $wl]
        set ti [expr $ll - 2]
        set win [join [lrange $wl 0 $ti] .]

	return $win
}
#
proc sum nl {

	set s 0
	set ll [llength $nl]
	foreach n $nl {
		set s [expr $s + $n]
	}

	return $s
}
#

#@package: UCO-Data strFold Capitalize stringFix stringFix2 Tokenize \
	unTokenize chkNum getType formatCols numericCols isRoman sortAny \
	lreverse alphaSort uniFormat klDiff breakList klFmt txtDiff listDiff


# $Header: /home/cvsroot/tcldb/ucodb/Tlib/Capitalize,v 1.1.1.1 1996/10/12 01:08:25 de Exp $
# tcl procs saved on Sun Sep 03 16:18:59 PDT 1995

proc Capitalize {string mode} {

	case $mode in  {
	{all} {
	
	set nstring ""

	foreach word $string {

		set let1 [string toupper [crange $word 0 0]]
		set rem  [string tolower [crange $word 1 end]]

		append nstring "$let1$rem "
		
	}

	} 
	{first} {

	set word [lindex $string 0]
	set let1 [string toupper [crange $word 0 0]]
	set rem  [string tolower [crange $word 1 end]]
		
	append nstring "$let1$rem "

	foreach word [lrange $string 1 end] {
		append nstring "[string tolower $word] "
	}
		
	}
	{default} {

        set word [lindex $string 0]
        set let1 [string toupper [crange $word 0 0]]
        set rem  [string tolower [crange $word 1 end]]

        append nstring "$let1$rem "

        foreach word [lrange $string 1 end] {
                append nstring "$word "
        }

        }

	}

	return $nstring

}

# $Header: /home/cvsroot/tcldb/ucodb/Tlib/Tokenize,v 1.2 1997/07/24 06:24:43 de Exp $
# tcl procs saved on Sun Sep 03 16:19:03 PDT 1995

proc Tokenize line {

      regsub -all "\{" $line "LCB" line
      regsub -all "\}" $line "RCB" line
      regsub -all "\\\(" $line "LPA" line
      regsub -all "\\\)" $line "RPA" line
      regsub -all "\\\$" $line "EVV" line
      regsub -all "\\\[" $line "LSB" line
      regsub -all "\\\]" $line "RSB" line
      regsub -all "\"" $line "QQ" line
      regsub -all "\;" $line "SCO" line
      regsub -all "\\\\" $line "BSL" line

	return "$line"

}

proc alphaSort {l1 l2} {

#
#	object:  sort list 1 into the order of the corresponding alpha list 2
#
#	Rules:  no dups in either list
#

	if {[llength $l1] > [llength [lrmdups $l1]]} {
		return {}
	}
	if {[llength $l2] > [llength [lrmdups $l2]]} {
		return {}
	}

	foreach e2 $l2 {

		set e1 [lvarpop l1]

		set look($e2) $e1

	}

	set res ""
	foreach k [lsort [array names look]] {

		lappend res $look($k)

	}

	return $res

}
proc breakList {l n} {

#	given a list l, break it into n sublists of approx equal length

	set ll [llength $l]
	set over [int [fmod $ll $n]]
	set sl [expr $ll/$n]

	loop i 0 $n {
		if {$over} {
		set e $sl
		incr over -1
		} else {
		set e [expr $sl - 1]
		}
		set sub [lrange $l 0 $e]
		lappend ret $sub
		set l [lrange $l [expr $e+1] end]
	}

	return "$ret"
}
# $Header: /home/cvsroot/tcldb/ucodb/Tlib/chkNum,v 1.2 1999/03/09 22:43:03 de Exp $
# tcl procs saved on Sun Sep 03 16:18:54 PDT 1995

proc chkNum {which num} {



# This is from thw wisql 1.4 code (DC)
#       which is I or F
#       num is a string pretending to be a number
#       we will return a 1 (bad, unacceptable) or a 0
#       plus the fixed number... plus an optional message.
#       if you put in -$67.90.763 you should get out
#                       1 -67.90763



	if {[string trimleft $num] == ""} {
		return "0 NULL"
	}

#       more than one word?  take only the first
        if {[llength $num] > 1} {
                set num [lindex $num 0]
        }

#       save the original input
        set onum $num

#       First get rid of all $ and commas
        set neg 0
        set fixed 0
        set money 0

        set res [regsub -all \\\$ $num "" num]
        if {$res} {
        }

        set res [regsub -all , $num "" num]
        if {$res} {
        }

#       We have to keep sign though so check if there is a -

        if {[crange $num 0 0] == "-"} {
                set neg 1
        }
#
#	Which regsub syntax?

	set tclv [lindex [split [info tclversion] .] 0]
#	Pre-v7 version
	if {$tclv < 7} {

        set res [regsub -all - $num "" num]

	} else {

        set res [regsub -all -- - $num "" num]

	}

        if {$res} {
		set fixed 1
        } 

#       Now strip periods and check for numericity (!)

        set res [regsub -all \\\. $num "" temp]

        if {$res} {
        } else {
		set temp $num
	}

        if {[ctype digit $temp] == 0} {
                return {1 NOT}
        }

        if {[string first . $num] == -1} {
                if {$which == "F"} {
                        set num [format "%.2f" $num]
                }
        } else {
                case $which in {
                {F} {
                        set ind [string first . $num]
#		if it starts with a . then fake it up to start with a 0

			if {$ind == 0} {
				set temp "0$temp"
				set ind 1
			}

                        if {$money} {
                        set fnum [format "%s.%s"  [crange $temp 0 [expr {$ind - 1}]]  [crange $temp $ind [expr {$ind + 1}]]]
                        } else {
                        set fnum [format "%s.%s"  [crange $temp 0 [expr {$ind - 1}]]  [crange $temp $ind end] ]
                        }

                        if {$fnum != $num} {
                        set fixed 1
                        }
                        set num $fnum
                }
                {I} {
                        set ind [string first . $num]
                        set num [crange $num 0 [expr {$ind - 1}] ]
                        set fixed 1
                }
                }
        }


        if {$neg} {set num [format "-%s" $num]}

        if {$fixed} {
        set msg "I had to change $onum to $num to make it a valid number type $which."
        } else {
        set msg ""
        }

#       return list of 3 items.
        set retval "0 $num"
        lappend retval $msg
        return "$retval"
}

# $Header: /home/cvsroot/tcldb/ucodb/Tlib/formatCols,v 1.3 1998/03/25 23:22:41 de Exp $
# tcl procs saved on Sun Sep 03 16:19:12 PDT 1995

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

	set ellips ""
    case $t {
      {int int4}   {set len 12 ; set just "" }
      {tinyint}   {set len 4 ; set just "" }
      {smallint int2}   {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 - }
      {text} {set len 25; set just - ; set ellips "..."}
      {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$ellips "

  }
  return $fmt
}

# $Header: /home/cvsroot/tcldb/ucodb/Tlib/getType,v 1.6 2000/01/13 19:59:35 de Exp $
# tcl procs saved on Sun Sep 03 16:18:53 PDT 1995

proc getType type {



#       Possible types:
#       char varchar text int float money date smallint tinyint smallmoney
#       smalldate (ugh) real binary varbinary image bit timestamp sysname
#
#       so gee, how to encode these.
#       basically they fall into Ints Floats and Strings, where Dates get
#       treated like Strings.  Then there is another category called Not,
#       which is the types we cannot handle.  So I F S N where
#       *date* is S
#       *char* is S
#       *int* is I
#       float/real/money/smallmoney is F
#	numeric is I
#       text binary varbinary bit image timestamp sysname are N

	if {[string first "date" $type] >= 0} {
		return "S"
	}
	if {[string first "abstime" $type] >= 0} {
		return "S"
	}
	if {[string first "int" $type] >= 0} {
		return "I"
	}
	if {[string first "numeric" $type] >= 0} {
		return "I"
	}
	if {[string first "char" $type] >= 0} {
		return "S"
	}
	if {[string first "float" $type] >= 0} {
		return "F"
	}
	if {[string first "real" $type] >= 0} {
		return "F"
	}
	if {[string first "money" $type] >= 0} {
		return "F"
	}
	set baddies [list binary varbinary text bit image timestamp sysname]
	if {[lsearch $baddies $type] >= 0} {
		return "N"
	}

#       well, we're out of legitimate possibilities, so
#	if we haven't matched it by now, it's Unknown
	return "U"

}

proc isRoman {str} {

	set str [string toupper $str]

	set not 0

	foreach c [split $str {}] {

		case $c in {

		{I V X C L M} {
			continue
		}
		{default} {
			set not 1
		}

		}
	}

	if {$not} {
		return "NO"
	} else {
		return $str
	}
}
#---------------------------------------------------------------------------
proc klDiff {l1 l2 {icase {}} {except {}} { descrip {}} } {

#	Diff 2 keyed lists
#	if icase exists it means "ignore case"
#	if except exists, it's a list of keys to ignore
#	if descript exists, it's a list of names of descriptive text fields
#		(i.e. semantics of some kind) which should be specially
#		diffed if found

#	return 0 if equal -- good

	if {$icase != ""} {set icase 1} else {set icase 0}

      	if {[cequal $l1 $l2]} {
              return [list 0 {}]
      	}

#	get lists of keys

	set k1 [keylkeys l1]
	set k2 [keylkeys l2]

#	return -1 if keys do not match -- very bad
	if {![cequal $k1 $k2]} {
		set foo [intersect3 $k1 $k2]
		return [list -1 $foo]
	}

#	get list of diffs
	
	set diff ""
	set dc 0
	set nc 0

#	if there are text fields, we should diff them somehow

	set tpct 0
	set tc 0
	foreach k $k1 {
		if {[lcontain $except $k]} continue
		set v1 [keylget l1 $k]
		set v2 [keylget l2 $k]
		if {[lcontain $descrip $k]} {
			lassign [txtDiff $v1 $v2] pct lens words
			set tpct [expr $tpct + $pct]
			incr tc
		}
		if {$icase} {
			set c1 [string toupper $v1]
			set c2 [string toupper $v2]
		} else {
			set c1 $v1
			set c2 $v2
		}
		if {$c1 != $c2} {
		incr dc
		keylset diff $k [list $v1 $v2]
		if {$v1 == ""} {
			incr nc
		}
		}
	}

	if {$tc} {
	set tpct [expr $tpct / double($tc)]
	} else {
#	no text therefore no tpct data
	set tpct 0
	}

	return [list $dc $diff $nc $tpct]

}
proc klFmt {kl {tw {80}} {leading {}}} {

#	proc to format a keyed list nicely
#	preface each formatted line with "leading"
#	set to max width $w

	if {$kl == ""} {return ""}

	set tot 0
	set ct 0
	set text ""
	foreach k [keylkeys kl] {
		set v [keylget kl $k]
		set vs [clength [string trim $v]]
		if {!$vs} {set vs 4}
		keylset kl $k [string trim $v]
		set ks [clength $k]
		set length($k) [expr $ks + $vs + 2]
		if {$vs >= 30} {
			lappend text $k
		} else {
			incr tot $length($k)
			incr ct
		}
	}

	set avg 8
	catch {set avg [expr $tot/[double $ct]]}

	regsub -all \\\t $leading "        " leading
#	eval set leading $leading

	set ll [clength $leading]
	set w [expr $tw - $ll]

	set cols [int [floor [expr $w / $avg]]]
	incr cols -1

	set cw [int $avg]
	
	set fmt "%-$ll.${ll}s "
	set toset ""

	
	foreach k [keylkeys kl] {
		if {[lcontain $text $k]} {continue}
		lappend toset $k
	}

#	puts stderr "We have leading width $ll, total width $tw, net $w"
#	puts stderr "We have avg col width $avg for $cols col of $cw ea"
#	puts stderr "We have regular cols $toset"
#	puts stderr "We have text cols $text"

	set slen [llength $toset]
#	puts stderr "There are $slen pieces of data to set"

	set ct -1
	set same 0
	set c 0

	while 1 {

		incr ct
		if {$ct > [expr $slen * 4]} {
		puts stderr "SOMETHING WRONG not converging on kl format"
		puts stderr "We have iterated $ct times for a set length of $slen"
		puts stderr "Give up! can't set:\n$toset"
		append out "\n($toset)\n"
		break
		}

#		puts stderr "      toset is $toset"
		set lastl [llength $toset]
#		puts stderr "      last toset $lastl long"

		if {$lastl == 0} {
			break
		}

		set k [lvarpop toset]

		set l $length($k)	
#		puts stderr "      $k $l chars to set in col $c"

		set span [expr [int [expr $l / $cw]] + 1]
		set avail [expr $cols - $c]

#		puts stderr "      wants to span $span, avail $avail"

		if {!$avail} {
#			puts stderr "     No more columns available. NEWLINE."
			append out "\n"
			set avail $cols
			set same 0
			set c 0
			set span [expr [int [expr $l / $cw]] + 1]
			set avail [expr $cols - $c]
		}

		if !$c {
			if {$leading != ""} {
##			puts stderr "insert leading"
			append out "[format "$fmt" $leading]"
			}
		}

		if {$span > $cols} {
#			puts stderr "WARNING span $span > cols $cols, truncate"
			set span $cols
		}

#	lvarpop above takes care of this
#		set i [lsearch $toset $k]
#		set toset [lreplace $toset $i $i]

		if {$span <= $avail} {
#			puts stderr "       OK it fits, incr c $c by $span"
			set sw [expr $span * $cw]
			append out [format "%-$sw.${sw}s " "$k: [keylget kl $k]"]
			incr c $span
		} else {
#			puts stderr "       NOPE no fit, put it back on list"
			lappend toset $k
		}

		if {$lastl == [llength $toset]} {
			incr same
#			puts stderr "       Length toset is SAME $same as last $lastl"
		}
		if {$same == [llength $toset]} {
#			puts stderr "       Has been SAME [llength $toset] times, bummer!"
#			puts stderr "       FORCE NEWLINE!"
			append out "\n"
			set avail $cols
			set same 0
			set c 0
		}
	}

	foreach k $text {
#		append out "\n"
		set t "$k: [keylget kl $k]"
		set lines [strFold $t [expr $w - 8]]
		set lc 0
		foreach l $lines {
			if !$lc {
			append out "$leading $l\n"
			} else {
			append out "$leading  $l\n"
			}
			incr lc
		}
		append out "\n"
	}

	return $out

}
proc listDiff {l1 l2 {icase {}} {except {}} } {

#	Diff 2 Tcl lists
#	if icase exists it means "ignore case"
#	if except exists, it's a list of diff values to ignore

#	if you feed this routine lists containing dups you may
#	get unexpected results

#	what we return:  a count of differences
#			 a list of differences

#	return 0 if equal -- good

	if {$icase != ""} {set icase 1} else {set icase 0}

	if {$icase} {
		set l1 [string tolower $l1]
		set l2 [string tolower $l2]
	}

      	if {[cequal $l1 $l2]} {
              return [list 0 {}]
      	}

#	If you have got this far then you know they are not identical

	set diff ""
	set dc 0
	set nc 0

#	assume these are simple lists, no hugely long text fields.

	set ll1 [llength $l1]
	set ll2 [llength $l2]

	lassign [intersect3 $l1 $l2] l1o common l2o

	set llc [llength $common]
	set ll1o [llength $l1o]
	set ll2o [llength $l2o]

#	if ll1o, then ll1 contains stuff not in ll2
#	if ll2o  then ll2 contains stuff not in ll1

	if {$ll1o || $ll2o} {
		return [list [expr $ll1o + $ll2o] $l1o $l2o]
	}

	if {($llc != $ll1) || ($llc != $ll2)} {
#		there must be dups somewhere but no diff elements
		set l1d ""
		set l2d ""
		if {$llc != $ll1} {
			set l1d dups
		}
		if {$llc != $ll2} {
			set l2d dups
		}
		return [list 0 $l1d $l2d]
	}

#	there are no diff elements but the order must be diff

	return [list 0 ord ord]


}
proc lreverse l {

      set ll [llength $l]
      set res ""
      loop i [expr $ll - 1] -1 -1 {
              lappend res [lindex $l $i]
      }

      return "$res"

}
# $Header: /home/cvsroot/tcldb/ucodb/Tlib/numericCols,v 1.1.1.1 1996/10/12 01:08:26 de Exp $
# tcl procs saved on Sun Sep 03 16:19:19 PDT 1995

proc numericCols types {


  set fmt ""

  set i 0
  set num ""
  while {! [lempty $types] } {
    set t [lvarpop types]

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


    case $t in {
      {int tinyint smallint float real}   {lappend num $i}
        {default} {}
    }

        incr i
  }
  return $num
}

proc sortAny {items} {

# $Header: /home/cvsroot/tcldb/ucodb/Tlib/sortAny,v 1.1 1998/12/07 20:18:33 de Exp $

#	Try integer sort.  If that fails, try real.  If that fails, use alpha.

        set err [catch {set items [lsort -integer $items]}]
        if {$err} {
               set err [catch {set items [lsort -real $items]}]
               if {$err} {
                       set items [lsort $items]
               }
        }

	return $items
}
# $Header: /home/cvsroot/tcldb/ucodb/Tlib/strFold,v 1.1.1.1 1996/10/12 01:08:25 de Exp $
# tcl procs saved on Sun Sep 03 16:19:05 PDT 1995

proc strFold {str wid} {

# folds a list or space-sep string into lines of width $wid:  brute-force method

        set line ""
        set out {}

        foreach word $str {

                append line "$word "
                if {[clength $line] >= $wid} {
                        lappend out "$line"
                        set line {}
                }

        }

        if {$line != ""} {
        lappend out "$line"
        }

        return "$out"

}

# $Header: /home/cvsroot/tcldb/ucodb/Tlib/stringFix,v 1.1.1.1 1996/10/12 01:08:25 de Exp $
# tcl procs saved on Sun Sep 03 16:18:57 PDT 1995

proc stringFix strg {

#
#	all we do is strip quotes at the moment and remove any lead/trail
#	curlies AND trailing blanks 
#	(Jun 96) AND trailing newlines -- thanks for breaking the text widget JO.
#
#	This is lifted from the chkSel proc in wisql 1.4
#	$w.data.pic.win.winR.$col.st insert 0 "$where($ind,sql)"
#
        set err [regsub -all \" $strg "" strg]
        if {$err == 0} {
#               echo "failed to find dbl quotes strip sgl"
        } 

        set err [regsub -all \' $strg "" strg]
	if {$err  == 0} {
#               echo "failed to find sgl quotes strip braces"
	}

	set strg "[string trimleft [string trimright $strg \}] \{]"

	set strg "[string trimright $strg \n]"

	set strg "[string trimright $strg]"

	return $strg
	
}

# $Header: /home/cvsroot/tcldb/ucodb/Tlib/stringFix2,v 1.1.1.1 1996/10/12 01:08:25 de Exp $
# tcl procs saved on Sun Sep 03 16:19:09 PDT 1995

proc stringFix2 {strg mode} {

# Dir is either in or out.
# If in (from dbase) then turn dbl sgl quo into sgl quo
# if out (to dbase) then turn dbl quo into dbl sgl quo and
# turn sgl quo into dbl sgl




# 	In either case we translate the '' into ' before proceeding

	set err [regsub -all "''" $strg \' strg]
	if {$err} {
	}

#	If outbound, we translate all embedded quotes into dblsgls

	if {$mode == "out"} {

        set err [regsub -all \" $strg "''" strg]
        if {$err} {
        } 

        set err [regsub -all \' $strg "''" strg]
	if {$err} {
	}

	}

#	If this string is framed in curlies then trim them.  Otherwise leave
#	them alone.

	set ce [expr [clength $strg] -1]
	if {([crange $strg 0 0] == "\{" ) && ([crange $strg $ce $ce] == "\}" )} {

#	don't trim double curlies from end of list w/embedded list!
#	just clip one char off each end
#	set strg "[string trimleft [string trimright $strg \}] \{]"

	if {[expr $ce - 1] < 1} {
		set strg ""
	} else {
		set strg "[crange $strg 1 [expr $ce - 1]]"
	}

	}

#	now trim trailing CR and spaces

	set strg [string trimright $strg \n]
	set strg [string trimright $strg]

	return $strg
	
}

proc txtDiff {t1 t2} {

#	problem:  how similar or different are texts 1 and 2?
#		  if we assume that "similar" means similar in
#		  content, rather than in style, we can almost
#		  answer this question by a crude and brutal
#		  vocab analysis.

#	first we have to reduce them to lists of words.
#	no punctuation.

	regsub -all \\\( $t1 "" t1
	regsub -all \\\) $t1 "" t1
	regsub -all \\\[ $t1 "" t1
	regsub -all \\\] $t1 "" t1
	regsub -all \\\. $t1 "" t1
	regsub -all , $t1 "" t1
	regsub -all ' $t1 "" t1
	regsub -all \\\: $t1 "" t1
	regsub -all \\\; $t1 "" t1
	regsub -all -- - $t1 " " t1

	regsub -all \\\( $t2 "" t2
	regsub -all \\\) $t2 "" t2
	regsub -all \\\[ $t2 "" t2
	regsub -all \\\] $t2 "" t2
	regsub -all \\\. $t2 "" t2
	regsub -all , $t2 "" t2
	regsub -all ' $t2 "" t2
	regsub -all \\\: $t2 "" t2
	regsub -all \\\; $t2 "" t2
	regsub -all -- - $t2 " " t2

	set t1 [string toupper $t1]
	set t2 [string toupper $t2]

	set t1 [lrmdups $t1]
	set t2 [lrmdups $t2]
	
	lassign [intersect3 $t1 $t2] w1 common w2

#	now, what to do with the result?  first, we
#	have to eliminate common words like

	set junk [list A AN THE IT OF FOR TO FROM BY WITH WITHOUT AND OR WHICH ANY DO DOES HAVE HAS HAD IS WAS BE ARE WERE NOT TRUE FALSE OFF ON WHEN SET]

	foreach l [list w1 common w2] {

		set fix ""

		foreach w [set $l] {
			if [lcontain $junk $w] {continue}
			if {[crange $w end-2 end] == "ING"} {
				set w [crange $w 0 end-3]
			} elseif {[crange $w end-1 end] == "ED"} {
				set w [crange $w 0 end-2]
			} elseif {[crange $w end end] == "S"} {
				set w [crange $w 0 end-1]
			}
			lappend fix $w
		}

		set $l $fix
	}

#	having eliminated the dross, what do we want to know?
#	what percentage of A and B is common?

	set tl [expr [llength $w1] + [llength $common] + [llength $w2]]

	keylset detl w1 $w1 common $common w2 $w2
	keylset nums l1 [llength $w1] lc [llength $common] l2 [llength $w2]

#	well that's clearly not the right number!  it's not whether
#	COMMON is a greater or lesser percentage of the total so much
#	as... as what?  

#	a bigger number is more similar.   a smaller number is less similar.
	set cp [expr [llength $common]/double($tl)]

	return [list $cp $nums $detl]

}
# $Header: /home/cvsroot/tcldb/ucodb/Tlib/unTokenize,v 1.2 1997/07/24 06:24:43 de Exp $
# tcl procs saved on Sun Sep 03 16:19:04 PDT 1995

proc unTokenize line {

      regsub -all "LCB" $line "\{" line
      regsub -all "RCB" $line "\}" line
      regsub -all "LPA" $line "\(" line
      regsub -all "RPA" $line "\)" line
      regsub -all "EVV" $line "\$" line
      regsub -all "LSB" $line "\[" line
      regsub -all "RSB" $line "\]" line
      regsub -all "SCO" $line "\;" line
      regsub -all "BSL" $line "\\" line
      regsub -all "QQ" $line "\"" line

	return "$line"

}

proc uniFormat {} {

	global htmfmt ltxfmt plnfmt

# -------------------------- SET UP OUTPUT FORMAT STYLES -------------------
#
#                            H T M L
#
set htmfmt(Bul)         {<ul>}
set htmfmt(Eul)         {</ul>}
set htmfmt(Bol)         {<ol>}
set htmfmt(Eol)         {</ol>}
set htmfmt(li)          {<li>%s}
set htmfmt(Bdl)         {<dl>}
set htmfmt(Edl)         {</dl>}
set htmfmt(dt)          {<dt>}
set htmfmt(dd)          {<dd>}
set htmfmt(bold)        {<b>%s</b>}
set htmfmt(ital)        {<i>%s</i>}
set htmfmt(tt)          {<tt>%s</tt>}
set htmfmt(var)         {<var>%s</var>}
set htmfmt(rule)        {<hr>}
set htmfmt(ss)          {<center><b>%s</b></center>}
set htmfmt(br)          {<br>}
set htmfmt(p)           {<p>}
set htmfmt(h2)          {<h2>%s</h2>}
set htmfmt(h3)          {<h3>%s</h3>}
set htmfmt(h4)          {<h4>%s</h4>}
set htmfmt(Bhead)       {<head>}
set htmfmt(Ehead)       {</head>}
set htmfmt(Bbody)       {<body>}
set htmfmt(Ebody)       {</body>}
set htmfmt(title)       {<title>%s</title>}
set htmfmt(Bhtml)       {<html>}
set htmfmt(Ehtml)       {</html>}
set htmfmt(null)        {}
#
#                            L A T E X
#
set ltxfmt(Bul)         {\begin{itemize}}
set ltxfmt(Eul)         {\end{itemize}}
set ltxfmt(Bol)         {\begin{enum}}
set ltxfmt(Eol)         {\end{enum}}
set ltxfmt(li)          {\item %s}
#
# if you use these, you always get boldface on the meme name
#       even in both members of ISA pairs.  and everything is
#       double spaced.  This is the right way.
#
set ltxfmt(Bdl)         {\begin{description} \setlength{\itemsep}{0pt} \setlength{\parsep} {0.5ex plus0.2ex minus0.1ex}}
set ltxfmt(Edl)         {\end{description}}
#
# But if you use these, you're hosed.  Don't do it.
#
# set ltxfmt(Bdl)         {\begin{itemize}}
# set ltxfmt(Edl)         {\end{itemize}}
#
set ltxfmt(dt)          "\\item\[\{%%"
set ltxfmt(dd)          "\}\]%%"
set ltxfmt(bold)        {\textbf{%s}}
set ltxfmt(ital)        {\textit{%s}}
set ltxfmt(tt)          {\texttt{%s}}
set ltxfmt(var)         {$%s$}
set ltxfmt(rule)        {}
set ltxfmt(ss)          {\subsection{%s}}
set ltxfmt(br)          "\\\\"
set ltxfmt(p)           {}
set ltxfmt(h2)          {{\huge %s}\\}
set ltxfmt(h3)          {{\huge %s}\\}
set ltxfmt(h4)          {{\large %s}\\}
set ltxfmt(Bhead)       "\\documentclass\[twoside,11pt,openright\]{report}\n\
\\usepackage{desrev}\n
\\chauthor{auto maton}{deimos@ucolick.org}"
set ltxfmt(Ehead)       {%% end head}
set ltxfmt(Bbody)       {\begin{document}}
set ltxfmt(Ebody)       {\end{document}}
set ltxfmt(title)       {%% HTML title %s}
set ltxfmt(Bhtml)       {%% autogenerated LaTeX from mbc}
set ltxfmt(Ehtml)       {%% trailer cruft}
set ltxfmt(null)        {%%}
#
#
# ----------------------------------------------------------------------------
#
}

#@package: UCO-Oracle oraOpen oraClose oraCols oraSQL oraNext oraCancel \
	oraStart


# $Header: /home/cvsroot/tcldb/ucodb/Tlib/oraCancel,v 1.1.1.1 1996/10/12 01:08:26 de Exp $

proc oraCancel pipeno {

        global dbpipe$pipeno oramsg 
        upvar sqt sqt

        set ora [eval set dbpipe$pipeno]

        set err [catch {oracancel $ora}]

        if {$err == 1} {
                echo "Error attempting oracancel on on pipe $pipeno"
		echo "ERROR $oramsg(rc): $oramsg(errortxt)"
        }

}

# $Header: /home/cvsroot/tcldb/ucodb/Tlib/oraClose,v 1.1.1.1 1996/10/12 01:08:26 de Exp $

proc oraClose pipeno {

        global  oramsg dbpipe$pipeno

        set dbpipe [eval set dbpipe$pipeno]

        oraclose $dbpipe

}

# $Header: /home/cvsroot/tcldb/ucodb/Tlib/oraCols,v 1.1.1.1 1996/10/12 01:08:26 de Exp $

proc oraCols pipeno {

	global dbpipe$pipeno oramsg server

	set ora [eval set dbpipe$pipeno]

	set cols [oracols $ora]

	return $cols

}

# $Header: /home/cvsroot/tcldb/ucodb/Tlib/oraNext,v 1.1.1.1 1996/10/12 01:08:26 de Exp $

proc oraNext pipeno {

	global dbpipe$pipeno oramsg server

	set ora [eval set dbpipe$pipeno]

	set geterr [catch {set value [orafetch $ora]} ]

  	if {$geterr == 1} {
    		set value "ERROR : line $oramsg(rc): $oramsg(errortext)"
		echo $value
  	} 

	return $value

}

# $Header: /home/cvsroot/tcldb/ucodb/Tlib/oraOpen,v 1.1.1.1 1996/10/12 01:08:26 de Exp $

proc oraOpen oracon {

        global oramsg

        set dbpipe [oraopen $oracon]

        return $dbpipe

}

# $Header: /home/cvsroot/tcldb/ucodb/Tlib/oraSQL,v 1.1.1.1 1996/10/12 01:08:26 de Exp $

proc oraSQL pipeno {

        global dbpipe$pipeno oramsg 
        upvar sqlcmd sc
        upvar sqt sqt

#	echo "doing oraSQL on dbpipe$pipeno set ora var"
        set ora [eval set dbpipe$pipeno]
#	echo "got pipe name $ora for number $pipeno"

	set result NO_DICE

#	echo "let's now do orasql statement orasql $ora $sc"
        set err [catch {set result [orasql $ora $sc]}]

        if {$err == 1} {
                echo "oraSQL was trying to do the command \n$sc\n on pipe $pipeno"
                echo "Failed to access table $sqt, tell your dba:"
		echo "ERROR $oramsg(rc): $oramsg(errortxt)"
                set result "ERROR $oramsg(rc): $oramsg(errortxt)"
        }

        return $result
}

# $Header: /home/cvsroot/tcldb/ucodb/Tlib/oraStart,v 1.1.1.1 1996/10/12 01:08:26 de Exp $

proc oraStart {user pass dbid} {

	set id "$user/$pass@$dbid"

	set err [catch {set oracon [oralogon $id]}]

	if {$err} {
		puts stderr "sorry, there was an error opening Oracle connection to $dbid"
		return -1
	}

#	echo "connected to Oracle server $dbid as $user"
	return $oracon
}


#@package: UCO-PG95 pgOpen pgClose pgCancel pgSQL pgNext pgGet pgGetI \
	pgCols PGgetSignOn PGglobals PGchkPriv PGgetPkeys


# $Header: /home/cvsroot/tcldb/ucodb/Tlib/PGchkPriv,v 1.3 1998/05/18 22:28:44 de Exp $
# tcl procs saved on Sun Sep 03 16:18:55 PDT 1995

proc PGchkPriv {table priv} {

        global uname 

        case $priv in {
        {sel} {
                set code r
        }
        {ins} {
                set code w
        }
        {del} {
                set code w
        }
        {upd} {
                set code w
        }
        }

#       echo "chkPriv looking for protection code $code on table $table for user $uname"

        set temp [split $table .]
	set pref ""
	if {[llength $temp] == 3} {
		lassign $temp dbs usr tbl
		set pref "$dbs.."
	} else {
		lassign $temp usr tbl
	}

#       get my real server uid

	set sqlcmd "select b.usename, a.relacl from pg_class a, pg_user b where a.relname = '$tbl' and b.usesysid = a.relowner"

	set sqt "functions"
#        echo "chkPriv sqlcmd is\n$sqlcmd"

	set sqt pg_class 
	lassign [pgSQL 1] ct han res
#	puts stderr "return from pgSQL got ct $ct han $han res $res"
        if {[lindex $res 0] == "ERROR"} {
                startMsg "chkPriv problem : $res"
                echo "$sqlcmd"
                echo "$res"
                return NO 
        }

        lassign [pgGetI $han 0] owner privs
	set privs [split [string trimleft [string trimright $privs \}] \{] ,]
	set access ""
	foreach p $privs {
		set p [string trimleft [string trimright $p \"] \"]
		lassign [split $p =] u a
		if {($u == "") || ($u == $uname)} {
			append access $a
		}
	}

#        puts stderr "got owner $owner relacl $privs"

	if {$owner != $usr} {
		puts stderr "OUCH what happened?"
		puts stderr "Table $table owned by $owner?"
	}

#	return YES or NO

	if {($owner == $uname) || ([string first $code $access] >= 0)} {
		return YES
	} else {
		return NO
	}

}

# $Header: /home/cvsroot/tcldb/ucodb/Tlib/PGgetPkeys,v 1.2 1998/05/18 22:28:45 de Exp $
# tcl procs saved on Sun Sep 03 16:18:54 PDT 1995

proc PGgetPkeys table {

        global dbpipe1 server 
	global PGuids PGtypids PGusers PGtypes

#	Since PG95 has no concept of primarykeying, we will
#	just look for oid.  If we don't find an oid we are
#	unkeyed.

	set temp [split $table .]
        set pref ""
        if {[llength $temp] == 3} {
                lassign $temp dbs usr tbl
                set pref "$dbs.."
        } else {
                lassign $temp usr tbl
        }

#	This is all ripped off from PGgetEZcols

	set sqlcmd "select pg_class.oid,pg_class.relname from pg_class where relname = '$tbl' and relowner = $PGuids($usr)"


        set sqt "pg_class"
        lassign [pgSQL 1] ct han res
        if {[lindex $res 0] == "ERROR"} {
                echo "Something went wrong here:"
                echo "$res"
                exit 1
        }

        loop i 0 $ct {
                set line [pgGetI $han $i]
                lassign $line toid tnam
                keylset tables($i) toid $toid tnam $tnam
        }
        if {[llength [array names tables]] > 1} {
                puts stderr "Whoa Nellie!  Two tables called $tbl owned by $us
r??"
                return
        }
        set toid [keylget tables(0) toid]

        set sqlcmd "select attname from pg_attribute where attrelid = $toid and attnum < 0"

#        puts stderr "GETCOLS $sqlcmd"
        set sqt pg_attribute
        lassign [pgSQL 1] ct han res

	set keys ""
        loop i 0 $ct {

                set col [pgGetI $han $i]

                if {[lindex $col 0] == "ERROR"} {
                        puts stderr "$col"
                        break
                }

                if {$col == ""} {break}

		if {$col == "oid"} {
			set keys "oid"
			break
		}
	}
	return $keys

}

# $Header: /home/cvsroot/tcldb/ucodb/Tlib/PGgetSignOn,v 1.4 1998/03/22 21:43:58 de Exp $
# tcl procs saved on Sun Sep 03 16:18:49 PDT 1995

proc PGgetSignOn {} {
# profile on

  global uname
  global pw
  global env
  global matchInfo

  # get valid servers from interfaces file
   set pg_home [lsearch [array names env] POSTGRESDIR] 
 
   if {$pg_home == -1} {
       set pg_home ""
       set pg_home [exec grep postgres < /etc/passwd ]
       if {[string length $pg_home] > 0} {
           set pg_home [lindex [split $pg_home :] 5]
       } else {
           set pg_home ""
       }
   } else {
       set pg_home $env(POSTGRESDIR)
   }
 
  if {[info exists env(PGHOST)]} {
  lappend serverList $env(PGHOST)
  } else {
  puts stderr "oops you haven't set your PGHOST envar..."
  puts stderr "setting to localhost and crossing fingers.."
  set serverList localhost
  }

  wm geom     . 300x300+200+200

  frame .s -background bisque
  set font [getFont {} banner]
  message .s.m -justify center         -text "SQL Server Sign on" -aspect 2000         -font $font -background bisque
	
  frame .s.i -background bisque
  entry .s.i.uname -relief sunken  -width 19 -text uname -background ivory
#  label .s.i.id  -text "  User Id" -anchor e
  label .s.i.id  -text "  User Id" -background bisque
  frame .s.p -background bisque

#  set font [getFont {} secure]
#	the ashu quick patch for v4
  entry .s.p.pw  -relief sunken -width 19 -text pw -background ivory
  label .s.p.p   -text "  Database" -anchor e -background bisque

  frame .s.s -background bisque
  entry .s.s.ser -relief sunken -width 19 -background lemonchiffon
  menubutton .s.s.s -text " Server  " -anchor e -menu .s.s.s.m -relief raised -padx 0 -pady 0 -background lavender
  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 500 -background bisque

  frame .s.b -background bisque
  button .s.b.ok  -text "Sign on"       -command {PGtryConnect [.s.p.pw get] [.s.s.ser get]} -padx 0 -pady 0 -background lemonchiffon -activebackground lemonchiffon -activeforeground magenta2
  button .s.b.can -text "Cancel" -command "destroy ." -padx 0 -pady 0 -background white -activebackground red -activeforeground yellow -activebackground black

  pack .s -side top -fill both -expand true
  pack .s.m -side top -fill x -ipady 10
  pack .s.i -side top -ipady 10 -anchor e
  pack .s.i.uname -side right -expand true -ipadx 20
  pack .s.i.id -side left
  pack .s.p -side top -ipady 10 -anchor e
  pack .s.p.pw  -side right -expand true -ipadx 20
  pack .s.p.p  -side left

  pack .s.err -side top -fill x -expand true
  pack .s.b -side bottom -fill x 
  pack .s.b.ok -side left -fill x -expand true 
  pack .s.b.can -side left -fill x -expand true

  pack .s.s -side bottom -ipady 10 -anchor e
  pack .s.s.ser -side right -expand true -ipadx 20
  pack .s.s.s  -side left

#  no longer needed, tied to text var now
#  .s.i.uname insert 0 $uname

  if {[lsearch [array names env] PGHOST] >= 0} {
    .s.s.ser insert 0 $env(PGHOST)
  } else {
    .s.s.ser insert 0 localhost
  }

  bind .s.i.uname <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"

  if {$uname != ""} {
  focus .s.p.pw
  } else {
  focus .s.i.uname
  }

}

proc PGglobals {} {

#	once you have a connect, you need to figure out
#	a few things before getting started.  To begin
#	with, you need a table of data type oids to
#	data type names and sizes
#

	global PGtypes Pgtypids PGusers PGuids

	set typtbl pg_type
	set usrtbl pg_user

	set sqlcmd "select $typtbl.oid, $typtbl.* from $typtbl"
	set sqt $typtbl
	lassign [pgSQL 1] ct han res
	set atts [pgCols $han]
	foreach a $atts {
		lappend cols [lindex $a 0]
	}

	loop i 0 $ct {
		set line [pgGetI $han $i]
		eval lassign \$line $cols
		foreach c $cols {
			keylset PGtypes($oid) $c [set $c]
		}
		set PGtypids($typname) $oid
	}
	
#

	set cols ""
	set sqlcmd "select $usrtbl.oid,$usrtbl.* from $usrtbl"
	set sqt $usrtbl

	lassign [pgSQL 1] ct han res

	set atts [pgCols $han]
	foreach a $atts {
		lappend cols [lindex $a 0]
	}
#
	loop i 0 $ct {
		set line [pgGetI $han $i]
		eval lassign \$line $cols
		foreach c $cols {
			keylset PGusers($usesysid) $c [set $c]
		}
		set PGuids($usename) $usesysid
	}
#

	set ofp [open debug.out w]
	foreach a {PGtypes PGusers} {
	puts $ofp "\n\nArray $a:"
	foreach i [array names $a] {
	puts $ofp "  Elem $i :"
	foreach k [keylkeys ${a}($i)] {
		puts $ofp "    $k : [keylget ${a}($i) $k]"
	}
	}
	}
	close $ofp
}
proc pgCancel pghand {
# $Header: /home/cvsroot/tcldb/ucodb/Tlib/pgCancel,v 1.3 1996/10/17 05:42:28 de Exp $

	global curs.$pghand

        upvar sqt sqt

        set err [catch {pg_result $pghand -clear}]
	catch {unset curs.$pghand}

        if {$err == 1} {
                echo "Error attempting pgclear on on handle $pghand"
        }

}
proc pgClose conno {
# $Header: /home/cvsroot/tcldb/ucodb/Tlib/pgClose,v 1.4 1996/12/06 07:31:29 de Exp $

        global pgmsg dbpipe$conno

        set dbconn [eval set dbpipe$conno]

        pg_disconnect $dbconn

}
proc pgCols pghand { 
# $Header: /home/cvsroot/tcldb/ucodb/Tlib/pgCols,v 1.6 1997/05/28 02:07:05 de Exp $

#	PG95 user, use this line
#	pre Postgres 6, required my libpgtcl hack to get triple result
#	set cols [pg_result $pghand -attributes]

#	PostgreSQL user, use this line
#	post Postgres 6 -lAttributes gets triple col/type/len
	set cols [pg_result $pghand -lAttributes]

#	puts stderr "pgCols returning $cols"
	return $cols

}
proc pgGet pghand {
# $Header: /home/cvsroot/tcldb/ucodb/Tlib/pgGet,v 1.3 1996/10/17 05:42:29 de Exp $

#	You can use this if you have not too many records, and
#	get a list of keyed lists.  otherwise use pgNext

	global pgmsg server curs.$pghand

	set geterr [catch {set value [pg_result $pghand -assign res] } msg]
  	if {$geterr == 1} {
    		set value "ERROR : $msg"
		puts stderr $value
		return $value
  	} 

	set ct [pg_result $pghand -numTuples]
	set cols [pg_result $pghand -attributes]

	loop i 0 $ct {
		foreach c $cols {
		keylset l $c "$res($i,$c)"
		}
		lappend out "$l"
	}

	set curs.$pghand 0

	return "$out"
}
proc pgGetI {pghand i} {
# $Header: /home/cvsroot/tcldb/ucodb/Tlib/pgGetI,v 1.1 1996/12/10 06:07:31 de Exp $

	global curs.$pghand pgmsg server

	set lim [expr [pg_result $pghand -numTuples] + 1]
	if {$i > $lim} {
		return ""
	}
	set curs.$pghand $i
	set geterr [catch {set value [pg_result $pghand -getTuple $i] } msg]

  	if {$geterr == 1} {
    		set value "ERROR : $msg"
		echo $value
  	} 
	incr curs.$pghand

	return $value

}
proc pgNext pghand {
# $Header: /home/cvsroot/tcldb/ucodb/Tlib/pgNext,v 1.3 1996/10/17 05:42:29 de Exp $

	global curs.$pghand pgmsg server

	set i [set curs.$pghand]
	set lim [expr [pg_result $pghand -numTuples] + 1]
	if {$i > $lim} {
		return ""
	}

	set geterr [catch {set value [pg_result $pghand -getTuple $i] } msg]

  	if {$geterr == 1} {
    		set value "ERROR : $msg"
		puts stderr "$value"
  	} 

	incr curs.$pghand

	return $value

}
proc pgOpen {base {host {}}} {
# $Header: /home/cvsroot/tcldb/ucodb/Tlib/pgOpen,v 1.3 1996/10/17 05:42:30 de Exp $

        global pgmsg

	if {$host != ""} {
	set dbpipe [pg_connect $base -host $host]
	} else {
	set dbpipe [pg_connect $base]
	} 

        return $dbpipe

}
proc pgSQL conno {
# $Header: /home/cvsroot/tcldb/ucodb/Tlib/pgSQL,v 1.5 1997/07/22 17:21:23 de Exp $

        global dbpipe$conno pgmsg 
        upvar sqlcmd sc
        upvar sqt sqt

#	puts stderr "doing pgSQL on dbpipe$conno set pg var"
        set pg [eval set dbpipe$conno]
#	puts stderr "got pipe name $pg for number $conno"

	set result NO_DICE

#	puts stderr "let's now do pgsql statement pgsql $pg $sc"
        set err [catch {set pghand [pg_exec $pg $sc]} msg]
        if {$err} {
               puts stderr "pgSQL was trying to do the command \n$sc\n on pipe $conno"
               puts stderr "Failed to access table $sqt, tell your dba:"
	       puts stderr "ERROR $msg"
               return "[list 0 ERROR $msg]"
        } 
	set pgmsg [pg_result $pghand -status]
	set pgct [pg_result $pghand -numTuples]
	set pgid [pg_result $pghand -oid]

	upvar #0 curs.$pghand curs.$pghand
	catch {unset curs.$pghand}
	set curs.$pghand 0

	set result "$pgct $pghand $pgmsg"
#	puts stderr "pgSQL got pgid $pgid, returning $result"
	
        return $result

}

#@package: UCO-Sybase sybOpen sybClose sybCols sybNext doSQL sybCancel \
	SYBgetPkeys SYBgetSignOn SYBchkPriv


# $Header: /home/cvsroot/tcldb/ucodb/Tlib/SYBchkPriv,v 1.2 1997/07/24 06:25:26 de Exp $
# tcl procs saved on Sun Sep 03 16:18:55 PDT 1995

proc SYBchkPriv {table priv} {

        global uname sybmsg 

        case $priv in {
        {sel} {
                set code 193
        }
        {ins} {
                set code 195
        }
        {del} {
                set code 196
        }
        {upd} {
                set code 197
        }
        {ctbl} {
                set code 198
        }
        {crul} {
                set code 236
        }
        {cvuw} {
                set code 207
        }
        {cpro} {
                set code 222
        }
        }

#       echo "chkPriv looking for protection code $code on table $table for user $uname"

        set temp [split $table .]
	set pref ""
	if {[llength $temp] == 3} {
		lassign $temp dbs usr tbl
		set pref "$dbs.."
	} else {
		lassign $temp usr tbl
	}

#       get my real server uid

        set sqlcmd "select suser_id('$uname'), user_id('$usr')"

	set sqt "functions"
#        echo "chkPriv sqlcmd is\n$sqlcmd"

        set res [doSQL 1]
        if {[lindex $res 0] == "ERROR"} {
                startMsg "chkPriv problem : $res"
                echo "$sqlcmd"
                echo "$res"
                return NO 
        }

        set line [sybNext 1]
        set usuid [lindex $line 0]
        set odbuid [lindex $line 1]

#        echo "user $uname server uid is $usuid, owner db uid is $odbuid"

        set sqlcmd "select uid, gid from ${pref}sysusers where suid = $usuid"

#        echo "chkPriv sqlcmd is\n$sqlcmd"
	set sqt "${pref}sysusers"

        set res [doSQL 1]
        if {[lindex $res 0] == "ERROR"} {
                startMsg "chkPriv problem : $res"
                echo "$sqlcmd"
                echo "$res"
                return NO 
        }

        set line [sybNext 1]

        set udbuid [lindex $line 0]
        set udbgid [lindex $line 1]

#        echo "user $uname local db userid is $udbuid and groupid is $udbgid"

#       You are sa, or equivalent, if your suid is 1;  you are dbo if your
#       user id is 1.  dbo does not automatically have all privs!  if you
#       are sa or the object owner then you can do anything, of course.

        if {($udbuid == $odbuid) || ($usuid == 1)} {
                return "YES"
        }

#       Otherwise, check for uid and gid granted perms on
#       object: do I belong to a group granted perms?

#        echo "table name was $table, owner $usr, user $uname, grp $udbgid, tbl $tbl priv $priv code $code"

#       check to see if I or my group have the requested permission on
#       the current object or if 'public' has the requested permission on
#       this object (public is grp 0) -- this is a parsimonious but somewhat
#       obscure method that Sybase uses to code protection bits.

        set cando NO

	# Tom, what on earth were you doing here?  I'm taking this back out --de 9/2/95
	#   hack -just return yes --tp
	#   return YES



        set sqlcmd "select a.* from ${pref}sysprotects a, ${pref}sysobjects b  where a.action = $code and b.name = '$tbl' and b.uid = user_id('$usr') and  (a.uid = $udbuid or a.uid = $udbgid or a.uid = 0) and a.id = b.id"

#        echo "chkPriv sql cmd was\n$sqlcmd"
	set sqt "${pref}sysprotects"

	set res [doSQL 1]
	if {[lindex $res 0] == "ERROR"} {
		startMsg "chkPriv problem: $res"
		echo "$sqlcmd"
		echo "$res"
		return NO
	}

        while {1 == 1} {
                if {$sybmsg(nextrow) == "NO_MORE_RESULTS"} {break}
                set able [sybNext 1]
#                echo "got $able from sysprotects etc"
                if {$able != ""} {
                        set cando YES
                        return $cando
                }
        }

        return $cando

}

# $Header: /home/cvsroot/tcldb/ucodb/Tlib/SYBgetPkeys,v 1.1 1996/12/06 07:31:27 de Exp $
# tcl procs saved on Sun Sep 03 16:18:54 PDT 1995

proc SYBgetPkeys table {

        global dbpipe1 sybmsg server 


	set temp [split $table .]
        set pref ""
        if {[llength $temp] == 3} {
                lassign $temp dbs usr tbl
                set pref "$dbs.."
        } else {
                lassign $temp usr tbl
        }

        set sqlcmd "select key1,key2,key3,key4,key5,key6,key7,key8 from  ${pref}syskeys a, ${pref}sysobjects b where a.type = 1 and  b.uid = user_id('$usr') and b.name = '$tbl' and a.id = b.id"

	set sqt "${pref}syskeys"
        set res [doSQL 1]
        if {[lindex $res 0] == "ERROR"} {
                set error "ERROR : line $sybmsg(line): $sybmsg(msgno) : $sybmsg(msgtext)"
                return $error
        } 
        set keys [sybNext 1]
	if {[lindex $keys 0] == "ERROR"} {
		set keys ""
	}

	set err [regsub -all NULL $keys "0" keys]
	return $keys

}

# $Header: /home/cvsroot/tcldb/ucodb/Tlib/SYBgetSignOn,v 1.5 1999/10/13 23:22:17 de Exp $
# tcl procs saved on Sun Sep 03 16:18:49 PDT 1995

proc SYBgetSignOn {} {
# profile on

  global uname
  global pw
  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 ^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 ierr [catch {set fd [open $intFile]}]
      if {$ierr} {echo "error opening $intFile"}
      set sc [scancontext create]
      scanmatch -nocase $sc {^[a-z]} {lappend serverList $matchInfo(line)}
      scanfile $sc $fd
      close $fd
    } else {
      set serverList SYBASE
    }
  } else {
    puts stderr "SORRY cannot find SYBASE home dir by any means."
    puts stderr "      No envar SYBASE found."
    puts stderr "      No login dir for user sybase found in NIS or passwd file."
    exit 1
  }

  wm geom     . 300x300+200+200

  frame .s -background bisque
  set font [getFont {} banner]
  message .s.m -justify center -text "SQL Server Sign on" -aspect 2000  -font $font -background bisque
	
  frame .s.i -background bisque
  entry .s.i.uname -relief sunken  -width 19 -text uname -background ivory
#  label .s.i.id  -text "  User Id" -anchor e 
  label .s.i.id  -text "  User Id" -background bisque
  frame .s.p -background bisque

#  set font [getFont {} secure]
#	the ashu quick patch for v4
  entry .s.p.pw  -relief sunken -width 19 -show * -text pw -background ivory
  label .s.p.p   -text "  Password" -anchor e -background bisque

  frame .s.s -background bisque
  entry .s.s.ser -relief sunken -width 19 -background lemonchiffon
  menubutton .s.s.s -text " Server  " -anchor e -menu .s.s.s.m -relief raised -padx 0 -pady 0 -background lavender -activebackground lavender -activeforeground magenta2
  menu .s.s.s.m -background lavender
  foreach s $serverList {
    .s.s.s.m add command -label $s -command ".s.s.ser delete 0 end; .s.s.ser insert 0 $s " -background lavender -activebackground lavender -activeforeground magenta2
  }

  message .s.err -text "" -justify center -aspect 500 -background bisque 

  frame .s.b -background bisque
  button .s.b.ok  -text "Sign on"       -command {SYBtryConnect [.s.i.uname get] [.s.p.pw get] [.s.s.ser get]} -padx 0 -pady 0 -background lemonchiffon -activebackground lemonchiffon -activeforeground magenta2
  button .s.b.can -text "Cancel" -command "destroy ." -padx 0 -pady 0 -background white -activebackground black -activeforeground yellow -foreground red

  pack .s -side top -fill both -expand true
  pack .s.m -side top -fill x -ipady 10
  pack .s.i -side top -ipady 10 -anchor e
  pack .s.i.uname -side right -expand true -ipadx 20
  pack .s.i.id -side left
  pack .s.p -side top -ipady 10 -anchor e
  pack .s.p.pw  -side right -expand true -ipadx 20
  pack .s.p.p  -side left

  pack .s.err -side top -fill x -expand true
  pack .s.b -side bottom -fill x 
  pack .s.b.ok -side left -fill x -expand true 
  pack .s.b.can -side left -fill x -expand true

  pack .s.s -side bottom -ipady 10 -anchor e
  pack .s.s.ser -side right -expand true -ipadx 20
  pack .s.s.s  -side left

#  no longer needed, tied to text var now
#  .s.i.uname insert 0 $uname

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

  bind .s.i.uname <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"

  if {$uname != ""} {
  focus .s.p.pw
  } else {
  focus .s.i.uname
  }

}

# $Header: /home/cvsroot/tcldb/ucodb/Tlib/doSQL,v 1.1.1.1 1996/10/12 01:08:25 de Exp $
# tcl procs saved on Sun Sep 03 16:18:48 PDT 1995

proc doSQL pipeno {

        global dbpipe$pipeno sybmsg 
        upvar sqlcmd sc
        upvar sqt sqt


        set syb [eval set dbpipe$pipeno]


	set result NO_DICE

        set err [catch {set result [sybsql $syb $sc]}]


        if {$err == 1} {
                echo "doSQL was trying to do the command \n$sc\n on pipe $pipeno
"
                echo "Failed to access table $sqt, tell your dba:"
		echo "ERROR $sybmsg(msgno): $sybmsg(msgtext)"
                set result "ERROR $sybmsg(msgno): $sybmsg(msgtext)"
        }


        return $result
}

# $Header: /home/cvsroot/tcldb/ucodb/Tlib/sybCancel,v 1.1.1.1 1996/10/12 01:08:26 de Exp $
# tcl procs saved on Sun Sep 03 16:19:15 PDT 1995

proc sybCancel pipeno {

        global dbpipe$pipeno sybmsg 
        upvar sqt sqt


        set syb [eval set dbpipe$pipeno]


        set err [catch {sybcancel $syb}]

        if {$err == 1} {
                echo "Error attempting sybcancel on on pipe $pipeno"
		echo "ERROR $sybmsg(msgno): $sybmsg(msgtext)"
        }

}

# $Header: /home/cvsroot/tcldb/ucodb/Tlib/sybClose,v 1.1.1.1 1996/10/12 01:08:24 de Exp $
# tcl procs saved on Sun Sep 03 16:18:42 PDT 1995

proc sybClose pipeno {

        global  sybmsg dbpipe$pipeno


        set dbpipe [eval set dbpipe$pipeno]


        sybclose $dbpipe


}

# $Header: /home/cvsroot/tcldb/ucodb/Tlib/sybCols,v 1.2 2000/03/30 21:46:53 de Exp $
# tcl procs saved on Sun Sep 03 16:18:46 PDT 1995

proc sybCols pipeno {

	global dbpipe$pipeno sybmsg server

	set syb [eval set dbpipe$pipeno]

	set cols [sybcols $syb]

	set c2 [lrmdups $cols]

#	are there dup col names???
	
	set newcols ""
	set dup 0
	set cc 1
	foreach c $cols {
		if ![info exists ct($c)] {
			set ct($c) 1
			lappend newcols $c
		} else {
			set dup 1
			incr ct($c)
			lappend newcols ${c}_$cc
		}
		incr cc
	}

	if {$dup} {
		set cols $newcols
	}

	return $cols

}

# $Header: /home/cvsroot/tcldb/ucodb/Tlib/sybNext,v 1.1.1.1 1996/10/12 01:08:25 de Exp $
# tcl procs saved on Sun Sep 03 16:18:47 PDT 1995

proc sybNext pipeno {

	global dbpipe$pipeno sybmsg server

	set syb [eval set dbpipe$pipeno]

	set geterr [ catch {set value [sybnext $syb]} ]

  	if {$geterr == 1} {
    		set value "ERROR : line $sybmsg(line): $sybmsg(msgno) : $sybmsg(msgtext)"
		echo $value
  	} 

	return $value

}

# $Header: /home/cvsroot/tcldb/ucodb/Tlib/sybOpen,v 1.5 2000/01/14 19:38:51 de Exp $
# tcl procs saved on Sun Sep 03 16:18:10 PDT 1995

proc sybOpen {base user pass server} {

        global sybmsg argv0

	if {[info commands sybconnect] == ""} {
		puts stderr "SORRY this interp is not Sybase extended."
		puts stderr "      you have to install SybTcl before using"
		puts stderr "      the UCODB sybXxxxx tcl procs."
		return
	}
		
        set err [catch {set dbpipe [sybconnect $user $pass $server]} res]

#	This hack was put in right after cutover to ASE11 linux,
#	to catch orphan scripts

	set str ""
	if $err {
		append str "ERROR opening Sybase connection to $server as $user\n"
		append str "who:   [id user] \nwhat:  $argv0 \nwhere: [id host]\n"
		append str "when:  [clock format [clock seconds]]"
		append str "ERR $sybmsg(msgtext)"
		append str "DB  $sybmsg(dberrstr)"
		append str "OS  $sybmsg(oserrstr)"
		set mf /tmp/mail.[clock seconds]
		write_file $mf "$str"
		puts stderr "$str"
		set err [catch {system "Mail -s SYBASE_ERROR ksa de < $mf"} res]
		if $err {
			puts stderr "Couldn't Mail to mavens"
			puts stderr "$res"
		}
		unlink $mf
	}

#       echo "Opened database connection $dbpipe"

        sybuse $dbpipe $base

        return $dbpipe

}


#@package: UCO-trf trf_init trf_place trf_line trf_saveb trf_restoreb \
	trf_print trf_block


proc trf_block y {
# $Header: /home/cvsroot/tcldb/ucodb/Tlib/trf_block,v 1.1.1.1 1996/10/12 01:08:27 de Exp $
	global trf_wid trf_len trf_sav trf_pag trf_lin
	global trf_arr trf_blk trf_fp trf_pnf trf_pnx trf_pny trf_pnn

#	y is 0 for turn off block, . or line num for turn on block

	if {$y == "."} {
		set y $trf_lin
	} else {
		if {$y > $trf_len} {
			puts stderr "WARNING, cannot start block at line $y, would force a new page"
			return
		}
	}

	set trf_blk $y

}
proc trf_init {} {
# $Header: /home/cvsroot/tcldb/ucodb/Tlib/trf_init,v 1.1.1.1 1996/10/12 01:08:27 de Exp $

	global trf_len trf_wid trf_arr trf_sav trf_lin trf_pag
	global trf_pnf trf_pnx trf_pny trf_blk trf_pnn

#	set up defaults
	if {![info exists trf_sav]} {
		set trf_sav ""
	}
	if {![info exists trf_wid]} {
		set trf_wid 80
	}
	if {![info exists trf_len]} {
		set trf_len 66
	}
	if {![info exists trf_blk]} {
		set trf_blk 0 
	}
	if {![info exists trf_pnn]} {
		set trf_pnn 1 
	}

	set lin 1
	set hdr 0
	loop i 1 [expr $trf_len + 1] {
		if {[lsearch $trf_sav $i] < 0} {
		set trf_arr($i) [replicate " " $trf_wid]
		} else {
		set hdr 1
		incr lin
		}
	}
# stick those page numbers where they belong eh
	loop j 1 [expr $trf_pnn + 1] {
	if {[info exists trf_pnf($j)]} {
		trf_place $trf_pny($j) $trf_pnx($j) $trf_pag $trf_pnf($j) 0 {} HDR
	}
	}
#
	set trf_lin $lin

}
proc trf_line {y x len dir {hdr {}}} {
# $Header: /home/cvsroot/tcldb/ucodb/Tlib/trf_line,v 1.1.1.1 1996/10/12 01:08:27 de Exp $
	global trf_arr trf_lin
	
	if {$y == "."} {
		set y $trf_lin
	}

#
	if {$dir == "H"} {
		set val [replicate - $len]
		trf_place $y $x $val %${len}s 0 {} $hdr
	} else {
		loop l $y [expr $y + $len + 1] {
			trf_place $l $x "|" %1s
		}
	}
}
proc trf_place {y x val fmt {brk 0} {nl {}} {hdr {}}} {
# $Header: /home/cvsroot/tcldb/ucodb/Tlib/trf_place,v 1.1.1.1 1996/10/12 01:08:27 de Exp $

	global trf_wid trf_len trf_sav trf_pag trf_lin
	global trf_arr trf_blk trf_fp trf_pnf trf_pnx trf_pny trf_pnn

#	puts stderr "enter trf_place with args col $x line $y val $val fmt $fmt brk $brk nl? $nl hdr? $hdr"

#	trf_wid:  width of page in char
#	trf_len:	 length of page in lines
#	trf_pag:  current page counter
#	trf_lin:  current line counter
#	trf_sav:  list of lines to preserve (save) across page breaks
#	trf_arr:  an array of lines making up a page in progress
#	trf_blk:  the line at which a block of data began which cannot
#		 contain a page break


#	puts stderr "Call trf_place..."

	if {$nl == "+"} {
		incr trf_lin
	}

	if {$y == "."} {
		set y $trf_lin
	} else {
		if {$y > $trf_len} {
#			puts stderr "WARNING, text placed at line $y will force a new page"
		}
		set trf_lin $y
	}

#	puts stderr "  y is really $y"

	if {$hdr != ""} {
		lappend trf_sav $y
		set trf_sav [lrmdups $trf_sav]
		if {$val == "PNO"} {
			set trf_pnf($trf_pnn) $fmt
			set trf_pnx($trf_pnn) $x
			set trf_pny($trf_pnn) $y
			set val $trf_pag
			incr trf_pnn
		}
	} else {
		if {[lsearch $trf_sav $y] >= 0} {
#			puts stderr "  Data $val hdr $hdr would be at $y, $x in a protected line! New page!"
			set y [expr $trf_len + 1]
		}
	}

	if {$y > $trf_len} {
#		puts stderr "  next y ($y) is greater than $trf_len NEW PAGE"
		if {$trf_blk} {
			trf_saveb 
		}
		trf_print
		trf_init
		if {$trf_blk} {
                        trf_restoreb
		}
		set y $trf_lin
#		puts stderr "  new y on new page is $y"
	}

	if {$brk > 0} {
#		puts stderr "  breaking line to $brk chars"
		set sa [strFold $val $brk]
		set fl " [llength $sa]"
#		puts stderr "  produced $fl lines"
	} else {
		set fl ""
		eval set sa \{\{$val\}\}
	}
#
# you have to sanity check y position within the loop as well (sigh)
#
	foreach v $sa {

	if {$hdr == ""} {
	if {[lsearch $trf_sav $y] >= 0} {
#		puts stderr "  Data $val hdr $hdr would be at $y, $x in a protected line! New page!"
		set y [expr $trf_len + 1]
	}
	}
	if {$y > $trf_len} {
#		puts stderr "    next y ($y) is greater than $trf_len NEW PAGE"
		if {$trf_blk} {
			trf_saveb 
		}
		trf_print
		trf_init
		if {$trf_blk} {
                        trf_restoreb
		}
		set y $trf_lin
#		puts stderr "new y on new page is $y"
	}

#	puts stderr "  place value $v"

#	put formatted data in right place in requested line
	set line $trf_arr($y)
	
	set newl1 ""
	if {$x > 0} {
	set newl1 [crange $line 0 [expr $x - 1]]
	}

	set newl2 "[format $fmt $v]"
	set vlen [clength $newl2]

	if {[expr $x + $vlen] > $trf_wid} {
#		puts stderr "WARNING, page $trf_pag line $y, text $newl2 placed at $x exceeds margin"
	}

	set newl3 [crange $line [expr $x + $vlen] end]

	set line "$newl1$newl2$newl3"

	set trf_arr($y) "$line"

	incr y

	}

	set trf_lin [expr $y - 1]
	return "$trf_lin$fl"

}
proc trf_print {} {
# $Header: /home/cvsroot/tcldb/ucodb/Tlib/trf_print,v 1.1.1.1 1996/10/12 01:08:27 de Exp $
	global trf_arr trf_len trf_wid trf_pag trf_fp

	loop i 1 [expr $trf_len + 1] {

		puts $trf_fp "$trf_arr($i)"

	}
	puts $trf_fp "\f"

	incr trf_pag
}
proc trf_restoreb {} {
# $Header: /home/cvsroot/tcldb/ucodb/Tlib/trf_restoreb,v 1.1.1.1 1996/10/12 01:08:27 de Exp $
	global trf_blk trf_arr trf_tmp trf_len trf_sav trf_lin

	set i 1
	while {[lsearch $trf_sav $i] >= 0} {
		incr i
	}
	foreach l [lsort -integer [array names trf_tmp]] {
		set trf_arr($i) $trf_tmp($l)
		incr i
	}
	set trf_lin $i
}
proc trf_saveb {} {
# $Header: /home/cvsroot/tcldb/ucodb/Tlib/trf_saveb,v 1.1.1.1 1996/10/12 01:08:27 de Exp $

	global trf_blk trf_arr trf_tmp trf_len trf_sav

	catch {unset trf_tmp}	

	loop  i $trf_blk [expr $trf_len + 1] {
		if {[lsearch $trf_sav $i] >= 0} {
			break
		}
		set trf_tmp($i) $trf_arr($i)
		set trf_arr($i) ""
	}

}