proc _logcommand {{fname ~/tool.log} {cmd}} {
   set fd [open $fname a]
   puts $fd "[whoami] [exec date +%a] [exec date +%x] [exec date +%X] $cmd"
   close $fd
}

proc _mesg_on {{mesg "Working..."}} {
   global gvar
   catch {destroy .ms}
   toplevel .ms
   wm title .ms "WAIT"
   wm geometry .ms +500+500

   if [info exist gvar(font5)] {
      set font1 $gvar(font5)
   } else {
      set font1 "-adobe-helvetica-medium-r-normal--24-240-75-75-p-130-iso8859-1"
   }
   
   frame .ms.lv0 -relief raised -bd 5
   pack append .ms.lv0 \
      [label .ms.lv0.b0 -text "$mesg" -relief raised -bd 2 \
         -font $font1] {top padx 20 pady 20 fill expand}
   pack append .ms .ms.lv0 {}
   after 500
}

proc _mesg_off {} {
   catch {destroy .ms}
}

proc _brief_mesg {w mesg secs} {
   global gvar
   catch {destroy $w}
   toplevel $w
   wm title $w "MESSAGE"
   wm geometry $w +500+500
   
   frame $w.lv0 -relief raised -bd 2
   pack append $w.lv0 \
      [label $w.lv0.b0 -text "$mesg" -relief raised -bd 2] \
         {top padx 20 pady 20 fill expand}
   pack append $w $w.lv0 {}
   set t1 [expr secs*1000]
   after $t1 destroy $w
}

proc _busy {cmds} {
    global errorInfo gvar

    _mesg_on {"Working..."}
    set busy {}
    set list [winfo children .]
    set busy $list
    while {$list != ""} {
        set next {}
        foreach w $list {
            set class [winfo class $w]
            set cursor [lindex [$w config -cursor] 4]
            if {[winfo toplevel $w] == $w} {
                lappend busy [list $w $cursor]
            }
            set next [concat $next [winfo children $w]]
        }
        set list $next
    }

    foreach w $busy {
        catch {[lindex $w 0] config -cursor watch}
    }

    update idletasks

    set error [catch {uplevel eval [list $cmds]} result]
    set ei $errorInfo

    foreach w $busy {
          catch {[lindex $w 0] config -cursor [lindex $w 1]}
    }

    _mesg_off
    if $error {
          error $result $ei
    } else {
          return $result
    }
}

proc _changeview {w x} {
#  $w.list xview $v
#  $w.entry view $v
   set last [$w.hscroll get]
   if {$x > [expr [lindex $last 0]-[lindex $last 1]]} {
      set x [expr [lindex $last 0]-[lindex $last 1]+1]
   }
   $w.list xview $x
   $w.entry view $x
}

proc _mklistbox {{w .lb} {ltxt "List Box"} {wbx 300} {wby 300}} {
   global gvar
   catch {destroy $w}

   #<---------------- wbx ------------------->
   #<  >-- obw                   <   >-- ibw
   #   <---------- lbx ---------->   <   >-- sbs
   #..........................................
   #.                                        .  ^
   #.  +-------------------------+ ^ +---+   .  |
   #.  |                         | | |   |   .  |
   #.  |                         | | |   |   .  |
   #.  |                         |lby|   |   .  |
   #.  |                         | | |   |   .  |
   #.  |                         | | |   |   . wby
   #.  +-------------------------+ v +---+ v .  |
   #.                                     ibw.  |
   #.  +-------------------------+  ^      ^ .  |
   #.  |                         | sbs       .  |
   #.  +-------------------------+  v        .  |
   #.                                        .  |
   #..........................................  v

   set obw 10
   set ibw 5
   set sbs 20
   set t1 [expr $wbx.0-(2.0*$obw.0)-$sbs.0-$ibw.0]
   set y1 [expr $obw.0+$ibw.0+25.0]
   set t2 [expr $wby.0-$obw.0-$ibw-$sbs.0-$y1]
   set lbx [expr $t1.0/$wbx.0]
   set lby [expr $t2.0/$wby.0]
   set t3 [expr $wbx-$sbs-$obw]
   set t4 [expr $wby-$sbs-$obw]

   if [info exist gvar(font1)] {
      set font1 $gvar(font1)
   } else {
      set font1 "-adobe-courier-bold-r-normal--14-140-75-75-m-90-iso8859-1"
   }
   if [info exist gvar(font3)] {
      set font3 $gvar(font3)
   } else {
      set font3 "-adobe-courier-medium-r-normal--14-140-75-75-m-90-iso8859-1"
   }

   frame $w -borderwidth $obw -geometry [format "%sx%s" $wbx $wby]
   place [entry $w.entry -relief raise -borderwidth 2 \
      -font $font1] \
      -in $w -bordermode outside -x $obw -y $obw -relwidth $lbx
   place [listbox   $w.list -relief sunken -xscroll "$w.hscroll set" \
      -yscroll "$w.vscroll set" -exportselection 0] -in $w \
      -x $obw -y $y1 -relheight $lby -relwidth $lbx -bordermode outside
   $w.list configure -font $font3
   $w.entry insert 0 $ltxt
   place [scrollbar $w.vscroll -relief sunken \
      -command "$w.list yview"] -in $w -bordermode outside \
      -x $t3 -y $y1 -relheight $lby
   place [scrollbar $w.hscroll -orient horiz -relief sunken \
      -command "_changeview $w"] -in $w -bordermode outside \
      -x $obw -y $t4 -relwidth $lbx
}

proc _mkdialog {w mesg buttons} {
   # hacked from John's widget demo
   # w       = window name
   # mesg    = message format and text
   # buttons = a list consisting of {text,action}
   # gvar(dialogrc) = choice pick (0=not pick, 1=choice 1 ... n=choice n)
   global gvar
   catch {destroy $w}
   toplevel $w
   wm title $w "DIALOG"
   wm minsize $w 300 200
   wm geometry $w +500+500

   if [info exist gvar(font5)] {
      set font5 $gvar(font5)
   } else {
      set font5 "-adobe-helvetica-medium-r-normal--18-180-75-75-p-98-iso8859-1"
   }

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

   eval message $w.top.msg -justify center -font $font5 $mesg
   pack append $w.top $w.top.msg {top padx 20 pady 10 expand}

   set gvar(dialogrc) 0
   if {[llength $buttons] > 0} {
      set j 0
      foreach i [lrange $buttons 0 end] {
         set j [incr j]
         set bt [lindex $i 0]
         set sl [expr [string length $bt]+8]
         if {$j == 1} {
            frame $w.bot.def -relief sunken -border 1
            button $w.bot.def.$j -text $bt -height 5 -width $sl \
               -command "set gvar(dialogrc) 1; [lindex $i 1]"
            pack append $w.bot.def $w.bot.def.$j {expand padx 12 pady 12}
            pack append $w.bot $w.bot.def {left expand padx 10 pady 10}
            bind $w <Return> "set gvar(dialogrc) 1; [lindex $i 1]"
         } else {
            button $w.bot.$j -text $bt -height 5 -width $sl \
               -command "set gvar(dialogrc) $j; [lindex $i 1]"
            pack append $w.bot $w.bot.$j {left expand padx 20}
         }
      }
   }

   bind $w.top     <Enter> "$w.bot.def.1 activate"
   bind $w.bot     <Enter> "$w.bot.def.1 activate"
   bind $w.top.msg <Enter> "$w.bot.def.1 activate"
   bind $w.bot.def <Enter> "$w.bot.def.1 activate"
   bind $w.top     <Leave> "$w.bot.def.1 deactivate"
   bind $w.bot     <Leave> "$w.bot.def.1 deactivate"
   bind $w.top.msg <Leave> "$w.bot.def.1 deactivate"
   bind $w.bot.def <Leave> "$w.bot.def.1 deactivate"
   bind $w         <1>     "$w.bot.def.1 config -relief sunken"
   bind $w         <Any-Enter>   [list focus $w]
   bind $w         <Visibility>  "focus $w"

   tkwait window $w
}

proc _nextentry {{w} {i 0}} {
   global gvar
   incr i
# need to get rid of gvar(fieldname)
   if {$i >= [llength $gvar(fieldname)]} {
      set i 0
   }
   focus $w.$i.b2
}

proc _preventry {{w} {i 0}} {
   global gvar
   incr i -1
   if {$i < 0} {
# need to get rid of gvar(fieldname)
      set i [expr [llength $gvar(fieldname)]-1]
   }
   focus $w.$i.b2
}

proc _mkentry {{w} {i 0} {text "Entry"}} {
   frame $w.$i
   pack append $w.$i \
      [label $w.$i.b1 -text "$text" -anchor e -width 10] {left} \
      [entry $w.$i.b2 -relief sunken -width 30] {left}
   bind $w.$i.b2 <Return> "_nextentry $w $i"
   bind $w.$i.b2 <Tab>    "_preventry $w $i"
}

proc _author {{w .aw} {pic ""} {name}} {
   global gvar

   catch {destroy $w}

   toplevel $w
   wm title $w "AUTHOR"
   wm iconname $w "Author"
  
   if [file readable $pic] {
      set path $pic
   } else {
      set path "/bnr/bootleg/bin/tcl/mprint/author_icon"
   }

   frame $w.frame -bd 2
   pack append $w.frame \
      [label $w.frame.l1 -bitmap @$path -bd 2 -relief sunken] top \
      [label $w.frame.l2 -text "$name"] {frame center fillx} \
      [button $w.frame.l3 -text "DONE" \
         -command "destroy $w"] {fillx expand}
   pack append $w $w.frame {fill}
}

proc _insertwithtags {w text args} {
   set start [$w index insert]
   $w insert insert $text
   foreach tag [$w tag names $start] {
      $w tag remove $tag $start insert
   }
   foreach i $args {
      $w tag add $i $start insert
   }
}

proc entry.center {w} {
   set cursor_pos [$w index cursor]
   $w view 0
   set left_extent [$w index @0]
   set right_extent [$w index @[winfo width $w]]
   set entry_length [expr {$right_extent - $left_extent}]
   set text_length [expr [$w index end]]
   if {$text_length > $entry_length} {
      $w view [expr {$cursor_pos - $entry_length / 2 + 1}]
   }
}

proc entry.cursor {w} {
   set left_extent [$w index @0]
   set right_extent [$w index @[winfo width $w]]
   set cursor_pos [$w index cursor]
   set entry_length [expr {$right_extent - $left_extent}]
   if {$cursor_pos >= $right_extent || \
       $cursor_pos <= $left_extent} {
      entry.center $w
   }
}

proc entry.deleteleft {w} {
   set t1 ""
   set t2 [catch {$w index sel.first} t1]
   if {[string range $t1 0 8] != "selection"} {
      $w delete sel.first sel.last
      entry.cursor $w
   } else {
      set x [expr {[$w index cursor] - 1}]
      if {$x >= 0} {$w delete $x}
      entry.cursor $w
   }
}

proc entry.cursorleft {w} {
   set x [expr {[$w index cursor] - 1}]
   if {$x >= 0} {$w cursor $x}
   entry.cursor $w
}

proc entry.cursorright {w} {
   set x [expr {[$w index cursor] + 1}]
   set xm [$w index end]
   if {$x <= $xm} {$w cursor $x}
   entry.cursor $w
}

proc _setentrybind {{w Entry}} {
   bind $w <Any-KeyPress>   {%W insert cursor "%A"; entry.cursor %W}
   bind $w <space>          {%W insert cursor " "; entry.cursor %W}
   bind $w <Control-h>      {entry.deleteleft %W}
   bind $w <BackSpace>      {entry.deleteleft %W}
   bind $w <Delete>         {entry.deleteleft %W}
   bind $w <Control-u>      {%W delete 0 end; %W view 0}
   bind $w <ButtonPress-1>  {%W cursor @%x; focus %W; %W select from @%x}
   bind $w <Button1-Motion> {%W select to @%x}
   bind $w <ButtonPress-2>  {%W insert cursor [selection get]; entry.cursor %W}
   bind $w <Left>           {entry.cursorleft %W}
   bind $w <Right>          {entry.cursorright %W}
}
