CD Actual 3/CD ACTUAL 3.iso/linux/incoming/jstools-.6v3/jstools-/jstools-tk3.6v3.0/lib/joptionbutton.tcl

Text File | 1995-02-05 | 5.6 KB | 225 lines

# joptionbutton.tcl - one-of-many choice button with popup list
#
# Copyright 1994 by Jay Sekora.  All rights reserved, except
# that this file may be freely redistributed in whole or in part
# for non-profit, noncommercial use.
######################################################################

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

proc j:option { w args } {
  j:parse_args {
    {font {}}
    {list {(none)}}
    {width 20}
    {current {}}
  }
  # should do error checking on args.

  global LIST_FOR_$w
  global OPTION_FOR_$w

  if {"x$current" == "x"} {
    set current [lindex $list 0]
  }
  set OPTION_FOR_$w $current

  set LIST_FOR_$w $list

  # parameterise following:
  label $w -width $width -textvariable OPTION_FOR_$w \
    -borderwidth 2 -relief raised
  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 \
    j:option:popup .option_popup $w \
  ]

  catch {rename ${w}-orig {}}
  rename $w ${w}-orig
  proc $w { option args } [format {
    set tmp %s
    global OPTION_FOR_$tmp

    switch -exact $option {
      get {
        return [set OPTION_FOR_$tmp]
      }
      set {
        return [set OPTION_FOR_$tmp [lindex $args 0]]
      }
      configure {
        return [j:option:configure $tmp $args]
      }
      default {
        error "Invalid argument $option to option widget command $tmp."
      }
    }
  } $w]
}

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

proc j:option:configure { w arglist } {
  upvar #0 OPTION_FOR_$w current_value
  upvar #0 LIST_FOR_$w current_list

  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]
      }
      -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 "no value given to option \"$option\"."
    }

    set arglist [lreplace $arglist 0 1]    ;# with nothing

    switch -exact -- $option {
      -font {
        ${w}-orig configure -font $value
      }
      -list {
        set current_list $value
      }
      -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 j:option:popup { w button } {
  upvar #0 OPTION_FOR_$button value
  upvar #0 LIST_FOR_$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

  j:tk3 {$w.lb configure -geometry ${width}x[llength $list]}
  j:tk4 {
    $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]

  wm geometry $w +$x+$y
  wm deiconify $w

  # disable all current bindings:
  foreach event [bind Listbox] {
    bind $w.lb $event {}
  }

  j:tk3 {
    bind $w.lb <Visibility> "
      grab -global %W
      %W select from $index
      %W select to $index
    "
  }
  j:tk4 {
    bind $w.lb <Visibility> "
      grab -global %W
      %W selection clear 0 end
      %W selection set $index $index
    "
  }

  bind $w.lb <Any-ButtonRelease-1> "
    set OPTION_FOR_$button \[%W get \[%W nearest %y\]\]
    grab release %W
    destroy \[winfo toplevel %W\]
  "

  j:tk3 {
    bind $w.lb <Any-B1-Motion> {
      %W select from [%W nearest %y]
      %W select to [%W nearest %y]
    }
  }
  j:tk4 {
    bind $w.lb <Any-B1-Motion> {
      %W selection clear 0 end
      %W selection set [%W nearest %y] [%W nearest %y]
    }
  }
}