-- Bryan Schofield 25 May 2004 --
This page contains source to a demo program that uses an action package.
See Actions for an introduction to the action concept.
See ActionPackage for source code to the implementation of an action package that this demo program uses.
# action-demo.tcl --
source action.tcl
package require Tk 8.4
package require action
set smile {R0lGODlhDwAPAMYAAAAAAH1/ZsLGnOPns9/jrX1/XwgICJ6hfdDUp+vvwPf7xvv/xvv/wvn9
verur8fLk5mcd/v/ydvfsvv/y+frr/v/uvv/t4eKYdTYo/v/w/D0vSYnHu/zwuntsy4vIvD0
sPr/tOLnoYiLZvv/vfv/wOntteHluN3hqBESDejtp/r/sfr/r3R3UM3Rl/v/vPP3uQUGBO/z
wOzwsCgpHPL3qvr/rfr/q9nelPT5sPr/tvv/ueHlqNrfl/r/qvr/qPr/p+XqmOjtpPr/o8HF
fbC0evr/rDIzIvr/oPn/jvn/kfn/mD5AJvn/nfr/nn6BUOjtncjMgzs9JsfMecfMbjEzHbq/
b+zyko+SXvn+or7Ddjg6IS8xGwgJBL7Da/n/lKarZcHFe+jukfX7levxitDWd+3zgfn/it3j
fpKWVYGFTtvhgMfMbXp9Qv//////////////////////////////////////////////////
/////////////////////////yH+FUNyZWF0ZWQgd2l0aCBUaGUgR0lNUAAh+QQBCgB/ACwA
AAAADwAPAAAHsoB/goIAhYWDiH+FAQIDBAWHiAYHCAkKCwwNDg8AgwAQCxESE5gUFRYXnYoY
GRobHAsdHh8gIZ0AIiMkJQAmCycoKSorLIUtFS4vMDELMjM0NTY3hTg5Fjo7GQsgPD0+P0CF
QSrk5D1C6OhDhUQ1RUY/R0hJSktMTU63Tz9QUVJIU6hUUWJFFYArWI5k0bKFS5ckXr6oUgQm
jJgxZMqYOYNmIiEAadQgWcMmUiJFhjz+CQQAOw==}
set bigsmile {R0lGODlhDwAPAMYAAAAAAH1/ZsLGnOPns9/jrX1/XwgICJ6hfdDUp+vvwPf7xvv/xvv/wvn9
verur8fLk5mcd/v/ydvfsvv/y+frr/v/uvv/t4eKYdTYo/v/w/D0vSYnHu/zwuntsy4vIvD0
sPr/tOLnoYiLZvv/vfv/wOntteHluN3hqBESDejtp/r/sfr/r3R3UM3Rl/v/vPP3uQUGBO/z
wOzwsCgpHPL3qvr/rfr/q9nelPT5sPr/tjExMfv/ueHlqNrfl/r/qvr/p+XqmOjtpMDEifr/
o8DDfsHFfbC0er+/v2JiYhwcHDo6Ovr/nn6BUOjtnTIzIczMzP///+Xl5ZKSkuzyko+SXvn+
omRmS+rq6tnZ2V5fSfn/lKarZcHFe+jukd3jfpKWVYGFTtvhgPn/jsfMbXp9QgAAAAAAAAAA
AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
AAAAAAAAAAAAAAAAAAAAAAAAACH+FUNyZWF0ZWQgd2l0aCBUaGUgR0lNUAAh+QQBCgB/ACwA
AAAADwAPAAAHsIB/goIAhYWDiH+FAQIDBAWHiAYHCAkKCwwNDg8AgwAQCxESE5gUFRYXnYoY
GRobHAsdHh8gIZ0AIiMkJQAmCycoKSorLIUtFS4vMDELMjM0NTY3hTg5Ojs8GQsgPT46P0CF
QSo6OkIqPkNE5UNFhUY1OkdIOklKSEc6S0y3TU5PUKIEhCJFxxRVAKhUsfLkCpQrWLJo2aJK
EZcuhgp5+VKREAAwYcSMIRMpkaKMiQIBADs=}
set frown {R0lGODlhDwAPAMYAAAAAAH1/ZsLGnOPns9/jrX1/XwgICJ6hfdDUp+vvwPf7xvv/xvv/wvn9
verur8fLk5mcd/v/ydvfsvv/y+frr/v/uvv/t4eKYdTYo/v/w/D0vSYnHu/zwuntsy4vIvD0
sPr/tOLnoYiLZvv/vfv/wOntteHluN3hqBESDejtp/r/sfr/r3R3UM3Rl/v/vPP3uQUGBO/z
wOzwsCgpHPL3qvr/rfr/q9nelPT5sPr/tvv/ueHlqNrfl/r/qvr/qPr/p+XqmOjtpO3yp9HW
ju7zm/r/o8HFfbC0evr/rL/Dfzg6JC8xGwgJBb7DdPn/m/n/nfr/nn6BUOjtncjMgzs9JsfM
efn/jsfMbjEzHbq/b/n/mOzyko+SXvn+ovr/oPn/lfn/h/n/jfn/kfn/lKarZcHFe+jukfX7
lfj+kvn/iPn/it3jfpKWVYGFTtvhgMfMbXp9Qv//////////////////////////////////
/////////////////////////yH+FUNyZWF0ZWQgd2l0aCBUaGUgR0lNUAAh+QQBCgB/ACwA
AAAADwAPAAAHtIB/goIAhYWDiH+FAQIDBAWHiAYHCAkKCwwNDg8AgwAQCxESE5gUFRYXnYoY
GRobHAsdHh8gIZ0AIiMkJQAmCycoKSorLIUtFS4vMDELMjM0NTY3hTg5Fjo7GQsgPD0+P0CF
QSrkKkJDREXqRUaFRzVIPUlKS0xNTk9QUbdSP1NUVaxcwZJFyxZVALh08eLkixUwYcSMIaNK
URkzZ9BYSaNmDZuKhAC0cWPlDZxIiRQZAvknEAA7}
set sick {R0lGODlhDwAPAMYAAAAAAF5wSpGucqbKgaLFe1luQwgICHuRY6G9gLPUjrndkLjgj7XeirDa
hKPMeYmtZXqOZMbnocPlnsDkmb3ilLTdibHbhK7agKvZfFt0QqfCh8fnoxsfFrXWkiYtHiMs
G6TOeRAVDKnXeZfBa2l8VMPlncTmn6O/hT5IMq3OiqXNexYcEJS9aabWdaTVc0xiNZy6fL/j
mMDkmi84JrTTkiYsHio2H5jEayAqFqLUcKHTb4y3X7fbkLzhlK3af57SapDAYavQhbngj7jf
jrffjKbOe4exXY3CWJbNX5jPY5rPZJvQZnegToGdYrbei7LchoWmYyYxGx8oFQUHA3GcR5TM
XZfOYUxoMqbNfbHchYyuaCkzHYWrX6LTb3ynU6wTDaVrRZPMW43CWWV9S67ZgazZfqnYep3R
ariEU8c6IGKIPYWoYp/Jc6XTdqTUc57Sa4e4WFh4OFdvPpC7ZX+oVUxmMsjopMjopMjopMjo
pMjopMjopMjopMjopMjopMjopCH+FUNyZWF0ZWQgd2l0aCBUaGUgR0lNUAAh+QQBCgB/ACwA
AAAADwAPAAAHs4B/goIAhYWDiH+FAQIDBAWHiAYHCAkKCwwNDg8AgwAQERITFAsVFhcYGZ2K
GhscHR4LHyAhIiOdACQlJicoKQsqKywtLi+FMDEyMzQ1CzY3ODk6O4U8PdfXPj/b20CFQUJD
RBVFRkdISUpLTIVNThVPUFFSU1RVSFZXuFhZWltcXbx8ARNGzCoAY8iUMdOiyxk0aaqoWaVo
DZs2brq8WQInDkVCAOTM6UKnTqREigx9/BMIADs=}
# create some images
image create photo bigsmile -data $bigsmile
image create photo smile -data $smile
image create photo frown -data $frown
image create photo sick -data $sick
# make the demo look nice
if {$tcl_platform(platform) == "unix"} {
set palette grey80
tk_setPalette $palette
option add *background $palette
option add *foreground black
option add *Labelframe.relief groove
option add *Labelframe.borderWidth 2
option add *Cheeseframe.relief groove ; # our custom widget class
option add *Cheeseframe.borderWidth 2 ; # our custom widget class
option add *Button.borderWidth 1
option add *Radiobutton.borderWidth 1
option add *Menu.borderWidth 1
option add *Menu.activeBorderWidth 1
option add *Entry.borderWidth 1
option add *Entry.background white
option add *Entry.foreground black
}
option add *Label.anchor w
option add *Cheeseframe.cmd.text "Invoke"
option add *Cheeseframe.hlp.text "This is a custom \"Cheeseframe\" class widget\nwith registered action applicators and options"
# this is a command that we'll associate with actions later.. it's just
# something to do
proc mbox {act} {
tk_messageBox \
-parent . \
-title "Action Message Box" \
-icon info \
-message "A message box from action \"$act\"\n\nConfiguration:\n[::action::configure $act]" \
-type ok
}
# this allows the ui to apply preferences to an action. by configuring the
# action here, those options will propogate to various widgets that the action
# has been applied
proc applyAction {act} {
::action::configure $act \
-text $::actionText($act) \
-image $::actionImage($act) \
-command $::actionCmd($act) \
-cheesecolor $::actionColor($act) \
-state $::actionState($act)
return 1
}
# creates frame and some controls to configure the action options, such as
# images, text, and command
proc actionConfigFrame {f act} {
set ::actionCmd($act) [::action::cget $act -command]
set ::actionImage($act) [::action::cget $act -image]
set ::actionText($act) [::action::cget $act -text]
set ::actionColor($act) [::action::cget $act -cheesecolor]
set ::actionState($act) [::action::cget $act -state]
labelframe $f \
-text "Action: $act"
label $f.l1 -text "Text:"
entry $f.e \
-textvariable ::actionText($act) \
-validate all \
-vcmd [list applyAction $act]
label $f.l2 -text "Image:"
foreach img {bigsmile smile frown sick} {
radiobutton $f.r$img \
-image $img \
-variable ::actionImage($act) \
-value $img \
-command [list applyAction $act]
}
label $f.l3 -text "Command:"
radiobutton $f.rbell \
-text "Bell" \
-variable ::actionCmd($act) \
-value "bell" \
-command [list applyAction $act]
radiobutton $f.rmbox \
-text "Message Box" \
-variable ::actionCmd($act) \
-value [list mbox $act] \
-command [list applyAction $act]
label $f.l4 -text "Cheeseframe:"
foreach color {palegreen skyblue} {
radiobutton $f.$color \
-text "$color" \
-value $color \
-variable ::actionColor($act) \
-command [list applyAction $act]
}
label $f.l5 -text "State:"
foreach state {normal disabled} {
radiobutton $f.$state \
-text "$state" \
-value $state \
-variable ::actionState($act) \
-command [list applyAction $act]
}
grid $f.l1 $f.e - - - - -stick ew -padx 4 -pady 4
grid $f.l2 $f.rbigsmile $f.rsmile $f.rfrown $f.rsick x -stick ew -padx 4 -pady 4
grid $f.l3 $f.rbell - $f.rmbox - - -stick w -padx 4 -pady 4
grid $f.l4 $f.palegreen - $f.skyblue - - - -stick w -padx 4 -pady 4
grid $f.l5 $f.normal - $f.disabled - - - -stick w -padx 4 -pady 4
grid columnconfigure $f 5 -weight 1
return $f
}
# this creates our custom class of widget... a Cheeseframe
proc createCheeseFrame {f} {
labelframe $f \
-class Cheeseframe
label $f.hlp
label $f.img
button $f.cmd
grid $f.hlp - -stick ew -padx 4 -pady 4
grid $f.img $f.cmd -stick ew -padx 4 -pady 4
grid columnconfigure $f 1 -weight 1
return $f
}
# this has the smarts to apply an action to our custom Cheeseframe class
# widgets
proc cheeseframeApplicator {w act} {
# let's parse thru the current configuration and only use what is available
# to us. By doing reacting to options instead of looking for specific
# options, this allows us to not really care if one of the options is
# missing. For example, if the -cheesecolor option is removed, this proc
# will still function just fine, only the -cheesecolor will never be
# processed. Of course, if we really had to have it, we could generate an
# error if we didn't find it.
foreach optSet [::action::configure $act] {
switch -- [lindex $optSet 0] {
-text {$w configure -text [lindex $optSet 1]}
-image {$w.img configure -image [lindex $optSet 1]}
-command {$w.cmd configure -command [lindex $optSet 1]}
-state {$w.cmd configure -state [lindex $optSet 1]}
-cheesecolor {
set color [lindex $optSet 1]
#$w configure -background $color
foreach child [winfo children $w] {
$child configure -background $color
}
}
}
}
}
# this little proc will be used to validate a color is a color when setting
# the -cheesecolor option. This prevents someone from doing this:
# -cheesecolor 1
# The "configure" will return an error.
proc cheesecolorValidator {color} {
if {[catch {winfo rgb . $color} err]} {
return -code error "invalid cheesecolor $color"
}
}
# add our custom -cheesecolor option for Cheeseframes and set the applicator
# proc
::action::addOption -cheesecolor palegreen cheesecolorValidator
::action::setApplicator Cheeseframe cheeseframeApplicator
# create a couple of actions and a little ui to configure what the actions do
# notice we are not setting -cheesecolor, these actions will pick up the
# default value, though we could just as easy set the value here.
action::create uno -text "Uno!" -image "smile" -command "bell" -cheesecolor skyblue
action::create dos -text "Dos!" -image "bigsmile" -command [list mbox dos]
actionConfigFrame .cfguno uno
actionConfigFrame .cfgdos dos
# create a menu bar so we can show off actions in a Menu class widget
menu .m -relief flat
. configure -menu .m
.m add cascade \
-label "File" \
-menu .m.file
.m add cascade \
-label "Actions" \
-menu .m.acts
menu .m.file
menu .m.acts
# create some buttons so we can show off actions in Button class widgets
labelframe .buttons \
-text "Buttons with Actions"
grid [button .buttons.uno] [button .buttons.dos] -stick ew -padx 4 -pady 4
grid columnconfigure .buttons {0 1} -weight 1
# create our custom Cheeseframe widgets so we can show off the flexible nature
# of the action framework for allowing everything to be configurable.
labelframe .cheese \
-text "Custom widgets that accept actions"
grid [createCheeseFrame .cheese.uno] [createCheeseFrame .cheese.dos] \
-stick ew -padx 4 -pady 4
grid columnconfigure .cheese {0 1} -weight 1
# apply the actions to the widgets
::action::apply uno .buttons.uno .m.acts .cheese.uno
::action::apply dos .buttons.dos .m.acts .cheese.dos
# lastly, create an "exit" action and a button
::action::create exit \
-text "Exit" \
-command "exit"
button .exit
::action::apply exit .exit .m.file
# oh, and stick in a label that explains what we are doing
label .help -text {
This demo shows the practical use action framework. We have create two actions
and have allowed these actions to modified through the user interface. Each
action has been applied to a menu, a button, and a custom widget. Options
and action applicators for the menu and button are standard in the action
package. For the custom widget, we have added a color option to action
framework, provided a custom color validator and a widget applicator for our
custom widget class.
You will notice by configuring the action, the options will automatically be
propogated and be appropriately applied to each type of widget.
} -justify left
grid .help - -stick {} -padx 4 -pady 4
grid .cfguno .cfgdos -stick ew -padx 4 -pady 4
grid .buttons - -stick ew -padx 4 -pady 4
grid .cheese - -stick ew -padx 4 -pady 4
grid .exit - -stick ew -padx 4 -pady 4
grid columnconfigure . {0 1} -weight 1