Lightweight Object System for Tcl, or LOST, provides a tiny but highly-functional object system.
LOST is a 38-line Tcl script that creates class procs for object variables, enabling a objname method arg1... syntax. LOST uses init for argument parsing.
From a news:comp.lang.tcl posting by Larry Smith on 2000-08-21:
Richard Suchenwirth's articles on his "gadgets" system have lead me to first reverse-engineer his basic idea, and then to play with it for a bit. This is the latest version of it, and I'm calling mine LOST, for Lightweight Object System for Tcl. It's a rather intriguing demonstration of Tcl's chameleon-like ability to adapt to a problem, in this case using a meta-programming scheme...
See also MOST for a version using arrays which can be teamed with tequila to provide remote object method calls for simple but effective distributed programming.
The example code is based on Richard's example - the "=" method for File does not adapt well to the args parser I've added (which parses the args for you and assigns useful local variables). But I left it that way since it's a demo based on Richard's gadget idea and not a "production" system. It's lightly tested, I'm sure there are more bugs. There is at least one design difficiency, there is no way to call a super- class's version of a method you've overridden.
To Richard's Gadgets, this version adds multiple inheritance and the ability to declare instance variables.
# scans for -foo "str" pairs and converts them
# into variable=value pairs in the surrounding
# scope - i.e. -foo "str" becomes "foo" with a
# value of "str" in the calling routine.
proc init { args } {
set max [ llength $args ]
if { $max == 1 } {
# braced set of args
eval set args $args
set max [ llength $args ]
}
for { set i 0 } { $i <= $max } { } {
set s [ lindex $args $i ]
if { [ string index $s 0 ] == "-" } {
set var [ string range $s 1 end ]
incr i
if { $i < $max } {
set val [ lindex $args $i ]
if { [ string index $val 0 ] != "-" } {
uplevel 1 set $var \{$val\}
continue
}
}
uplevel 1 set $var 1
}
incr i
}
}
proc class { type inherits instvars methods } {
global classinfo
foreach superclass $inherits {
set methods "
$methods
$classinfo($superclass-methods)
"
eval lappend instvars $classinfo($superclass-instvars)
}
set classinfo($type-instvars) $instvars
set classinfo($type-methods) $methods
set typeproc {
set instproc {
upvar @var THIS
@type THIS $method $args
}
upvar $var THIS
if { "$method" == "" } { return $self(=value) }
@init
switch $method {
@methods
}
regsub -all @var $instproc $var instproc
proc $var { { method "" } args } $instproc
}
regsub -all @type $typeproc $type typeproc
regsub -all self $methods THIS(=value) methods
foreach instvar $instvars {
if { "$instvar" == "args" } {
regsub @init $typeproc {init $args} typeproc
} else {
regsub -all $instvar $methods self($instvar) methods
}
}
regsub -all @init $typeproc "" typeproc
regsub -all @methods $typeproc $methods typeproc
regsub -all THIS $typeproc self typeproc
proc $type { var method args } $typeproc
}
class File {} { args filename } {
= {set filename "$open" ; set self [open $open]}
gets {return [ gets $self ]}
puts {puts $self "$args"}
eof {return [eof $self]}
close {close $self}
name {return $filename}
}
class TextFile { File } {} {
= { set filename "${open}.txt" ; set self [open $filename]}
}
class int {} {} {
= {set self [expr int(round($args))]}
++ {incr self}
}
TextFile F = -open chap2
puts "Filename is [F name]"
int i = 1
while 1 {
set line [ F gets]
if [F eof] break
puts "[i]:$line"
i ++
}
F close
# .-. .-. .---. .---. .-..-. | "Bill Gates is just a monocle
# | |__ / | \| |-< | |-< > / | and a Persian Cat away from
# `----'`-^-'`-'`-'`-'`-' `-' | being one of the bad guys in a
# My opinions only. | James Bond movie." -- D Miller