RZ I'm missing some features in plain TclOO. So I added these features on top of it. Feel free to comment or use it.
Everything is on top of TclOO. The class ::zz::class contains the ::oo::class commands and the additional features. The ::zz::define command contains the ::oo::define commands and the additional features. New classes should use ::zz::object as superclass. All classes will be created with the createWithNamespace function of TclOO. New Object will be created without the new function. The new object name is the first parameter.
constructor Access to private variables, setup internal structures and calling next destructor Access to private variables, deleting components and calling next method Access to private variables variable Additional -private and -privateclear switches
option <name> <value> <body>
Define new option. The <body> will on optionsetting in the current class context evaluated.
option delete <name> ..
Remove previously defined option.
component add <name> createcommand ?optionlist?
component addprivate <name> createcommand ?optionlist?
Define new component. If the name starts with '.' (dot) it is a widget. If name is '.' (only a dot) it will make the current object act as a widget. If the name starts with ':' (double colon) it is a object.
The createcommand will be evaluated to create the component. It should return the component command. Component commands should also have cget/configure methods to access options. If the second word inside the createcomand start with %W then %W is replaced with the current object widget '$zz(.)'
The optionlist is a "key value" list.
If key is keep then value is used as an option list. All component options matching one of these entries will be added to the object options.
If key is ignore then value is used as an option list. All already defined component options matching one of these entries will be deleted.
If key and value is starting with '-' (minus sign) then component option names key is mapped to object option value.
component delete <name> ..
component deleteprivate <name> ..
Remove previously defined component's.
cget <option> Get option values.
configure ?option value ..? Get and set options.
'component' Return all component names.
'component <name>' Return command of the given name.
'component args' See above for the add* and del* command syntax.
_zz_constructor Setup internal variables
_zz_destructor Internal cleanup
_zz_method Access to private variables
The public array variable '{}' is used to store options (-*) and components objects (:*) and component widgets (.*). The private array variable _ is used to store private component object _(:*) and private component widgets _(.*).
::zz::class create togglelabel { superclass zz::object component . {label %W -text test} {keep -*} constructor {args} {my configure {*}$args} method toggle {} { set myBg $(-background) set myFg $(-foreground) array set {} [list -foreground $myBg -background $myFg] } togglelabel .l -foreground black -background white] .l toggle
::zz::class create zz1 { superclass zz::object option -xyz z1xyz {puts zz1-xyz=$(-xyz)} option -abc abc {puts zz1-abc=$(-abc)} component add . {toplevel %W} component add .l1 {label %W.l1 -text extern} {keep -text -bd -bd ignore -bd} constructor args { lappend (a) zz1 lappend _(my) zz1 my component addprivate .l2 {label $(.).l2 -text inside} {-text -text} grid $(.l1) $_(.l2) my configure {*}$args } destructor {} method parray {name} {puts zz1>;::parray $name} } ::zz::class create zz2 { superclass zz1 option -xyz z2xyz {puts zz2-xyz=$(-xyz)} component add .l2 {label $(.).l3 -text outside} {-text -text} destructor {} constructor args { lappend (a) zz2 lappend _(my) zz2 grid $(.l2) } method parray {name} {puts zz2>;::parray $name;next $name} } zz2 .z .z parray "" .z parray _
# Helper functions. interp alias {} ::? {} ::msgcat::mc #=============================================================================== namespace eval ::zz { ## Customized ::oo::define command. # # Constructor with private variables, next and initialization: # constructor arglist body # # Destructor with private variables, next and internal clean up: # destructor body # # Method with private variables: # method arglist body # # Definition of additional private variables: # variable -private <name> .. # Remove all private variables: # variable -privateclear # # New definition or overwrite of options: # option <-name> value ?body? # Remove of existing options: # option delete <-name> .. # # Handling of components. See method component for documentation. # component add <component> createcmd ?optionlist? # component addprivate <component> createcmd ?optionlist? # component delete <component> .. # component deleteprivate <component> .. # proc define {class args} { switch -- [lindex $args 0] { constructor {::oo::define $class {*}[lrange $args 0 1]\ "my _zz_method;next;my _zz_constructor\n[lindex $args 2]" } destructor {::oo::define $class [lindex $args 0]\ "my _zz_method\n[lindex $args 1] \nmy _zz_destructor;next" } method {::oo::define $class {*}[lrange $args 0 2]\ "my _zz_method\n[lindex $args 3]" } variable { upvar 0 ${class}::(vars) _ switch -- [lindex $args 1] { -private { foreach myVar [lrange $args 2 end] { if {[lsearch $_ $myVar] == -1} {lappend _ $myVar $myVar} } } -privateclear {set _ {_ _}} default {::oo::define $class variable {*}$args} } } option { upvar 0 ${class}:: _ if {[lindex $args 1] eq {delete}} { set myName " $class\ -\ " foreach myOpt [lrange $args 2 end] { if {[string index $myOpt 0] ne {-}} { error [? {wrong option name: %1$s} $myOpt] } set myNr [lsearch $_(optionsets) $myName$myOpt] if {$myNr == -1} {error [? {option not found: %1$s} $myOpt]} set _(optionsets) [lreplace $_(optionsets) $myNr $myNr] set _(optioninit) [lreplace $_(optioninit) $myNr $myNr] } } else { lassign $args x myOpt myVal myBody if {[string index $myOpt 0] ne {-}} { error [? {wrong option name: %1$s} $myOpt] } set myName " $class\ -\ $myOpt" set myNr [lsearch $_(optionsets) $myName] if {$myNr == -1} { lappend _(optionsets) $myName $myBody lappend _(optioninit) $myOpt $myVal } else { lset _(optionsets) [incr myNr] $myBody lset _(optioninit) $myNr $myVal } } } component { upvar 0 ${class}::(complist) _ switch -- [lindex $args 1] { add - addprivate { lassign $args x myMode myName myCmd myOpts if {[string index $myName 0] ni {. :}} { default {error [? {wrong comp name %1$s} $myName]} } foreach myL $_ { if {[lindex $myL 1] eq $myName && [lindex $myL 0] eq $myMode} { error [? {comp name exists%1$s} $myName] } } lappend _ [list $myMode $myName $myCmd $myOpts] } delete - deleteprivate { if {[lindex $args 1] eq {delete}} { set myMode add } else { set myMode addprivate } foreach myName [lrange $args 2 end] { set myNr 0 foreach myL $_ { if {[lindex $myL 1] eq $myName && [lindex $myL 0] eq $myMode} { set _ [lreplace $_ $myNr $myNr] set myNr -1 break } incr myNr } if {$myNr != -1} {error [? {component not found: %1$s} $myName]} } } default {[? {wrong component command '%1$s', should be one of %2$s}\ [lindex $args 1] {add addprivate delete deleteprivate}] } } } default {tailcall ::oo::define $class {*}$args} } } } #=============================================================================== ## Customized ::oo::class command. ::oo::class create ::zz::class { superclass ::oo::class self export createWithNamespace self unexport new ## Always create new classes with namespace. # See "oo::class create" command. self method create {args} { return [uplevel 1 [list [self] createWithNamespace [lindex $args 0] {*}$args]] } ## Build new class using ::zz::class with additional commands. constructor {args} { # Current class name. set myCls [self object] # Make ::zz::* methods in class definition available. foreach myName {constructor destructor method variable option component} { interp alias {} [self namespace]::$myName {} ::zz::define $myCls $myName } # Make ::oo::define methods available. foreach myName {renamemethod deletemethod forward unexport mixin superclass export filter} { interp alias {} [self namespace]::$myName {} ::oo::define $myCls $myName } ## Internal method to handle option setting. # Defined in each class to support access to private class parts. # If op is empty then eval command given in array (internal usage only!) # Otherwise call al option related bodies. ::oo::define $myCls method _zz_trace {array field op} { if {$op eq {}} {eval $array ; return};# eval body if {[string index $field 0] ne {-}} return;# no option # Ensure the option setting body of . comes last, TODO optimization set myC [self class] foreach myList [lsort -decreasing [array names $array *\ $field]] { lassign $myList myCls myCmp myOpt if {$myCls eq $myC} { my _zz_trace $($myList) {} {} } else { nextto $myCls $($myList) {} {} } } } # Internal class informations. Define class definition variables. array set ${myCls}:: [list vars {_ _} optionsets {} optioninit {} complist {}] # Define internally used array variable. ::oo::define $myCls variable {} # Add ::zz::object to list of superclasses if {$myCls ne {::zz::object}} { ::oo::define $myCls {superclass ::zz::object} } # Define default constructor ::zz::define $myCls constructor args {} # Define default destructor. ::zz::define $myCls destructor {} # Read and evaluate the class definition. my eval {*}$args } ## Enable object creation with namespace and without "new" word. method unknown {args} { my createWithNamespace ::[lindex $args 0] {*}$args } } #=============================================================================== ## Class to create objects. Define class methods with ::oo::define! ::zz::class create ::zz::object { ## Array variable to hold internal informations. # (-*) Value of option. # (.*) Component widget command. # (:*) Component object command. # ( <class> <comp> <option>) Used body when setting options. variable {} } ## ::oo::define ::zz::object constructor {args} { } ## ::oo::define ::zz::object destructor { foreach myComp [array names {} {[.:]*}] { if {![info exists ($myComp)]} continue;# may be already destroyed if {[string index $myComp 0] eq {:}} { $($myComp) destroy continue } destroy $($myComp) } } ## Return value of configuration option. ::oo::define ::zz::object method cget {option} { if {[string index $option 0] ne {-} || ![info exists ($option)]} { error [? {unknown option %1$s} $option] } return $($option) } ## Work with configuration options. ::oo::define ::zz::object method configure {args} { set l [llength $args] if {$l == 0} { set myRet {} foreach myOpt [lsort [array names {} -*]] { lappend myRet $myOpt $($myOpt) } return $myRet } elseif {$l == 1} {;# same as cget() function if {[string index $args 0] ne {-} || ![info exists ($args)]} { error [? {unknown option %1$s} $args] } return $($args) } elseif {$l%2 == 0} { set myArgs {} if {[catch { foreach {o v} $args { if {[string index $o 0] ne {-} || ![info exists ($o)]} { error [? {unknown option %1$s} $o] } lappend myArgs $o $($o) set ($o) $v } } myMsg]} { my configure {*}$myArgs error [? {error in configure: %1$s} $myMsg] } } else { error [? {wrong configure: %s} $args] } } ## Component command. # <component> names starting with . are treated as widgets. # <component> names starting with : are treated as objects. # # Get list of available public components: # component # Get command of available public component: # component <component> # Add new public component: # component add <component> createcmd ?optionlist? # Add new private component: # component addprivate <component> createcmd ?optionlist? # Delete existing public component: # component delete <component> .. # Delete existing private component: # component deleteprivate <component> .. # # \note Defined with ::zz::define to access private variable _. ::zz::define ::zz::object method component {args} { # Return public component names if {$args eq {}} {return [array names {} {[.:]*}]} set myMode [lindex $args 0] # Return public component command if {[string index $myMode 0] in {. :}} { if {[info exists ($myMode)]} { return $($myMode) } error [? {unknown component %1$s} $myMode] } # Add and delete components set myCls [uplevel 1 self class] set args [lrange $args 1 end] switch -- $myMode { add - addprivate {;# Add new component if {$myMode eq {add}} { set myVar [my varname {}] } else { set myVar [my varname { }]${myCls}::_ } lassign $args myComp myCmd myOpts set myCompvar ${myVar}($myComp) if {[info exists $myCompvar]} { error [? {comp %1$s already exists} $myComp] } set myCopts {} set myCvals {} switch -- [string index $myComp 0] { . { set myCmd [string map [list %W [namespace tail [self]]] $myCmd] if {$myComp eq {.}} { set mySelf [self] rename $mySelf ::zz::self set w [uplevel 1 $myCmd] set myW ::${w}__zz__ set myBind [list $w destroy] rename $w $myW rename ::zz::self $mySelf } else { set w [uplevel 1 $myCmd] set myW $w set myBind "array unset \{$myVar\} \{ $myCls $myComp -*\} \; unset \{$myCompvar\}" } set $myCompvar $w bindtags $w [list ::zz::$w {*}[bindtags $w]] bind ::zz::$w <Destroy> $myBind } : { set $myCompvar [uplevel 1 $myCmd] foreach myList [$myCmd configure] { lappend myCopts [lindex $myList 0] lappend myCvals [lindex $myList end] } set myW [set $myCompvar] } default {error [? {wrong comp name %1$s} $myComp]} } foreach myList [$myW configure] { lappend myCopts [lindex $myList 0] lappend myCvals [lindex $myList end] } # Get all component options array set myFound {} foreach {myFrom myTo} $myOpts { if {[string index $myFrom 0] eq {-}} {;# -copt -opt if {[string index $myTo 0] ne {-}} { error [? {wrong option name: %1$s} $myTo] } set myNr [lsearch $myCopts $myFrom] if {$myNr == -1} { error [? {option not found: %1$s} $myFrom] } append myFound($myTo) "\n$myW configure $myFrom \$($myTo)" if {[lsearch $myCopts $myTo] == -1} { lappend myCopts $myTo lappend myCvals [lindex $myCvals $myNr] } } elseif {$myFrom eq {keep}} {;# keep -* foreach myT $myTo { foreach myO [lsearch -inline -glob -all $myCopts $myT] { append myFound($myO) "\n$myW configure $myO \$($myO)" } } } elseif {$myFrom eq {ignore}} {;# ignore -* foreach myT $myTo { foreach myO [array names myFound $myT] {unset myFound($myO)} } } else { error [? {wrong from part name: %1$s} $myFrom] } } # Set options foreach myOpt [array names myFound] { set (\ $myCls\ $myComp\ $myOpt) $myFound($myOpt) if {![info exists ($myOpt)]} { set ($myOpt) [lindex $myCvals [lsearch $myCopts $myOpt]] } } return [set $myCompvar] } delete - deleteprivate {;# Delete existing component if {$myMode eq {delete}} { set myVar [my varname {}] } else { set myVar [my varname { }]${myCls}::_ } foreach myComp $args { set myCompvar ${myVar}($myComp) if {![info exists $myCompvar]} return # Remove option info array unset $myVar " $myCls $myComp -*" unset $myCompvar # Remove widget/object if {[string index $myComp 0] eq {:}} { catch {[set $myCompvar] destroy} continue } set w [set $myCompvar] if {[winfo exists $w]} { set myTags [bindtags $w] set i [lsearch $myTags "::zz::$w"] if {$i >= 0} { bindtags $w [lreplace $myTags $i $i] } bind ::zz::$w <Destroy> {} destroy $w } } } default {[? {wrong command '%1$s', should be one of %2$s}\ [lindex $args 1] {add addprivate delete deleteprivate}] } } } ## Function for use in constructor. ::oo::define ::zz::object method _zz_constructor {} { set myCls [uplevel 1 self class] array set {} [set ${myCls}::(optionsets)] array set {} [set ${myCls}::(optioninit)] foreach myList [set ${myCls}::(complist)] { uplevel 1 [list my component {*}$myList] } # Start option variable trace in outermost class if {[info object class [self object]] eq $myCls} { trace add var [my varname {}] write [list [namespace which my] _zz_trace] } } ## Function for use in destructor. ::oo::define ::zz::object method _zz_destructor {} { set myCls [uplevel 1 self class] set myVar [my varname { }]${myCls}::_ foreach myComp [array names $myVar {[.:]*}] { if {[string index $myComp 0] eq {:}} { catch {[set ${myVar}($myComp)] destroy} } else { catch {destroy [set ${myVar}($myComp)]} } } } ## Function to access private variables. ::oo::define ::zz::object method _zz_method {} { set myCls [uplevel 1 self class] set myNs [my varname { }]$myCls namespace eval $myNs {} uplevel 1 [list namespace upvar $myNs {*}[set ${myCls}::(vars)]] } #===============================================================================
DKF: My main comment is this: have you put this in a repository somewhere? It's much easier to develop when you've got proper history mechanisms available. If you prefer fossil, check out http://chiselapp.com (run by Roy Keene), if you prefer git, there's github of course, and for subversion you're probably better with google code.
Aside from that, a very useful technique for doing the configure is to evaluate the user's script in a namespace (that's what oo::define really is doing, with some small extra tricks). It's great, because it takes very little code to do right. I'd also commend using forwarded methods as a technique for exposing methods from underlying widgets; by putting the contained implementation widgets in the instance namespace, you get automatic cleanup and concealment and organisation for almost nothing.
RZ This is so far just a proof of concept. If it is working I will put it into some fossil repository and remove the code from here. TclOO is still a great tool but I hope to get private variables directly in it in time ;) Options, cget/configure and components would be fine too. But this is more tricky and can be evaluated in scripted extensions.
Do you mean by configure the option setting part? Here I have used the _zz_trace function to evaluate code in the correct namespace. This is necessary to access private variables. Is there a better solution for this task?
I'm at loss with your hint to use forward. For which part should I use it?
To make cleanup easy I have put all private variables on the same place as normal variables. But I have used here for each class a separate sub-namespace. This prevent collisions because normal variables could not contain the : sign.
Component widgets and objects need still deletion by hand. Therefore the destructor and _zz_destructor functions.
DKF: The little megawidget framework inside Tk (see library/megawidget.tcl) puts the real Tk widgets it wraps inside its instance namespace and forwards some methods on to them. For example, if you embedded a button and wanted to expose its flash method, you might do:
oo::define megabuttonclass { forward flash buttonWidget flash }
Where buttonWidget is what the button has been renamed to inside the instance. This is a class-level forwarding that forwards to something in an instance (technically, the forwarding target command is resolved with respect to the instance namespace); you can do a lot of clever stuff with this. TclOO is an extremely heavy user of Tcl's namespace and stack frame facilities; because of this, it required almost no core changes.
RZ Thank you for the example.