# jtkutils.tcl - general utilities requiring Tk
#
######################################################################
# Copyright 1992-2002 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.     #
######################################################################

package provide aq 0.1

# following has side-effect of making sure ::aq namespace is defined
namespace eval ::aq {
  namespace export {[a-z]*}
  catch {
    package require jldb
    # following likely to fail, because done by other libraries too
    namespace import ::jldb::shortcuts::*
  }
}

######################################################################
# global variables:
#
global J_PREFS env
::aq::default J_PREFS(autoposition) 0
::aq::default J_PREFS(confirm) 1
::aq::default J_PREFS(visiblebell) 1
::aq::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

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

proc ::aq::wm_client {{hostname USE_HOSTNAME}} {
  if {"x$hostname" == "xUSE_HOSTNAME"} {
    set hostname [info hostname]
  }
  wm client . $hostname
}

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

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

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

proc ::aq::new_toplevel { prefix args } {
  set count 0
  
  while {[winfo exists $prefix$count]} {
    incr count
  }
  
  set tl $prefix$count
  eval toplevel [list $tl] $args
  return $tl
}

######################################################################
# ::aq::beep w - ring bell in (or flash) widget W
######################################################################

proc ::aq::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) {
    bell -displayof $w
  }
  
  after $delay "set j_beep($w) 0"	;# allow processing future bells
  
  return 0
}

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

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

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

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

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

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

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

proc ::aq::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]]
      bind $w $key "+\nbreak"
    }
  }
}

######################################################################
# ::aq::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 ::aq::dialogue { w } {
  global J_PREFS
  global AQSYSINFO
  if {$AQSYSINFO(tinyscreen)} {
    wm minsize $w $AQSYSINFO(min_width) $AQSYSINFO(min_height)
  } else {
    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]]]
      if {$y < 0} {set y 0}
      # we don't do this for x because if x is off screen, the window *must*
      # be too wide for the screen.
      wm geom $w +$x+$y
    }
    update idletasks		;# force geometry managers to run
  }
  wm deiconify $w		;# display window
  wm focus $w			;#### ???? ################################
  
  # hack - if we're on a PDA, set the transient property.  since we don't
  # know what if any window the dialogue box is transient *for* (aqtools
  # doesn't use windows in quite the way implied by setting a window 
  # transient for a toplevel), we just set it transient for the toplevel
  # (which may or may not be visible, depending on the app), and hope
  # the window manager doesn't do anything awful.
  
  if {$AQSYSINFO(tinyscreen)} {
    wm transient $w .
  }
}

proc ::aq::dialog [info args ::aq::dialogue] \
  [info body ::aq::dialogue]

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

proc ::aq::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
}

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

proc ::aq::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
}

######################################################################
# ::aq::hide_pointer w - blank mouse cursor in w
######################################################################

proc ::aq::hide_pointer { w } {
  global aq_library
  global JSTOOLS
  
  if {! [info exists JSTOOLS(pointer_hidden,$w)]} {
    set JSTOOLS(pointer_hidden,$w) 0
  }
  
  if {!$JSTOOLS(pointer_hidden,$w)} {
    set JSTOOLS(pointer_hidden,$w) 1
    catch {
     $w configure \
       -cursor [list @[file join $aq_library bitmaps blank.xbm] white]
   }
 }
}

######################################################################
# ::aq::show_pointer w - restore mouse cursor in w
######################################################################

proc ::aq::show_pointer { w } {
  global JSTOOLS
  
  if {![info exists JSTOOLS(pointer_hidden,$w)]} {
    set JSTOOLS(pointer_hidden,$w) 0
  }
  
  if {$JSTOOLS(pointer_hidden,$w)} {
    set JSTOOLS(pointer_hidden,$w) 0
    catch {
      $w configure -cursor [lindex [$w configure -cursor] 3]
    }
  }
}

######################################################################
# ::aq::configure_font widget fontlist - use first listed font
#   sets widget's font to first listed font
#   if a font is `default', sets to X default font.
#   if a font is {}, sets to courier 12-point.
######################################################################
# NOTE - In current versions of Tk, setting a font is *always* successful,
#        even if the given font doesn't exist; it just might not have any
#        effect.  Therefore, the only actual effect of this procedure versus
#        just configuring the font is the handling of "default" and "".

proc ::aq::configure_font { widget fontlist } {
  set font [lindex $fontlist 0]
  if {$font == {default}} {
    set font [option get $widget font Font]
    if {$font == {}} {set font {Courier 12}}
  }
  $widget configure -font $font
}

######################################################################
# ::aq::configure_tag_font widget tag fontlist - use first listed font
#   sets tag's font to first listed font
#   if a font is `default', sets to X default font.
#   if a font is {}, sets to courier 12-point.
######################################################################
# NOTE - In current versions of Tk, setting a font is *always* successful,
#        even if the given font doesn't exist; it just might not have any
#        effect.  Therefore, the only actual effect of this procedure versus
#        just configuring the font is the handling of "default" and "".

proc ::aq::configure_tag_font { widget tag fontlist } {
  set font [lindex $fontlist 0]
  if {$font == {default}} {
    set font [option get $widget font Font]
    if {$font == {}} {set font {Courier 12}}
  }
  $widget tag configure $tag -font $font
}

######################################################################
# ::aq::active_window [-class Class] [w] -
#   return or set the most recent active window (optionally of class Class)
######################################################################

proc ::aq::active_window { args } {
  ::aq::parse_args {
    {class any}
  }
  
  global ACTIVE_WINDOW
  
  switch -exact [llength $args] {
    1 {
      set win [lindex $args 0]
      set ACTIVE_WINDOW(any) $win
      set ACTIVE_WINDOW([winfo class $win]) $win
    }
    0 {
      if [info exists ACTIVE_WINDOW($class)] {
        return $ACTIVE_WINDOW($class)
      } else {
        return none
      }
    }
    default {
      error {wrong # args: should be "::aq::active_window ?-class class? window"}
    }
  }
}

######################################################################
# ::aq::jwinfo $w get|set|defined|unset property [value]
#   manipulate properties associated with windows
######################################################################

proc ::aq::jwinfo { w action {property {}} {value {}} } {
  global J_WINFO
  
  switch -exact -- $action {
    set {
      set J_WINFO($w..$property) $value
      return $value
    }
    get {
      if {![info exists J_WINFO($w..$property)]} {
        return $value
      }
      return $J_WINFO($w..$property)
    }
    unset {
      catch {unset J_WINFO($w..$property)}
      return {}
    }
    defined {
      if [info exists J_WINFO($w..$property)] {
        return 1
      } else {
        return 0
      }
    }
    list {
      if {![array exists J_WINFO]} {
        return {}
      }
      set rvalue {}
      foreach index [array names J_WINFO $w..*] {
        regsub -- {.*\.\.} $index {} index
        lappend rvalue $index
      }
      return $rvalue
    }
    default {
      error "bad option \"$action\": must be set, get, unset, defined, or list"
    }
  }
}

######################################################################
# ::aq::tlinfo $w get|set|defined|unset property [value]
#   manipulate properties associated with toplevels
######################################################################

proc ::aq::tlinfo { w action property {value {}} } {
  global J_WINFO
  
  set w [winfo toplevel $w]
  
  switch -exact -- $action {
    set {
      set J_WINFO($w..$property) $value
      return $value
    }
    get {
      if {![info exists J_WINFO($w..$property)]} {
        return $value
      }
      return $J_WINFO($w..$property)
    }
    unset {
      catch {unset J_WINFO($w..$property)}
      return {}
    }
    defined {
      if [info exists J_WINFO($w..$property)] {
        return 1
      } else {
        return 0
      }
    }
    list {
      if {![array exists J_WINFO]} {
        return {}
      }
      set rvalue {}
      foreach index [array names J_WINFO $w..*] {
        regsub -- {.*\.\.} $index {} index
        lappend rvalue $index
      }
      return $rvalue
    }
    default {
      error "bad option \"$action\": must be set, get, unset, defined, or list"
    }
  }
}
