**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.

This widget is written and copyright 2002-2003 by [ulis], using the [NOL] license.

[img-tinyswitch]

======tcl
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
}
======

<<categories>>Category Widget