LOST

Lightweight Object System for Tcl, or LOST, provides a tiny but highly-functional object system.

Attributes

updated
09/2007
contact
mailto:[email protected] (Larry Smith)

Description

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