# 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