[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:
   * BindDestroy - Private method called when the widget is destroyed. It is used to destroy the OO object.
   * configure - Public method used to retrieve or change widget configuration.
   * cget - Public method used to retrieve widget configuration
   * Opt - Private method used to add and remove options.
   * Exists - Private method called at the first of the constructor to make sure the widget hasn't already been created.

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::autoscroll]
   * [tkoo::browser]
   * [tkoo::dtree]
   * [tkoo::etext]
   * [tkoo::scrolledframe]

======tcl
#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

======

<<categories>> Widget | Object Orientation