Updated 2014-02-09 16:54:53 by dkf

Richard Suchenwirth 2002-10-03 - Oh-oh, we've done it so often - here I go again... Object orientation is a strong fashion in programming. There are several OO systems for Tcl, but the fact that none has taken Tclworld by storm seems to indicate that we are not as concerned with this fashion as followers of other languages are. Still, OO concepts ever again have a certain fascination. Let's look at fictitious examples:
 class Foo  ;# introduce a class "Foo" of objects
 Foo bar    ;# create an object of class "Foo" named "bar"
 bar say hi ;# invoke method "say" of class "Foo" for object "bar",
            ;# amounts to: Foo::say bar hi

and make them come to life, using namespaces and interp aliases. The idea is that every class has one namespace (to put its methods), and every object has a child namespace of its class' (to put its instance variables). For each class, its constructor is aliased to its name; for each object, its dispatcher is aliased to its name, and its "evaluator" to its name followed by a colon (see below). The following code evolved over a weekend and features (limited) multiple inheritance and garbage collection:
 namespace eval class {variable count 0 names ""}
 
 proc class {{name ""} {superclasses ""} args} {
    upvar #0 ::class::names names
    if {$name == ""} {return $names} ;# another introspection helper
    if {[lsearch $names $name]<0} {lappend names $name}
    # -- maybe inherit from superclasses
    set inheritedVars {}
    foreach superclass $superclasses {
        $superclass _ ;# temporary instance to ask for methods and vars
        foreach method [_ methods] {
            interp alias {} ${name}::$method {} ${superclass}::$method
        }
        foreach var [_ vars] {lappend inheritedVars $var [_: set $var]}
        _ delete
    }
    # -- inherit standard methods from 'class' to the new one
    foreach method {delete methods vars} {
        interp alias {} ${name}::$method {} class::$method $name
    }
    # -- The constructor is just called like the name of the class
    set args [concat $inheritedVars $args]
    interp alias {} $name {} class::new $name $args
 }
 proc class::new {class defaults {self ""} args} {
    if {$self == ""} {
        return [string map [list ::${class}:: ""]\
                     [namespace children ::$class]]
    }
    # -- make sure we're not clobbering an existing command
    if {[info command $self] != ""} {error "$self exists"}
    # -- if wanted, auto-create a unique object name
    if {$self == "#auto"} {variable count; set self $class#[incr count]}
    # -- create sugar for 'namespace eval' access
    interp alias {} $self: {} namespace eval ::${class}::$self
    # -- set the instance variables known so far
    namespace eval ::${class}::$self variable $defaults $args
    # -- if present, call custom constructor
    if {[info command ::${class}::new] != ""} {::${class}::new $self}
    # -- prepare garbage collection (see discussion below - turned off)
    #uplevel 1 "set $self ::${class}::$self"
    #uplevel 1 "trace var $self wu {catch {$self delete} ;#}"
    # -- The dispatcher is just called like the name of the object
    interp alias {} $self  {} class::dispatch $class $self
 }
 proc class::delete {class self} {
    # -- if present, call custom destructor
    if {[info command ::${class}::del] != ""} {::${class}::del $self}
    # -- remove object namespace, hence all instance variables
    namespace delete ::${class}::$self
    # -- remove the two object aliases
    foreach i [list $self $self:] {interp alias {} $i {} {}}
    uplevel 1 "catch {unset $self}" ;# remove caller's reference
 }
 proc class::dispatch {class self {cmd methods} args} {
    # -- turn 'foo bar grill' into 'Class::bar foo grill'
    # -- Command name defaults to 'methods', as introspection help
    uplevel 1 [list ::${class}::$cmd $self] $args
 }
 proc class::methods {class -} {
    # -- make a list of methods available for class
    set prefix ::${class}::
    string map [list $prefix ""] [info commands $prefix*]
 }
 proc class::vars {class self} {
    # -- make a list of variable names available for object
    set prefix ::${class}::${self}::
    string map [list $prefix ""] [info vars $prefix*]
 }

Now testing... We create a class Boy, with custom constructor and destructor (which must be named "del", to preserve the Foo::delete alias) and some class methods, all in usual namespace notation; instantiate an object (both here and at class creation can instance variables with default values be specified) and try out all our new toys :-}
 class Boy  {}  arms 2 hairs 1000               ;# defaults for i. variables
 proc  Boy::new {self} {$self: variable legs 2} ;# another default
 proc  Boy::del {self} {puts "$self says goodbye..."}
 proc  Boy::say {self what} {
    puts "Hi, as a [namespace current] named $self I say: $what"
 }
 proc  Boy::showLegs {self {n ""}} {
    if {$n != ""} {$self: [list set legs $n]} ;# need [list] to wrap
    puts "I have [$self: set legs] legs"
 }
 #-------------------------------- Now playing around with it ...
 Boy sue age "42 +" hairs 500 ;# add new instance variable, and override one
 sue say "hello, world!"
 puts "[sue: set legs] legs"
 sue showLegs
 sue showLegs "exactly two"
 sue: set hair(beard) white
 puts [sue: array get hair]

Works, and is pretty lean: this "OO system" costs just a few procs in 40+ (pretty dense) lines of code... (I've almost doubled this figure by generously commenting what goes on, contrary to my habits ;-).

Classes inherit the generic constructor and destructor, but can also provide custom ones; objects inherit the generic dispatcher and evaluator (when called with trailing colon ":"). Instance variables can be introduced per class or object. Make sure that variables really exist in your namespace - otherwise you might end up in existing global variables instead. Using colon, we can execute all global commands in the Boy::sue namespace. This allows read/write/unset access to all instance variables - so I don't have to handle special cases of arrays, etc. You may consider "sue:" as a shorthand for "sue eval", that's how I started this, but the syntax
 object: set variable ?value?

reads so much nicer... Now testing object deletion:
 Boy shortlived
 shortlived: set tolive 0
 shortlived delete
 catch {shortlived: set tolive} res
 puts $res
 puts [info commands short*]

So what have we got here? A tiny framework for a class hierarchy (all classes inherit from class, and possible superclasses) where you can add or remove class methods or instance variables at any time, and introspect them with the methods and vars methods. No "private" or "protected" parts - this is more about freedom than encapsulation. You get most freedom (and save you and me work) by the namespace eval gateway, which exists in Tcl anyway, and the sweet sue: shorthand for it. One line of code buys us optional automatic object name generation, as known from incr Tcl. But as commands and namespaces go, all objects are global and persistent, so you have to delete them explicitly when done.

Looks like interp alias and namespaces indeed provide 95% of what's needed for (some flavor of) OO in Tcl...

"The tinkering then goes on for the rest of your life", as someone wrote about trains3.tcl. Here's how class inheritance (even multiple) is implemented: methods of superclasses are aliased, declared instance variables, with default values, are stored in the constructor alias. Note however that methods and vars are in sort of flat lists - if the superclasses have equally-named items, the last one wins. Also, the inherited methods and vars are a snapshot - if the superclasses later get more of them, they won't be automatically known to the subclass (but as shown below with the Truck::sound method, superclass methods can be called - as well as methods of any other class, e.g. Dog::sound...) Again, this is not about encapsulation, or preventing the programmer from doing certain things. Like before, you can do everything with Tcl, and this OO sugar just makes some things easier to write and read.
 #------------------------- testing inheritance ...
 class Car       {} wheels 4  motor gasoline  mph 100
 proc  Car::sound self {return honk} ;# will be overridden in test

 class Container {} volume ""  covered 1
 proc  Container::sound self {return rattle}

 class Truck     {Car Container} motor Diesel  mph 60
 proc  Truck::brake self {return screech!}

 Truck t1 volume 40m3  payload 30t  owner "John Smith"  wheels 6
 puts "Before: [t1 sound]"
 proc Truck::sound self {
    return [Car::sound $self],[Container::sound $self]
 }
 puts "After:  [t1 sound]"
 foreach var [t1 vars] {puts "$var: [t1: set $var]"}
 puts "Methods: [t1 methods]"

Works like expected again - after Tcl'ing for years, I'm yet again amazed by the power of the language, in this case the interp and namespace commands... and tinkering on...

Garbage collection means that objects are automatically deleted when no more needed. How long an object is needed, may be hard to tell, but one indication is: when the context it was created in is left. For this purpose I re-use a trick from Gadgets: associate a guard variable in caller's scope to the object, and call the destructor when the guard variable is deleted (explicitly, or on return) or assigned a value. For simplicity, the guard variable name is the name of the object; its value is the namespace name, so a simple but sufficient "runtime type information" (RTTI) is also provided. DISCLAIMER: Experiments in Playing OO design showed that this GC deletes too eagerly, if you don't want to litter global variables. Hence I commented the two lines out - back to explicit delete, sorry...
 # -------------------- Testing garbage collection:
 class Dog {} legs 4
 proc Dog::speak self {puts bow-wow!}
 proc testGC {} {
    global snoopy
    Dog snoopy size small
    [Dog fido] speak
    puts localDogs:[namespace children ::Dog]
 }
 testGC
 puts globalDogs:[namespace children ::Dog]

As the test example shows, you can prevent the automatic destruction by beforehand declaring the object name global - just as with variables (it is one!). After invocation of testGC, "snoopy" survives but "fido" has disappeared. Another example for look and feel, trying the short variable name I in place of self:
 class File   {} mode r  fp ""  name ""
 proc  File::new I {$I: set fp [open [$I: set name] [$I: set mode]]}
 proc  File::del I {::close [$I: set fp]}
 proc  File::<<  {I string} {puts [$I: set fp] $string}
 proc  File::>>  {I varName} {
    upvar 1 $varName var
    gets [$I: set fp] var
 }
 proc  File::close I {$I delete}
 #---------------------------------- testing again:
 File f name t.txt mode w
 f << "hello world!"
 f close
 File f name t.txt
 f >> input
 puts input:$input

In finishing touches, care was taken to make introspection easy:
 class ;# returns the list of defined classes
 Foo   ;# returns the list of objects of class "Foo"
 bar   ;# returns the list of methods for object "bar"

See Playing OO design for a more elaborate example.