SS 14 Dec 2004:
It is clear for the Tcl comunity that we need a "standard OOP system" for Tcl. It is not clear what's the best available, nor if it's wise to get an already developed one, or to create a new one using the experience we collected thanks to the fact that there are a number of OOP systems for Tcl. So while the discussion is hot... I want to express my opinion about it.
I called this object system Odys. The name is related to Dynamic Object System. This are the main ideas:
So, what is lost in power because of semantical simplicity, is gained because all is dynamic. This is the way I think at Tcl itself. Imagine Tcl without introspection, without uplevel, and so on... As a result of this first design principle:
This is the classical toaster example:
class Toaster { var crumbs 0 method toast nslices { if {[$this crumbs] > 50} { error "== FIRE! FIRE! ==" } $this crumbs [expr {[$this crumbs]+4*$nslices}] } method clean {} { $this crumbs 0 } } class SmartToaster extends Toaster { method toast nslices { if {[$this crumbs] > 40} { $this clean } $this parent toast $nslices } }
As you can see:
Instance variables are just methods, if called with a single argument like [$obj foo] the value of the instance variable foo is returned. Instead it can be called with two arguments to set a new value like in [$obj foo $newval]. So instance variables are always accessed using methods, or in other terms, sending messages to the object.
If the object $o is of class xyz that inherits from xy, to call the method foobar of xy with $o as target there is just to write [$o parent foobar]. parent can be used multiple times, like [$o parent parent parent foobar]. Parent is just a method (semantically...), that exists in every class created.
About the fact that it's dynamic. This is what is possible to do:
class foobar { var x 100 classvar y method ciao name {puts "Ciao $name! I'm $this, x = [$this x]"} method hello {} {puts "Hello!"} } set o [new foobar] set class [$o class] puts "The '[$class name]' class methods are: [$class methods]" puts "The '[$class name]' instance vars are: [$class vars]" puts "The '[$class name]' class vars are: [$class classvars]" puts "Method 'ciao' args are: [$class args ciao]" puts "Method 'ciao' body is:\n[$class body ciao]" puts {} puts "Adding a new method to the class..." $class setmethod newmethod {} {puts newmethod} puts "Now the list of methods is: [$class methods]" puts {} puts "Deleting the new method..." $class delmethod newmethod puts "Now the list of methods is: [$class methods]"
Because classes are objects to define a new method there is just to write [$class setmethod foobar ...], and so on.
If you write [new foobar], what you get is something like: ::odysObj::obj0, so to create data structures using objects is simple. This is an example of linked list implementation:
class node { var next {} var value {} } class linkedlist { var head {} method push value { set newnode [new node] $newnode value $value $newnode next [$this head] $this head $newnode return $this } method pop {} { if {[$this head] eq {}} { error "Pop against empty linkedlist object" } set head [$this head] set val [$head value] $this head [$head next] free $head return $val } method len {} { set node [$this head] set len 0 while {$node ne {}} { incr len set node [$node next] } return $len } } set ll [new linkedlist] for {set i 0} {$i < 10} {incr i} { $ll push $i } set node [$ll head] while {$node ne {}} { puts [$node value] set node [$node next] } puts [$ll pop] puts [$ll pop] puts [$ll pop] puts "Len: [$ll len]"
That's all for now. Note that this is just a draft, but I think the main ideas are already present. Every kind of comment, even if very negative, is welcomed.
Prototype implementation
# The ODYS object system # TODO: # # - 'class' class methods to set methods, get methods lists, and # similar things for vars and classvars. # # - Ability to create objects that are auto-destroied when the # procedure where they are created returns. [MSW]: solved by [[local]], # see below. # # - Object to string convertion, and vice versa. # # FEATURES TO REMEMBER: # # - method with empty name is called when the object is # used as a procedure without arguments, like [$myobj]. # For example, in a file object this may return the whole file content. namespace eval odys {} namespace eval odysObj {} set ::odys::objId -1 array set ::odys::class {} array set ::odys::classMethod {} set ::odys::debugFlag 0 proc ::odys::debug str { if {$::odys::debugFlag} { puts $str } } proc new {class args} { set objName "::odysObj::obj[incr ::odys::objId]" # Get the class object if {[catch {set classObj $::odys::class($class)}]} { error "Unknown class '$class'" } namespace eval $objName {} set ${objName}::__class__ $classObj # Copy instance variables into the object set t $classObj while {$classObj ne {}} { foreach var [info vars ${classObj}::vars::*] { set tail [namespace tail $var] set ${objName}::${tail} [set $var] } set classObj [set ${classObj}::parent] } # Create the alias interp alias {} $objName {} ::odys::dispatch $objName uplevel 1 $objName init $args return $objName } proc local {class args} { set obj [uplevel new $class $args] set fobj [string map {: _} $obj] uplevel set $fobj 1 uplevel trace var $fobj u cleanObj return $obj } proc cleanObj {obj args} { set obj [string map {_ :} $obj] free $obj } proc ::odys::dispatch {id args} { ::odys::debug "Object $id received message '$args'" set classObj [set ${id}::__class__] # Handle 'parent' special method while {[lindex $args 0] eq {parent}} { if {[set ${classObj}::parent] eq {}} { error "Object's class has not parent." } set classObj [set ${classObj}::parent] set args [lrange $args 1 end] } # Method lookup while 1 { if {[info proc ${classObj}::methods::[lindex $args 0]] ne {}} { return [uplevel 1 ${classObj}::methods::[lindex $args 0] $id \ [lrange $args 1 end]] } if {[set ${classObj}::parent] eq {}} { error "No such method '$method'" } # Retry with the parent set classObj [set ${classObj}::parent] } } set ::odys::class(class) {} proc free id { $id free namespace delete $id interp alias {} $id {} } proc class {name args} { switch -- [llength $args] { 1 {set parentClassObj {}; set body [lindex $args 0]} 3 { if {[lindex $args 0] ne {extends}} { error {wrong args: second argument must be "extends" if present} } set parent [lindex $args 1]; set body [lindex $args 2] if {[catch {set parentClassObj $::odys::class($parent)}]} { error "Unknown class '$class'" } } default { error {wrong # args: should be "class className ?extends parentName? body"} } } set classObj [new class] namespace eval ${classObj}::methods {} namespace eval ${classObj}::vars {} namespace eval ${classObj}::classvars {} interp alias {} ${classObj}::method {} ::odys::method interp alias {} ${classObj}::var {} ::odys::var interp alias {} ${classObj}::classvar {} ::odys::classvar proc ${classObj}::methods::init this {} proc ${classObj}::methods::free this {} proc ${classObj}::methods::class this { set ${this}::__class__ } set ${classObj}::name $name if {[catch {namespace eval $classObj $body} errmsg]} { free $classObj error $errmsg } set ${classObj}::parent $parentClassObj set ::odys::class($name) $classObj } proc ::odys::method {name arglist body} { set classObj [uplevel namespace current] proc ${classObj}::methods::${name} [concat this $arglist] $body } proc ::odys::var {name {value {}}} { set classObj [uplevel namespace current] proc ${classObj}::methods::${name} {this args} [format { if {[llength $args] == 0} { return [set ${this}::%s] } elseif {[llength $args] == 1} { return [set ${this}::%s [lindex $args 0]] } else { error {instance variable access method can accept 0 or 1 arg.} } } $name $name] set ${classObj}::vars::${name} $value } proc ::odys::classvar {name {value {}}} { set classObj [uplevel namespace current] proc ${classObj}::methods::${name} {this args} [format { if {[llength $args] == 0} { return [set [set ${this}::__class__]::classvars::%s] } elseif {[llength $args] == 1} { return [set [set ${this}::__class__]::classvars::%s [lindex $args 0]] } else { error {class variable access method can accept 0 or 1 arg.} } } $name $name] set ${classObj}::classvars::${name} $value } proc ::odys::isClassObj id { if {![namespace exists $id]} {return 0} if {[$id class] ne $::odys::classClassObj} {return 0} return 1 } ############################### The 'class' class ############################## # This class is build by hand because it's somewhat special, and # the [class] command itself requires this class to be already-working. # Create the 'class' class. namespace eval ::odysObj::obj0 {set parent {}} namespace eval ::odysObj::obj0::methods {} proc ::odysObj::obj0::methods::init this {} set ::odys::class(class) ::odysObj::obj0 set ::odys::classClassObj [new class] # Initialize this class by hand. namespace eval ${::odys::classClassObj}::methods {} namespace eval ${::odys::classClassObj}::vars {} namespace eval ${::odys::classClassObj}::classvars {} set ${::odys::classClassObj}::vars::methods {} set ${::odys::classClassObj}::vars::vars {} set ${::odys::classClassObj}::vars::classvars {} set ${::odys::classClassObj}::parent {} set ${::odys::classClassObj}::__class__ $::odys::classClassObj proc ${::odys::classClassObj}::methods::free {this} {} proc ${::odys::classClassObj}::methods::name {this} {set ${this}::name} proc ${::odys::classClassObj}::methods::setparent {this args} { if {[llength $args] == 1} { set newparent [lindex $args 0] if {$newparent ne {} && ![::odys::isClassObj $newparent]} { error "Can't set '$newparent' as parent. Not a class object." } set ${this}::parent $newparent } elseif {[llength $args] == 0} { set ${this}::parent } else { error "bad # of args: setparent can accept 0 or 1 argument." } } proc ${::odys::classClassObj}::methods::methods this { set methods [info procs ${this}::methods::*] set tails {} foreach m $methods { lappend tails [namespace tail $m] } return $tails } proc ${::odys::classClassObj}::methods::vars this { set vars [info vars ${this}::vars::*] set tails {} foreach v $vars { lappend tails [namespace tail $v] } return $tails } proc ${::odys::classClassObj}::methods::classvars this { set vars [info vars ${this}::classvars::*] set tails {} foreach v $vars { lappend tails [namespace tail $v] } return $tails } proc ${::odys::classClassObj}::methods::args {this name} { lrange [info args ${this}::methods::${name}] 1 end } proc ${::odys::classClassObj}::methods::body {this name} { info body ${this}::methods::${name} } proc ${::odys::classClassObj}::methods::setmethod {this name args body} { set args [concat this $args] proc ${this}::methods::${name} $args $body } proc ${::odys::classClassObj}::methods::delmethod {this name} { rename ${this}::methods::${name} {} } set ::odys::class(class) ${::odys::classClassObj} ################################################################################
Some more example of usage
This is a file object:
source odys.tcl class file { var fd {} method init args { if {[llength $args] == 0} return eval $this open $args } method free {} { set fd [$this fd] if {$fd ne {}} { ::close $fd } } method open args { $this fd [eval ::open $args] } method close {} { ::close [$this fd] $this fd {} } method gets args { switch [llength $args] { 0 {::gets [$this fd]} 1 { upvar 1 [lindex $args 0] line ::gets [$this fd] line } default { error "wrong # of args, try: gets ?varname?" } } } method rewind {} { seek [$this fd] 0 } method foreach {varname script} { set fd [$this fd] upvar $varname line while {[::gets $fd line] != -1} { uplevel 1 $script } } method {} {} { $this rewind set buf [read [$this fd]] $this rewind return $buf } } set t [new file /etc/passwd] $t foreach line {puts -nonewline "[string length $line] "} puts {} $t close free $t set t [new file /etc/resolv.conf] puts [$t] free $t
Class vars example
source odys.tcl class foobar { classvar x 0 } set a [new foobar] set b [new foobar] $a x 100 puts [$a x] puts [$b x]
Auto clean example
source odys.tcl class tst { var msg {} method init args { $this msg $args } method free {} { puts "Freeing [$this msg]" } } proc a {} { set t1 [new tst "Test #1"] set t2 [local tst "Test #2"] } a
Comments
WHD: Implementing instance variables as methods is interesting, but ultimately frustrating; you lose incr, lappend, etc. You need to have instance variables that can be handed to another object and traced, e.g., as -textvariables. Also, you're going to need array variables. DKF has done some interesting stuff using Tcl 8.5 dicts to store instance variables; the dict with command brings all of the dict fields into scope as variables, and packs any changes back into the dict.