[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.
----
'''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 evalualtion.

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

----
'''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] which uses similar markup as you've implemented.  And there is a
[mime] [rich text] (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] | [Category GUI] | [Category Widget]