Zarutian tormented kbk the other day (late Desember 2007 or early January 2008) with this:
package Tcl 8.5
variable storage {}
proc restore {caller vars} {
if {![dict exists $::storage $caller]} { return }
foreach var $vars {
uplevel 1 [list set $var [dict get $::storage $caller $var]]
}
}
proc save {caller vars} {
foreach var $vars {
dict set ::storage $caller $var [uplevel 1 [list set $var]]
}
}
proc persist {args} {
set vars $args; unset args
if {[uplevel 1 [list info exists __[info level 0]]]} { return }
uplevel 1 [list set __[info level 0] exists]
set caller [lindex [info level 1] 0]
uplevel 1 [list restore $caller $vars]
catch [list uplevel 1 [info body $caller]] result options
uplevel 1 [list save $caller $vars]
dict incr options -level +2
return -options $options $result
}
proc prufa {args} {
persist si
incr si 42
puts "si = $si"
}another well known procedure decorator is memoize, but that only works for referentially transparent functions (i.e. side-effect free procedures).
DKF: So what does this code do? It's not at all clear from just reading the code...
RS: Could it have to do with static variables? But I don't understand the code either...
Zarutian: indeed the above example of an decorator is for persisting static variables.
| enter categories here |
|---|
For Tcl 8.4 lovers should work in this way
package require dict
variable storage {}
proc restore {caller vars} {
if {![dict exists $::storage $caller]} { return }
foreach var $vars {
uplevel 1 [list set $var [dict get $::storage $caller $var]]
}
}
proc save {caller vars} {
foreach var $vars {
dict set ::storage $caller $var [uplevel 1 [list set $var]]
}
}
proc persist {args} {
set vars $args; unset args
if {[uplevel 1 [list info exists __[info level 0]]]} { return }
uplevel 1 [list set __[info level 0] exists]
set caller [lindex [info level 1] 0]
uplevel 1 [list restore $caller $vars]
catch [list uplevel 1 [info body $caller]] result
uplevel 1 [list save $caller $vars]
dict incr -level +2
return $result
}
proc prufa {{si 0}} {
persist si
incr si 42
#puts "si = $si"
}
puts [prufa]
puts [prufa]
puts [prufa]