Tk Library Source Code

#==============================================================================

package require Tk
package require tsw
package require tablelist_tile

if {[tk windowingsystem] eq "x11" &&
    ($tk_version < 8.7 || [package vcompare $tk_patchLevel "8.7a5"] <= 0)} {
    #
    # Patch the default theme's styles TCheckbutton and TRadiobutton
    #
    package require themepatch
    themepatch::patch default
}

What is new in Tsw 1.0?
-----------------------

This is the first release.  Thanks to Nicolas Bats for his early
testing and proposing the support for the "-variable" toggleswitch
option.

off.  In the on state the slider is placed at the end of the trough, and
in the off state at its beginning.  The user can toggle between these
two states with the mouse or the space key.

You can use the "switchstate" subcommand of the Tcl command associated
with a toggleswitch to change or query the widget's switch state.  By
using the "-command" configuration option, you can specify a script to
execute whenever the switch state of the widget gets toggled.  For
compatibility with the ttk::checkbutton, toggleswitch widgets also
support the "-offvalue", "-onvalue", and "-variable" options.

How to Get It?
--------------

Tsw is available for free download from the Web page

    https://www.nemethi.de

</pre>
    </dd>

    <dt><a href="#widget_options">WIDGET-SPECIFIC OPTIONS</a></dt>

    <dd><code><b><a href="#command">-command</a></b> <i>command</i></code></dd>

    <dd><code><b><a href="#offvalue">-offvalue</a></b> <i>value</i></code></dd>

    <dd><code><b><a href="#onvalue">-onvalue</a></b> <i>value</i></code></dd>

    <dd><code><b><a href="#size">-size</a></b>
    <b>1</b>|<b>2</b>|<b>3</b></code></dd>

    <dd><code><b><a href="#takefocus">-takefocus</a></b>
    <b>0</b>|<b>1</b>|<b>""</b>|<i>command</i></code></dd>

    <dd><code><b><a href="#variable">-variable</a></b>
    <i>variable</i></code></dd>

    <dt class="tm"><a href="#widget_command">WIDGET COMMAND</a></dt>

    <dd><code><i>pathName</i> <b><a href="#attrib">attrib</a></b> ?<i>name</i>
    ?<i>value</i> <i>name</i> <i>value</i> ...??</code></dd>

    <dd><code><i>pathName</i> <b><a href="#cget">cget</a></b>

    invoked, there must not exist a window named <code><i>pathName</i></code>,
    but <code><i>pathName</i></code>'s parent must exist.</dd>

    <dd class="tm">A toggleswitch is a mega-widget consisting of a horizontal
    <b>trough</b> and a <b>slider</b>, just like a ttk::scale widget.&nbsp;
    Actually, these elements belong to a ttk::scale contained in the
    widget.&nbsp; The trough is a fully rounded filled rectangle, and the
    slider is a filled circle contained in the trough.&nbsp; Both elements are
    rendered using scaling-aware SVG images.&nbsp; Their dimensions depend on
    the display's scaling level, the current theme, and the value of the
    <code><b><a href="#size">-size</a></b></code> configuration option.</dd>

    <dd class="tm">Just like a light switch, a toggleswitch widget can have one
    of two possible <b>switch state</b>s: on or off.&nbsp; In the on state the
    slider is placed at the end of the trough, and in the off state at its
    beginning.&nbsp; As described in the <a href="#bindings">DEFAULT
    BINDINGS</a> section below, the user can toggle between these two states
    with the mouse or the <code>space</code> key.</dd>

    <dd class="tm">The Tcl command associated with a toggleswitch widget has a
    very simple API.&nbsp; You can use the <code><b><a href=
    "#switchstate">switchstate</a></b></code> subcommand to change or query
    the widget's switch state.&nbsp; By using the <code><b><a href=
    "#command">-command</a></b></code> configuration option, you can specify a
    script to execute whenever this subcommand or the convenience one named
    <code><b><a href="#toggle">toggle</a></b></code> causes the widget's switch
    state to get toggled.&nbsp; For compatibility with the ttk::checkbutton,
    toggleswitch widgets also support the <code><b><a href=
    "#offvalue">-offvalue</a></b></code>, <code><b><a href=
    "#onvalue">-onvalue</a></b></code>, and <code><b><a href=
    "#variable">-variable</a></b></code> options.</dd>

    <dd class="tm">The colors used when drawing the trough and the slider in
    the various widget states (such as <code><b>active</b></code>,
    <code><b>background</b></code>, <code><b>disabled</b></code>,
    <code><b>pressed</b></code>, and <code><b>selected</b></code>) depend on
    the current theme.&nbsp; The implementation contains procedures that create
    these elements for the themes <code><b>aqua</b></code>,

      <blockquote>
        <p>Specifies a Tcl script to execute whenever the switch state of the
        widget is toggled (programmatically or interactively).&nbsp; The
        default is an empty string.</p>
      </blockquote>
    </dd>

    <dd id="offvalue">
      <table border="0" cellpadding="0" cellspacing="0">
        <tr>
          <td>Command-Line Name:&nbsp;</td>
          <td><code><b>-offvalue</b></code></td>
        </tr>

        <tr>
          <td>Database Name:</td>
          <td><code><b>&nbsp;offValue</b></code></td>
        </tr>

        <tr>
          <td>Database Class:</td>
          <td><code><b>&nbsp;OffValue</b></code></td>
        </tr>
      </table>

      <blockquote>
        <p>The value to store in the associated <a href=
	"#variable">variable</a> when the widget's switch state is set to
	off.&nbsp; Defaults to <code>0</code>.</p>
      </blockquote>
    </dd>

    <dd id="onvalue">
      <table border="0" cellpadding="0" cellspacing="0">
        <tr>
          <td>Command-Line Name:&nbsp;</td>
          <td><code><b>-onvalue</b></code></td>
        </tr>

        <tr>
          <td>Database Name:</td>
          <td><code><b>&nbsp;onValue</b></code></td>
        </tr>

        <tr>
          <td>Database Class:</td>
          <td><code><b>&nbsp;OnValue</b></code></td>
        </tr>
      </table>

      <blockquote>
        <p>The value to store in the associated <a href=
	"#variable">variable</a> when the widget's switch state is set to
	on.&nbsp; Defaults to <code>1</code>.</p>
      </blockquote>
    </dd>

    <dd id="size">
      <table border="0" cellpadding="0" cellspacing="0">
        <tr>
          <td>Command-Line Name:&nbsp;</td>
          <td><code><b>-size</b></code></td>
        </tr>

        itself but the ttk::scale widget contained in it will receive the focus
        during keyboard traversal with the standard keys (<code>Tab</code> and
        <code>Shift-Tab</code>).&nbsp; The default is
        <code>"ttk::takefocus"</code> (just like for most Tk themed
        widgets).</p>
      </blockquote>
    </dd>

    <dd id="variable">
      <table border="0" cellpadding="0" cellspacing="0">
        <tr>
          <td>Command-Line Name:&nbsp;</td>
          <td><code><b>-variable</b></code></td>
        </tr>

        <tr>
          <td>Database Name:</td>
          <td><code><b>&nbsp;variable</b></code></td>
        </tr>

        <tr>
          <td>Database Class:</td>
          <td><code><b>&nbsp;Variable</b></code></td>
        </tr>
      </table>

      <blockquote>
        <p>The name of a global variable whose value is linked to the
	toggleswitch.&nbsp; The widget's switch state changes to on when this
	variable is set to the value specified by the <code><b><a href=
	"#onvalue">-onvalue</a></b></code> option and to off otherwise.&nbsp;
	Defaults to the widget's pathname if not specified.</p>
      </blockquote>
    </dd>

    <dt class="tm" id="widget_command"><b>WIDGET COMMAND</b></dt>

    <dd>
      The <code><b>tsw::toggleswitch</b></code> command creates a new Tcl
      command whose name is <code><i>pathName</i></code>.&nbsp; This command
      may be used to invoke various operations on the widget.&nbsp; It has the

        ?<i>stateSpec</i>?</code></dt>

        <dd>See the <b>ttk_widget</b> manual entry.</dd>

        <dt class="tm" id="style"><code><i>pathName</i>
        <b>style</b></code></dt>

        <dd>Returns the style used by the underlying ttk::scale widget.&nbsp;
	This can be one of <code><b>Toggleswitch1</b></code>,
	<code><b>Toggleswitch2</b></code>, or
	<code><b>Toggleswitch3</b></code>, depending on the value of the
        <code><b><a href="#size">-size</a></b></code> option.&nbsp; For Tk
        themed widgets this subcommand was introduced in Tk 8.7a4, but the
        toggleswitch widget provides it for all supported Tk versions.</dd>

        <dt class="tm" id="switchstate"><code><i>pathName</i>
        <b>switchstate</b> ?<i>boolean</i>?</code></dt>

        <dd>Modifies or inquires the widget's switch state.&nbsp; If the
        optional argument is present then it must be a boolean (a numeric
        value, where 0 is false and anything else is true, or a string such as
        <code><b>true</b>/<b>yes</b>/<b>on</b></code> or
        <code><b>false</b>/<b>no</b>/<b>off</b></code>).&nbsp; If it is true
        then the command sets the <code><b>selected</b></code> flag of the
        underlying ttk::scale widget, moves the slider to the end of the
        trough, and sets the associated <a href="#variable">variable</a> to the
	value specified by the <code><b><a href=
        "#onvalue">-onvalue</a></b></code> option; otherwise it clears the
	<code><b>selected</b></code> flag, moves the slider to the beginning of
	the trough, and sets the associated variable to the value specified by
	the <code><b><a href="#offvalue">-offvalue</a></b></code> option.&nbsp;
	If the argument's value causes the widget's switch state to get toggled
	and the script specified as the value of the <code><b><a href=
        "#command">-command</a></b></code> option is a nonempty string then the
        subcommand evaluates that script at global scope and returns its
	result; otherwise the return value is an empty string.&nbsp; If the
	optional argument is not present then the command returns the widget's
	current switch state as <code>0</code> or <code>1</code>.&nbsp; When a
        toggleswitch widget is created, its switch state is initialized with
        <code>0</code>.</dd>

        <dt class="tm" id="toggle"><code><i>pathName</i>
        <b>toggle</b></code></dt>

        <dd>

  <p>You can use the <code><a href=
  "toggleswitch.html#switchstate">switchstate</a></code> subcommand of the Tcl
  command associated with a toggleswitch to change or query the widget's switch
  state.&nbsp; By using the <code><a href=
  "toggleswitch.html#command">-command</a></code> configuration option, you can
  specify a script to execute whenever the switch state of the widget gets
  toggled.&nbsp; For compatibility with the ttk::checkbutton, toggleswitch
  widgets also support the <code><a href=
  "toggleswitch.html#offvalue">-offvalue</a></code>, <code><a href=
  "toggleswitch.html#onvalue">-onvalue</a></code>, and <code><a href=
  "toggleswitch.html#variable">-variable</a></code> options.</p>

  <h3 id="ov_get">How to Get It?</h3>

  <p>Tsw is available for free download from the Web page</p>

  <blockquote>
    <address>

# Tcl autoload index file, version 2.0
# This file is generated by the "auto_mkindex" command
# and sourced to set up indexing information for one or
# more commands.  Typically each line is a command that
# sets an element in the auto_index array, where the
# element name is the name of a command and the value is
# a script that loads the command.

set auto_index(::tsw::svgFormat) [list source [file join $dir elements.tcl]]
set auto_index(::tsw::createElements_default) [list source [file join $dir elements.tcl]]
set auto_index(::tsw::createElements_default-dark) [list source [file join $dir elements.tcl]]
set auto_index(::tsw::createElements_clam) [list source [file join $dir elements.tcl]]
set auto_index(::tsw::createElements_vista) [list source [file join $dir elements.tcl]]
set auto_index(::tsw::createElements_win11) [list source [file join $dir elements.tcl]]
set auto_index(::tsw::createElements_win10) [list source [file join $dir elements.tcl]]
set auto_index(::tsw::createElements_aqua) [list source [file join $dir elements.tcl]]
set auto_index(::tsw::updateElements_aqua) [list source [file join $dir elements.tcl]]
set auto_index(::tsw::condMakeLayouts) [list source [file join $dir toggleswitch.tcl]]
set auto_index(::tsw::createBindings) [list source [file join $dir toggleswitch.tcl]]
set auto_index(::tsw::toggleswitch) [list source [file join $dir toggleswitch.tcl]]
set auto_index(::tsw::doConfig) [list source [file join $dir toggleswitch.tcl]]
set auto_index(::tsw::makeVariable) [list source [file join $dir toggleswitch.tcl]]
set auto_index(::tsw::varTrace) [list source [file join $dir toggleswitch.tcl]]
set auto_index(::tsw::doCget) [list source [file join $dir toggleswitch.tcl]]
set auto_index(::tsw::toggleswitchWidgetCmd) [list source [file join $dir toggleswitch.tcl]]
set auto_index(::tsw::onDestroy) [list source [file join $dir toggleswitch.tcl]]
set auto_index(::tsw::onThemeChanged) [list source [file join $dir toggleswitch.tcl]]
set auto_index(::tsw::onButton1) [list source [file join $dir toggleswitch.tcl]]
set auto_index(::tsw::onB1Motion) [list source [file join $dir toggleswitch.tcl]]
set auto_index(::tsw::onButtonRel1) [list source [file join $dir toggleswitch.tcl]]
set auto_index(::tsw::onSpace) [list source [file join $dir toggleswitch.tcl]]
set auto_index(::tsw::startToggling) [list source [file join $dir toggleswitch.tcl]]
set auto_index(::tsw::startMovingLeft) [list source [file join $dir toggleswitch.tcl]]
set auto_index(::tsw::moveLeft) [list source [file join $dir toggleswitch.tcl]]
set auto_index(::tsw::startMovingRight) [list source [file join $dir toggleswitch.tcl]]
set auto_index(::tsw::moveRight) [list source [file join $dir toggleswitch.tcl]]
set auto_index(::tsw::toggleSwitchState) [list source [file join $dir toggleswitch.tcl]]

    #   Command-Line Name	{Database Name	Database Class	W}
    #   ----------------------------------------------------------
    #
    variable configSpecs
    array set configSpecs {
	-command		{command	Command		w}
	-cursor			{cursor		Cursor		f}
	-offvalue		{offValue	OffValue	w}
	-onvalue		{onValue	OnValue		w}
	-size			{size		Size		w}
	-takefocus		{takeFocus	TakeFocus	f}
	-variable		{variable	Variable	w}
    }

    #
    # Extend the elements of the array configSpecs
    #
    lappend configSpecs(-command)	""
    lappend configSpecs(-cursor)	""
    lappend configSpecs(-offvalue)	0
    lappend configSpecs(-onvalue)	1
    lappend configSpecs(-size)		2
    lappend configSpecs(-takefocus)	"ttk::takefocus"
    lappend configSpecs(-variable)	""

    variable configOpts [lsort [array names configSpecs]]

    #
    # Use a list to facilitate the handling of command options
    #
    variable cmdOpts [list attrib cget configure hasattrib identify instate \

proc tsw::createBindings {} {
    bind Toggleswitch <KeyPress> continue
    bind Toggleswitch <FocusIn> {
	if {[focus -lastfor %W] eq "%W"} {
	    focus %W.scl
	}
    }
    bind Toggleswitch <Destroy>		{ tsw::onDestroy %W }



    bind Toggleswitch <<ThemeChanged>>	{ tsw::onThemeChanged %W }

    bindtags . [linsert [bindtags .] 1 TswMain]
    foreach event {<<ThemeChanged>> <<LightAqua>> <<DarkAqua>>} {
	bind TswMain $event { tsw::onThemeChanged %W }
    }

    #

    #
    # Initialize some further components of data
    #
    upvar ::tsw::ns${win}::data data
    foreach opt $configOpts {
	set data($opt) [lindex $configSpecs($opt) 3]
    }
    set data(varTraceCmd) [list tsw::varTrace $win]

    #
    # Create a ttk::scale child widget of a special style
    #
    set size [lindex $configSpecs(-size) end]
    set scl [ttk::scale $win.scl -class TswScale -style Toggleswitch$size \
	     -takefocus 0 -length 0 -from 0 -to 20]
    pack $scl -expand 1 -fill both
    bindtags $scl [linsert [bindtags $scl] 3 ToggleswitchKeyNav]

    #
    # Configure the widget according to the command-line
    # arguments and to the available database options
    #
    upvar #0 $win var
    if {![array exists var]} {
	set args [linsert $args 1 -variable $win]
    }
    if {[catch {
	mwutil::configureWidget $win configSpecs tsw::doConfig tsw::doCget \
	    [lrange $args 1 end] 1
    } result] != 0} {
	destroy $win
	return -code error $result
    }

		-cursor { $win.scl configure $opt $val }
	    }
	}

	w {
	    switch -- $opt {
		-command { set data($opt) $val }

		-offvalue -
		-onvalue {
		    if {[array exists $val]} {
			return -code error "value \"$val\" is array"
		    }

		    if {$data(-variable) ne ""} {
			#
			# Conditionally update the variable
			#
			set selected [$win.scl instate selected]
			if {($opt eq "-offvalue" && !$selected) ||
			    ($opt eq "-onvalue" && $selected)} {
			    upvar #0 $data(-variable) var
			    trace remove variable var {write unset} \
				$data(varTraceCmd)
			    set var $val
			    trace add variable var {write unset} \
				$data(varTraceCmd)
			}
		    }

		    set data($opt) $val
		}

		-size {
		    set val [mwutil::fullOpt "size" $val {1 2 3}]
		    $win.scl configure -style Toggleswitch$val

		    set data($opt) $val
		}

		-variable {
		    makeVariable $win $val
		    set data($opt) $val
		}
	    }
	}
    }
}

#------------------------------------------------------------------------------
# tsw::makeVariable
#
# Arranges for the global variable specified by varName to become the variable
# associated with the toggleswitch widget win.
#------------------------------------------------------------------------------
proc tsw::makeVariable {win varName} {
    upvar ::tsw::ns${win}::data data
    if {$varName eq ""} {
	#
	# If there is an old variable associated with the
	# widget then remove the trace set on this variable
	#
	if {$data(-variable) ne ""} {
	    upvar #0 $data(-variable) oldVar
	    trace remove variable oldVar {write unset} $data(varTraceCmd)
	}
	return ""
    }

    #
    # The variable may be an array element but must not be an array
    #
    upvar #0 $varName var
    if {![regexp {^(.*)\((.*)\)$} $varName dummy name1 name2]} {
	if {[array exists var]} {
	    return -code error "variable \"$varName\" is array"
	}

	set name1 $varName
	set name2 ""
    }

    #
    # If there is an old variable associated with the
    # widget then remove the trace set on this variable
    #
    if {$data(-variable) ne ""} {
	upvar #0 $data(-variable) oldVar
	trace remove variable oldVar {write unset} $data(varTraceCmd)
    }

    if {[info exists var]} {
	#
	# Invoke the trace procedure associated with the new variable
	#
	varTrace $win $name1 $name2 write
    } else {
	#
	# Set $varName according to the widget's switch state
	#
	set selected [$win.scl instate selected]
	set var [expr {$selected ? $data(-onvalue) : $data(-offvalue)}]
    }

    #
    # Set a trace on the new variable
    #
    trace add variable var {write unset} $data(varTraceCmd)
}

#------------------------------------------------------------------------------
# tsw::varTrace
#
# This procedure is executed whenever the global variable specified by varName
# and arrIndex is written or unset.  It makes sure that the widget's switch
# state is synchronized with the value of the variable, and that the variable
# is recreated if it was unset.
#------------------------------------------------------------------------------
proc tsw::varTrace {win varName arrIndex op} {
    if {$arrIndex ne ""} {
	set varName ${varName}($arrIndex)
    }
    upvar #0 $varName var

    set scl $win.scl
    upvar ::tsw::ns${win}::data data
    switch $op {
	write {
	    #
	    # Synchronize the widget's switch state with the variable's value
	    #
	    set oldSelState [$scl instate selected]
	    set newSelState [expr {$var eq $data(-onvalue) ? 1 : 0}]
	    if {$newSelState} {
		$scl state selected
		$scl set [$scl cget -to]
	    } else {
		$scl state !selected
		$scl set 0
	    }

	    if {$newSelState != $oldSelState && $data(-command) ne ""} {
		uplevel #0 $data(-command)
	    }
	}

	unset {
	    #
	    # Recreate the variable $varName by setting it according to
	    # the widget's switch state, and set the trace on it again
	    #
	    set selected [$scl instate selected]
	    set var [expr {$selected ? $data(-onvalue) : $data(-offvalue)}]
	    trace add variable var {write unset} $data(varTraceCmd)
	}
    }
}

#------------------------------------------------------------------------------
# tsw::doCget
#
# Returns the value of the configuration option opt for the toggleswitch

	switchstate {
	    if {$argCount < 1 || $argCount > 2} {
		mwutil::wrongNumArgs "$win $cmd ?boolean?"
	    }

	    if {$argCount == 1} {
		#
		# Return the widget's current switch state
		#
		return [$scl instate selected]
	    } else {
		#
		# Update the widget's switch state
		#
		set oldSelState [$scl instate selected]
		set newSelState [expr {[lindex $args 1] ? 1 : 0}]
		if {$newSelState} {
		    $scl state selected
		    $scl set [$scl cget -to]
		} else {
		    $scl state !selected
		    $scl set 0
		}

		upvar ::tsw::ns${win}::data data
		if {$data(-variable) ne ""} {
		    #
		    # Update the associated variable
		    #
		    upvar #0 $data(-variable) var
		    trace remove variable var {write unset} $data(varTraceCmd)
		    set var [expr {$newSelState ?
				   $data(-onvalue) : $data(-offvalue)}]
		    trace add variable var {write unset} $data(varTraceCmd)
		}

		if {$newSelState == $oldSelState || $data(-command) eq ""} {
		    return ""
		} else {
		    return [uplevel #0 $data(-command)]
		}
	    }
	}

    }
}

#
# Private procedures used in bindings
# ===================================
#

#------------------------------------------------------------------------------
# tsw::onDestroy
#------------------------------------------------------------------------------
proc tsw::onDestroy win {
    upvar ::tsw::ns${win}::data data
    if {$data(-variable) ne ""} {
	upvar #0 $data(-variable) var
	trace remove variable var {write unset} $data(varTraceCmd)
    }

    namespace delete ::tsw::ns$win
    catch {rename ::$win ""}
}

#------------------------------------------------------------------------------
# tsw::onThemeChanged
#------------------------------------------------------------------------------
proc tsw::onThemeChanged w {
    variable theme [ttk::style theme use]