Richard Suchenwirth: I have toyed with the gadget concept every now and then for years now (see tally: a string counter gadget or A matrix gadget), but here's a generalized approach. See also LOST for Larry Smith's extension to that.. and On Things for a more radical typeless approach.
I call gadgets "poor man's objects" - basically they are a variable (string, list or array) and a proc, both with the same name. The proc is renamed away when the variable dies. No inheritance (yet), no namespaces involved, but they offer a slick Tk-like API where you call the gadget's name with a minor command (method name) and possibly other parameters.
First, a look at the generalized API. You can specify a gadget type with methods, in which you can refer to 'args' for the method's arguments (parse'em yourself ;-) and 'self' for the variable itself, like this:
gadget type number {
= {set self [expr $args]}
++ {set self [expr $self+1]}
round {set self [expr round($self)]}
sqrt {expr sqrt($self)}
}
gadget type int {
= {set self [expr round($args)]}
++ {incr self}
}
gadget type Array {
= - += {eval array set self $args }
-= {catch {unset self($args)}}
@ {set self($args)}
empty {expr [array size self]==0}
names {array names self}
{} {array get self}
}
gadget type List {
= {eval set self $args}
+= {lappend self $args}
@ {lindex $self $args}
empty {expr [llength $self]==0}
sort {lsort $self}
length {llength $self}
}
gadget type File {
= {set self [eval open $args]}
>> {upvar $args var; expr [gets $self var]+1}
<< {puts $self $args}
eof {eof $self}
open? {expr ![catch {seek $self 0 current}]}
close {close $self}
}For a defined gadget type, you can call a "constructor" with a name, and possibly an initialization:
number N = 1.5
Array A
List L = {foo bar}For a "destructor", we just reuse the good old unset wheel.
Now you can use these variables or procs as you wish, with the addition that calling a (non-array) gadget proc without arguments returns its value, so [N] is a new alternative to $N and [set N]:
N = [N] * $N -> 2.25 (just for the fun of it ;)
set A(cat) Katze -> Katze
A names -> cat
L += grill
L = [L sort]
puts "[L] has [L length] elements, second is [L @ 1]"
-> bar foo grill has 3 elements, second is foo
File F = gadget.tcl
int i = 1
while {[F >> line]} {
puts [i]:$line
i ++
}
F closeYes, this is still Tcl, and no, it's not like in the book. You can adjust the language pretty much to your likings via the method names. Arithmetic assignments look almost like all the world expects them to look (cf. Radical language modification, where I tried the same goal with the unknown command), and by pressing the assigned value through expr in the "number =" or "int =" method, some typechecking is introduced.
The polymorphism (same method names for different types) allows some hiding of internal quirks, e.g. now you can increment a double like an int with ++, by just adding 1 to it resp. calling incr. Notice also the polymorphism of += for lists vs. arrays: append an element, or set a key-value pair.
For introspection, you can get the types and names defined, and each gadget tells his type if asked:
gadget types -> number int Array List File gadget names -> N A L F N type -> number
Book-keeping of names and types is done not with global variables, but with procs whose bodies are rewritten when needed. The calls to proc gadget:names show how that's done: start with a argumentless list command, append a new name on gadget creation, lreplace the name out on gadget destruction.
OK, so here's the code that does that (not very long, but not the easiest reading either - after all you write a proc that writes a proc that writes a proc ;-): The switch line containing 'type' did not work on my system: adding eval worked like a charm. Has there been a change in how the switch command works since 2002? -- Jim Hinds
proc gadget {cmd args} {
switch -- $cmd {
names {gadget:names}
type {gadget:type $args ; # This command needed eval as in {eval gadget:type $args} JH }
types {gadget:types}
default {return -code error "$cmd? should be name, type, or types"}
}
}
proc gadget:types {} {list}
proc gadget:names {} {list}
proc gadget:type {type methods} {
if {[info commands $type]!=""} {
return -code error "type $type redefines existing command"
}
proc gadget:types {} {concat [info body gadget:types] $type}
set template {
proc @type@ {name args} {
if {$name==""} {
set name [lindex $args 0]
upvar 2 $name self
set rest [lindex $args 1]
set cmd [lindex $rest 0]
set args [lrange $rest 1 end]
switch -- $cmd {
type {return @type@}
@methods@
{} {set self}
default {return -code error\
"$cmd? Should be one of [join [list type @cmds@]]"}
}
} else {
if {[info commands $name]!=""} {
error "gadget $name redefines existing command"
}
uplevel trace variable $name u gadget:unset
proc gadget:names {} {concat [info body gadget:names] $name}
proc $name {args} "@type@ {} $name \$args"
if [llength $args] {uplevel $name $args}
}
}
}
set cmds [list]
foreach {cmd -} $methods {lappend cmds $cmd}
regsub -all @cmds@ $template $cmds template
regsub -all @type@ $template $type template
regsub -all @methods@ $template $methods template
eval $template
set type
}
proc gadget:unset {name el -} {
if {$el==""} {
rename $name ""
set names [info body gadget:names]
set where [lsearch $names $name]
proc gadget:names {} [lreplace $names $where $where]
}
}Notes: Gadgets can be passed by name in proc calls, where you either reuse the same name, or register the upvar variable:
upvar $name $name ;# or: upvar $name var; [$name type] var
As their procs are (of course) global, gadget names must be unique and may not use existing command (C or Tcl) names. This prevents one from accidentally rewriting "set" or other Tcl essentials. Drawback: gadgets with same name cannot be used in recursive procs.
Larry Smith (mailto:larry(...at sign...)smith-house.org) reverse-engineered an example I put on comp.lang.tcl and came to this beautiful short solution:
proc gadget { unused type methods } {
set typeproc {
set typeproc {
upvar @var self
@type self $method $args
}
upvar $var self
if { "$method" == "" } {
return $self
}
switch $method {
@methods
}
regsub @var $typeproc $var typeproc
proc $var { { method "" } args } $typeproc
}
regsub @type $typeproc $type typeproc
regsub @methods $typeproc $methods typeproc
proc $type { var method args } $typeproc
}I find it more legible, though, if all four mentions of typeproc inside the first set typeproc .. are replaced by instproc, as that is dealing with the instance proc anyway. - RS
AMG: The [regsub]s can be replaced with [string map]s:
proc $var {{method ""} args} [string map [list @var $var] $typeproc]
proc $type {var method args} [string map [list @type $type @methods $methods] $typeproc]Whoa, to avoid unwanted expansion, better put an extra level of listiness in there:
[string map [list @var [list $var]] $typeproc]
You can even lose the $typeproc variables, instead directly including the template. To make things easier still, make a helper procedure to do the string mapping. Yet more: make that helper procedure itself make procedures!
proc proc_template {name lazy_args eager_args body} {
set map [list]
foreach varname $eager_args {
upvar 1 $varname var
lappend map @$varname@ [list $var]
}
proc $name $lazy_args [string map $map $body]
}
proc gadget {unused type methods} {
proc_template $type {var method args} {type methods} {
upvar $var self
if {$method eq ""} {
return $self
}
switch $method @methods@
proc_template $var {{method ""} args} {var} {
upvar @var@ self
@type@ self $method $args
}
}
}There's a pitfall here, though:
gadget type @var@ {= {set self [expr $args]}}
@var@ name = 5
name
ERROR: too many nested evaluationsThe outer [proc_template] expands the inner @type@ to @var@, and the inner [proc_template] expands both @var@s to name, resulting in proc name {{method ""} args} {upvar name self; name self $method $args}. Bad!
Does anyone have any suggestions for how to make this safe?
Method inheritance (even multiple) can be had cheaply if the methods to be inherited are spliced in after the @methods above. The switch might sometimes run longer, but every method not defined for your type would fall through to the first inherited method of same name.