Toggle Button with indicator

Toggle Button with indicator edit

bll 2017-10-4: A megawidget button with a display image indicating the status.
-variable : a boolean variable to track
-imageon : the image to display when true (from [image create photo])
-imageoff : the image to display when false
#!/usr/bin/tclsh
#
# Copyright 2017 Brad Lanam Walnut Creek CA
#

package require Tcl 8.5-
package require Tk

# -variable : boolean variable to track
# -imageon : image to display when -variable is true
#            (from [image create photo])
# -imageoff : image to display when -variable is false
proc ::buttontoggle { nm args } {
  btntoggle new $nm {*}$args
  return $nm
}

proc ::buttontoggleHandler { cbox args } {
  $cbox {*}$args
}

::oo::class create ::btntoggle {
  constructor { nm args } {
    my variable vars

    set vars(state) off
    set vars(widget) [ttk::button ${nm}]
    set vars(btn) ${nm}_buttontoggle
    rename $vars(widget) ::$vars(btn)
    interp alias {} $vars(widget) {} ::buttontoggleHandler [self]
    uplevel 2 [list $vars(widget) configure {*}$args]

    bind $vars(widget) <Destroy> [list [self] destruct]
  }

  method destruct { } {
    my variable vars

    trace remove variable $vars(-variable) write [list [self] settrace]
    interp alias {} $vars(widget) {}
    [self] destroy
  }

  method unknown { args } {
    my variable vars

    set nm $vars(btn)
    return [uplevel 2 [list $nm {*}$args]]
  }

  method _getfqvname { v } {
    set fqv {}
    if { [string match {::*} $v] } {
      set fqv $v
    }
    if { $fqv eq {} } {
      set fqv [uplevel 3 [list namespace which -variable $v]]
      if { $fqv eq {} } {
        set ns [uplevel 3 [list namespace current]]
        set fqv $ns$v
        if { [string match ::::* $fqv] } {
          set fqv [string range $fqv 2 end]
        }
      }
    }
    return $fqv
  }

  method _setimage { } {
    variable vars

    set k -variable
    if { [info exists vars($k)] &&
        [info exists $vars($k)] &&
        [set $vars($k)] ne {} &&
        [set $vars($k)] } {
      $vars(btn) configure -image [set $vars(-imageon)] -compound right
    } else {
      $vars(btn) configure -image [set $vars(-imageoff)] -compound right
    }
  }

  method settrace { args } {
    my variable vars

    my _setimage
  }

  method cget { key } {
    my variable vars

    set rv {}
    if { $key eq "-variable" ||
        $key eq "-imageon" ||
        $key eq "-imageoff" } {
      if { [info exists vars($key)] } {
        set rv $vars($key)
      }
    } else {
      set rv [$vars(btn) cget $key]
    }
    return $rv
  }

  method configure { args } {
    my variable vars

    foreach {k v} $args {
      if { $k eq "-imageon" } {
        set fqv [my _getfqvname $v]
        set vars($k) $fqv
        if { ! [info exists $vars($k)] } {
          set vars($k) {}
        }
      } elseif { $k eq "-imageoff" } {
        set fqv [my _getfqvname $v]
        set vars($k) $fqv
        if { ! [info exists $vars($k)] } {
          set vars($k) {}
        }
      } elseif { $k eq "-variable" } {
        set fqv [my _getfqvname $v]
        if { [info exists vars($k)] &&
            [info exists $vars($k)] &&
            $vars($k) ne $fqv } {
          trace remove variable $vars($k) write [list [self] settrace]
        }
        set vars($k) $fqv
        if { ! [info exists $vars($k)] } {
          set $vars($k) {}
        }
      } else {
        set nm $vars(btn)
        uplevel 2 [list $nm configure $k $v]
      }
    }

    set k -variable
    if { [info exists vars($k)] &&
        [info exists $vars($k)] } {
      trace add variable $vars($k) write [list [self] settrace]
    }
    my _setimage
    return -code ok
  }
}

package provide buttontoggle 1.0
Category Widget
Megawidget