I'm interested in your OO extensions and would like to be on your mailing list. I'm "Parag Patel" parag@sde.hp.com. Thanks!

Just for fun, a while ago I had built a primitive class mechanism for TCL entirely written in TCL! Here it is to add to your "truly deranged" archives.

These files work with the Tcl 4.0 release as I use a lot of the 4.0 functions like incr, clength, split, etc. It could be made to work with Tcl 5.0, but I haven't had the time to hack it yet. Sorry!

Just source "class.eg" for the example code of how classes work. (I use a Tcl proc named "@" as the basic "send-object-message" routine.)

-- Parag

---- Cut Here and feed the following to sh ---- #!/bin/sh # This is a shell archive (produced by shar 3.49) # To extract the files from this archive, save it to a file, remove # everything above the "!/bin/sh" line above, and type "sh file_name". # # made 05/31/1991 18:10 UTC by parag@hpsdeb # Source directory /users/parag/lib/tcl # # existing files will NOT be overwritten unless -c is specified # # This shar contains: # length mode name # ------ ---------- ------------------------------------------ # 529 -rw-r--r-- class.eg # 3345 -rw-r--r-- class.tcl # # ============= class.eg ============== if test -f 'class.eg' -a X"$1" != X"-c"; then echo 'x - skipping class.eg (File already exists)' else sed 's/^X//' << 'SHAR_EOF' > 'class.eg' && source class.tcl X # define class "Foo" with construct, destructor, and message "Get" class Foo {value string} cproc Foo Foo {} { echo Constructed!; cset string "<default>" } cproc Foo ~Foo {} { echo Destructed! } cproc Foo Get {} { return [cset string] } X # define class Bar derived from Foo with an addition message "Set" class Bar:Foo {} cproc Bar Set {s} { cset string $s } X # create a new Bar object - both Set and Get should be available set foo [new Bar] echo [@ $foo Get] @ $foo Set NewValue echo [@ $foo Get] delete $foo SHAR_EOF chmod 0644 class.eg || echo 'restore of class.eg failed' Wc_c="`wc -c < 'class.eg'`" test 529 -eq "$Wc_c" || echo 'class.eg: original size 529, current size' "$Wc_c" fi # ============= class.tcl ============== if test -f 'class.tcl' -a X"$1" != X"-c"; then echo 'x - skipping class.tcl (File already exists)' else sed 's/^X//' << 'SHAR_EOF' > 'class.tcl' && # Prototype of Class extensions to TCL # by Parag Patel X set classlist "" set inheritlist "" X proc class {class vars} { X global classlist inheritlist X X # get the inheritance info, if any X set inh [split : $class] X set class [index $inh 0] X set inherit "" X if {[length $inh] == 2} { set inherit [index $inh 1] } { X if {[length $inh] != 1} { X error "illegal inheritance syntax for class $class" X } X } X X # each elt in inheritlist in the name of the parent class X # - the key is the child class which is derived from the parent X set inheritlist($class) $inherit X X # each elt in classlist is a list of its class vars X set classlist($class) $vars } X proc cproc {class mesg arglist body} { X # add "this" to the arglist and define a proc "class.mesg" X set arglist "this $arglist" X proc $class.$mesg "$arglist" $body } X proc cset {var args} { X set this [uplevel {list $this}] X global $this X if {[clength "$args"]} { X set ${this}($var) $args X } { X return [set ${this}($var)] X } } X set objectid 0 proc new {class args} { X global classlist inheritlist objectid X X # create a new object handle X set this "@Object_$objectid" X incr objectid X X # the handle is also an array indexed by its class var names X # - thus the values for these array elts are unique for each object! X global $this X X # initialize all the class vars to empty X # - we need to walk the inheritance tree to get ALL the vars X set clist "" X set inhlist "" X set varlist "" X for {set c $class} {[clength "$c"] > 0} {set c [set inheritlist($c)]} { X foreach {v} [set classlist($c)] { X set ${this}($v) "" X set varlist "$v $varlist" X } X set clist " $c$clist" X set inhlist "$inhlist $c" X } X set clist "$c$clist" X X # these are just to make message dispatching easier in "@" below, and X # so that delete can call the right destructors - at the very least, X # "class.name" must always be available to extract everything else X set ${this}(class.name) $class X set ${this}(class.variables) "$varlist" X set ${this}(class.inheritance) "$inhlist" X X # invoke the constructors in the correct order, deepest parent 1st X foreach {c} $clist { X if {[clength "[info procs $c.$c]"]} { X if {[clength "$args"]} { @ $this $c $args } { @ $this $c } X } X } X X # and return our new object's handle X return $this } X proc delete {this} { X global $this X X # sanity check - do not allow deleting a deleted object X if {![info exists ${this}(class.inheritance)]} { X error "no object $this exists to delete" X } X X # call the destructors in reverse order of constructors, child 1st X foreach {c} [set ${this}(class.inheritance)] { X if {[clength "[info procs $c.~$c]"]} { @ $this ~$c } X } X X unset $this } X proc @ {this mesg args} { X global classlist inheritlist $this X X # find a message proc following the inheritance chain X set procname "" X foreach {c} [set ${this}(class.inheritance)] { X set p $c.$mesg X if {[clength "[info procs $p]"]} { set procname $p; break } X } X if {![clength "$procname"]} { X error "No message $mesg defined for class [set ${this}(class.name)]" X } X X # invoke the message proc adding "this" to the arguments X if {[clength "$args"]} { X return [$procname $this $args] X } { X return [$procname $this] X } } SHAR_EOF chmod 0644 class.tcl || echo 'restore of class.tcl failed' Wc_c="`wc -c < 'class.tcl'`" test 3345 -eq "$Wc_c" || echo 'class.tcl: original size 3345, current size' "$Wc_c" fi exit 0