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. A lot of code is just stolen from these wiki pages ...
So here my approximately 100 lines of code:
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 megawidget 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 widgets 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 for widget use:
# 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
Here an idea to create the wrapper and the class in one step:
proc oowidgets::widget {name body} {
oowidgets::new $name
oo::class create $name $body
oo::define $name { superclass oowidgets::BaseWidget }
}That way we can get rid of the new call and the superclass statement within our class definition. Let's create a bluelabel widget just for illustration purposes:
oowidgets::widget ::flash::BlueLabel {
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 blue
update idletasks
after [my cget -flashtime]
my configure -foreground $fg
update idletasks
after [my cget -flashtime]
}
puts labelflashed
}
}Here a very basic variant of a composite widget consisting of a ttk::label and a ttk::entry within a frame.
oowidgets::widget ::flash::LEntry {
variable ent
variable lab
constructor {path args} {
# the main widget is the frame
# add an additional label
my install ttk::frame $path
set lab [ttk::label $path.lab]
set ent [ttk::entry $path.ent]
pack $lab -side left -padx 5 -pady 5
pack $ent -side left -padx 5 -pady 5
my configure {*}$args
}
# expose the internal widgets using subcommands
method label {args} {
$lab {*}$args
}
method entry {args} {
$ent {*}$args
}
# you could as well delegate all methods to the entry widget
# making it your default widget
method unknown {args} {
$ent {*}$args
}
}
# let's test
set test true
if {$test} {
set le2 [flash::lentry .le2 -relief ridge -borderwidth 5]
$le2 label configure -text "LEntry Example" -width 20
$le2 entry configure -show *
$le2 entry insert 0 "password"
pack $le2 -side bottom -fill x -expand false
}Here a mixin example. Firstly we need to create a class for an existing tk or ttk widget, then we create the mixin lcass which should be not used to create any object on itself, it should be only used as mixin, then we use oo::define to add this mixin to our widget:
namespace eval ::oow { }
# proxy class for ttk::label
oowidgets::widget ::oow::Label {
constructor {path args} {
my install ttk::label $path
my configure {*}$args
}
}
# the mixin which should be not instantiated on its own
oo::class create ::oow::LblFlash {
method flash {{flashtime 300}} {
set fg [my cget -foreground]
for {set i 0} {$i < 5} {incr i} {
my configure -foreground green
update idletasks
after $flashtime
my configure -foreground $fg
update idletasks
after $flashtime
}
puts "Mixin for label flashed"
}
}
# add mixin to our class
oo::define oow::Label { mixin ::oow::LblFlash }
# testing
if {1} {
set lbl [oow::label .lbl -text "Hello" -foreground blue]
pack $lbl -side top
set btn [ttk::button .btn -text "Exit" -command exit]
pack $btn -side top
$lbl flash
}This is a rewrite based on the famous snit widget here on Snit's Not Incr Tcl.
::oowidgets::widget Rotext {
variable textw
constructor {path args} {
# we need the real widget
set textw ${path}_
# Create the text widget; turn off its insert cursor
my install tk::text $path -insertwidth 0 -border 5 -relief flat
my configure {*}$args
}
# Disable the text widget's insert and delete methods
# to make this readonly even if the user writes text.
method insert {args} { }
method delete {args} { }
# programmatically we can still insert and delete ...
method ins {args} { $textw insert {*}$args }
method del {args} { $textw delete {*}$args }
}Here an example which uses existing namespace code from this wikipage Entering Unicode characters in a widget and wraps this into an mixin which can be easily added. The code requires the latest oowidgets code available at https://github.com/mittelmark/oowidgets
package require oowidgets
# wrapper widget
namespace eval ::sample {}
oowidgets::widget ::sample::Text {
constructor {path args} {
my install tk::text $path
my configure {*}$args
}
}
namespace eval ::sample::unicode {
variable uc_keys
}
proc ::sample::unicode::enable_unicode_entry {widget} {
variable uc_keys
set uc_keys($widget) {}
}
proc ::sample::unicode::disable_unicode_entry {widget} {
variable uc_keys
unset -nocomplain uc_keys($widget)
}
proc ::sample::unicode::handle_uc_key {widget key} {
variable uc_keys
if {![info exists uc_keys($widget)]} {
return
}
upvar 0 uc_keys($widget) keys
switch -glob -- [string toupper $key] {
{[0-9A-F]} {
append keys $key
if {[string length $keys] >= 4} {
$widget insert insert [subst \\u$keys]
disable_unicode_entry $widget
}
return -code break
}
default {
$widget insert insert $keys
disable_unicode_entry $widget
}
}
}
::oo::class create ::sample::txunicode {
method unicode {{keypress Control-Key-u}} {
set w [my widget]
bindtags $w [list $w UnicodeEntry Text . all]
bind UnicodeEntry <$keypress> [list ::sample::unicode::enable_unicode_entry %W]
bind UnicodeEntry <Key> [list ::sample::unicode::handle_uc_key %W %A]
}
}
# testing
if {true} {
set txt [sample::text .txtu -background grey80 -font "Courier 18"]
$txt insert end "Press Ctrl-Shift-u and then thereafter 4 numbers like 2602\n\n"
oo::objdefine $txt mixin sample::txunicode
$txt unicode Control-Key-U ;# To use Control-Shift-u
pack $txt -side top -fill both -expand yes
}DDG - 2023-03-18: May be I missed an implementation of megawidgets using TclOO which is in 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. With around 100 LOC the result seems to be really impressive - thanks to TclOO and its creators.
DDG - 2023-08-26: Bugfix for configuring non existing options for the parent widget