samoc: retry is try more than once.
usage: retry count_var count body ?handler...? ?finally script?
e.g. try a few times to get a message through if the network is busy ...
retry count 3 {
send_message "Hello"
} trap NetworkBusy {} {}... or, retry with exponential backoff...
retry count 10 {
send_message "Hello"
} trap NetworkBusy {msg info} {
puts "$msg"
after [expr {$count * $count * 100}]
}It might occasionally be useful to retry for all errors:
retry count 3 {
send_message "Hello"
} on error {} {}Implementation:
proc retry {count_var count body args} {
# Retry "body" up to "count" times for exceptions caught by "args".
# "args" is a list of trap handlers: trap pattern variableList script...
# The retry count is made visible through "count_var".
assert string is wordchar $count_var
assert string is integer $count
assert {[lindex $args 0] in {trap on finally}}
upvar $count_var i
if {[lindex $args end-1] == "finally"} {
set traps [lrange $args 0 end-2]
set finally [lrange $args end-1 end]
} else {
set traps $args
set finally {}
}
for {set i 1} {$i <= $count} {incr i} {
# Try to execute "body". On success break from loop...
uplevel [list try $body {*}$traps on ok {} break {*}$finally]
# On the last attempt, suppress the trap handlers...
if {$i + 1 == $count} {
set traps {}
}
}
}https://github.com/samoconnor/oclib.tcl
Here is a nice real-world example of using retry when dealing with a distributed Amazon Web Services SQS Queue.
retry count 4 {
set res [aws_sqs $aws CreateQueue QueueName $name {*}$attributes]
} trap QueueAlreadyExists {} {
delete_aws_sqs_queue [aws_sqs_queue $aws $name]
} trap AWS.SimpleQueueService.QueueDeletedRecently {} {
puts "Waiting 1 minute to re-create SQS Queue \"$name\"..."
after 60000
}Here is an alternate approach that adds a retry keyword to the normal try command:
interp alias {} retry {} continue
rename try tcl_try
proc try {args} {
while {1} {
uplevel tcl_try $args
break
}
}
try {
do_attempt
} on error {msg} {
puts "$msg\nTrying again..."
retry
}AMG: Some more explanation would be welcome. -- samoc sorry about the original unexplained version. Revised version is above.
This code appears to retry an operation a specified number of times, swallowing configurable errors and other such abnormal returns all but the final time, though giving the user the ability to specify the handlers. Your example shows waiting one second between retries.
Is this code intended to dodge a race condition? Maybe find another way to design your system such that the race doesn't exist. -- samoc: This code is intended to deal with interfacing to real-world non-determinism (networks, people, actuators, sensors etc...)
RLE (2014-05-25): samoc: Now you've posted, effectively, non-working code because you've left out your custom 'assert' implementation. However, if you are using Tcllib's assert then you need a "package require control" before defining the proc.
AMG: This [assert] looks fairly straightforward. From how it's being used, I assume this custom [assert] could be the following:
proc assert {test args} {
if {[llength $args]} {
set test \[[concat [list $test] $args]\]
}
if {![uplevel expr [list $test]]} {
error "assert failure: $test"
}
}samoc: In fact, my version of assert looks like this:
proc assert {args} {
# usage: assert command args...
# or: assert {expression}
if {[llength $args] == 1} {
if {[uplevel expr $args]} {
return
}
} else {
# Was just "[{*}$args]", thx to AMG for fix.
if {[uplevel $args]} {
return
}
}
return -code error \
-errorcode [list assert $args] \
"Assertion Failed:\n $args"
}
interp alias {} require {} assert... but there is plenty of other information about Assertions elsewhere on the wiki.
AMG: Doing {*}$args means it can't be an arbitrary script but only a command prefix. Furthermore, the lack of [uplevel] means it can't see the caller's variables. [info exists] is an example of where this matters. The following code fails with your [assert] but works with mine:
set somevar someval assert info exists somevar
samoc: Nice one. I missed that use-case. In my own code-base I used to have [uplevel $args] instead of [{*}$args] but I "simplified" it one step too far... I've reverted it now. Thankyou. The remaining difference between the two asserts seems to be: "trap" compatibility (-errorcode); and avoidance of the expr wrapper for non-expression asserts (not sure if it matters, the behaviour is the same).
samoc: The real version of retry that I use in my own code follows...
The version above is edited to make it more like plain Tcl. I have a special prize for anyone who can guess what language my custom version of proc is inspired by :)
proc retry {count_var count body args} {
Retry "body" up to "count" times for exceptions caught by "args".
"args" is a list of trap handlers: trap pattern variableList script...
The retry count is made visible through "count_var".
} require {
is wordchar $count_var
is integer $count
{[lfirst $args] in {trap on finally}}
} do {
upvar $count_var i
if {[lindex $args end-1] == "finally"} {
set traps [lrange $args 0 end-2]
set finally [lrange $args end-1 end]
} else {
set traps $args
set finally {}
}
for {set i 1} {$i <= $count} {incr i} {
# Try to execute "body". On success break from loop...
uplevel [list try $body {*}$traps on ok {} break {*}$finally]
# On the last attempt, suppress the trap handlers...
if {$i + 1 == $count} {
set traps {}
}
}
}RLE (2014-05-26): First guess, it looks quite Lisp like, with a doc-string, a let clause to define variable bindings, although in your case it is assertions, and a body to execute.
samoc: mais non, ce n'est pas lisp!
samoc: Oui! Eiffel. Le chef-d'œuvre de mon professeur Bertrand Meyer - http://bertrandmeyer.com . I worked on the Eiffel compiler and runtime at https://www.eiffel.com in S.B. for a couple of years in the late 90s. I later implemented a full-blown Eiffel-syntax class and design-by-contract system in Tcl, but I don't own that code. These days I'm trying to come up with a more lightweight way to incorporate the good bits from Eiffel, Obj-C, python etc into my Tcl code.
Here is proc:
rename proc tcl_proc
tcl_proc proc {name arguments args} {
if {[llength $args] == 1} {
set body [lfirst $args]
} else {
lassign $args comment require precondition do body
assert {$require == "require"}
assert {$do == "do"}
set precondition [lines [trim $precondition]]
prepend body [join [lmap l $precondition {get "assert $l"}] \n]
}
uplevel [list tcl_proc $name $arguments $body]
}Non-standard stuff in proc above includes: ::tcl::string::* is imported into ::; get (see shorthand dict set) and:
proc prepend {var_name string} {
upvar $var_name v
set v $string$v
}
proc lfirst {list} {
lindex $list 0
}
proc lines {string} {
lmap l [split [trimright $string \n] \n] {trimright $l \r}
}AMG: At the risk of straying from topic, I want to point out that in Tcl 8.4 and beyond, it's preferred to use eq and ne to test for string equality. The trouble with == and != is in how they compare strings like "0" and "0.0". They're numerically equal but textually unequal. What's more, eq is faster due to bypassing the attempted conversion to number.