-- 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 ---- [Category Actions] | [Category GUI]