[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
Re: Binary data and set. & other things
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