-- Bryan Schofield 25 May 2004 --
This page contains an implementation of a package to that provides the action concept to Tcl.
See Actions for an introduction to the action concept.
See ActionPackageDemo for source code to a demo program that uses this package.
# action.tcl --
#
# This file provides the complete package that introduces the concept of
# "actions" to Tk. All code is contained with the ::action or ::action
# decedent namespaces.
#
# Copyright (c) 2003 Bryan Schofield
#
# Permission is hereby granted, free of charge, to any person obtaining a copy
# of this software and associated documentation files (the "Software"), to
# deal in the Software without restriction, including without limitation the
# rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
# sell copies of the Software, and to permit persons to whom the Software is
# furnished to do so, subject to the following conditions:
#
# The above copyright notice and this permission notice shall be included in
# all copies or substantial portions of the Software.
#
# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
# FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
# IN THE SOFTWARE.
#
#
# TERMS AND DEFINITIONS
#
# action A collection of options and values that can be set and queried
# at a single data repository but applies to any number of Tk
# widgets. These options, typically refered to as "configuration
# options", may not be applicable to all widgets. Under these
# circumstances, the said options are simply ignored for some
# widgets.
#
# applicator A procedure that is capable of extracting useful configuration
# options from an action and appling the values of those options
# to a particular class of widgets.
#
# validator A procedure that can ensure the validity of an action
# configuration option. Validator procedures are invoked during
# action configuration and can generate errors if option values
# are invalid.
#
#
#
# THE ACTION FRAMEWORK
#
# The action framework, or Framework, consists of mechanisms for specifying
# action options, configuring or querying action options, and application of
# action configuration options to Tk widgets. The Framework itself does not
# provide details of what an action consists of or how the actions are applied
# to common Tk widgets. However, this package provides implementations for
# applying actions to Button and Menu class widgets.
# See ::action::initializeDefaults
#
#
#
# COMMANDS
#
# Details on commands can be read for specific commands at each command's proc
# definition. A summary of the widely used commands is provided here.
#
#
# Adding, removing, and querying action configuration options
#
# ::action::addOption name defaultValue ?validationCmd?
# ::action::removeOption name
# ::action::getOptionList
#
#
# Setting and querying widget class applicators
#
# ::action::setApplicator class applicatorCmd
# ::action::getApplicator class
#
#
# Creating, deleting, configuring, and querying actions
#
# ::action::create act ?option value ...?
# ::action::delete act
# ::action::exists act
# ::action::cget act opt
# ::action::configure act ?option value ...?
#
#
# Applying, removing, and querying relationships bewteen actions and widgets
# ::action::apply act args
# ::action::remove act args
# ::action::widgets act
#
#
#
# DEFAULT ACTION CONFIGURATION OPTIONS AND WIDGET CLASS APPLICATORS
#
# -text The text or label associated with an action
# -image The image associated with an action
# -command The command to evaluated when an action is invoked
# -state The state of the action, which can be "normal" or "disabled"
#
# Button Sets -text, -image, -command, -state options according to the
# action and -compound to "left"
# Menu Adds or modifies a menu entry matching the text string value
# of the -text action option. Sets the -image, -command, and
# -state options according to the actions, the -label according
# to the -text action option, and -compound to "left".
#
# * ATTENTION *
# The Menu applicator uses the "-text" value to identify which entry, if any,
# in a menu corresponds to the action. This is done by trying to find a menu
# entry index by pattern matching. See the menu man page or documentation for
# more details on menu pattern matching for indices. If the menu has an entry
# with the same -label value as the action's -text value, that menu entry will
# be considered to be associated with the action. In short don't do this and
# expect the Menu applicator to know that you want to *add* a new entry
# instead of *modify* an existing entry:
#
# ::action::create a -text "Hello" -command "doSomething"
# menu .m
# .m add command -label "Hello" -command "doSomethingElse"
# ::action::apply a .m
# # BAD! The action just overrode the -command menu option for
# # manually configured menu entry.
#
# Having said that, it safe to change the action -text option. The menu
# applicator will know to change the existing entry instead of creating a new
# one.
#
# ::action::create a -text "Hello" -command "sayHello"
# menu .m
# ::action::apply a .m
# ...
# ::action::configure a -text "Goodbye" -command "sayGoodbye"
# # GOOD! The action just changes the label and command of the
# # existing menu entry for "a"
#
#
#
# TYPICAL USAGE
#
# package require action
# namespace eval ::img {}
# image create photo ::img::myImg -file myimage.gif
# ::action::create myAction \
# -text "Do Something" \
# -image ::img::myImg \
# -command [list myCommand]
# button .b1
# button .b2
# menu .menubar
# menu .popup
# ::action::apply myAction .b1 .b2 .menubar .popup
# ...
# ::action::configure myAction -state "disabled"
# ...
# ::action::configure myAction -state "normal" -text "Tun Sie Etwas"
#
#
#
#
# ADVANCED USAGE
#
# # add a new option for Superframe class widgets
# proc ::action::validator::superopt { value } {
# if { ... } {
# # $value is not ok!
# return -code error "invalid superopt value \"$value\", must be ..."
# }
# }
# ::action::addOption -superopt "Super Default" ::action::validator::superopt
#
# # add a new widget class, Superframe to accept actions
# proc ::action::applicator::Superframe {widget act} {
# foreach optSet [::action::configure $act] {
# switch -- [lindex $optSet 0] {
# -text {# do something to $widget}
# -image {# do something to $widget}
# -command {# do something to $widget}
# -state {# do something to $widget}
# -superopt {# do something to $widget}
# }
# }
# }
#
# ::action::create superAction \
# -text "Do Something" \
# -image ::img::myImg \
# -command [list myCommand] \
# -superopt "Be super!"
#
# Superframe .sf
# ::action::apply superAction .sf
#
#
package require Tcl 8.4
package require Tk 8.4
package provide action 1.0
namespace eval ::action {
# a namespace for containing procs that validate values for options
namespace eval validator {}
# a namespace for containing procs that apply actions to widgets
namespace eval applicator {}
# array of commands used to apply actions to classes of widgets
# key is widget class
variable applicator
array set applicator {}
# default option/value array
# this contains option names as keys and default values
variable option
array set option {}
variable validator
array set validator {}
# the action data array
variable action
array set action {}
}
# ::action::addOption --
#
# Adds an option to the action framework. Action are able to configure
# this option immediately after the option was added. Existing actions
# will inherit default values.
#
# Arguments:
# name The name of the option
# defaultValue The option default value
# validationCmd A tcl command to be evaluated when this option is
# configured. This command will be passed the value of the
# option and should generate an error if the value is
# invalid.
#
# Results:
# Error if the option name has white spaces or upper case letters
# Nothing if successful
#
proc ::action::addOption {name defaultValue {validationCmd ""}} {
# if the name has capital letters or white space, reject it
if {![regexp {^-?([a-z]|[0-9])+$} $name]} {
return -code error "invalid option name \"$name\", names must be all lower case and can not have white spaces"
}
# make sure the first character is a "-"
if {[string index $name 0] != "-"} {
set name "-$name"
}
# set the default value of this option, if one already exists, then we will
# just override it
variable option
variable validator
set option($name) $defaultValue
set validator($name) $validationCmd
return
}
# ::action::removeOption --
#
# Removes an option from the action framework.
#
# Arguments:
# name The name of the option
#
# Results:
# Error if the option of the name
# Nothing if successful
#
proc ::action::removeOption {name} {
variable option
variable action
variable validator
# make sure the first character is a "-"
if {[string index $name 0] != "-"} {
set name "-$name"
}
if {![info exists option($name)]} {
return -code error "action option \"$name\" does not exist"
}
# remove any references that existing action may have
foreach act [array names action] {
unset -nocomplain action($act,$name)
}
# remove the default option/value
unset option($name) validator($name)
return
}
# ::action::getOptionList --
#
# Get a list of options, default values, and validator commands in the
# action framework. The list format is:
# {{option defaultValue validatorCmd}
# {option defaultValue validatorCmd} ..}
#
# Arguments:
# none
#
# Results:
# List of options, default values and validator commands
#
proc ::action::getOptionList {} {
variable option
variable validator
set optSet {}
foreach opt [lsort [array names option]] {
lappend optSet [list $opt $option($opt) $validator($opt)]
}
return $optSet
}
# ::action::initializeDefaults --
#
# This command sets up a set of default options and widget class
# handlers in the action frame work
#
# Arguments:
# none
#
# Results:
# none
#
proc ::action::initializeDefaults {} {
::action::addOption -text ""
::action::addOption -image "" ::action::validator::image
::action::addOption -command ""
::action::addOption -state "normal" ::action::validator::state
::action::setApplicator Button ::action::applicator::Button
::action::setApplicator Menu ::action::applicator::Menu
return
}
# ::action::create --
#
# Creates a new action with a given name and configures it according to
# any specified options.
#
# Arguments:
# act The action name. This must be a unique name
# args Options configuration arguments
#
# Returns:
# Error if an action by the specified name already exists
# Error if any of the configuration options are invalid
# The action name if successful
#
proc ::action::create {act args} {
if {[::action::exists $act]} {
return -code error "action \"$act\" already exists"
}
variable action
# the list of widgets associated with the action
set action($act,widgets) {}
set action($act,previousConfig) {} ; # this will get set in the "configure" below
# if we catch an error configuring the options, make sure we clean up
# anything that we might have created
if {[catch {eval ::action::configure $act $args} err]} {
catch {::action::delete $act}
return -code error $err
}
return $act
}
# ::action::delete --
#
# Deletes an action from the action framework
#
# Arguments:
# act The action name
#
# Results:
# none
#
proc ::action::delete {act} {
if {![::action::exists $act]} {
return -code error "action \"$act\" does not exist"
}
variable action
# the list of widgets associated with the action
unset -nocomplain action($act,widgets) action($act,previousConfig)
array unset action "$act,*"
return
}
# ::action::exists --
#
# Determines if an action of the specified name exists
#
# Arguments:
# act The action name
#
# Results:
# Returns 1 if action exists
# Returns 0 if action does not exist
#
proc ::action::exists {act} {
variable action
return [info exists action($act,widgets)]
}
# ::action::cget --
#
# Get the value for an option of an action
#
# Arguments:
# act The action name
# opt The configuration option name
#
# Results:
# Error if the option name is invalid
# Value if the option for the action action has been configured via
# "configure" method
# Default option value if the option for the action has not been
# configured via the "configure" method
#
proc ::action::cget {act opt} {
variable option
variable action
# make sure the action exists
if {![::action::exists $act]} {
return -code error "action \"$act\" does not exist"
}
# make sure the option is valid
if {![info exists option($opt)]} {
return -code error "invalid option \"$opt\", must be [array names option]"
}
if {[info exists action($act,$opt)]} {
# return the action configured value
return $action($act,$opt)
} else {
# return the default value
return $option($opt)
}
}
# ::action::configure --
#
# Configures options for an action or returns a list describing the
# current configuration for the the action. The list is presented in
# the following format:
# {{-option value defaultValue} {-option value defaultValue} ...}
#
# Arguments:
# act The action name
# args (optional) list of options and values
#
# Results:
# Error if any of the configuration options are invalid or have invalid
# values
# Nothing if options were successfully applied
# Current configuration list if no configuration options were specified
#
proc ::action::configure {act args} {
if {![::action::exists $act]} {
return -code error "action \"$act\" does not exist"
}
# if arguments were specified, then we should apply them to the action
# if not, then we should generate a current option configuration list
if {$args != ""} {
return [eval ::action::applyConfigure $act $args]
} else {
return [::action::generateCurrentConfigurationList $act]
}
}
# ::action::applyConfigure --
#
# Applies configuration option to an action
#
# Arguments:
# act The action name
# args List of configuration options
#
# Results:
# Error if any of the configuration options are invalid or have invalid
# values
# Nothing if options were successfully applied
#
proc ::action::applyConfigure {act args} {
variable option
variable validator
variable action
set action($act,previousConfig) [::action::configure $act]
foreach {opt value} $args {
# make sure the option is valid
if {![info exists option($opt)]} {
return -code error "invalid option \"$opt\", must be [join [array names option] {, }]"
}
# make sure the option value is valid
if {($validator($opt) != "")
&& [catch {eval $validator($opt) \$value} err]} {
return -code error "option \"$opt\" has invalid value of \"$value\", $err"
}
# save the option value
set action($act,$opt) $value
}
eval ::action::apply $act [::action::widgets $act]
return
}
# ::action::generateCurrentConfigurationList --
#
# Generates a list of the current configuration for the action in the tk
# configure style:
# {{-option value defaultValue} {-option value defaultValue} ...}
#
# Arguments:
# act The action name
#
# Results:
# configuration list
#
proc ::action::generateCurrentConfigurationList { act } {
variable option
variable action
set config {}
foreach opt [array names option] {
lappend config [list $opt [::action::cget $act $opt] $option($opt)]
}
return $config
}
# ::action::setApplicator --
#
# Registers an applicator for a particular class. The applicator command
# will be evaluated with widget name and a list of configuration options
# as returned by "configure". The applicator can be removed by
# re-registering the class with an empty string
#
# Arguments:
# class The widget class
# applicatorCmd The command to evaluate to apply an action to a class
# of widgets.
#
# Results:
# none
#
proc ::action::setApplicator {class applicatorCmd} {
variable applicator
if {$applicatorCmd == ""} {
unset -nocomplain applicator($class)
} else {
set applicator($class) $applicatorCmd
}
return
}
# ::action::getApplicator --
#
# Gets the applicator command for a particular class. If no applicator
# command has been registers, an empty string is returned
#
# Arguments:
# class The widget class
#
# Results:
# A tcl command if applicator has been registered
# An empty string if no applicator has been registered
#
proc ::action::getApplicator {class} {
variable applicator
if {[info exists applicator($class)]} {
return $applicator($class)
} else {
return ""
}
}
# ::action::apply --
#
# Applies an action to a set of widgets. This is accomplished by
# delegating actual application to registered applicators depending on
# the class of the widget(s)
#
# Arguments:
# act The action name
# args List of widgets to apply the action to
#
# Returns:
# Error if action does not exist
# Error if widget does not exist
# Error if widget class has no registered applicator
# Nothing if successful
#
proc ::action::apply {act args} {
variable action
if {![::action::exists $act]} {
return -code error "action \"$act\" does not exist"
}
foreach widget $args {
if {$widget == ""} { continue }
if {![winfo exists $widget]} {
return -code error "can not apply action \"$act\" to \"$widget\", widget does not exist"
}
set class [winfo class $widget]
set applicator [::action::getApplicator $class]
if {$applicator == ""} {
return -code error "can not apply action \"$act\" to \"$widget\", no applicator for class \"$class\" has been registered"
}
eval $applicator $widget $act
if {[lsearch $action($act,widgets) $widget] == -1} {
lappend action($act,widgets) $widget
}
}
return
}
# ::action::remove --
#
# Removes any association between an action and a set of widgets. The
# widgets are *not* modified as a result of doing this. It merely breaks
# the connection of the action and widgets for future modification to
# the action
#
# Arguments:
# act The action name
# args List of widgets to apply the action to
#
# Returns:
# Error if action does not exist
# Error if widget does not exist
# Error if widget class has no registered applicator
# Nothing if successful
#
proc ::action::remove {act args} {
variable action
if {![::action::exists $act]} {
return -code error "action \"$act\" does not exist"
}
foreach widget $args {
if {$widget == ""} { continue }
set i [lsearch $action($act,widgets) $widget]
if {$i != -1} {
set action($act,widgets) [lreplace $action($act,widgets) $i $i]
}
}
}
# ::action::widgets --
#
# Returns a list widgets that the action has been applied to and still
# exists.
#
# Arguments:
# act The action name
#
# Results:
# A list of widgets
#
proc ::action::widgets {act} {
if {![::action::exists $act]} {
return -code error "action \"$act\" does not exist"
}
variable action
# build a list of widgets and make sure that any destroyed widgets have
# been removed from the list
set widgets {}
foreach w $action($act,widgets) {
if {[winfo exists $w]} {
lappend widgets $w
}
}
# save the new, edited list
set action($act,widgets) $widgets
return $widgets
}
#======================================================================
# validators
#======================================================================
proc ::action::validator::image { imgName } {
if {[lsearch [::image names] $imgName] == -1} {
return -code error "image \"$imgName\" does not exist"
}
}
proc ::action::validator::state { state } {
if {($state != "normal") && ($state != "disabled")} {
return -code error "invalid state \"$state\", must be normal, disabled"
}
}
#======================================================================
# applicators
#======================================================================
proc ::action::applicator::Button {b act} {
# it's good if we just casually look to see what options the action has
# available to us, rather than just expecting it to have some specific
# options. You never know, someone might have removed an option. At any
# rate, we can look at the configuration and when we see something we like,
# apply it to the button
foreach optSet [::action::configure $act] {
switch -- [lindex $optSet 0] {
-text {$b configure -text [lindex $optSet 1]}
-image {$b configure -image [lindex $optSet 1] -compound left}
-command {$b configure -command [lindex $optSet 1]}
-state {$b configure -state [lindex $optSet 1]}
}
}
}
proc ::action::applicator::Menu {m act} {
# try to find the menu item in the menu that corresponds to this action.
# we have to use the previous configuration information to find the action
# by label because the by the time we will have been called, the action
# might have a new -text value, which would make it impossible to find the
# original menu entry.
set label ""
foreach optSet $::action::action($act,previousConfig) {
switch -- [lindex $optSet 0] {
-text {set label [lindex $optSet 1]}
}
}
# now find the old label in the menu
if {[catch {$m index $label} index]} {
# hmm, no menu item exists, let's create one
$m add command
set index end
}
# now casually look to see what we can configure in the menu entry
foreach optSet [::action::configure $act] {
switch -- [lindex $optSet 0] {
-text {$m entryconfigure $index -label [lindex $optSet 1]}
-image {$m entryconfigure $index -image [lindex $optSet 1] -compound left}
-command {$m entryconfigure $index -command [lindex $optSet 1]}
-state {$m entryconfigure $index -state [lindex $optSet 1]}
}
}
}
#======================================================================
# Initialize defaults
#======================================================================
::action::initializeDefaults