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.
option <name> <value> <body>
option delete <name> ..
component add <name> createcommand ?optionlist?
component addprivate <name> createcommand ?optionlist?
component delete <name> ..
component deleteprivate <name> ..
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 _catch {rename ::? {}}
## Helper function for msgcat::mc command inside classes.
proc ::? {args} {
if {[catch {set myNs [uplevel 1 self class]}]} {
set myNs [uplevel 1 namespace current]
}
namespace eval $myNs ::msgcat::mc $args
}
#===============================================================================
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 _ {_zz _zz}}
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 \c _zz_trace 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 all option related bodies.
set myBody "namespace upvar \[my varname { }\]$myCls {*}\$${myCls}::(vars)"
append myBody {
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 $zz($myList) {} {}
} else {
nextto $myCls $zz($myList) {} {}
}
}
}
::oo::define $myCls method _zz_trace {array field op} $myBody
# Internal class informations. Define class definition variables.
array set ${myCls}:: [list vars {_zz _zz} optionsets {} optioninit {} complist {}]
# Define internally used array variable.
::oo::define $myCls variable zz
# 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 zz
}
#-------------------------------------------------------------------------------
##
::oo::define ::zz::object constructor {args} { }
#-------------------------------------------------------------------------------
##
::oo::define ::zz::object destructor {
# object
foreach {myN myV} [array get zz :*] {$myV destroy}
# widget
if {[info exists zz(.)]} {
if {[winfo exists $zz(.)]} {destroy $zz(.)}
} else {
foreach {myN myV} [array get zz .*] {
if {[winfo exists $myV]} {destroy $myV}
}
}
}
## Return value of configuration option.
::oo::define ::zz::object method cget {option} {
if {[string index $option 0] ne {-} || ![info exists zz($option)]} {
error [? {unknown option %1$s} $option]
}
return $zz($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 zz -*]] {
lappend myRet $myOpt $zz($myOpt)
}
return $myRet
} elseif {$l == 1} {;# same as cget() function
if {[string index $args 0] ne {-} || ![info exists zz($args)]} {
error [? {unknown option %1$s} $args]
}
return $zz($args)
} elseif {$l%2 == 0} {
foreach {o v} $args {
if {[string index $o 0] ne {-} || ![info exists zz($o)]} {
error [? {unknown option %1$s} $o]
}
set myOld $zz($o)
if {[catch {set zz($o) $v} myMsg]} {
catch {set zz($o) $myOld}
error [? {error in configure %1$s: %2$s} $o $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.
::zz::define ::zz::object method component {args} {
# Return public component names
if {$args eq {}} {return [array names zz {[.:]*}]}
set myMode [lindex $args 0]
# Return public component command
if {[string index $myMode 0] in {. :}} {
if {[info exists zz($myMode)]} {
return $zz($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 zz]
} else {
set myVar [my varname { }]${myCls}::_zz
}
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 -nocomplain \{$myCompvar\}"
}
set w [string trimleft $w :]
bindtags $w [list zz$myW {*}[bindtags $w]]
bind zz$myW <Destroy> $myBind
set $myCompvar $w
}
: {
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 \$zz($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 \$zz($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 zz(\ $myCls\ $myComp\ $myOpt) $myFound($myOpt)
if {![info exists zz($myOpt)]} {
set zz($myOpt) [lindex $myCvals [lsearch $myCopts $myOpt]]
}
}
return [set $myCompvar]
}
delete - deleteprivate {;# Delete existing component
if {$myMode eq {delete}} {
set myVar [my varname zz]
} else {
set myVar [my varname { }]${myCls}::_zz
}
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 zz [set ${myCls}::(optionsets)]
array set zz [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 zz] 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}::_zz
# object
foreach {myN myV} [array get $myVar :*] {$myV destroy}
# widget
if {[info exists ${myVar}(.)]} {
set myV [set ${myVar}(.)]
if {[winfo exists $myV]} {destroy $myV}
} else {
foreach {myN myV} [array get $myVar .*] {
if {[winfo exists $myV]} {destroy $myV}
}
}
}
#-------------------------------------------------------------------------------
## 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)]]
}
#-------------------------------------------------------------------------------
## Function to access private variables.
::oo::define ::zz::object method _zz_varname {name} {
return [my varname { }][uplevel 1 self class]::$name
}
#-------------------------------------------------------------------------------
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.