One very interesting feature of Tcl is that you can write your own control structures, essentially extending the language. The uplevel command, which allows you to write a procedure which executes code in the context of the caller, is the trick.
For example, if we want to augment Tcl's standard for and while looping constructs with
do body while condition
we would simply write a do proc which executes the code in the caller's context. In its simplest form, it would look like this:
proc do {body condition} {
while {1} {
uplevel $body
if {![uplevel "expr $condition"]} {break}
}
}We can make this a little more robust by specifying the exact number of levels to uplevel, which may prevent $body from being misinterpreted. We should also use list to construct the conditional command.
proc do {body condition} {
while {1} {
uplevel 1 $body
if {![uplevel 1 [list expr $condition]]} {break}
}
}Just to make things look prettier, we can add an exra argument to do that expects the word while. You could probably get fancy and make the while optional (like the else is optional for the if command), but this should be good enough for our purposes.
proc do {body whileword condition} {
if {![string equal $whileword while]} {
error "should be \"do body while condition\""
}
while {1} {
uplevel 1 $body
if {![uplevel 1 [list expr $condition]]} {break}
}
}This procedure does not handle errors well, though. For a good discussion of the issues involved, take a look at the exception handling chapter in John Ousterhout's book BOOK Tcl and the Tk Toolkit. But the primary issue is that we want to catch exceptional conditions when executing the $body code, and correctly throw errors upwards. This error handling makes our new procedure really appear to be part of the language.
Recall that the error codes are
proc do {body whileword condition} {
global errorInfor errorCode
if {![string equal $whileword while]} {
error "should be \"do body while condition\""
}
while {1} {
set code [catch {uplevel 1 $body} message]
switch -- $code {
1 { return -code error \
-errorinfo $errorInfo \
-errorcode $errorCode $message }
2 { return -code return $message }
3 { return {} }
4 { }
default { return -code $code $message }
}
if {![uplevel 1 [list expr $condition]]} {break}
}
}To make this really really really robust, you should consider adding the same error handling to the uplevel condition, but that is left as an exercise for the reader.
RWT (with a lot of help from comp.lang.tcl) Feb 4, 2000
Some pages with various new control structures are:
GPS Oct 08, 2003 - This is a conditional repeat:
proc repeat {cond time body} {
if !$cond return
uplevel #0 $body
after $time [info level 0]
} ;#GPS
repeat {[winfo exists .foo]} 1000 {puts [.foo get]} Another version of that which is easier to parse mentally is:
proc repeat {body _every_ time _until_ cond} {
if $cond return
uplevel #0 $body
after $time [info level 0]
} ;#GPS
repeat [list raise .rename .] every 1000 until {![winfo exists .rename]}GPS Oct 19, 2003 - I was going through a Python tutorial and came upon this nice concise code: if ok in ('y', 'ye', 'yes'): return 1 I became curious about doing such a thing in Tcl, and I came up with this:
proc if.in.list {val list body} { if {[lsearch $list $val] >= 0} {uplevel $body}}Example usage:
% set v abc
abc
% if.in.list $v [list abc adef foo] {puts TRUE}
TRUEGoogie Here is a structure which I met in EPIC4 (IRC client) scripting language. It's called FEC - For Every Character.
proc fec {var string body} {
uplevel "
for {set fec 0} {\[string index {$string} \$fec] != {}} {incr fec} {
set $var \[string index {$string} \$fec]
$body
}
"
}It uses uplevel to allow using other variables in body. Using example:
set validFlags "abcde"
set flagsToSet "asdfghj"
fec flag $flagsToSet {
if {[string first $flag $validFlags] == -1} {
puts "Invalid flag: $flag"
}
}RS: Note however that the following is probably faster (and saves quoting hell ;^):
foreach flag [split $flagsToSet ""] {...}Whoever wrote all this provided a very nice and clear explanation and examples. I yearn for more.