GJS 2012/5/12 This is my first attempt at an OO class for Tk.
This package creates several classes all in the tkoo namespace.
tkoo::widget is the base widget class. On it's 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.
#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