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 -privateappend -privateclear and -privateset 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 <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> ..
Remove previously defined component's.
cget <option> Get option values.
configure ?option value ..? Get and set options.
'component ?name?' Return all component names or the command of the given name.
_zz_method Access to private variables
_zz_component ?-private? name createcommand ?optionlist? Create components and private components.
The public array variable 'zz' is used to store options zz(-*) and components objects zz(:*) and component widgets zz(.*). The private array variable _zz is used to store private component object _zz(:*) and private component widgets _zz(.*).
::zz::class create togglelabel {
superclass zz::object
component . {label %W -text test} {keep -*}
constructor {args} {my configure {*}$args}
method toggle {} {
set myBg $zz(-background)
set myFg $zz(-foreground)
array set zz [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=$zz(-xyz)}
option -abc abc {puts zz1-abc=$zz(-abc)}
component . {toplevel %W}
component .l1 {label %W.l1 -text extern} {keep -text -bd -bd ignore -bd}
constructor args {
lappend zz(a) zz1
lappend _zz(my) zz1
my _zz_component -private .l2 {label $zz(.).l2 -text inside} {-text -text}
grid $zz(.l1) $_zz(.l2)
my configure {*}$args
}
destructor {}
method parray {name} {puts zz1>;::parray $name}
}
::zz::class create zz2 {
superclass zz1
option -xyz z2xyz {puts zz2-xyz=$zz(-xyz)}
component .l2 {label $zz(.).l3 -text outside} {-text -text}
destructor {}
constructor args {
lappend zz(a) zz2
lappend _zz(my) zz2
grid $zz(.l2)
}
method parray {name} {puts zz2>;::parray $name;next $name}
}
zz2 .z
.z parray zz
.z parray _zz# Helper functions.
interp alias {} ::? {} ::msgcat::mc
#===============================================================================
namespace eval ::zz {
## Customized ::oo::define command.
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 {
switch -- [lindex $args 1] {
-private - -privateappend {
foreach myVar [lrange $args 2 end] {
if {[lsearch [set ${class}::(vars)] $myVar] == -1} {
lappend ${class}::(vars) $myVar $myVar
}
}
}
-privateclear {
set ${class}::(vars) {_zz _zz}
}
-privateset {
set ${class}::(vars) {}
foreach myVar [lrange $args 2 end] {
lappend ${class}::(vars) $myVar $myVar
}
}
default {::oo::define $class variable {*}$args}
}
}
option {;# option value ?body? || delete option ..
if {[lindex $args 1] eq {delete}} {
foreach myOpt [lrange $args 2 end] {
if {[string index $myOpt 0] ne {-}} {
error [? {wrong option name: %1$s} $myOpt]
}
set myNr [lsearch [set ${class}::(optionsets)] $myName]
if {$myNr == -1} {error [? {option not found: %1$s} $myOpt]}
set ${class}::(optionsets) [lreplace [set ${class}::(optionsets)] $myNr $myNr]
set ${class}::(optioninit) [lreplace [set ${class}::(optioninit)] $myNr $myNr]
}
}
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 [set ${class}::(optionsets)] $myName]
if {$myNr == -1} {
lappend ${class}::(optionsets) $myName $myBody
lappend ${class}::(optioninit) $myOpt $myVal
} else {
set myNr [expr {1+$myNr*2}]
lset ${class}::(optionsets) $myNr $myBody
lset ${class}::(optioninit) $myNr $myVal
}
}
component {;# name createcmd ?optionlist? || delete name ..
if {[lindex $args 1] eq {delete}} {
foreach myName [lrange $args 2 end] {
set myNr [lsearch -index 0 [set ${class}::(complist)] $myName]
if {$myNr == -1} {error [? {component not found: %1$s} $myName]}
set ${class}::(complist) [lreplace [set ${class}::(complist)] $myNr $myNr]
}
}
lassign $args x myName myCmd myOpts
if {[string index $myName 0] ni {. :}} {
default {error [? {wrong comp name %1$s} $myName]}
}
if {[lsearch -index 0 [set ${class}::(complist)] $myName] != -1} {
error [? {comp name exists: %1$s} $myName]
}
lappend ${class}::(complist) [list $myName $myCmd $myOpts]
}
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.
::oo::define $myCls method _zz_trace {array field op} {
if {$op eq {}} {;# internal call to eval body in class context
eval $array
return
}
# array write call
if {[string index $field 0] ne {-}} return
set myC [self class]
# Ensure the option setting body of . comes last, TODO optimization
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) {} {}
}
}
}
# Internal class informations. Define private variable array _zz.
array set ${myCls}:: [list vars {_zz _zz} optionsets {} optioninit {} complist {}]
# Define internally used zz array variable.
my eval variable zz
# 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 {
foreach myComp [array names zz {[.,]*}] {
if {![info exists zz($myComp)]} continue;# may be already destroyed
if {[string index $myComp 0] eq {:}} {
$zz($myComp) destroy
continue
}
destroy $zz($myComp)
}
}
## 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} {
return [array get zz -*]
} 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} {
set myArgs {}
if {[catch {
foreach {o v} $args {
if {[string index $o 0] ne {-} || ![info exists zz($o)]} {
error [? {unknown option %1$s} $o]
}
lappend myArgs $o $zz($o)
set zz($o) $v
}
} myMsg]} {
my configure {*}$myArgs
error [? {error in configure: %1$s} $myMsg]
}
} else {
error [? {wrong configure: %s} $args]
}
}
## Return component command.
::oo::define ::zz::object method component {{comp {}}} {
if {$comp eq {}} {return [array names zz {[.,]*}]}
if {[string index $comp 0] ni {. ,} || ![info exists zz($comp)]} {
error [? {unknown comp %1$s} $comp]
}
return $zz($comp)
}
## 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 _zz_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
foreach myComp [array names $myVar {[.,]*}] {
if {[string index $myComp 0] eq {:}} {
catch {[set ${myVar}($myComp)] destroy}
continue
}
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)]]
}
## Work with components.
# - add new widget
# _zz_component ?-private? .* createcmd ?optionlist?
# - add new object
# _zz_component ?-private? ,* createcmd ?optionlist?
# - delete widget/object
# _zz_component ?-private? delete ..
::oo::define ::zz::object method _zz_component {args} {
set myCls [uplevel 1 self class]
if {[lindex $args 0] eq {-private}} {
set args [lrange $args 1 end]
set myVar [my varname { }]${myCls}::_zz
} else {
set myVar [my varname zz]
}
# Delete existing component
if {[lindex $args 0] eq {delete}} {
foreach myComp $args {
set myVar1 ${myVar}($myComp)
if {![info exists $myVar1]} return
# Remove option info
foreach myName [array names $myVar " $myCls $myComp -*"] {
unset ${myVar}($myName)
}
unset $myVar1
# Remove widget/object
if {[string index $myComp 0] eq {:}} {
catch {[set $myVar1] destroy}
continue
}
set w [set $myVar1]
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
}
}
return
}
# Add new component
lassign $args myComp myCmd myOpts
set myVar ${myVar}($myComp)
if {[info exists $myVar]} {
error [? {comp %1$s already exists} $myComp]
}
set myCopts {}
set myCvals {}
switch -- [string index $myComp 0] {
. {
set myW [lindex $myCmd 1]
if {[string range $myW 0 1] eq {%W}} {
lset myCmd 1 [namespace tail [self]][string range $myW 2 end]
}
if {$myComp eq {.}} {
set mySelf [self]
rename $mySelf ::zz::self
set w [uplevel 1 $myCmd]
foreach myList [$w configure] {
lappend myCopts [lindex $myList 0]
lappend myCvals [lindex $myList end]
}
set myCmd [list $w destroy]
rename $w ::${w}__zz__
set $myVar ${w}
set myW ::${w}__zz__
rename ::zz::self $mySelf
} else {
set w [uplevel 1 $myCmd]
set $myVar $w
set myCmd "array unset [my varname zz] \{ $myCls $myComp -*\} \; unset \{$myVar\}"
foreach myList [$w configure] {
lappend myCopts [lindex $myList 0]
lappend myCvals [lindex $myList end]
}
set myW [set $myVar]
}
bindtags $w [list ::zz::$w {*}[bindtags $w]]
bind ::zz::$w <Destroy> $myCmd
}
: {
set $myVar [uplevel 1 $myCmd]
foreach myList [$myCmd configure] {
lappend myCopts [lindex $myList 0]
lappend myCvals [lindex $myList end]
}
set myW [set $myVar]
}
default {error [? {wrong comp name %1$s} $myComp]}
}
# 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 $myVar]
}
#===============================================================================