Version 1 of Doing things

Updated 2002-12-06 13:45:20

Richard Suchenwirth - Things look good. In On things, I have shown a minimal OO API for Tcl, inspired by Self. Here's the initial implementation. See Doing things in namespaces for an advanced version.

Similar to Gadgets, a thing (which can be used like an object, or class... its untypedness fits Tcl pretty well) consists of an array in the caller's scope (may, but need not be global) and a proc, both of same name. The trivial one-liner proc is only needed so the thing can be called by name - it only redirects

 proc foo {args} {uplevel thing:dispatch foo $args}

The array holds the properties and the ways (methods) of the thing - all that is to know about the thing. The most important property is the is-a list that every thing has. This lists its superthings and is searched when retrieving a property or way.

The lookup is not transitive, i.e. superthings of superthings are not searched. This is for safety: as hierarchies are not predefined, cycles can easily occur. With a one-pass is-a list, the lookup is guaranteed to terminate. You can have multi-level inheritance if you specify all super*things in the is-a list (OK, not exactly elegant).

Setting properties or ways is always done in the specified thing itself (in contrast to Tcl's namespace resolution, see Dangers of creative writing).

Ways are also in the same array. They are something like procs: they have a name, an arglist (args feature not yet supported) and a body. But using China Blue's procless lambda trick (see Lambda in Tcl), they act like pure lambdas: A list of arglist and body is the value of the (ticked) name and can be assigned to another. To distinguish ways from properties, their name gets a tick prefixed which is stripped off again when listed, so

 foo wayto bar {x {expr !$x}} == foo set 'bar {x {expr !$x}}

Now here's the thing:

 proc thing {name args} {
    if {$name=="-names"} {return [thing:names]}
    if {[info commands $name]!=""} {error "can't make thing $name: exists"}
    upvar 1 $name self
    set           self(is-a) {}
    array set     self $args
    regsub @name {uplevel thing:dispatch @name $args} $name body
    proc   $name args $body
    uplevel trace var $name u thing:unset
    proc thing:names {} [concat [info body thing:names] $name]
    set name
 }

Thing procs are removed when the whole thing (not just an array element) is unset:

 proc thing:unset {name el -} {
    if {$el==""} {
        rename $name ""
        set names [info body thing:names]
        set where [lsearch $names $name]
        if {$where>0} {
           proc thing:names {} [lreplace $names $where $where]
        }
    }
 }

The list of things is maintained in a proc body that is extended when a new thing is created, or purged when a thing is deleted:

 proc thing:names {} {list}

All thing invocations (the built-ins set, get, unset, is-a, wayto and the ways - I added get as synonym for set, just for sugar) go through this dispatcher:

 proc thing:dispatch {name way args} {
    upvar 1 $name self
    switch -- $way {
        get - set {
            switch -- [llength $args] {
                0 {
                    set res [array names self]
                    foreach i $self(is-a) {
                        ladd res [uplevel array names $i]
                    }
                    return $res
                }
                1 {
                    foreach i [concat $name $self(is-a)] {
                        if [llength [uplevel array names $i $args]] {
                            return [uplevel set [set i]($args)]
                        }
                    }
                }
                default {
                    array set self $args
                    return [lindex $args end]
                }
            }
        }
        unset {foreach i $args {unset self($i)}}
        is-a {
            if [llength $args] {lappend self(is-a) $args}
            return $self(is-a)
        }
        wayto {
            switch -- [llength $args] {
                0 {
                    set res [list]
                    foreach i [concat $name $self(is-a)] {
                        foreach j [uplevel array names $i '*] {
                            regexp {^'(.+)} $j -> i2
                            ladd res $i2
                        }
                    }
                    return $res
                }
                1 {set self('$args)}
                2 {
                    foreach {wayname waylambda} $args break 
                    set self('$wayname) $waylambda
                }
            }
        }
        default {
            foreach i [concat $name $self(is-a)] {
                if [llength [uplevel array names $i '$way]] {
                    upvar 1 $i super
                    foreach {argl body} $super('$way) break
                    if [llength $argl] {
                       foreach $argl $args break ;# binding to locals
                    }
                    return [eval $body]
                }
            }
            error "$way? Use one of: set, unset, is-a, [uplevel $name wayto]"
        }
    }
 }

Little helper for lappending if the list doesn't have it yet:

 proc ladd {_L list} {
    upvar 1 $_L L
    foreach i $list {
        if {[lsearch $L $i]<0} {lappend L $i}
    }
 }

That's it. Finally, my little test suite:

 ###################### Test code
 set tests {
    thing human legs 2
    thing Socrates is-a {human philosopher}
    human set mortal 1
    Socrates is-a
    Socrates set hair white
    Socrates set hair
    Socrates unset hair
    Socrates set mortal
    Socrates set
    human wayto sing {text {subst $text,$text,lala}}
    Socrates wayto sing {{text} {subst "$text, haha."}}
    Socrates wayto sing
    Socrates wayto
    Socrates sing Lali
    [thing Joe is-a human] sing hey
    thing Plato
    Plato wayto sing [Socrates wayto sing]
    Plato sing kalimera
    catch {Socrates help} res
    set res
    thing -names
 }
 foreach i [split $tests \n] {
    puts "$i => [eval $i]"
 }

General trace handler: I am experimenting with the following handler that will be called on all accesses to a thing:

 proc thing:trace {name el mode} {
    if {$el=="" && $mode=="u"} {
        rename $name ""
        set names [info body thing:names]
        set where [lsearch $names $name]
        if {$where>0} {
            proc thing:names {} [lreplace $names $where $where]
        }
    } else {
        upvar 1 $name self
        if [info exists self('$mode'$el)] {
            foreach {argl body} $self('$mode'$el) break
            if [llength $argl] {
                foreach $argl $args break ;# binding to locals
            }
            return [uplevel $body]
        }
    }
 }

It includes the original unset trace for the whole array, but in addition checks whether a way for the operation and element exists, so the test suite can be extended to

 Socrates wayto w'legs {{} {puts "hey, I $name have $self(legs) legs"}}
 Socrates wayto u'legs {{} {puts "hey, I $name need legs"}}
 Socrates set legs 3
 Socrates unset legs

No sugaring for the trace mode letter yet... which is activated by replacing the trace line in proc thing by

    uplevel trace var $name rwu thing:trace

Category Object Orientation | Arts and crafts of Tcl-Tk programming