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 [
1]. They're used for a bunch of different reasons, from memoization and timing to static methods and getters/setters[
2].
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:
- @namedArgs -- lets you call functions like myFunc var1=value1 var2=value2
- @tip288
-- implementation of tip288, args anywhere in the procedure argument list - @memoize -- automatically memoizes any function
- @autoIndex -- allow a+b type arguments (ala lindex) for any function
- @passByReference -- turns all &arg into a pass by reference argument
- @debug -- prints the arguments a function is called with and its return value
- @time -- prints how much time a function took to execute
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 dictinary 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 lambda} {
if {$p ne "proc"} { error "bad synax: $p != 'proc'"}
proc $pname $pargs "
set cmd \[info level 0\]
if {\[info exists ::MEM(\$cmd\)\]} { return \$::MEM(\$cmd) }
set argVals \[lmap var {$pargs} {set \$var}]
set ::MEM(\$cmd) \[apply {{$pargs} {$lambda}} {*}\$argVals\]
"
}
@memoize \
proc test_@memoize {a b} {
puts "in test_@memoize $a $b"
return $a
}
test_@memoize 1 2
test_@memoize 1 2
# ================
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
