If you're creating a mega-widget (aka composite widget) that you want to be extensible, but you aren't quite ready to take the plunge into a full Tcl class extension (or haven't found one quite for you), the following is a simple "next best thing".
Download
Copy to clipboard1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 | 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 { uplevel [set NS]::$command $hWnd $args } result]
set ei $errorInfo
set ec $errorCode
break
}
}
if {![info exist rc]} {
set rc [catch { uplevel @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
}
# Example:
#
# namespace eval MyWidget {
# proc MyWidget { hWnd args } [
#
# # Main frame for the mega-widget
#
# frame $hWnd
#
# # ... other widgets created/packed in the main frame
#
# # Turn created frame into a mega-widget.
#
# MegaWidget $hWnd
# return $hWnd
# }
#
# proc dosomething { hWnd args } {
# # ...
# }
#
# proc dosomethingelse { hWnd args } {
# # ...
# }
# }
#
# MyWidget::MyWidget .mw
# .mw dosomething -option value ...
# .mw dosomethingelse -option value ...
|
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. 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. (In the above example, ".mw dosomething" calls "MyWidget::dosomething with .mw passed in the hWnd parameter).
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 ...?.
See http://aspn.activestate.com/ASPN/Cookbook/Tcl/Recipe/122548 for a working mega-widget based on this function.
Aug 08, 2003 Edit - changed evals in widget procs to uplevels so that upvar can be used in the widget proc.
