Updated 2016-08-29 13:47:08 by dkf ▲

TclOO extension edit

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.

  • private variables (see also TclOO private variables)
  • options with cget/configure function
  • components (object and widgets) with integration in cget/configure methods
  • private components

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.

Enhanced commands

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

New class commands

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.

New object commands

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.

Commands inside methods

_zz_constructor
Setup internal variables
_zz_destructor
Internal cleanup
_zz_method
Access to private variables

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 _(.*).

Examples edit

Extending 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

Private variables, components

::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 _

Code edit

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
}
#-------------------------------------------------------------------------------

Comments edit

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.

TclOO