Keith Vetter 2018-05-03: @decorators.tsh -- A tcl implementation of Python decorators
In Python, decorators are syntactic sugar that lets you wrap a function to provide some extra functionality [L1 ]. They're used for a bunch of different reasons, from memoization and timing to static methods and getters/setters[L2 ].
Once you start thinking in terms of wrapping functions, it's easy to come up with more and more instances when they can be very helpful.
Here's a short list of some useful tcl decorators that I've come up with in the past few months:
The syntax mimics Python:
@namedArgs \
proc MyFunction {...} {...}Here are the implementations and an example how to use each one:
proc @namedArgs {defaults p pname pargs lambda} {
# Creates dictionary argsDict with values in $defaults merged
# with all key=value items in $args
if {$p ne "proc"} { error "bad syntax: $p != 'proc'" }
if {[lindex $pargs end] ne "args"} {
proc $pname $pargs $lambda
return
}
set body "
set argsDict \[dict create $defaults\]
set newArgs {}
foreach arg \$args {
if {\[regexp {^(.*)=(.*)$} \$arg . key value\]} {
dict set argsDict \$key \$value
} else {
lappend newArgs \$arg
}
}
set args \$newArgs
$lambda
"
proc $pname $pargs $body
return $pname
}
@namedArgs {name1 default1 name2 default2 name3 default3 name4 default4} \
proc test_namedArgs {args} {
puts "In test_namedArgs with argsDict: "
set longest [tcl::mathfunc::max 0 {*}[lmap key [dict keys $argsDict] {string length $key}]]
dict for {key value} $argsDict {
puts [format " %-${longest}s = %s" $key $value]
}
}
test_namedArgs name1=value1 name3=value3 other args name4=value4
# ================
proc @tip288 {p {pname ""} {pargs ""} {lambda ""}} {
if {$p ne "proc"} {
if {$pname ne "" || $pargs ne "" || $lambda ne ""} {error "bad synax: $p != 'proc'"}
set pname $p
set pargs [info args $pname]
set lambda [info body $pname]
}
set idx [lsearch $pargs "args"]
if {$idx == -1 || $idx == [llength $pargs] - 1} {
proc $pname $pargs $lambda
return
}
set pre [lrange $pargs 0 $idx]
set post [lrange $pargs $idx+1 end]
set body "
set args \[lreverse \[lassign \[lreverse \$args\] [lreverse $post]\]\]
$lambda
"
proc $pname $pre $body
return $pname
}
@tip288 \
proc test_@tip288 {a b args c d} {
set msg "a: '$a' b: '$b' c: '$c' d: '$d' => args: '$args'"
puts $msg
return $msg
}
test_@tip288 A B these are random arguments for testing C D
# ================
proc @memoize {p pname pargs body} {
if {$p ne {proc}} {error [list {bad syntax} $p != proc]}
uplevel 1 [list ::proc $pname args [
list ::apply [list {memory pargs body} {
upvar 1 args args
if {[dict exists $memory $args]} {
return [dict get $memory $args]
}
set res [uplevel 2 [list ::apply [
list $pargs $body [namespace current]] {*}$args]]
dict set memory $args $res
puts [::tcl::unsupported::representation $memory]
proc [lindex [info level -1] 0] args [
lreplace [info level 0] 2 2 $memory]
return $res
} [uplevel 1 {namespace current}]] {} $pargs $body
]]
}
@memoize \
proc test_@memoize {a b} {
puts "in test_@memoize $a $b"
return $a
}
puts [test_@memoize 1 2]
puts [test_@memoize 1 2]
puts [test_@memoize 4 3]
puts [test_@memoize 4 3]
# ================
proc @autoIndex {p pname pargs lambda} {
if {$p ne "proc"} { error "bad synax: $p != 'proc'"}
proc $pname $pargs "
set argVals {}
foreach arg {$pargs} {
set val \[set \$arg\]
if {\[regexp \{^-?\\d+\[+-\]-?\\d+$\} \$val\]} { set val \[expr \$val\] }
lappend argVals \$val
}
apply {{$pargs} {$lambda}} {*}\$argVals
"
}
@autoIndex \
proc test_autoIndex {a b c} {
puts "a is $a and b is $b and c is $c"
}
test_autoIndex hello 3 4+5
# ================
proc @passByReference {p {pname ""} {pargs ""} {lambda ""}} {
if {$p ne "proc"} {
if {$pname ne "" || $pargs ne "" || $lambda ne ""} {error "bad synax: $p != 'proc'"}
set pname $p
set pargs [info args $pname]
set lambda [info body $pname]
}
set prefix ""
foreach arg [lsearch -all -inline -glob $pargs &*] {
append prefix "upvar 1 \${$arg} [string range $arg 1 end];\n"
}
proc $pname $pargs "$prefix$lambda"
return $pname
}
@passByReference \
proc test_@pbr {arg1 &who} {
puts "in test_@pbr: arg1='$arg1' who='$who'"
set who "new value for my global variable"
return
}
set myGlobal "my global variable"
puts "myGlobal before call: $myGlobal"
test_@pbr xxx myGlobal
puts "myGlobal after call: $myGlobal"
# ================
proc @debug {p pname pargs lambda} {
if {$p ne "proc"} { error "bad syntax: $p != 'proc'" }
proc $pname $pargs "
set msg \"DEBUG: calling $pname \"
foreach arg {$pargs} {
append msg \"\$arg=\[set \$arg\] \"
}
puts \$msg
try {
set start \[clock microseconds\]
set argVals \[lmap var {$pargs} {set \$var}]
set rval \[apply {{$pargs} {$lambda}} {*}\$argVals\]
} finally {
puts \"DEBUG: $pname returned \$rval\"
}
"
}
@debug \
proc test_debug {a b c} {
puts "a: $a b: $b c: $c"
return [string length $a]
}
test_debug 1 2 3
# ================
proc @time {p {pname ""} {pargs ""} {lambda ""}} {
if {$p ne "proc"} {
if {$pname ne "" || $pargs ne "" || $lambda ne ""} {error "bad synax: $p != 'proc'"}
set pname $p
set pargs [info args $pname]
set lambda [info body $pname]
}
proc $pname $pargs "
try {
set start \[clock microseconds\]
set argVals \[lmap var {$pargs} {set \$var}]
return \[apply {{$pargs} {$lambda}} {*}\$argVals\]
} finally {
puts \"$pname took \[expr {\[clock microseconds\] - \$start}\] microseconds\"
}
"
return $pname
}
@time \
proc test_timing {n} {
puts "in test_@timing: $n"
after $n
return "n is $n"
}
test_timing 500