Overloading widgets

Summary edit

Richard Suchenwirth 2001-01-19: overloading 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.

Description edit

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

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.

HE 2018-09-04: The above doesn't clean up properly when we try to destroy .t. Perhaps, this is what WHD meant:

(bin) 7 % info commands .t
.t
(bin) 8 % info commands _.t
_.t
(bin) 9 % 
(bin) 9 % destroy .t
(bin) 10 % 
(bin) 10 % 
(bin) 10 % info commands .t
.t
(bin) 11 % info commands _.t
(bin) 12 %

It looks like the widget with path .t is still connected to its original command which is now _.t. Therefore, _.t vanish when the widget .t is destroyed. But, not the command .t.

What is missed is a mechanism to remove the new command .t. This could be done with a 'trace command _$w delete ...' and the new proc supertext_destroy (supertext_instanceCmd stays at is it). I also changed "eval text $w $args" to "text $w {*}$args" which would work since 8.5:

proc supertext {w args} {
        text $w {*}$args ;# create the "base" thing
        rename $w _$w      ;# keep the original widget command
        # Install the alias...
        interp alias {} $w {} supertext_instanceCmd $w
        # Assure that instanceCmd will be deleted when widget will be destroyed
        trace add command _$w delete [list supertext_destroy $w]
        return $w ;# like the original "text" command
}

proc supertext_destroy {w args} {
        interp alias {} $w {}
        return
}

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

And here the functional test that destroy works:

(bin) 8 % info commands .t
.t
(bin) 9 % info commands _.t
_.t
(bin) 10 % 
(bin) 10 % destroy .t
(bin) 11 % 
(bin) 11 % info commands .t
(bin) 12 % info commands _.t
(bin) 13 %

Adding a new method to a widget (using interp only) edit

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 (see does renaming core command affect byte code compiler? ,comp.lang.tcl ,2004-12-14

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

HE 2018-09-05: This example has the same disadvantage as the example before: The command .t is not removed when 'destroy .t' is executed.

With the original command hidden we can't use trace to detect the destroy of the widget.

But we can use a binding to detect this:

proc supertext {w args} {
    # create the "base" thing:
    text $w {*}$args
    # hide the original widget command, but keep it:
    interp hide {} $w
    # Install the alias:
    interp alias {} $w {} supertext_instanceCmd $w
    # and establish a binding to detect destroy
    bind $w <Destroy> {
        interp alias {} %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

And here the test of destroying the widget:

(bin) 7 % info commands .t
.t
(bin) 8 % info commands _.t
(bin) 9 % 
(bin) 9 % destroy .t
(bin) 10 % 
(bin) 10 % 
(bin) 10 % info commands .t
(bin) 11 % info commands _.t
(bin) 12 %

Adding new options to a widget edit

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

If you try to make a standard binding on the overloaded textwidget in the last example above, like

supertext .t
pack .t
bind .t <Motion> {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 edit

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 <ButtonPress-1> [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 edit

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 widgets that function as multi-line entries.

Useful examples of small megawidgets edit

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

, which uses similar markup as you've implemented. And there is a mime richtext

(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

Category GUI

Category Widget