[MAK] - Someone asked over on the chat for a simple example of a meta-widget or megawidget. This is the method I generally use, which has been on the ASPN Tcl Cookbook for a while. I thought it might be convenient to have it listed here, as well. (The version I use is in a non-global namespace -- the MegaWidget proc can be moved anywhere -- and has some extra sugar in the <Destroy> binding for simple destructor-like cleanup, but others might have different preferences so it's not included.)
This MegaWidget procedure allows you to treat namespaces and widgets loosely as extensible classes. The class name is defined by the namespace from which the MegaWidget command was called (MyWidget in the example), and the specific class instance is named by the main widget name.
When MegaWidget is called, it is passed the path of some widget that you want to turn into a mega widget (such as a frame containing other widgets). The namespace of the caller is added to a search list (list of namespaces from which MegaWidget was called on the named widget) and the widget's command (provided by Tk) is renamed and replaced. When this replacement command is called, it will scan through the search list, checking each namespace stored for a procedure with the same name as the first argument. If found, then it's called, with the widget name inserted as the first argument.
Note: this assumes that the procedure will already have been defined so that it will be visible via "info proc". If the procedure hasn't been auto-loaded, it might call the wrong layer.
If no procedure is found in any of the namespaces of the search list, then the command is passed on to the widget command its self as if it were not a mega-widget.
The MegaWidget function provides some basic inheritence mechanisms. You can call it multiple times from different namespaces to add or override basic functionality. To call a specific parent-class's version of a function, you just need to call the function directly, passing the widget path as the first argument. e.g., MegaWidget::dosomething .mw ?arg arg ...?.
package provide MegaWidget 1.0
proc MegaWidget { hWnd } {
variable widgetClasses
# Get the namespace for the mega-widget from the caller
set NS [uplevel namespace current]
# If the widget has already been turned into a mega-widget, just insert
# the new namespace into the top of the search list and return.
if {[info exist widgetClasses($hWnd)]} {
set widgetClasses($hWnd) [linsert $widgetClasses($hWnd) 0 $NS]
return
}
# The widget has yet been turned into a mega-widget. Store the
# caller's namespace as the first in the search list.
set widgetClasses($hWnd) $NS
# Rename the widget command to something in this procedure's namespace
# so that calls to the widget command are not sent to the widget directly.
rename ::$hWnd [namespace current]::mega$hWnd
# Set up binding to clear the search list for the widget and delete
# the replacement procedure for the widget command. Make sure that
# the widget generating the event is the same as the widget that was
# turned into a mega-widget: this allows a toplevel to be turned
# into mega-widget too (otherwise, it will get <Destroy> events from
# child windows).
set template {
if {[string match %W @HWND@]} {
namespace eval @MYNS@ array unset widgetClasses %W
rename %W {}
}
}
regsub -all {@HWND@} $template $hWnd template
regsub -all {@MYNS@} $template [namespace current] template
bind $hWnd <Destroy> $template
# Create a new top-level procedure with the same name as the widget.
# This procedure will scan through the search list for a namespace
# containing a procedure by the same name as the first argument passed
# to this new procedure.
set template {
global errorInfo errorCode
variable widgetClasses
set hWnd @HWND@
foreach NS $@MYNS@::widgetClasses($hWnd) {
if {[namespace inscope $NS info proc $command] == $command} {
set rc [catch { eval [set NS]::$command $hWnd $args } result]
set ei $errorInfo
set ec $errorCode
break
}
}
if {![info exist rc]} {
set rc [catch { eval @MYNS@::mega$hWnd $command $args } result]
set ei $errorInfo
set ec $errorCode
}
return -code $rc -errorinfo $ei -errorcode $ec $result
}
regsub -all {@HWND@} $template $hWnd template
regsub -all {@MYNS@} $template [namespace current] template
proc ::$hWnd { command args } $template
}And here is a simple example that creates a text widget with horizontal and vertical scrollbars, that otherwise behaves just like a plain text widget:
package require MegaWidget
package provide XYText 1.0
namespace eval XYText {
proc XYText { hWnd args } {
frame $hWnd -bd 1 -relief sunken
set hWndTxt \
[text $hWnd.txt \
-bd 0 \
-relief flat \
-xscroll "$hWnd.scrX set" \
-yscroll "$hWnd.scrY set" \
-wrap none \
]
set hWndXScr \
[scrollbar $hWnd.scrX \
-orient horizontal \
-command "$hWndTxt xview" \
]
set hWndYScr \
[scrollbar $hWnd.scrY \
-orient vertical \
-command "$hWndTxt yview" \
]
set hWndBox \
[frame $hWnd.frBox \
-bd 1 \
-relief raised \
]
grid rowconfig $hWnd 0 -weight 1 -minsize 0
grid rowconfig $hWnd 1 -weight 0 -minsize 0
grid columnconfig $hWnd 0 -weight 1 -minsize 0
grid columnconfig $hWnd 1 -weight 0 -minsize 0
grid $hWndTxt -row 0 -column 0 -sticky news
grid $hWndYScr -row 0 -column 1 -sticky ns
grid $hWndXScr -row 1 -column 0 -sticky ew
grid $hWndBox -row 1 -column 1 -sticky news
MegaWidget $hWnd
return $hWnd
}
# Create XYText MegaWidget commands to be passed on to the text widget.
foreach textCmd [list bbox cget compare configure debug delete \
dlineinfo dump get image index insert mark scan search see \
tag window xview yview] {
proc $textCmd { hWnd args } "
return \[eval \$hWnd.txt $textCmd \$args\]
"
}
}There is a problem here still to be resolved: a normal binding command like
XYText::XYText .t
pack .t -padx 5 -pady 5
bind .t <Motion> {puts moving}on this megawidget will not do anything because the binding is associated with the frame, not the text widget. See overloading widgets for a solution.
Need more example: