tinyswitch widget
tinyswitch widget
bll 2018-7-23: I was just glancing at the Virtuallist code/demos, and happened to notice this cute little widget. Just preserving it in the wiki. A nice alternative to radio buttons or checkboxes when there are only two selections.
This widget is written and copyright 2002-2003 by ulis, using the NOL license.
if {[info exists ::tinyswitch::version]} { return }
namespace eval ::tinyswitch \
{
# beginning of ::tinyswitch namespace definition
namespace export tinyswitch
# ####################################
#
# Tinyswitch widget
#
set version 0.9
#
# ulis, (C) 2002-2003
#
# ------------------------------------
# ####################################
# ==========================
#
# package
#
# ==========================
package provide Tinyswitch $version
package provide tinyswitch $version
package require Tk 8.4
# ==========================
#
# options
#
# ==========================
# widget default config
variable w ._tinyswitch_canvas_test_
canvas $w
$w create text 0 0 -tags text
variable keys \
{
background
cursor
highlightbackground
highlightcolor
highlightthickness
selectforeground
state
takefocus
}
variable key
foreach key $keys { set $key [$w cget -$key] }
variable stdfont
set font [$w itemcget text -font]
set stdfont(font) $font
set stdfont(charwidth) [font measure $font 0]
set stdfont(charheight) [font metrics $font -linespace]
set foreground [$w itemcget text -fill]
variable disabledforeground [$w itemcget text -disabledfill]
eval [format {
variable woptions \
{
{-background background Background {%s}}
{-bbg -buttonbackground}
{-bd -borderwidth}
{-bfg -buttonforeground}
{-bg -background}
{-borderwidth borderWidth BorderWidth 1}
{-bheight -buttonheight}
{-buttonbackground buttonBackground Background {%s}}
{-buttonheight buttonHeight Height 11}
{-buttonwidth buttonWidth Width 11}
{-bwidth -buttonwidth}
{-cmd -command}
{-command command Command {}}
{-cursor cursor Cursor {%s}}
{-dfg -disabledforeground}
{-disabledforeground disabledForeground Foreground {%s}}
{-fg -foreground}
{-font font Font {}}
{-foreground foreground Foreground {%s}}
{-hbg -highlightbackground}
{-hcolor -highlightcolor}
{-height height Height 21}
{-highlightbackground highlightBackground HighlightBackground {%s}}
{-highlightcolor highlightColor HighlightColor {%s}}
{-highlightthickness highlightThickness HighlightThickness {%s}}
{-hthick -highlightthickness}
{-notch notch Image {}}
{-offtext offText Text {}}
{-offvalue offValue Value 0}
{-ontext onText Text {}}
{-onvalue onValue Value 1}
{-orientation orientation Orientation horizontal}
{-relief relief Relief flat}
{-selectforeground selectForeground Foreground {%s}}
{-state state State {%s}}
{-takefocus takeFocus TakeFocus {%s}}
{-user user User {}}
{-value value Value 1}
{-variable variable Variable {}}
{-width width Width 80}
}
} $background $background \
$cursor $disabledforeground $foreground \
$highlightbackground $highlightcolor \
$highlightthickness $selectforeground \
$state $takefocus]
destroy $w
unset w
foreach key $keys { unset $key }
unset disabledforeground
# ==========================
#
# image
#
# ==========================
image create photo ::tinyswitch::notch1
::tinyswitch::notch1 put \
{
{#000000 #949494 #7b7b7b #848484 #a5a5a5 #000000}
{#9c9c9c #848484 #8c8c8c #949494 #9c9c9c #adadad}
{#949494 #949494 #9c9c9c #a5a5a5 #adadad #adadad}
{#a5a5a5 #adadad #adadad #b5b5b5 #b5b5b5 #bdbdbd}
{#bdbdbd #bdbdbd #bdbdbd #c6c6c6 #c6c6c6 #bdbdbd}
{#000000 #c6c6c6 #c6c6c6 #cecece #c6c6c6 #000000}
}
foreach {x y} {0 0 0 5 5 0 5 5} \
{ ::tinyswitch::notch1 transparency set $x $y 1 }
image create photo ::tinyswitch::notch2
::tinyswitch::notch2 put \
{
{#000000 #808080 #000000}
{#808080 #808080 #808080}
{#000000 #808080 #000000}
}
foreach {x y} {0 0 0 2 2 0 2 2} \
{ ::tinyswitch::notch2 transparency set $x $y 1 }
# ==========================
#
# internal variables
#
# ==========================
variable inits \
{
charheight 0
charwidth 0
font {}
updated 0
value 1
resized 0
setting 0
}
# ==========================
#
# commands syntax check
#
# ==========================
variable optmsg {cget, configure, info or send}
variable patcmd \
{
cge* w:cget
con* w:config
inf* w:info
sen* w:send
}
variable cmdmsg
array set cmdmsg \
{
w:cget:1 {}
w:cget {"$w cget $option"}
w:config {}
w:info:1 {}
w:info {"$w info $name"}
w:send:1 {}
w:send {"$w send $event"}
}
# ==========================
#
# bindings
#
# ==========================
bind Tinyswitch <space> {::tinyswitch::w:select %W}
bind Tinyswitch <Left> {::tinyswitch::w:select %W 1}
bind Tinyswitch <Right> {::tinyswitch::w:select %W 0}
bind Tinyswitch <Up> {::tinyswitch::w:select %W 1}
bind Tinyswitch <Down> {::tinyswitch::w:select %W 0}
# ==========================
#
# create/destroy
#
# ==========================
# -------------
# constructor
# -
# create a widget
# -------------
# parm1: widget path
# parm2: widget config
# -------------
# return: widget path
# -------------
proc tinyswitch {w args} \
{
variable {}
variable woptions
variable inits
variable stdfont
# clean-up
catch { dispose $w }
# widget default values
foreach {item} $woptions \
{
if {[llength $item] == 4} \
{
foreach {key - - value} $item break
set ($w:$key) $value
if {$value != {}} { lappend wdefconf $key $value }
}
}
# init parameters
foreach {key value} $inits { set ($w:$key) $value }
set ($w:font) $stdfont(font)
set ($w:charwidth) $stdfont(charwidth)
set ($w:charheight) $stdfont(charheight)
set ($w:variable) ::tinyswitch::($w:-value)
# create megawidget frame
frame $w -class Tinyswitch
# redirect frame reference
rename $w ::_$w
# widget reference
interp alias {} $w {} ::tinyswitch::w:dispatch $w
# create intermediate frame
frame $w.f -highlightthickness 0
pack $w.f -fill both -expand 1
# create subwidgets
pack [canvas $w.f.c -highlightthickness 0] -expand 1 -fill both
$w.f.c create text 0 0 -tags {text1 on text}
$w.f.c create text 0 0 -tags {text0 off text}
canvas $w.f.c.bottom -bd 1 -relief sunken -highlightthickness 0
$w.f.c create window 0 0 -window $w.f.c.bottom -tags bottom
canvas $w.f.c.top -bd 2 -relief raised -highlightthickness 0
$w.f.c.top create image 0 0 -tags image
$w.f.c create window 0 0 -window $w.f.c.top -tags top
# bindings
bind $w.f <Destroy> [list ::tinyswitch::w:dispose $w %W]
$w.f.c bind text1 <1> [list ::tinyswitch::w:select $w 1]
$w.f.c bind text0 <1> [list ::tinyswitch::w:select $w 0]
bind $w.f.c.top <1> [list ::tinyswitch::w:select $w]
bind $w.f.c.bottom <1> [list ::tinyswitch::w:select $w]
# default colors
set ($w:background) [$w.f.c cget -bg]
set ($w:foreground) [$w.f.c itemcget text1 -fill]
# configure widget
#set rc [catch \
#{
foreach {key value} $args { lappend wdefconf $key $value }
eval [linsert $wdefconf 0 w:config $w]
#} msg]
if {0 && $rc} \
{
catch { destroy $w }
return -code error $msg
}
# resize & paint the widget
w:resize $w
w:paint $w
w:select $w $($w:value)
# return path
return $w
}
# -------------
# destructor
# -
# free the resources
# -------------
# parm1: widget path
# parm2: current destroyed widget path
# -------------
proc w:dispose {w W} \
{
# delete reference proc
if {$W != $w && $W != "$w.f"} { return }
catch { interp alias {} $w {} }
# delete old trace
variable {}
set oldname $($w:variable)
if {$oldname != ""} \
{
global $oldname
trace vdelete $oldname w [namespace code [list set:side $w]]
}
# delete image
image delete $($w:-notch)
# delete all variables
variable {}
array unset {} $w:*
}
# -------------
# w:dispatch
# -
# dispatch the operations of a widget
# -------------
# parm1: widget path
# parm2: called operation, operation args
# -------------
# return: depending on operation
# -------------
proc w:dispatch {w {cmd ""} args} \
{
variable {}
variable optmsg
variable patcmd
variable cmdmsg
# check args
if {$cmd == ""} \
{ error "wrong # args: should be \"$w operation ?arg arg ...?\"" }
# catch error
set rc [catch \
{
# retrieve command
foreach {pattern op} $patcmd \
{ if {[string match $pattern $cmd]} { set oper $op; break } }
if {![info exists oper]} \
{ error "bad operation \"$cmd\": should be $optmsg" }
# check args
set n [llength $args]
if {[info exists cmdmsg($oper:$n)]} \
{ set msg $cmdmsg($oper:$n) } \
else { set msg $cmdmsg($oper) }
if {$msg != ""} \
{ error "wrong # args: should be [string map [list \$w $w] $msg]" }
# eval command
eval [linsert $args 0 $oper $w]
} msg]
# return result
set code [expr {$rc ? "error" : "ok"}]
return -code $code $msg
}
# ==========================
#
# widget options
#
# ==========================
# -------------
# w:config
# -
# configure a widget
# -------------
# parm1: widget path
# parm2: widget config or option key or empty
# -------------
# return: option(s) description if parm2 is a key or empty
# -------------
proc w:config {w args} \
{
variable {}
variable stdfont
# check if description request
if {[llength $args] < 2} { return [eval get:option $w $args] }
# update config
foreach {key value} $args \
{
switch -glob -- $key \
{
-bd -
-bor* \
{
# -borderwidth
set ($w:-borderwidth) [winfo pixels . $value]
_$w config -bd $value
}
-bg -
-bac* \
{
# -background
winfo rgb . $value
set ($w:-background) $value
_$w config -bg $value
$w.f.c config -bg $value
}
-bbg -
-buttonb* \
{
# -buttonbackground
winfo rgb . $value
set ($w:-buttonbackground) $value
set ($w:updated) 0
}
-bhe* -
-buttonh* \
{
# -buttonheight
set ($w:-buttonheight) [winfo pixels . $value]
set ($w:resized) 0
}
-bwi* -
-buttonw* \
{
# -buttonwidth
set ($w:-buttonwidth) [winfo pixels . $value]
if {$($w:-notch) == ""} \
{
set notch [image create photo]
$notch copy ::tinyswitch::notch[expr {$value > 3 ? 1 : 2 }]
set ($w:notch) $notch
$w.f.c.top itemconf image -image $notch
}
set ($w:resized) 0
}
-cmd -
-com* \
{
# -command
set ($w:-command) $value
}
-cur* \
{
# -cursor
set ($w:-cursor) $value
for W [list _$w $w.f.c $w.f.c.top $w.f.c.bottom] { $W config -cursor $value }
}
-dfg -
-dis* \
{
# -disabledforeground
winfo rgb . $value
set ($w:-disabledforeground) $value
$w.f.c itemconfig text -disabledfill $value
}
-fg -
-for* \
{
# -foreground
winfo rgb . $value
set ($w:-foreground) $value
$w.f.c itemconfig text -fill $value
}
-fon* \
{
# font
set ($w:-font) $value
if {$value == ""} { set ($w:font) $stdfont(font) } \
else { set ($w:font) $value }
$w.f.c itemconfig text -font $value
}
-hei* \
{
# -height
set ($w:-height) [winfo pixels . $value]
set ($w:resized) 0
}
-hbg -
-highlightb* \
{
# -highlightbackground
winfo rgb . $value
set ($w:-highlightbackground) $value
_$w config -highlightbackground $value
}
-hfg -
-hco* -
-highlightc* \
{
# -highlightcolor
winfo rgb . $value
set ($w:-highlightcolor) $value
_$w config -highlightcolor $value
}
-hbd -
-hth* -
-highlightt* \
{
# -highlightthickness
set ($w:-highlightthickness) [winfo pixels . $value]
_$w config -highlightthickness $value
}
-not* \
{
# -notch
set ($w:-notch) $value
if {$value == ""} { set value $($w:notch) } \
else { set ($w:notch) $value }
$w.f.c.top itemconfig image -image $value
}
-offt* \
{
# -offtext
set ($w:-offtext) $value
$w.f.c itemconfig off -text $value
}
-offv* \
{
# -offvalue
set ($w:-offvalue) $value
}
-ont* \
{
# -ontext
set ($w:-ontext) $value
$w.f.c itemconfig on -text $value
}
-onv* \
{
# -onvalue
set ($w:-onvalue) $value
}
-ori* \
{
# orientation
switch -glob -- $value \
{
hor* { set value horizontal }
ver* { set value vertical }
default { error "wrong orientation \"$value\": should be horizontal or vertical" }
}
set ($w:-orientation) $value
set ($w:resized) 0
}
-rel* \
{
# -relief
switch -glob -- $value \
{
fla* { set value flat }
gro* { set value groove }
rai* { set value raised }
rid* { set value ridge }
sol* { set value solid }
sun* { set value sunken }
default { error "wrong relief \"$value\": should be flat, groove, raised, ridge, solid, or sunken" }
}
set ($w:-relief) $value
_$w config -relief $value
}
-sfg -
-sel* \
{
# -selectforeground
winfo rgb . $value
set ($w:-selectforeground) $value
}
-sta* \
{
# -state
switch -glob -- $value \
{
dis* { set value disabled }
nor* { set value normal }
default { error "wrong state \"$value\": should be disabled or normal" }
}
set ($w:-state) $value
$w.f.c config -state $value
$w.f.c.top config -state $value
$w.f.c.bottom config -state $value
}
-tak* \
{
# -takefocus
set ($w:-takefocus) [expr {$value ? 1 : 0}]
_$w config -takefocus $value
}
-use* \
{
# -user
set ($w:user) $value
}
-var* \
{
# -variable
set ($w:-variable) $value
set:var $w $value
}
-val* \
{
# -value
switch -glob -- $value \
$($w:-offvalue) { set ($w:value) 0 } \
$($w:-onvalue) { set ($w:value) 1 } \
default { error "wrong value \"$value\": should be \"$($w:-onvalue)\" or \"$($w:-offvalue)\"" }
set ($w:-value) $value
w:select $w $($w:value)
}
-wid* \
{
# -width
set ($w:-width) [winfo pixels . $value]
set ($w:resized) 0
}
default { error "wrong option \"$key\"" }
}
}
w:resize $w
w:paint $w
}
# -------------
# get:option
# -
# return a widget option description
# -------------
# parm1: widget path
# parm2: option name or empty
# -------------
# return: option description
# -------------
proc get:option {w {key ""}} \
{
variable {}
variable woptions
if {$key == ""} \
{
# all options
set result {}
foreach option $woptions \
{
if {[llength $option] > 2} \
{
set key [lindex $option 0]
lappend option $($w:$key)
}
lappend result $option
}
} \
else \
{
# the specified option
foreach option $woptions \
{
set name [lindex $option 0]
if {[string match $key* $name]} \
{
if {[llength $option] == 2} \
{ set result [get:option $w [lindex $option 1]] } \
else \
{ set result [concat $option [list $($w:$name)]] }
break
}
}
if {![info exists result]} { error "unknown option \"$key\"" }
}
return $result
}
# -------------
# w:cget
# -
# return a widget option value
# -------------
# parm1: widget path
# parm2: option name
# -------------
# return: option value
# -------------
proc w:cget {w key} \
{
variable {}
switch -glob -- $key \
{
-bd -
-bor* { set ($w:-borderwidth) }
-bg -
-bac* { set ($w:-background) }
-bbg -
-buttonb* { set ($w:-buttonbackground) }
-bhe* -
-buttonh* { set ($w:-buttonheight) }
-bwi* -
-buttonw* { set ($w:-buttonwidth) }
-cmd -
-com* { set ($w:-command) }
-cur* { set ($w:-cursor) }
-dfg -
-dis* { set ($w:-disabledforeground) }
-fg -
-for* { set ($w:-foreground) }
-fon* { set ($w:-font) }
-hei* { set ($w:-height) }
-hbg -
-highlightb* { set ($w:-highlightbackground) }
-hfg -
-hco* -
-highlightc* { set ($w:-highlightcolor) }
-hbd -
-hth* -
-highlightt* { set ($w:-highlightthickness) }
-not* { set ($w:-notch) }
-offt* { set ($w:-offtext) }
-offv* { set ($w:-offvalue) }
-ont* { set ($w:-ontext) }
-onv* { set ($w:-onvalue) }
-ori* { set ($w:-orientation) }
-rel* { set ($w:-relief) }
-sfg -
-sel* { set ($w:-selectforeground) }
-sid* { set ($w:-side) }
-sta* { set ($w:-state) }
-tak* \
{
if {$($w:-state) == "normal"} { set ($w:-takefocus) } \
else { set x 0 }
}
-use* { set ($w:-user) }
-val* { set ($w:-value) }
-var* { set ($w:-variable) }
-wid* { set ($w:-width) }
default { error "unknown option \"$key\"" }
}
}
# -------------
# w:info
# -
# return an info value
# -------------
# parm1: widget path
# parm2: info name
# -------------
# return: info value
# -------------
proc w:info {w name} \
{
variable {}
switch -glob -- $name \
{
tex* -
act* { expr {$($w:value) ? $($w:-ontext) : $($w:-offtext)} }
dow* { set ($w:-offtext) }
fon* { set ($w:font) }
lef* { set ($w:-ontext) }
charh* { set ($w:charheight) }
charw* { set ($w:charwidth) }
rig* { set ($w:-offtext) }
up { set ($w:-ontext) }
default { error "unknown info name \"$name\"" }
}
}
# ==========================
#
# button
#
# ==========================
# -------------
# w:resize
# -
# resize the widget
# -------------
# parm1: widget path
# -------------
proc w:resize {w} \
{
variable {}
if {$($w:resized)} { return } \
else { set ($w:resized) 1 }
set bd $($w:-borderwidth)
if {$($w:-relief) == "flat"} { set bd 0 }
set ww $($w:-width)
set wh $($w:-height)
set bh $($w:-buttonheight)
set bw $($w:-buttonwidth)
$w.f.c config -width $ww -height $wh
switch $($w:-orientation) \
{
horizontal \
{
if {$wh % 2 == 0} { incr wh }
set bmh [expr {$wh - $bd * 2 - 4}]
if {$bh > $bmh} { set bh $bmh }
$w.f.c.top config -width $bw -height $bh
set btw [expr {$bw * 2 + 4}]
$w.f.c.bottom config -width $btw -height [expr {$bh + 4}]
set tw [expr {($ww - $btw) / 2}]
set x [expr {$tw / 2 + $bd - 1}]
set y [expr {$wh / 2 + $bd}]
$w.f.c coord text1 $x $y
set x [expr {$tw + $btw + $tw / 2 + $bd + 1}]
$w.f.c coord text0 $x $y
set x [expr {$ww / 2 + $bd}]
set y [expr {$wh / 2 + $bd}]
$w.f.c coord bottom $x $y
set x [expr {$bw / 2 + 2}]
set y [expr {$bh / 2 + 2}]
$w.f.c.top coord image $x $y
}
vertical \
{
if {$ww % 2 == 0} { incr ww }
set bmw [expr {$ww - $bd * 2 - 4}]
if {$bw > $bmw} { set bw $bmw }
$w.f.c.top config -height $bh -width $bw
set bth [expr {$bh * 2 + 4}]
$w.f.c.bottom config -height $bth -width [expr {$bw + 4}]
set th [expr {($wh - $bth) / 2}]
set y [expr {$th / 2 + $bd - 1}]
set x [expr {$ww / 2 + $bd}]
$w.f.c coord text1 $x $y
set y [expr {$th + $bth + $th / 2 + $bd + 1}]
$w.f.c coord text0 $x $y
set y [expr {$wh / 2 + $bd}]
set x [expr {$ww / 2 + $bd}]
$w.f.c coord bottom $x $y
set y [expr {$bh / 2 + 2}]
set x [expr {$bw / 2 + 2}]
$w.f.c.top coord image $x $y
}
}
}
# -------------
# w:paint
# -
# colorize the notch
# -------------
# parm1: widget path
# -------------
proc w:paint {w} \
{
variable {}
if {$($w:updated)} { return } \
else { set ($w:updated) 1 }
set image $($w:-notch)
if {$image == ""} { set image $($w:notch) }
set width [image width $image]
set height [image height $image]
set bbg $($w:-buttonbackground)
foreach {rr gg bb} [winfo rgb . $bbg] break
set colors {}
for {set x 0} {$x < $width} {incr x} \
{
set row {}
for {set y 0} {$y < $height} {incr y} \
{
foreach {r g b} [$image get $x $y] break
if {$r == 0 && $g == 0 && $b == 0} \
{
lappend trans $x $y 1
lappend row #000000
} \
else \
{
lappend trans $x $y 0
set r [expr {round($r * $rr / 255)}]
set g [expr {round($g * $gg / 255)}]
set b [expr {round($b * $bb / 255)}]
lappend row [format #%-4.4x%-4.4x%-4.4x $r $g $b]
}
}
lappend colors $row
}
$image put $colors
foreach {x y t} $trans { $image transparency set $x $y $t }
$w.f.c.top config -bg $bbg
$w.f.c.bottom config -bg $bbg
}
# -------------
# w:flash
# -
# flash a text
# -------------
# parm1: widget path
# parm2: value
# -------------
proc w:flash {w value} \
{
variable {}
$w.f.c itemconf text$value -fill $($w:-selectforeground)
after 100 $w.f.c itemconf text$value -fill $($w:-foreground)
}
# ==========================
#
# variable
#
# ==========================
# -------------
# set:var
# -
# set the side variable
# -------------
# parm1: widget path
# parm2: var name
# -------------
proc set:var {w varname} \
{
variable {}
# save new name & old name
set realname $varname
set oldname $($w:variable)
# get name
if {$varname == ""} \
{
if {$oldname != ""} { set ($w:-value) [set $oldname] }
set varname ::tinyswitch::($w:-value)
} \
else \
{
if {[string range $varname 0 1] != "::"} \
{
uplevel 3 { set ::tinyswitch::var [namespace current] }
if {$::tinyswitch::var == "::"} { set ::tinyswitch::var "" }
append ::tinyswitch::var ::$varname
set varname $::tinyswitch::var
}
}
# check if name changed
if {$oldname == $varname && $realname != ""} { return }
# delete old trace
if {$oldname != ""} { trace vdelete $oldname w [namespace code [list set:value $w]] }
# create variable if not exists
if {![info exists $varname]} \
{
# create variable
set $varname {}
# get old value
if {$oldname != ""} { set $varname [set $oldname] }
}
# update the variable
set ($w:variable) $varname
# set new trace
trace variable $varname w [namespace code [list set:value $w]]
# set the value
set:value $w
}
# -------------
# set:value
# -
# called on value change
# -------------
# parm1: widget path
# parm2: dummy
# -------------
proc set:value {w args} \
{
# set new value
if {$::tinyswitch::($w:setting)} { return }
::tinyswitch::w:config $w -value [set $::tinyswitch::($w:variable)]
}
# ==========================
#
# widget events
#
# ==========================
# -------------
# w:select
# -
# select a side
# -------------
# parm1: widget path
# parm2: optional value
# -------------
proc w:select {w {value ""}} \
{
variable {}
# get widget handle
while {[winfo class $w] != "Tinyswitch"} { set w [winfo parent $w] }
# set value
if {$value == ""} { set value [expr {$($w:value) ? 0 : 1}] } \
else { w:flash $w $value }
# move the button
set bd $($w:-borderwidth)
if {$($w:-relief) == "flat"} { set bd 0 }
set ww $($w:-width)
set wh $($w:-height)
switch $($w:-orientation) \
{
horizontal \
{
set bw $($w:-buttonwidth)
if {$value} { set x [expr {($ww - $bw) / 2 + $bd}] } \
else { set x [expr {($ww + $bw) / 2 + $bd}] }
set y [expr {$wh / 2 + $bd}]
}
vertical \
{
set bh $($w:-buttonheight)
set x [expr {$ww / 2 + $bd}]
if {$value} { set y [expr {($wh - $bh) / 2 + $bd}] } \
else { set y [expr {($wh + $bh) / 2 + $bd}] }
}
}
$w.f.c coord top $x $y
set ($w:value) $value
set ($w:-value) [expr {$value ? $($w:-onvalue) : $($w:-offvalue)}]
set ($w:setting) 1
set $($w:variable) $($w:-value)
set ($w:setting) 0
# exec the command
set script $($w:-command)
if {$script != ""} \
{
set map [list %widget% $w %value% $($w:-value)]
set script [string map $map $script]
uplevel 1 $script
}
# generate the event
event generate $w <<TinyswitchSelect>>
}
# -------------
# w:send
# -
# send an event
# -------------
# parm1: widget path
# parm2: event
# -------------
proc w:send {w event} \
{
variable {}
switch -- $event \
{
<1> { w:select $w }
<space> { w:select $w }
<Down> { w:select $w 1 }
<Left> { w:select $w 0 }
<Right> { w:select $w 1 }
<Up> { w:select $w 0 }
default { error "wrong event \"$event\": should be <1>, <space>, <Down>, <Left>, <Right> or <Up>" }
}
}
# end of ::tinyswitch namespace definition
}