# 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