[Richard Suchenwirth] 2001-01-19 - [overload]ing a [widget] means writing a new widget [proc] with the same name and (at least) same functionality, so when [Tcl/Tk] (e.g., [pack]) calls it internally, it reacts in the same way. This is the lightweight way of creating "mini-megawidgets" in pure [Tcl] without much hassle. ---- '''Adding a new method to a widget (using rename only)''' This widget is based on the text widget and adds a new method called ''super''. This method [puts] text on stdout: ====== proc supertext {w args} { eval text $w $args ;# create the "base" thing rename $w _$w ;# keep the original widget command # Here comes the overloaded widget proc: proc $w {cmd args} { set self [lindex [info level 0] 0] ;# get name I was called with switch -- $cmd { super {puts "super! $args" ;# added method} default {uplevel 1 _$self $cmd $args} } } return $w ;# like the original "text" command } supertext .t -foreground red pack .t -fill both -expand 1 .t insert end "This is a.. (see stdout)" .t super example ====== This way, a supertext "inherits" all the behavior of a text widget, but in addition has the (here very stupid) "super" method. You can also overload the configure/cget "methods" (see below), but make sure the original "instance variables" are still passed through to the original widget proc. Adding "method names" like above is the easiest. See also [ANSI color control] for ''ansicolor::text'', a text widget where the ''insert'' command is intercepted to process color control escape sequences. ---- [EF] The method above also has the drawback to "pollute" the main namespace with a new (renamed) command that refers to the original widget command. So, when writing a [megawidget] through a namespace you will be tempted to rename the old command to a new command that only exists in "your" namespace. However, this sort of renaming will not resist to several renaming commands (if you decided to overload and overloaded widget). One way to solve this is to replace the command called to get the name the widget command was called with with a namespace tail command. The following code exemplifies this: ====== rename ::$w ::supertext::$w proc ::$w { cmd args } [string map [list @w@ ::supertext::$w] { set w [namespace tail [lindex [info level 0] 0]] switch -- $cmd { default {eval @w@ $cmd $args} } }] ====== ---- '''Adding a new method to a widget (using rename and interp)''' '''DKF:''' you can do even better for yourself if you use interpreter command aliases (i.e. your code can be simpler, more robust and less heavily nested, all by taking advantage of the ability to add extra arguments to the command via the alias - [RS]: which in functional programming circles is called "currying" - see [Custom curry].) Taking the example listed above: ====== proc supertext {w args} { eval text $w $args ;# create the "base" thing rename $w _$w ;# keep the original widget command # Install the alias... interp alias {} $w {} supertext_instanceCmd $w return $w ;# like the original "text" command } proc supertext_instanceCmd {self cmd args} { switch -- $cmd { super {puts "super! $args" ;# added method} default {return [uplevel 1 [list _$self $cmd] $args]} } } supertext .t -foreground red pack .t -fill both -expand 1 .t insert end "This is a.. (see stdout)" .t super example ====== This comes even more into its own when combined with namespaces and multiple interpreters. [WHD]: But note that this method can get you into trouble if your overloaded widget command is overloaded a second time. I forget the specifics, but the problem arises if the overloaded widget is destroyed. You have to un-overload in exactly the reverse order, and it doesn't quite work. ---- '''Adding a new method to a widget (using interp only)''' [TR] Here is an alternative method with the same result, but without using [rename] at all. This was inspired by the discussion, that rename invalidates the byte compiled representation of core commands [http://groups-beta.google.com/group/comp.lang.tcl/browse_frm/thread/3791969747e86489/159d22e0d70a908?hl=en&lr=&rnum=2&prev=/groups%3Fq%3Drename%2Balias%26hl%3Dde%26lr%3D%26group%3Dcomp.lang.tcl.*%26scoring%3Dd%26selm%3D41C083F0.6080000%2540bardo.clearlight.com%26rnum%3D2#159d22e0d70a908]. Note: Renaming widget names (aka commands) is just something like an alias, linking to the instance in C code, so there is no bytecode to lose and no performance loss by using [rename] in this way (thanks to [RS] for this clarification). ====== proc supertext {w args} { # create the "base" thing: eval text $w $args # hide the original widget command, but keep it: interp hide {} $w # Install the alias: interp alias {} $w {} supertext_instanceCmd $w # like the original "text" command: return $w } proc supertext_instanceCmd {self cmd args} { puts "supertext_instanceCmd $self $cmd $args" switch -- $cmd { super {puts "super! $args" ;# added method} default {return [uplevel 1 [list interp invokehidden {} $self $cmd] $args]} } } supertext .t -foreground red pack .t -fill both -expand 1 .t insert end "This is a.. (see stdout)" .t super example ====== The original widget command is hidden from the current interpreter and the alias is installed like in the previous example. The instanceCmd calls this hidden command in order to do the default work, that is not cusomized. ---- '''Adding new options to a widget''' You can easily add your own configure options to your new widget. This results (of course) in a bit more code, but the logic is simple. You need to intercept your new options and handle them separately. All default options are just passed to the original widget for evaluation. Here is an extended supertext example. It is a bit more convoluted, because it adds a [labelframe] around the text, so we need to take care of the text widget as a subwidget here. supertext has two new options here: -label (for the text on the labelframe) and -labelanchor (for the label position): ====== proc supertext {w args} { # new options and their standard values: array set options {-label {} -labelanchor nw} # split off the custom options: set textArgs [list] foreach {opt val} $args { switch -- $opt { {-label} - {-labelanchor} {set options($opt) $val} default {lappend textArgs $opt $val} } } # create the "base" widget for the new megawidget: labelframe $w -text $options(-label) -labelanchor $options(-labelanchor) eval text $w.text $textArgs pack $w.text -expand yes -fill both -padx 5 -pady 5 # hide the original widget command from the interpreter: interp hide {} $w # Install the alias: interp alias {} $w {} supertextCmd $w # return the original command: return $w } proc supertextCmd {self cmd args} { #puts "--> supertextCmd $self $cmd $args" switch -- $cmd { super {puts "super! $args" ;# added method} configure {eval supertextConfigure $self $cmd $args} cget {eval supertextCget $self $args} default {return [eval $self.text $cmd $args]} } } proc supertextConfigure {self cmd args} { # differentiate between 3 scenarios: # # $args is empty -> return all options with their values # $args is one element -> return current values # $args is 2+ elements -> configure the options switch [llength $args] { 0 { # frame option: set result [interp invokehidden {} $self cconfigure -text] # default options: lappend result [$self.text configure] return $result } 1 { switch -- $args { {-label} {return [interp invokehidden {} $self configure -text]} {-labelanchor} {return [interp invokehidden {} $self configure -labelanchor]} default {return [$self.text configure $args]} } } default { # go through each option: foreach {option value} $args { switch -- $option { {-label} {interp invokehidden {} $self configure -text $value} {-labelanchor} {interp invokehidden {} $self configure -labelanchor $value} default {$self.text configure $option $value} } } return {} } } } proc supertextCget {self args} { # frame related options must be handled separately, # the rest is done by the text cget command switch -- $args { {-label} {return [interp invokehidden {} $self cget -text]} {-labelanchor} {return [interp invokehidden {} $self cget -labelanchor]} default {return [$self.text cget $args]} } } supertext .t -foreground red -background white -label "A super text" \ -labelanchor ne pack .t -fill both -expand 1 .t insert end "This is a.. (see stdout)" .t super example set l "-label" puts [.t cget $l] puts [.t cget -foreground] puts [.t configure -label] puts [.t configure -foreground] puts [.t configure -foreground blue -label "a super result"] ====== As you can see from the 'puts' lines, you can use the widget normally with the two added configure options. [GWM] shows a less convoluted derived widget in [Another Graphing Widget] - ie one which adds "options" and commands to a canvas rather than combining 2 widgets into a super widget. ---- '''Bindings on overloaded widgets (and how to get them working again)''' If you try to make a standard binding on the overloaded textwidget in the last example above, like ====== supertext .t pack .t bind .t {puts "Moving cursor ..."} ====== nothing will happen. This is because we changed the command name for the new overloaded widget but this did of course not change the path name. So while ''.t'' is now a command meaning the text widget (inside the frame), the path ''.t'' used in the binding command still means the frame around the text widget. To resolve this problem, we can add a clever bindtags command to the procedure ''supertext'': ====== bindtags $w.text [lreplace [bindtags $w.text] 0 0 $w] ====== This takes the binding tags for the text widget created inside the ''supertext'' procedure and replaces the first element with the frame path. Originally this first element consisted of the path name of this particular text widget. After the replacement, this text widget will act upon bindings on the frame, so if a user makes a binding on ''.t'' (which is actually the frame), it will fire in the text widget, just as intended. All other bindings on the text class, the toplevel and ''All'' are still intact. The ''ScrolledWidget'' example below uses this technique to get the bindings right. ---- '''Dynamic bindings on overloaded widgets''' [Duoas] The above method has a drawback. When handling ''dynamic'' bindings on the megawidget, you get the same problem as before. For example, if you have specific behaviours bound to a tag which you add to the megawidget's list of bindtags, like ====== # Bindings for 'edit mode' on the supertext megawidget bind SuperEditMode [list dosomething %x %y] ... # Activate 'edit mode' on the supertext megawidget bindtags .t [linsert [bindtags .t] 0 SuperEditMode] ... # Deactivate 'edit mode' on the supertext megawidget bindtags .t [lsearch -inline -all -exact -not [bindtags .t] SuperEditMode] nothing will happen (again). This is for the very same reason as before: because the path ''.t'' means the frame around the text widget and not the text widget itself. ====== The way to overcome this is surprisingly simple: add an execution trace to the '''bindtags''' command. There are, of course, many ways to do it, but here is a simple proc that will give you good results. It combines the bindtags for both the frame and the specified subwidget, and removes the subwidget from the resulting list of tags: ====== proc UpdateBindtags {win subwin args} { if {($args eq {}) || ($win in [lindex $args 0])} { # combine the bindtags for the widget and subwidget set tags [bindtags $win] lappend tags {*}[bindtags $subwin] set tags [lsort -unique $tags] # remove the subwidget's tag from the result bindtags $subwin [lsearch -inline -all -exact -not $tags $subwin] } } ====== Next, in your widget's creation/initialization code, make sure to perform the proper updates: ====== ::UpdateBindtags $w $w.text trace add execution bindtags leave [list ::UpdateBindtags $w $w.text] ====== And that's all there is to it! As a side note, I'm not so sure that you always need to remove the subwidget's name from the list of tags. That is, of course, a matter to consider against your requirements and needs. ---- '''Intercepting changes to a widget's state''' [KBK] 2006-09-22: One thing that overloading can sometimes get you is the ability to act on changes to a widget's state. For instance, a text widget's characters can change only by the ''insert'' and ''delete'' widget commands; its insertion cursor can be moved only by the ''mark set insert'' command, and so on. These provide a limited number of places that you need to hook to attach new behaviours to the given actions. One worked example shows that you can provide a [text variable for text widget]s that function as multi-line entries. ---- '''Useful examples of small megawidgets'''' ''text widget with markup'' A more meaningful example was triggered by a c.l.t post from [Bryan Oakley]: ''it'd be nice to create text like "some things are *bold* and some are _underlined_" and be able to put that into a widget with a single call.'' Here's a quick shot: ====== proc markuptext {w args} { eval [list text $w] $args rename ::$w ::_$w proc ::$w {cmd args} { set w [lindex [info level 1] 0] switch -- $cmd { insert {eval [list markuptext'insert $w] $args} default {eval [list ::_$w $cmd] $args} } } set w } proc markuptext'insert {w position args} { if {[llength $args]==1} {set args [lindex $args 0]} foreach word [split $args] { if {$word==""} continue set tag "" if {[regexp {^\*(.+)\*$} $word -> word]} {set tag bold} if {[regexp {^_(.+)_$} $word -> word]} {set tag underline} ::_$w insert $position "$word " $tag } } #----------------------------- Test and demo code... pack [markuptext .t] .t tag configure bold -font {Arial 10 bold} .t tag configure underline -font {Arial 10 underline} .t insert end "Test for *bold* and _underlined_ words...\ with \"quotes\" and \{unbalanced braces" ====== [LV] There are several examples for markup languages. For instance, this wiki uses '''' to mark a request for emphasis (italics) and '''''' as a request for strong (bold) highlighting. This wiki doesn't have a notation for underlining. Then there's '''setext''' [http://www.valdemar.net/~erik/setext/], which uses similar markup as you've implemented. And there is a [mime] richtext[http://www.ietf.org/rfc/rfc1341.txt] (not the same as the [Microsoft] rich text), which has its own markup. See [A wiki-like markup language for the text widget] for an example. ''a scrolled widget megawidget'' This widget can be used to produce a standard widget with scrollbars around it. You call it with a standard widget as a parameter and specify, which scrollbars you want, and you get a scrolled widget of that type acting just like the standard thing. It just comes with functional added scrollbars: ====== # create a standard widget with scrollbars around # # wigdet -> name of the widget to be created # parent -> path to the frame, in which the widget and the scrollbars should # be created # scrollx -> boolean; create horizontal scrollbar? # scrolly -> boolean; create vertical scrollbar? # args -> additional arguments passed on the the original widget # # returns: the path to the created widget (frame) # proc ScrolledWidget {widget parent scrollx scrolly args} { # Create widget attached to scrollbars, pass thru $args frame $parent eval $widget $parent.list $args # Create scrollbars attached to the listbox if {$scrollx} { scrollbar $parent.sx -orient horizontal \ -command [list $parent.list xview] -elementborderwidth 1 grid $parent.sx -column 0 -row 1 -sticky ew $parent.list configure -xscrollcommand [list $parent.sx set] \ } if {$scrolly} { scrollbar $parent.sy -orient vertical \ -command [list $parent.list yview] -elementborderwidth 1 grid $parent.sy -column 1 -row 0 -sticky ns $parent.list configure -yscrollcommand [list $parent.sy set] } # Arrange them in the parent frame grid $parent.list -column 0 -row 0 -sticky ewsn grid columnconfigure $parent 0 -weight 1 grid rowconfigure $parent 0 -weight 1 # hide the original widget command from the interpreter: interp hide {} $parent # Install the alias: interp alias {} $parent {} ScrolledWidgetCmd $parent.list # fix the bindtags: bindtags $parent.list [lreplace [bindtags $parent.list] 0 0 $parent] return $parent } proc ScrolledWidgetCmd {self cmd args} { return [uplevel 1 [list $self $cmd] $args] } ====== To create a scrolled text widget with both scrollbars, use: ====== ScrolledWidget text .t 1 1 ====== ---- To see how a real megawidget framework does this work, start reading here: [megawidget] <>Arts and crafts of Tcl-Tk programming | GUI | Widget