GJS 2012/5/12 This is my first attempt at an OO class for Tk. GJS 2012/7/13 tkoo is on Google Code http://code.google.com/p/tkoo/
This package creates several classes all in the tkoo namespace.
tkoo::widget is the base widget class. On its own it is a frame with no options and only configure and cget public methods. The methods created so far are:
Most tk and ttk widgets are turned into classes to make them easier to build on. the tk classes will be tkoo::tk_<widget> and the ttk classes will be tkoo::ttk_<widget>. tkoo::wrap is used when sourced to wrap the tk and ttk widgets.
tkoo::class
Usage: tkoo::class class body
class is the namespace the widget class is created in and also the name of the procedure for creating a widget. The widget class will be named <class>::widget while the procedure will just be named <class>
body is code used by TclOO to create the widget class.
I have created a few widgets to go along with this package. Mostly widgets that are useful to me for my personal projects.
#tkoo-v-0.1.tm
package provide tkoo 0.1
namespace eval ::tkoo {}
oo::class create ::tkoo::widget {
variable widCmd pathname options exists
constructor {wid args} {
#has the widget been created
my Exists $wid
#create a frame (default widget)
if {![winfo exists $wid]} {
ttk::frame $wid
}
#store the widget pathname
set pathname $wid
#rename the widget command
set widCmd _$wid
for {set i 0} {[llength [info commands ::$widCmd]]} {incr i} {set widCmd _${i}_$wid}
rename ::$wid ::$widCmd
#rename this object
rename [self] ::$wid
#default bindings
bind $wid <Destroy> [namespace code [list my BindDestroy]]
}
destructor {
#get rid of the widget
if {[info exists pathname] && [winfo exists $pathname]} {
bind $pathname <Destroy> {}
destroy $pathname
}
#get rid of widget commands
if {[info exists widCmd] && [llength [info commands $widCmd]]} {
rename $widCmd {}
}
if {[info exists pathname] && [llength [info commands $pathname]]} {
rename $pathname {}
}
}
method BindDestroy {} {
bind $pathname <Destroy> {}
if {[lsearch [info commands [self]] [self]] >= 0} {
[self] destroy
}
}
method configure {args} {
#create a list of options
if {![info exists options(list)]} {set options(list) [list]}
if {![llength $args]} {
#return info about all args
set ret [list] ;#return variable
foreach o $options(list) {
lappend ret [list $o $options($o,nam) $options($o,cls) $options($o,def) $options($o,val)]
}
return $ret
} elseif {[llength $args] == 1} {
#return info about one arg
set opt [lindex $args 0]
if {[lsearch -exact $options(list) $opt] < 0} {error [msgcat::mc "unknown option \"%s\"" $opt]}
return [list $opt $options($opt,nam) $options($opt,cls) $options($opt,def) $options($opt,val)]
} elseif {[llength $args] % 2} {
#odd number of args
error [msgcat::mc "value for \"%s\" missing" [lindex args end]]
} else {
#split args into option value pairs and pass them to the option command
foreach {o v} $args {
my Opt set $o $v
}
}
}
method cget {option} {
return [my Opt get $option]
}
method Opt {method args} {
my variable widCmd pathname options exists
#create a list of options
if {![info exists options(list)]} {set options(list) [list]}
switch -exact -- $method {
add {
#use: my option add -option dbname dbclass default body
if {[llength $args] != 5} {error [msgcat::mc "wrong # args: should be \"%s\"" "my option add -option dbname dbclass default body"]}
#store info about the option
set opt [lindex $args 0] ;#option name
set options($opt,nam) [lindex $args 1] ;#database name
set options($opt,cls) [lindex $args 2] ;#database class
set options($opt,def) [lindex $args 3] ;#default value
set options($opt,val) [lindex $args 3] ;#current value
set options($opt,bod) [lindex $args 4] ;#code to exe when the option is set
#alphebetized list of options
lappend options(list) $opt
set options(list) [lsort -dictionary -unique $options(list)]
#create a method for the option
set m _opt($opt)
oo::objdefine [self] method $m {value old} $options($opt,bod)
#return
return
}
set {
if {[llength $args] != 2} {error [msgcat::mc "wrong # args: should be \"%s\"" "my option set -option value"]}
set opt [lindex $args 0] ;#option name
set val [lindex $args 1] ;#value
set old $options($opt,val)
set options($opt,val) $val ;#store option
if {[catch {my _opt($opt) $val $old} msg]} {
set options($opt,val) $old
error $msg
}
return
}
get {
if {[llength $args] != 1} {error [msgcat::mc "wrong # args: should be \"%s\"" "my option get -option"]}
set opt [lindex $args 0]
if {[lsearch -exact $options(list) $opt] < 0} {error [msgcat::mc "unknown option \"%s\"" $opt]}
return $options($opt,val)
}
eval {
if {[llength $args] != 1} {error [msgcat::mc "wrong # args: should be \"%s\"" "my option eval -option"]}
set opt [lindex $args 0]
set val $options($opt,val)
my Opt($opt) $val
}
default {}
}
}
method Exists {wid} {
if {![info exists exists]} {set exists 0}
if {!$exists} {
if {[llength [info commands $wid]]} {
error [msgcat::mc "window name \"%s\" already exists in parent" [lindex [split $wid .] end]]
}
}
set exists 1
}}
proc ::tkoo::init {args} {
#wrap all default tk widgets, so they can be super classed easily
lappend widgets ::tk::button ::tk::canvas ::tk::checkbutton ::tk::entry ::tk::frame ::tk::label
lappend widgets ::tk::labelframe ::tk::listbox ::tk::menubutton ::tk::message
lappend widgets ::tk::panedwindow ::tk::radiobutton ::tk::scale ::tk::toplevel
lappend widgets ::tk::scrollbar ::tk::spinbox ::tk::text ::ttk::button
lappend widgets ::ttk::checkbutton ::ttk::entry ::ttk::frame ::ttk::label
lappend widgets ::ttk::labelframe ::ttk::menubutton ::ttk::notebook
lappend widgets ::ttk::panedwindow ::ttk::progressbar ::ttk::radiobutton
lappend widgets ::ttk::scale ::ttk::scrollbar ::ttk::separator
lappend widgets ::ttk::sizegrip ::ttk::spinbox ::ttk::treeview
foreach w $widgets {
set new [namespace current]::[string map [list :: _] [string trimleft $w :]]
if {[catch {wrap $w $new} msg]} {
puts $w
puts $msg
}
}
}
proc ::tkoo::wrap {original new args} {
#create a dummy widget
set dummy .t
for {set i 0} {[winfo exists $dummy]} {incr i} {set dummy .t$i}
$original $dummy
#get a list of supported commands
catch {$dummy error} msg
set msg [string range $msg [expr [string first : $msg] + 2] end]
foreach c [lsearch -glob -all -inline $msg *,] {
lappend cmds [string range $c 0 end-1]
}
lappend cmds [lindex $msg end]
#get a list of supported options
set opts [$dummy configure]
#kill crash test dummies
destroy $dummy
#create the class
oo::class create $new {
superclass tkoo::widget
variable options widCmd pathname exists
}
#constructor
set map [list]
lappend map !OPTIONS! [list $opts]
lappend map !COMMAND! $original
oo::define $new constructor {wid args} [string map $map {
#does the class already exist
my Exists $wid
set widCmd $wid
set pathname $wid
#create all default options
if {![info exists options(list)]} {set options(list) [list]}
foreach o !OPTIONS! {
#loop through all options and add a default handler for them
if {[llength $o] != 5} {continue}
foreach {1 2 3 4 5} $o {}
if {[lsearch $options(list) $1] >= 0} {continue}
switch -exact -- $o {
-class -
-container -
-use -
-visual {
my Opt add $1 $2 $3 $4 {}
}
default {
my Opt add $1 $2 $3 $4 [string map [list !OPTION! $1] {
my variable options widCmd pathname exists
if {[winfo exists $pathname]} {
$widCmd configure !OPTION! $value
}
}]
}
}
}
#get options that can only be edited during creation
set cArgs [list]
for {set i 0} {$i < [llength $args]} {incr i 2} {
set o [lindex $args $i]
set v [lindex $args [expr $i + 1]]
switch -exact -- $o {
-class -
-container -
-visual {
lappend cArgs $o $v
}
default {}
}
}
#create the widget
if {![winfo exists $wid]} {!COMMAND! $wid {*}$cArgs}
#configure the widget
if {[llength $args]} {
my configure {*}$args
}
#default code
next $wid {*}$args
}]
foreach m $cmds {
switch -exact -- $m {
cget {}
configure {}
default {
oo::define $new method $m args [string map [list !METHOD! $m] {
return [tailcall $widCmd !METHOD! {*}$args]
}]
}
}
}
#return the name of the class created
return $new
}
proc ::tkoo::class {class body} {
set tail [namespace tail $class]
set ns [namespace qualifiers $class]
if {$ns eq ""} {
#find namespace name
set ns [uplevel 1 {namespace current}]
#find class name
set class ${ns}::$class
while {[string first ::: $class] > -1} {
set class [string map {::: ::} $class]
}
} elseif {![string match ::* $ns]} {
#find namespace name
set ns [uplevel 1 {namespace current}]::[namespace qualifiers $class]
while {[string first ::: $ns] > -1} {
set ns [string map {::: ::} $ns]
}
#find class name
set class ${ns}::[namespace tail $class]
while {[string first ::: $class] > -1} {
set class [string map {::: ::} $class]
}
}
set eval [string map [list !CLASS! $class !BODY! $body !TAIL! $tail !NS! $ns] {
namespace eval !CLASS! {
namespace export !TAIL!
oo::class create !CLASS!::widget {!BODY!}
proc !CLASS!::!TAIL! {pathname args} {return [namespace tail [widget new $pathname {*}$args]]}
namespace eval !NS! {
namespace import !CLASS!::!TAIL!
namespace export !TAIL!
}
}
}]
uplevel 1 [list eval $eval]
}
::tkoo::init