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