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 hiand 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 syntaxobject: 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:$inputIn 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.
