class construct for Tcl
Sam Shen
it for a couple of days and it seems useful. There's some comments in
the code that should explain things a bit, but basically it allows you
to write stuff like:
# declare a new type Foo with some members and methods
class Foo {
member bar "bar's initial value"
method printBar {} { puts [getmember bar] }
method setBar {new_bar} { setmember bar $new_bar }
}
# create an object of class Foo and store the handle in foo
Foo foo
# evaluate some commands in $foo's scope...
in $foo { printBar; setBar Yow!; printBar }
# and you can call the methods explicitly
Foo:setBar $foo "Hello there!"
Foo:printBar $foo
There's no inheritance, but of course member's can be objects.
Inheritance is overblown anyways. :)
What do you win doing using something like this? My feeling is that
it uses up the proc and variable namespace consistently, it's pretty
easy to use, and it's easy to instantiate multiple instances of
objects. One big lose is that it's slow.
I've included a StripChart class that does strip charts and a load
average meter that uses the StripChart class.
-Sam Shen (s...@aero.org)
#! /bin/sh
# This is a shell archive. Remove anything before this line, then unpack
# it by saving it into a file and typing "sh file". To overwrite existing
# files, type "sh file -c". You can also feed this as standard input via
# unshar, or by typing "sh <file", e.g.. If this archive is complete, you
# will see the following message at the end:
# "End of shell archive."
# Contents: class.tcl strip.tcl cload.tcl
# Wrapped by sls@batcomputer on Mon Feb 22 17:43:41 1993
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f 'class.tcl' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'class.tcl'\"
else
echo shar: Extracting \"'class.tcl'\" \(5049 characters\)
sed "s/^X//" >'class.tcl' <<'END_OF_FILE'
X#
X# class.tcl -- a simple class system in Tcl.
X#
X# Author: Sam Shen (s...@aero.org)
X#
X# This file defines three forms. The first,
X#
X# class <class-name> {
X# method <method-name> <method-args> <method-body>
X# :
X# member <member-name> <initial-value>
X# :
X# /* comments ...
X# :
X# */
X# :
X# }
X#
X# defines a new type <class-name>. The methods are transformed into proc's
X# with names <class-name>:<method-name>. The functions "setmember",
X# "getmember", and "aliasmember" are valid in the methods. "setmember"
X# and "getmember" set and get the values of members. "aliasmember" creates
X# an alias for a member variable (it uses upvar to create the alias.)
X# The methods, members, and block comments may come in any order.
X# All classes automatically have the member class, which is the name of
X# the class's class.
X#
X# Objects can be created by writing "<class-name> <object-name>".
X# A new variable <object-name> is created and set to a handle to the
X# object. The object handles are of the form O_<n> and are actually
X# global arrays. O_<n>(class) contains the class, O_<n>(<member>)
X# contains the member <member>.
X#
X# The second form,
X#
X# in <object-handle> <expr>
X#
X# evaluates expression inside the object. in creates aliases
X# <method-name> for each <class-name>:<method-name>, evaluates <expr>,
X# and finally restores any proc's the aliasing process might have
X# destroyed.
X#
X# And finally, the third form,
X#
X# delete <object-handle>
X#
X# deletes the state associated with <object-handle>.
X#
X# The variable namespace is polluted as follows:
X#
X# O_<n> - holds the storage of an object.
X# class_methods(<class-name>) - list of the methods of a class.
X# object_counter - holds the current <n> in O_<n>
X# in_counter - holds a counter that's used in in's renaming process.
X# If there are procs of the form procFoo, procFoo<n> where <n> is
X# a number in may fail.
X# in_sti, in_st() - holds a stack used by in the keep track of the current
X# scope.
X#
X
Xset object_counter 0
Xproc class {class_name spec} {
X global class_methods
X set members ""
X for {set i 0} {$i < [llength $spec]} {incr i} {
X case [lindex $spec $i] {
X method {
X set method_body [concat global \$this ";" in \$this]
X lappend method_body [lindex $spec [expr {$i+3}]]
X set ag [linsert [lindex $spec [expr {$i+2}]] 0 this]
X proc $class_name:[lindex $spec [expr {$i+1}]] \
X $ag $method_body
X lappend class_methods($class_name) [lindex $spec [expr {$i+1}]]
X incr i 3
X }
X member {
X lappend members [list [lindex $spec [expr {$i+1}]] \
X [lindex $spec [expr {$i+2}]]]
X incr i 2
X }
X "/\*" {
X incr i
X while {[lindex $spec $i] != "*/"} {
X incr i
X }
X }
X default {
X error [format {unknown keyword "%s" in class declaration} \
X [lindex $spec $i]]
X }
X }
X }
X if {$members != ""} {
X set ctor_body [format {
X upvar #0 $_this this
X foreach member {%s} {
X set this([lindex $member 0]) [lindex $member 1]
X }
X } $members]
X proc $class_name:Construct _this $ctor_body
X }
X set body [format {
X global object_counter
X upvar 1 $v var
X set var O_[incr object_counter]
X upvar #0 $var object
X set object(class) %s
X if {%d} {
X uplevel "%s:Construct $var"
X }
X } $class_name [expr {$members != ""}] $class_name]
X proc $class_name v $body
X}
X
Xset in_counter 0
Xset in_sti 0
Xproc push_scope {on} {
X global in_sti in_st
X set in_st([incr in_sti]) $on
X}
Xproc in_scope? {on} {
X global in_sti in_st
X expr {$in_sti > 0 && $in_st($in_sti) == $on}
X}
Xproc pop_scope {} {
X global in_sti in_st
X unset in_st($in_sti)
X incr in_sti -1
X}
X# this was useful for debugging
X#proc indentAndPrint {msg} {
X# for {set i 0} {$i < [info level]-1} {incr i} {
X# puts -nonewline \t
X# }
X# puts $msg
X#}
Xproc in {_object expr} {
X# indentAndPrint "in _object=$_object"
X upvar #0 $_object object
X global in_counter errorInfo class_methods
X set cleanup ""
X if ![in_scope? $_object] {
X push_scope $_object
X set switched_scope 1
X set ctr [incr in_counter]
X set cleanup "pop_scope; "
X set class $object(class)
X foreach method $class_methods($class) {
X if {[info procs $method] != ""} {
X set oldproc $method[set ctr]
X rename $method $oldproc
X append cleanup "rename $method {}; rename $oldproc $method; "
X } else {
X append cleanup "rename $method {}; "
X }
X set method_body [format {
X uplevel [format "%s %s %%s" $args]
X } $class:$method $_object]
X proc $method args $method_body
X }
X }
X if {[set retval [catch {uplevel $expr} result]] == 1} {
X set savedInfo $errorInfo
X }
X eval $cleanup
X if {$retval == 1} {
X error $result $savedInfo
X }
X return $result
X}
X
Xproc getmember var {
X upvar [uplevel "set this"] o
X set o($var)
X}
X
Xproc setmember {var val} {
X set cmd [format {set [set this](%s)} $var]
X lappend cmd $val
X return [uplevel $cmd]
X}
X
Xproc aliasmember {m var} {
X set cmd [format {upvar #0 [set this](%s) %s} $m $var]
X uplevel $cmd
X}
X
Xproc delete object {
X uplevel "unset $object"
X}
END_OF_FILE
if test 5049 -ne `wc -c <'class.tcl'`; then
echo shar: \"'class.tcl'\" unpacked with wrong size!
fi
# end of 'class.tcl'
fi
if test -f 'strip.tcl' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'strip.tcl'\"
else
echo shar: Extracting \"'strip.tcl'\" \(4759 characters\)
sed "s/^X//" >'strip.tcl' <<'END_OF_FILE'
X#
X# StripChart is a class that implements a strip chart.
X#
X# Author: Sam Shen (s...@aero.org)
X#
X# I'm sure there are bugs in here, but don't worry, they've been included
X# without charge.
X#
Xclass StripChart {
X
X member canvas {}
X member height 0
X member width 0
X member x 0
X member scale 1
X member tickevery 1
X member maxYLeft 0
X member maxYRight 0
X member minscale .2
X
X/*
X * notifyNewSize is called when the size of the window has changed.
X * It retags things so that left and right are correct for the new
X * width and height.
X */
X
X method notifyNewSize {new_width new_height} {
X set width [getmember width]
X set height [getmember height]
X set c [getmember canvas]
X set x [getmember x]
X set doshift 0
X if {[info exists c] && $height != 0} {
X set sy [expr {1.0*$new_height/$height}]
X $c scale left 0 0 1.0 $sy
X $c scale right 0 0 1.0 $sy
X $c scale ticks 0 0 1.0 $sy
X foreach t [$c find withtag ticks] {
X scan [$c coords $t] "%f %f %f %f" tx0 ty0 tx1 ty1
X $c coords $t 0 $ty0 $new_width $ty1
X }
X set w2 [expr {$new_width/2}]
X if {$new_width > $width} {
X foreach l [$c find withtag right] {
X if {[lindex [$c coords $l] 0] <= $w2} {
X $c addtag switchtag withtag $l
X }
X }
X $c addtag left withtag switchtag
X $c dtag switchtag right
X $c dtag switchtag
X } elseif {$new_width < $width} {
X foreach l [$c find withtag left] {
X if {[lindex [$c coords $l] 0] >= $w2} {
X $c addtag switchtag withtag $l
X }
X }
X $c addtag right withtag switchtag
X $c dtag switchtag left
X $c dtag switchtag
X foreach l [$c find withtag right] {
X if {[lindex [$c coords $l] 0] > $new_width} {
X $c delete $l
X }
X }
X if {$x >= $new_width} {
X set doshift 1
X }
X }
X }
X setmember width $new_width
X setmember height $new_height
X if {$doshift} {
X shiftLeft
X }
X }
X
X method create {w width height} {
X setmember canvas [canvas $w -width $width -height $height]
X bind [getmember canvas] <Configure> "in $this {
X if {%h != [getmember height] || %w != [getmember width]} {
X notifyNewSize %w %h
X }
X }"
X }
X
X method dataPoint {y} {
X set width [getmember width]
X set height [getmember height]
X set x [getmember x]
X set maxYLeft [getmember maxYLeft]
X set maxYRight [getmember maxYRight]
X set c [getmember canvas]
X set scale [getmember scale]
X
X if {$x > [expr {$width/2}]} {
X set tag right
X set maxYRight [max $y $maxYRight]
X } else {
X set tag left
X set maxYLeft [max $y $maxYLeft]
X }
X setmember maxYLeft $maxYLeft
X setmember maxYRight $maxYRight
X set cy [expr {$height-$height*$y/$scale}]
X $c create line $x $height $x $cy -tag $tag
X incr x
X setmember x $x
X checkMaxY [max $maxYLeft $maxYRight]
X if {$x >= $width} {
X shiftLeft
X }
X }
X
X method getCanvas {} {
X return [getmember canvas]
X }
X
X method getHeight {} {
X return [getmember height]
X }
X
X method getWidth {} {
X return [getmember width]
X }
X
X/*
X * max returns the maximum of its args.
X */
X
X method max args {
X set max [lindex $args 0]
X foreach x $args {
X if {$x > $max} {
X set max $x
X }
X }
X return $max
X }
X
X method truncate x {
X format %.0f $x
X }
X
X/*
X * checkMaxY checks the max y value and changes the scale if neccessary.
X */
X method checkMaxY {y} {
X set scale [getmember scale]
X set tickevery [getmember tickevery]
X set minscale [getmember minscale]
X if {($y < 0.5*$scale) && ($scale > $minscale)} {
X set new_scale [max $minscale [expr 0.5*$scale]]
X } elseif {$y > $scale} {
X set new_scale [expr 2*$scale]
X } else {
X return
X }
X set c [getmember canvas]
X set width [getmember width]
X set height [getmember height]
X $c delete ticks
X for {set i 1} {$i <= $new_scale/$tickevery} {incr i} {
X set y [expr {$height-$i*$tickevery*$height/$new_scale}]
X $c create line 0 $y $width $y -tag ticks
X }
X set sy [expr {1.0*$scale/$new_scale}]
X $c scale left 0 $height 1.0 $sy
X $c scale right 0 $height 1.0 $sy
X setmember scale $new_scale
X }
X
X/*
X * shiftLeft deletes everything on the left, moves everything
X * on the right to the left, updates the tags, and updates the max
X * Y on the left and right.
X */
X method shiftLeft {} {
X set width [getmember width]
X set maxYLeft [getmember maxYLeft]
X set maxYRight [getmember maxYRight]
X set scale [getmember scale]
X set c [getmember canvas]
X set x [expr {$width/2}]
X set dx $x
X if {($width % 2) == 1} {
X incr dx
X }
X $c delete left
X $c addtag left withtag right
X $c dtag right
X $c move left -$dx 0
X setmember maxYLeft $maxYRight
X setmember maxYRight 0
X setmember x $x
X checkMaxY $maxYLeft
X }
X
X method getWindow {} {
X return [getmember canvas]
X }
X
X method setTickEvery {te} {
X setmember tickevery $te
X }
X
X method setMinScale {ms} {
X setmember minscale $ms
X }
X}
END_OF_FILE
if test 4759 -ne `wc -c <'strip.tcl'`; then
echo shar: \"'strip.tcl'\" unpacked with wrong size!
fi
# end of 'strip.tcl'
fi
if test -f 'cload.tcl' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'cload.tcl'\"
else
echo shar: Extracting \"'cload.tcl'\" \(1715 characters\)
sed "s/^X//" >'cload.tcl' <<'END_OF_FILE'
X#
X# A load average meter done with the StripChart class.
X#
X# Author: Sam Shen (s...@aero.org)
X#
Xsource class.tcl
Xsource strip.tcl
X
XStripChart loadavg
Xin $loadavg {
X create .chart 1.5i 0.75i
X [getWindow] config -relief sunken
X
X}
X
Xset font -misc-fixed-medium-r-*-*-7-*-*-*-*-*-*-*
X
Xpack append . \
X [label .l -anchor w -font $font] "fillx" \
X .chart "fill expand"
X
Xwm minsize . 50 25
Xwm title . "Load Meter"
Xwm iconname . "Load Meter"
Xupdate
X
Xset updateDelay 1000
Xset host [exec hostname]
X
X#
X# make q quit, f update faster, s update slower.
X#
Xin $loadavg {
X set w [getWindow]
X bind $w <Key-q> "destroy ."
X bind $w <Key-f> {
X global updateDelay
X incr updateDelay -100
X if {$updateDelay < 100} {
X set updateDelay 100
X }
X flashDelay
X }
X bind $w <Key-s> {
X global updateDelay
X incr updateDelay 100
X flashDelay
X }
X bind $w <Enter> {
X focus %W
X }
X}
X
X#
X# flashDelay will flash the current delay in the upper right corner.
X#
Xproc flashDelay {} {
X global updateDelay loadavg font
X in $loadavg {
X set c [getWindow]
X $c delete delay
X $c create text [expr {[getWidth]-3}] 4 -anchor ne -font $font \
X -tag delay -text [format "%4.1f" [expr {$updateDelay/1000.0}]]
X update
X after 1000 "$c delete delay"
X }
X}
X
X#
X# getLoad gets the current load average by running uptime (under
X# Linux you can read it out of /proc/loadavg)
X#
Xproc getLoad {} {
X scan [lindex [exec uptime] 9] %f, load
X return [format %4.2f $load]
X}
X
X#
X# updateStats periodically updates the strip chart.
X#
Xproc updateStats {} {
X global loadavg updateDelay host
X set load [getLoad]
X in $loadavg {
X dataPoint $load
X .l config -text "$load $host"
X }
X after $updateDelay updateStats
X}
X
XupdateStats
END_OF_FILE
if test 1715 -ne `wc -c <'cload.tcl'`; then
echo shar: \"'cload.tcl'\" unpacked with wrong size!
fi
# end of 'cload.tcl'
fi
echo shar: End of shell archive.
exit 0