[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 [namespace]s 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 [namespace]s 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.

<<categories>> Gadgets | On things | Object Orientation | Arts and crafts of Tcl-Tk programming