# joptionbutton.tcl - one-of-many choice button with popup list
#
###############################################################################
#  Copyright 1992-2001 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]*}
}

######################################################################
# create a new option button.  -font and -width can adjust appearance.
#   -list is not really optional.  -current can set current value.
######################################################################

proc ::aq::option_button { w args } {
  ::aq::parse_args {
    {font {}}
    {list {(none)}}
    {width 20}
    {current {}}
    {command {}}
    {variable {DEFAULT}}
  }
  # should do error checking on args.
  
  # following avoid nasty problems when the same button is recreated.
  catch {rename $w {}}
  catch {rename ${w}-orig {}}
  
  if [string match DEFAULT $variable] {
    set variable JOPTION$w
  }
  
  global JOPTION				;# list,$w; var,$w; cmd,$w
  set JOPTION(var,$w) $variable
  set JOPTION(cmd,$w) $command

  if {[string match "" $current]} {		;# if no -current specified
    set current [lindex $list 0]		;# use first element, unless
  }
  
  # Following is a little tricky.  If $variable is j_fs(file), then saying
  # "global j_fs(file)" would declare j_fs(file) as a single global scalar
  # variable (with a really weird name), and setting j_fs(file) would set
  # a local variable instead.  So we have to use upvar.
  
  upvar #0 $variable g_var
  
  set g_var $current
  
  set JOPTION(list,$w) $list
  
  # parameterise following:                                      ##########
  label $w -width $width -textvariable $variable \
    -text $g_var \
    -takefocus 1 \
    -borderwidth 2 -padx 2 -pady 2 -relief raised
  catch {$w configure -highlightthickness 2}
  if [string length $font] {
    $w configure -font $font
  }
  
  frame $w.bump -height 6 -width 10 -borderwidth 2 -relief raised
  place $w.bump -in $w -relx 0.95 -rely 0.5 -anchor e
  
  bind $w <ButtonPress-1> [list \
    ::aq::_option_popup .option_popup $w \
  ]
  bind $w <ButtonPress-1> "+\nbreak"
  
  ###
  ###
  ### FOLLOWING DON'T WORK YET
  ### You can't tab out of the entry field, because it does tab-completion
  ### Also, bindings aren't set properly on the listbox.
  ###
  ###
  bind $w <Any-Key-Return> "
    ::aq::_option_popup .option_popup $w
    focus .option_popup.lb
  "
  
  bind $w <Any-Key-space> "
    ::aq::_option_popup .option_popup $w
    focus .option_popup.lb
  "
  
  catch {rename ${w}-orig {}}
  rename $w ${w}-orig
  proc $w { option args } [format {
    set tmp %s
    global JOPTION
    
    switch -exact $option {
      cget {
        return [lindex [::aq::_option_configure $tmp $args] 4]
      }
      configure {
        return [::aq::_option_configure $tmp $args]
      }
      get {
        return [uplevel #0 set $JOPTION(var,$tmp)]
      }
      invoke {
        ::aq::_option_invoke $tmp
        return {}
      }
      set {
        set rvalue [uplevel #0 set [set JOPTION(var,$tmp)] [lindex $args 0]]
        ::aq::_option_invoke $tmp
        return $rvalue
      }
      default {
        error \
          "Bad option \"$option\": must be cget, configure, get, invoke or set"
      }
    }
  } $w]
}

######################################################################
# invoke the command associated with an optionbutton widget
######################################################################

proc ::aq::_option_invoke { w } {
  global JOPTION
  if [string length $JOPTION(cmd,$w)] {
    uplevel #0 eval $JOPTION(cmd,$w)
  }
  return {}
}

######################################################################
# configure a setting for an optionbutton widget.
#   this should be more general, and it should be used by initial
#   arg-parsing code for ::aq::option_button .
######################################################################

proc ::aq::_option_configure { w arglist } {
  global JOPTION
  upvar #0 [set JOPTION(var,$w)] current_value
  upvar #0 JOPTION(list,$w) current_list
  upvar #0 JOPTION(cmd,$w) current_cmd
  upvar #0 JOPTION(var,$w) current_var
  
  if {[llength $arglist] == 0} {
    set rvalue {}
    foreach option {-font -list -command -variable -current -width} {
      lappend rvalue [::aq::_option_configure $w $option]
    }
    return $rvalue
  }
  
  if {[llength $arglist] == 1} {
    set option [lindex $arglist 0]
    switch -exact -- $option {
      -font {
        return [${w}-orig configure -font]
      }
      -list {
        return [list -list list List {(none)} $current_list]
      }
      -command {
        return [list -command command Command {} $current_cmd]
      }
      -variable {
        return [list -variable variable Variable JOPTION$w $current_var]
      }
      -current {
        return [list -current current Current {} $current_value]
      }
      -width {
        return [${w}-orig configure -width]
      }
      default {
        error "unknown option \"$option\""
      }
    }
  }
  
  while {[llength $arglist] > 0} {
    set option [lindex $arglist 0]
    set value [lindex $arglist 1]
    if {"x$value" == "x"} {
      error "value for \"$option\" missing"
    }
    
    set arglist [lreplace $arglist 0 1]	;# with nothing
    
    switch -exact -- $option {
      -font {
        ${w}-orig configure -font $value
      }
      -list {
        set current_list $value
      }
      -command {
        set current_cmd $value
      }
      -variable {
        # set current_var $value
        error "-variable can't be configured yet"
      }
      -current {
        set current_value $value
      }
      -width {
        ${w}-orig configure -width $value
      }
      default {
        error "unknown option \"$option\""
      }
    }
  }
}

######################################################################
# create (and position properly) the popup list invoked by <1>
######################################################################

proc ::aq::_option_popup { w button } {
  global JOPTION
  upvar #0 [set JOPTION(var,$button)] value
  upvar #0 JOPTION(list,$button) list
  
  # make sure the current value is in the list:
  if {[lsearch -exact $list $value] == -1} {
    set list [linsert $list 0 $value]
  }
  
  toplevel $w
  wm transient $w [winfo toplevel $button]
  wm overrideredirect $w 1
  wm withdraw $w
  
  set width [lindex [$button configure -width] 4]
  set font [lindex [$button configure -font] 4]
  
  listbox $w.lb \
    -font $font \
    -exportselection 0 \
    -borderwidth 2 -relief raised -cursor arrow
  
  $w.lb configure -width $width -height [llength $list]
  $w.lb configure -highlightthickness 0
  
  pack $w.lb -in $w
    
  foreach item $list {
    $w.lb insert end $item
  }
  
  # guess positioning of listbox so current value is over button:
  
  # get pixels per line - toplevel size is in pixels
  update
  set lines [llength $list]
  set pixels [winfo reqheight $w]
  set pixels_per_line [expr $pixels / $lines]
  
  # index is position of current value in list;
  # offset is that times pixels per line:
  set index [lsearch -exact $list $value]
  set offset [expr $index * $pixels_per_line]

  # subtract offset (position of current in list) from button y position:
  set x [winfo rootx $button]
  set y [expr [winfo rooty $button] - $offset]
  
  # adjust for highlight thickness:
  set x [expr $x + 2]
  set y [expr $y + 2]
  
  wm geometry $w +$x+$y
  wm deiconify $w
  
  # disable all current bindings:
  bindtags $w.lb $w.lb
  
  bind $w.lb <Visibility> "
    update
    grab -global %W
    %W selection clear 0 end
    %W selection set $index $index
    break
  "
  
  bind $w.lb <Any-ButtonRelease-1> "
    # set value
    set [set JOPTION(var,$button)] \[%W get \[%W nearest %y\]\]
    grab release %W
    destroy \[winfo toplevel %W\]
    # invoke command
    ::aq::_option_invoke $button
    break
  "
  
  bind $w.lb <Any-B1-Motion> {
    %W selection clear 0 end
    %W selection set [%W nearest %y] [%W nearest %y]
    break
  }
}
