oowidgets - Tcl package to create megawidgets using Tcl object system TclOO
This is yet another approach of creating megawidgets using TclOO. My first little project with TclOO. I had a look at Read-Only Text Megawidget with TclOO and Megawidgets with TclOO and then took some ideas from A Scrolled Widget implemented with TclOO.
package require Tk
package provide oowidgets 0.1
namespace eval ::oowidgets { }
# this creates a wrapper around the class,
# so that object creation works like for other Tk widgets
proc oowidgets::new name {
eval "
proc [string tolower $name] {path args} {
set obj \[$name create tmp \$path {*}\$args\]
rename \$obj ::\$path
return \$path
}
"
}
# the BaseWidget from which your MegaWidgest should inherit
oo::class create ::oowidgets::BaseWidget {
variable parentOptions ; # base widgets options
variable widgetOptions ; # additional options
variable widgettype
constructor {path args} {
my variable widgetOptions
my variable parentOptions
array set widgetOptions [list]
array set parentOptions [list]
#my configure {*}$args
}
# must be currently called in the constructor
# of the inheriting class
method install {wtype path args} {
my variable parentOptions
my variable widgetOptions
my variable widget
$wtype $path
set widget ${path}_
foreach opts [$path configure] {
set opt [lindex $opts 0]
set val [lindex $opts end]
set parentOptions($opt) $val
}
array set nopts $args
foreach opt [array names nopts] {
set widgetOptions($opt) $nopts($opt)
}
rename $path $widget
}
# overwriting the standard methods cget and configure
# to deal with possible new options
method cget { {opt "" } } {
my variable widgetOptions
my variable parentOptions
if { [string length $opt] == 0 } {
return [lsort [list [array get parentOptions] {*}[array get widgetOptions]]]
}
if { [info exists widgetOptions($opt) ] } {
return $widgetOptions($opt)
} elseif {[info exists parentOptions($opt)]} {
return $parentOptions($opt)
}
return -code error "# unknown option"
}
method configure { args } {
my variable widget
my variable widgetOptions
my variable parentOptions
if {[llength $args] == 0} {
return [lsort [list [array get parentOptions] {*}[array get widgetOptions]]]
} elseif {[llength $args] == 1} {
# return configuration value for this option
set opt $args
if { [info exists widgetOptions($opt) ] } {
return $widgetOptions($opt)
} elseif {[info exists parentOptions($opt)]} {
return $parentOptions($opt)
} else {
return -code error "# unkown option"
}
}
# error checking
if {[expr {[llength $args]%2}] == 1} {
return -code error "value for \"[lindex $args end]\" missing"
}
# process the new configuration options...
array set opts $args
foreach opt [array names opts] {
set val $opts($opt)
# overwrite with new value
if { [info exists widgetOptions($opt)] } {
set widgetOptions($opt) $val
} elseif {[info exists parentOptions($opt)]} {
set parentOptions($opt) $val
$widget configure $opt $val
} else {
return -code error "unknown configuration option: \"$opt\" specified"
}
}
}
# delegate all other methods to the widget
method unknown {args} {
my variable widget
$widget {*}$args
}
}
Let's now use this code above to create two little widget which extends the ttk::label and the ttk::button with a flash method:
namespace eval ::flash {}
# create the wrapper function
# so this creates a proc flash::button
# Please note that uppercasing the class name is required
# the wrapper proc is all lowercase
oowidgets::new ::flash::Button
# the actual implementation of our sample widget
oo::class create ::flash::Button {
superclass oowidgets::BaseWidget
constructor {path args} {
# new options with their defaults are added at the end
my install ttk::button $path -flashtime 500
my configure {*}$args
}
# our extension method
method flash {} {
set ot [my cget -text]
set ft [my cget -flashtime]
for {set i 0} {$i < 5} {incr i} {
my configure -text "......"
update idletasks
after $ft
my configure -text $ot
update idletasks
after $ft
}
puts flashed
my configure -text $ot
}
}
# Now just for demonstration purposes a second widget
# wrapper method ::flash::label creation
oowidgets::new ::flash::Label
# implementation
oo::class create ::flash::Label {
superclass oowidgets::BaseWidget
constructor {path args} {
my install ttk::label $path -flashtime 500
my configure {*}$args
}
method flash {} {
set fg [my cget -foreground]
for {set i 0} {$i < 10} {incr i} {
my configure -foreground red
update idletasks
after [my cget -flashtime]
my configure -foreground $fg
update idletasks
after [my cget -flashtime]
}
puts labelflashed
}
}Now example code on widget creation and using them:
# creating an packing the widgets set fb [flash::button .fb -text "Exit" -flashtime 100 -command exit] pack $fb -side top -pady 10 -pady 10 -fill both -expand true set fl [flash::label .fl -text "FlashLabel" -flashtime 200 -anchor center] pack $fl -side top -padx 10 -pady 10 -fill both -expand true # call by variable $fb flash puts "done 1" # call by path .fb flash puts "done 2" # the flash::label # call by path and then variable .fl flash $fl flash # calling a standard function of ttk::button (via unknown) $fb invoke
- composite widget demo (LabEntry) - mixin demo (flash as mixin, might be anyway better)
DDG - 2023-03-18: May be I missed an implementation of megawidgets using TclOO which is widespread used. Sorry if this is the case and I come here with an other one ... It was just thought as my first exercise using TclOO.