# jtkutils.tcl - general utilities requiring Tk
#
######################################################################
# Copyright 1992-1995 by Jay Sekora.  This file may be freely        #
# distributed, modified or unmodified, for any purpose, provided     #
# that this copyright notice is retained verbatim in all copies and  #
# no attempt is made to obscure the authorship of this file.  If you #
# distribute any modified versions, I ask, but do not require, that  #
# you clearly mark any changes you make as such and that you provide #
# your users with instructions for getting the original sources.     #
######################################################################

### TO DO
###   j:rule and j:filler should read defaults for size, colour, etc.

######################################################################
# global variables:
#
global J_PREFS env
j:default J_PREFS(autoposition) 0
j:default J_PREFS(confirm) 1
j:default J_PREFS(visiblebell) 1
j:default J_PREFS(audiblebell) 1
#
######################################################################

######################################################################
# metawidget options:
#
option add *Rule.relief sunken widgetDefault
option add *Rule.width 2 widgetDefault
option add *Rule.height 2 widgetDefault
option add *Rule.borderWidth 1 widgetDefault
option add *Filler.relief flat widgetDefault
option add *Filler.width 10 widgetDefault
option add *Filler.height 10 widgetDefault

######################################################################
# j:wm_client - set the session client hostname
######################################################################

proc j:wm_client {{hostname USE_HOSTNAME}} {
  if {"x$hostname" == "xUSE_HOSTNAME"} {
    set hostname localhost
    set hostname_cmd FAIL
    foreach pathname {
      /bin/hostname
      /etc/hostname
      /usr/etc/hostname
      /usr/bsd/hostname
      /usr/bin/hostname
      /usr/ucb/hostname
      hostname
    } {
      if [auto_execok $pathname] {
        set hostname_cmd $pathname
        break
      }
    }
    if {"x$hostname_cmd" == "xFAIL"} {
      error "Can't determine hostname; can't find `hostname' to execute."
    } else {
      if [catch [list exec $hostname_cmd] result] {
        error [j:ldb wmclient:hostnamefail \
          "Can't determine hostname:\n$result"]
      } else {
        set hostname $result
      }
    }
  }
  wm client . $hostname
}

######################################################################
# j:wm_command ?args? - set the session client command
######################################################################

proc j:wm_command {{command ""}} {
  global argv0 argv
  
  if {[llength $command] == 0} {
    set command [concat $argv0 $argv]
  }
  
  wm command . $command
}

######################################################################
# j:new_toplevel prefix ?args? -
#   create a new toplevel, avoiding name conflicts
######################################################################

proc j:new_toplevel { prefix args } {
  set count 0
  
  while {[winfo exists $prefix$count]} {
    incr count
  }
  
  set tl $prefix$count
  toplevel $tl
  
  if {"x$args" != "x"} {
    eval [list $tl configure] $args
  }
  return $tl
}

######################################################################
# j:selection_if_any - return selection if it exists, else {}
#   this is from R. James Noble <kjx@comp.vuw.ac.nz>
######################################################################

proc j:selection_if_any {} {
  if {[catch {selection get} s]} {return ""} {return $s}
}

######################################################################
# j:beep w - "ring bell" in widget W
######################################################################

proc j:beep { w } {
  global j_beep J_PREFS
  
  set delay 100				;# should be a preference
  
  if { ! [info exists j_beep($w)] } {
    set j_beep($w) 0
  }
  
  if $j_beep($w) {
    return 1
  }
  set j_beep($w) 1			;# used so bells don't queue up
  
  if $J_PREFS(visiblebell) {
    set fg black
    set bg white
    
    if ![catch {set fg [lindex [$w configure -foreground] 4]}] {
      catch {$w configure -foreground $bg}
      after $delay "catch {$w configure -foreground $fg}"
    }
    if ![catch {set bg [lindex [$w configure -background] 4]}] {
      catch {$w configure -background $fg}
      after $delay "catch {$w configure -background $bg}"
    }
    update
    after $delay "
      update
      set j_beep($w) 0
    "
  }
  if $J_PREFS(audiblebell) {
    j:tk4 {bell -displayof $w}
  }
  
  after $delay "set j_beep($w) 0"	;# allow processing future bells
  
  return 0
}

######################################################################
# j:no_selection - true if there is no selection
######################################################################

proc j:no_selection {} {
  if {[catch {selection get} s]} {return 1} {return 0}
}

######################################################################
# j:default_button button widget... - bind <Return> to default button
#   widget... is one or more widgets that can have the kbd focus
######################################################################

proc j:default_button { button args } {
  foreach w $args {
    bind $w <Return> [list catch [list $button invoke]]
    j:tk4 {bind $w <Return> "+\nbreak"}
  }
}

######################################################################
# j:cancel_button button widget... - set up bindings for cancel button
#   widget... is one or more widgets that can have the kbd focus
######################################################################

proc j:cancel_button { button args } {
  foreach w $args {
    foreach key {
      <Control-c>
      <Control-g>
      <Meta-q>
      <Meta-period>
    } {
      bind $w $key [list catch [list $button invoke]]
      j:tk4 {bind $w $key "+\nbreak"}
    }
  }
}

######################################################################
# j:tab_ring widget... - bind Tab and Shift-Tab to cycle through widgets
#  widget... is the list of widgets to bind, in order
######################################################################
### It's unfortunate to have to hardwire Shift-Tab to Backtab, but there
### doesn't seem to be a <Backtab> X11 keysym.

proc j:tab_ring {args} {
  j:tk4 {return}
  
  # index of last widget
  set last [expr {[llength $args] - 1}]
  
  for {set i 0} {$i < $last} {incr i} {
    set this [lindex $args $i]
    set next [lindex $args [expr {$i + 1}]]
    bind $this <Tab> [list catch [list focus $next]]
    bind $next <Shift-Tab> [list catch [list focus $this]]
  }
  
  # ... and bind last to focus on first:
  set this [lindex $args $last]
  set next [lindex $args 0]
  bind $this <Tab> [list catch [list focus $next]]
  bind $next <Shift-Tab> [list catch [list focus $this]]
}

######################################################################
# j:dialogue w - arrange to position window w near ctr of screen
#   mostly borrowed from /usr/local/lib/tk/dialog.tcl
# does nothing unless $J_PREFS(autoposition)
######################################################################

proc j:dialogue { w } {
  global J_PREFS

  if $J_PREFS(autoposition) {
    # first, display off-screen:
    wm withdraw $w		;# hide the window

    update idletasks		;# force geometry managers to run
    # calculate position:
    set x [expr [winfo screenwidth $w]/2 - [winfo reqwidth $w]/2 \
	    - [winfo vrootx [winfo parent $w]]]
    set y [expr [winfo screenheight $w]/3 - [winfo reqheight $w]/2 \
	    - [winfo vrooty [winfo parent $w]]]
    wm geom $w +$x+$y
    wm deiconify $w		;#### ???? ################################

    update idletasks		;# force geometry managers to run
    wm deiconify $w		;# display window
    wm focus $w			;#### ???? ################################
  }
}

proc j:dialog [info args j:dialogue] [info body j:dialogue]

######################################################################
# j:rule parent [args] - returns a rule suitable for parent
#       used as argument to a pack command
######################################################################

proc j:rule { {parent {}} args} {
  global j_rule

  if {$parent == "."} {set parent ""}	;# so "." doesn't give "..rule0"
  
  if {[info exists j_rule(count)]} then {
    set j_rule(count) [expr {$j_rule(count) + 1}]
  } else {
    set j_rule(count) 0
  }

  set rule "$parent.rule$j_rule(count)"
  frame $rule -class Rule
  if {$args != ""} {eval $rule configure $args}
  return $rule
}

######################################################################
# j:filler parent [args] - returns a filler frame suitable for parent
#       used as argument to a pack command
######################################################################

proc j:filler { {parent {}} args} {
  global j_filler

  if {$parent == "."} {set parent ""}	;# so "." doesn't give "..filler0"
  
  if {[info exists j_filler(count)]} then {
    set j_filler(count) [expr {$j_filler(count) + 1}]
  } else {
    set j_filler(count) 0
  }

  set filler "$parent.filler$j_filler(count)"
  frame $filler -class Filler
  if {$args != ""} {eval $filler configure $args}
  lower $filler				;# so it will be beneath its parent
  return $filler
}

######################################################################
# j:configure_font widget fontlist - use font from list, or default
#   tries to set widget's font to each font in list.
#   if a font is `default', tries to set to X default font.
#   if a font is {}, sets to courier 12-point.
######################################################################

proc j:configure_font { widget fontlist } {
  foreach font $fontlist {
    # try to use each font, until one is successful:
    if {$font == {default}} {
      set font [option get $widget font Font]
      if {$font == {}} {set font {*-courier-medium-r-normal--*-120-*}}
    }
    if {! [catch {$widget configure -font $font}]} {return}
  }
}

######################################################################
# j:configure_tag_font widget tag fontlist - use font from list, or default
#   tries to set tag's font to each font in list.
#   if a font is `default', tries to set to X default font.
#   if a font is {}, sets to courier 12-point.
######################################################################

proc j:configure_tag_font { widget tag fontlist } {
  foreach font $fontlist {
    # try to use each font, until one is successful:
    if {$font == {default}} {
      set font [option get $widget font Font]
      if {$font == {}} {set font {*-courier-medium-r-normal--*-120-*}}
    }
    if {! [catch {$widget tag configure $tag -font $font}]} {return}
  }
}





