#
# General TCL/TK utility packages for my environment
#  a generic "tkerror" background error handler
#  a generic dialog box routine
#  a generic routine to get a number and optionally update a menu entry
#  save contents of TK text widget or selection to file
#  front end to file selector that keeps us in same directory
#  a basic "kill ring" system to remember a history of selected pieces of text
#  some basic "exact string match" and "regexp match" text widget search
#     methods
#
# Dave Clemans, May/June 1993
#

#
# Globals/parameters
#
set tkutCatCmd "/bin/cat"
set tkutCpCmd "/bin/cp"
set tkutHostnameCmd "/bin/hostname"
set tkutSaveBackFiles 1
set tkutWinNumber 0
set tkutKillRingSize 8
set tkutKillRingIndex 0
set tkutKillRing(0) ""
set tkutSearchString ""
set tkutWindowCount 0
set tkutWindowRows 30
set tkutWindowCols 80

set tkutInitialDir [pwd]
set tkutLocalSystem "unknown"
catch {set tkutLocalSystem [exec $tkutHostnameCmd]}

#
# SunOS 4.1 == sss
# HPUX == hpu
# Apollo Domain/OX 10.4 == m
#
set tkutVco [exec /usr/mgc/bin/mgcvco]

#
# Express version information in a consistent way
#
set tkutTclVersion [info tclversion]
set tkutTkVersion $tk_version
set tkutTclXVersion ""
if {[info commands infox] != ""} {
   set tkutTclXVersion [infox version]
}

#
# Catch and display background errors from key bindings and menu entries
#
proc tkerror { msg } {
    global errorInfo
    global tkutWinNumber
    set f .error$tkutWinNumber
    incr tkutWinNumber
    toplevel $f
    set title "Error Detected In TK Script - "
    append title [info script]
    wm title $f "$title"
    wm iconname $f "TK Error Msg"
    frame $f.button -relief sunken -border 1
    pack append $f $f.button {left expand padx 20 pady 20}
    button $f.button.0 -text "Dismiss" -command "destroy $f"
    pack append $f.button $f.button.0 {expand padx 12 pady 12}
    message $f.msg -aspect 300 -text "$errorInfo"
    pack append $f $f.msg {top expand}
    bind $f <Any-Enter> [list focus $f]
    focus $f
}

#
# A simple dialog box for giving the user a message
#
proc tkutDialogBox {msg} {
    global tkutWinNumber
    set r .req$tkutWinNumber
    incr tkutWinNumber
    catch {destroy $r}
    toplevel $r -class Dialog
    set title "TK Script Message - "
    append title [info script]
    wm title $r $title
    wm iconname $r "TK Message"

    frame $r.top -relief raised -border 1
    frame $r.bot -relief raised -border 1
    pack append $r $r.top {top fill expand} $r.bot {top fill expand}

    message $r.top.msg -justify center -font -Adobe-times-medium-r-normal--*-180* \
        -text "$msg" -aspect 400
    pack append $r.top $r.top.msg {top expand padx 5 pady 5}

    frame $r.bot.0 -relief sunken -border 1
    pack append $r.bot $r.bot.0 {left expand padx 20 pady 20}
    button $r.bot.0.button -text "OK" -command "destroy $r"
    pack append $r.bot.0 $r.bot.0.button {expand padx 12 pady 12}
    bind $r <Return> "destroy $r"
    bind $r <Any-Enter> "focus $r"
    focus $r
}

#
# Get a specified numeric parameter from the user, and change a global
# variable and menu entries based on it
#
proc tkutGetNumber {path label variable} {
    global $variable
    global tkutWinNumber
    set f .number$tkutWinNumber
    incr tkutWinNumber
    catch {destroy $f}
    toplevel $f
    wm geometry $f 296x40
    wm title $f "$label ?"
    wm iconname $f "Get Number"
    frame $f.line
    label $f.line.label -text "$label:" -width 21 -anchor w
    set number 0
    entry $f.line.entry -width 14 -relief sunken -bd 3 -textvariable number
    button $f.line.button -text "Select" \
         -command "$path entryconfigure \"$label\" -accelerator \$number;
             set $variable \$number;destroy $f"
    pack append $f.line $f.line.label left $f.line.entry left \
        $f.line.button {left pady 10 padx 20}
    bind $f.line.entry <Return> \
        "$path entryconfigure \"$label\" -accelerator \$number;
            set $variable \$number;destroy $f"
    bind $f <Any-Enter> "focus $f.line.entry"
    pack append $f $f.line {top fill}
    grab $f
    focus $f.line.entry
}

#
# Save the contents of the current selection as a string into the specified file
#
proc tkutSelSave {w file} {
    global tkutCatCmd
    global tkutCpCmd
    global tkutSaveBackFiles
    if {$tkutSaveBackFiles == 1} {
        if {[file exists $file]} {
            exec $tkutCpCmd $file $file.bak
        }
    }
    exec $tkutCatCmd > $file << [selection get]
}

#
# Save the contents of a specified text widget into a specified file
# The previous contents of the file is saved to a ".bak" file before being 
# overwritten
#
proc tkutSave {w file} {
    global tkutCatCmd
    global tkutCpCmd
    global tkutSaveBackFiles
    if {![file writable $file]} {
        if {[file exists $file]} {
            tkutDialogBox "File $file is not writable."
            return
        }
    }
    if {$tkutSaveBackFiles == 1} {
        if {[file exists $file]} {
            exec $tkutCpCmd $file $file.bak
        }
    }
    set feof [$w index {end + 1 c}]
    exec $tkutCatCmd > $file << [$w get 1.0 $feof]
}

#
# Get the name of a file from the user and load/insert/save that file from 
# the given text widget
#
proc tkutFileReq {w t p} {
    global tkutInitialDir
    cd $tkutInitialDir
    tkfsFileselect $w $p $t .fileselect tkerror
}

#
# Initialize our "kill ring" system
#
proc tkutKillRingInit {{size 0}} {
   global tkutKillRingSize
   global tkutKillRingIndex
   global tkutKillRing
   if {$size != 0} {
      set tkutKillRingSize size
   }
   for {set i 0} {$i < $tkutKillRingSize} {incr i} {
      set tkutKillRing($i) ""
   }
   set tkutKillRingIndex 0
}

#
# Push a string onto our "kill ring"
#
proc tkutKillRingPush {str} {
   global tkutKillRingSize
   global tkutKillRingIndex
   global tkutKillRing
   set tkutKillRing($tkutKillRingIndex) "$str"
   incr tkutKillRingIndex
   if {$tkutKillRingIndex >= $tkutKillRingSize} {
      set tkutKillRingIndex 0
   }
}

#
# Append a string onto the current top of our "kill ring"
#
proc tkutKillRingAppend {str} {
   global tkutKillRingSize
   global tkutKillRingIndex
   global tkutKillRing
   set index $tkutKillRingIndex
   if {$index == 0} {
      set index $tkutKillRingSize
      set max [array size tkutKillRing]
      if {$index > $max} {
         set index $max
      }
   }
   incr index -1
   append tkutKillRing($index) "$str"
}

#
# Get the current "top" entry in our "kill ring"
#
proc tkutKillRingGet {} {
   global tkutKillRingSize
   global tkutKillRingIndex
   global tkutKillRing
   set index $tkutKillRingIndex
   if {$index == 0} {
      set index $tkutKillRingSize
      set max [array size tkutKillRing]
      if {$index > $max} {
         set index $max
      }
   }
   incr index -1
   return $tkutKillRing($index)
}

#
# Display a text window showing the contents of our kill ring
#
proc tkutShowKillRing {} {
   global tkutWinNumber
   set b .killring$tkutWinNumber
   incr tkutWinNumber
   toplevel $b
   set title "Kill Ring Contents - "
   append title [info script]
   wm title $b $title
   wm iconname $b "Kill Ring Contents"
   set t $b.text
   set s $b.sb
   text $t -relief raised -bd 2 -yscrollcommand "$s set" -setgrid true
   wm geometry $b 80x30
   scrollbar $s -relief flat -command "$t yview"
   pack append $b $s {right filly} $t {expand fill}
   #
   $t insert insert "Kill Ring Contents:\n"
   $t insert insert "---- ---- --------\n"
   global tkutKillRingIndex
   global tkutKillRingSize
   global tkutKillRing
   set ringSize [array size tkutKillRing]
   if {$ringSize > $tkutKillRingSize} {
      set ringSize $tkutKillRingSize
   }
   set slot 1
   for {set i [expr $tkutKillRingIndex-1]} {$i >= 0} {incr i -1} {
      if {"$tkutKillRing($i)" != ""} {
         $t insert insert "\nSlot #$slot\n------\n"
         incr slot
         $t insert insert $tkutKillRing($i)
         $t insert insert "------\n"
      }
   }
   for {set i [expr $ringSize-1]} {$i > $tkutKillRingIndex} {incr i -1} {
      if {"$tkutKillRing($i)" != ""} {
         $t insert insert "\nSlot #$slot\n------\n"
         incr slot
         $t insert insert $tkutKillRing($i)
         $t insert insert "------\n"
      }
   }
   $t configure -state disabled
}

#
# Do any necessary initialization to use the search package in a text widget
#
proc tkutSearchInit {w} {
    if {[tk colormodel $w] == "color"} {
        $w tag configure search -background SeaGreen4 -foreground white
    } else {
        $w tag configure search -background black -foreground white
    }
}

#
# Do a normal search for a substring in a string
#
proc tkutStringMatch {line search indices} {
    uplevel 1 set $indices "{0 0}"
    set r [string first $search $line]
    if {$r == -1} {
        return 0
    }
    set l [string length $search]
    uplevel 1 set $indices "{$r [expr $r+$l-1]}"
    return 1
}

#
# Do a regular expression search for a substring in a string
#
proc tkutRegexpMatch {line search indices} {
    set index {0 0}
    set r [regexp -indices $search $line index]
    uplevel 1 set $indices "{$index}"
    return $r
}

#
# Search the given text widget for all usages of given string and highlight it
# Text insertion cursor is not changed
#
# method defines how to search; either tkutStringMatch or tkutRegexpMatch
#
proc tkutSearchForAll {w string tag method} {
    $w tag remove search 0.0 end
    scan [$w index end] %d numLines
    set l [string length $string]
    set index {0 0}
    for {set i 1} {$i <= $numLines} {incr i} {
        set line [$w get $i.0 $i.10000]
        set flag [$method $line $string index]
        if {$flag == 0} {
            continue
        }
        set offset 0
        while 1 {
            set flag [$method $line $string index]
            if {$flag == 0} {
                break
            }
            incr offset [lindex $index 0]
            $w tag add $tag $i.[expr $offset] $i.[expr $offset+$l]
            incr offset $l
            set line [string range $line $offset 10000]
        }
    }
}

#
# Search from the current insertion point to EOF for a given string and
# highlight the first occurrence found; search will wrap-around
#
# method defines how to search; either tkutStringMatch or tkutRegexpMatch
#
proc tkutSearchForNext {w string tag method} {
    $w tag remove search 0.0 end
    set l [string length $string]
    set p [$w index {insert + 1 chars}]
    set index {0 0}
    while {[$w compare $p < [$w index end]]} {
        $w mark set smarker $p
        set q [$w index {smarker lineend}]
        set line [$w get $p $q]
        set flag [$method $line $string index]
        if {$flag > 0} {
            set ss [lindex $index 0]
            set s [$w index "smarker + $ss chars"]
            set tt [lindex $index 1]
            incr tt
            set t [$w index "smarker + $tt chars"]
            $w tag add $tag $s $t
            $w mark set insert $s
            $w yview -pickplace insert
            return
        }
        set oldp $p
        set p [$w index "$p+1l linestart"]
        if {[$w compare $p == $oldp]} {
            break
        }
    }
    set p [$w index 0.0]
    while {[$w compare $p <= [$w index insert]]} {
        $w mark set smarker $p
        set q [$w index {smarker lineend}]
        if {[$w compare $q > [$w index insert]]} {
            set q [$w index insert]
        }
        set line [$w get $p $q]
        set flag [$method $line $string index]
        if {$flag > 0} {
            set ss [lindex $index 0]
            set s [$w index "smarker + $ss chars"]
            set tt [lindex $index 1]
            incr tt
            set t [$w index "smarker + $tt chars"]
            $w tag add $tag $s $t
            $w mark set insert $s
            $w yview -pickplace insert
            return
        }
        set oldp $p
        set p [$w index "$p+1l linestart"]
        if {[$w compare $p == $oldp]} {
            break
        }
    }
}

#
# Get a search string from the user and search for it in the specified 
# text widget
#
proc tkutSearchFor {w lab cmd method} {
    global tkutSearchString
    global tkutWinNumber
    set s .searcher$tkutWinNumber
    incr tkutWinNumber
    catch {destroy $s}
    toplevel $s
    wm geometry $s 472x40
    wm title $s $lab
    wm iconname $s "Search requestor"
    frame $s.string
    label $s.string.label -text "Search string:" -width 13 -anchor w
    entry $s.string.entry -width 40 -relief sunken -bd 3 -textvariable tkutSearchString
    button $s.string.button1 -text "Search" -command "$cmd $w \$tkutSearchString search $method
        destroy $s"
    pack append $s.string $s.string.label left $s.string.entry left \
        $s.string.button1 {left pady 10 padx 10}
    bind $s.string.entry <Return> "$cmd $w \$tkutSearchString search $method
        destroy $s"
    bind $s <Any-Enter> "focus $s.string.entry"
    pack append $s $s.string {top fill}
    grab $s
    focus $s.string.entry
}

#
# Remove highlights from a previous search
#
proc tkutSearchClear {w} {
    $w tag remove search 0.0 end
}

#
# A new main window has been created; record it
#
proc tkutNewMainWindow {} {
   global tkutWindowCount
   incr tkutWindowCount
}

#
# A main window has been destroyed; record it
#
proc tkutDelMainWindow {} {
   global tkutWindowCount
   incr tkutWindowCount -1
}

#
# Wait until all main windows have been destroyed
#
proc tkutWaitForNoWindows {} {
   global tkutWindowCount

   while {$tkutWindowCount > 0} {
      tkwait variable tkutWindowCount
   }
}
