A Purely theoretical question on Tcl.
Following this question I was thinking on what would be the best way to implement anonymous functions in Tcl.
The end result should be allowing a developer to pass a full proc as an argument to anohter proc:
do_something $data {proc {} {input} {
puts $input;
}};
which would be similar to javascript's
do_something(data, function (input) {
alert(input);
});
now, naturally this will not work OOTB. I was thinking on something of this sort:
proc do_something {data anon_function} {
anon_run $anon_function $data
}
proc anon_run {proc args} {
set rand proc_[clock clicks];
set script [lreplace $proc 1 1 $rand];
uplevel 1 $script;
uplevel 1 [concat $rand $args];
uplevel 1 rename $rand {}; //delete the created proc
}
This works. But I was hoping to get suggestions for a better pattern then this, as it's not very elegant and not really using cool Tcl features. Mostly I'd like to get rid of manually calling anon_run.
In Tcl 8.5, you can use the apply command.
proc do_something {data anon_function} {
apply $anon_function $data
}
do_something $data {{input} {
puts $input
}}
Of course, if you're structuring your callbacks as command prefixes (recommended!) then you can do this:
proc lambda {arguments body} {
# We'll do this properly and include the optional namespace
set ns [uplevel 1 namespace current]
return [list ::apply [list $arguments $body $ns]]
}
proc do_something {data command} {
{*}$command $data
}
do_something $data [lambda {input} {
puts $input
}]
If you're using 8.4 or before, you need the code from the Tcler's Wiki as a substitute, but be aware that those solutions are only semantically equivalent (at best); they're not performance-equivalent.
Related
I have a Tcl utility that makes it easy to ensure a snippet of code run at the time control flow leaves the current scope (of the proc). It crashes in Tcl 8.6.6, so I'm wondering if there is a "better" way to implement the functionality in Tcl 8.6?
An example usage is:
proc test {file} {
set fh [open $file]
::Util::Defer [list close $fh]
# ... do a bunch of stuff
# and even if we hit an error
# [close $fh] will be evaluated as we return
# from the proc
}
It's worked great in Tcl 8.4, and I use it all over my code.
As I'm still coming up to speed on all the functionality available in Tcl 8.6, I'm asking how should the ::Util::Defer proc be written to best take advantage of Tcl 8.6?
Here is the 8.4 implementation:
namespace eval ::Util {}
proc ::Util::Defer_impl {cmd args} {
uplevel 1 $cmd
}
proc ::Util::Defer {cmd} {
set vname _u_defer_var
# look for a unique variable name
while {[uplevel 1 [list info vars $vname]] != ""} {
set vname ${vname}_
}
uplevel 1 [list set $vname $cmd]
# when the variable is unset, trigger a call to the command
uplevel 1 [list trace add variable $vname unset [list ::Util::Defer_impl $cmd]]
# return a chunk of code enabling the user to cancel this if desired
return [list variable $vname unset [list ::Util::Defer_impl $cmd]]
}
Edited to add:
I appreciate the answers. To be honest, I already have other syntactic sugar for a file handle, this:
proc test {file} {
set fh [::Util::LocalFileHandle $file]
# do stuff
}
I was just hoping more for a generic solution to the ::Util::Defer - because I occasionally have two or three uses (at different locations) in the same proc. Yes, I'm leaving out the error handling if the doesn't exist or isn't readable.
Note: I have reported the bug to ActiveState and filed a bug at core.tcl.tk.
Edited to add buggy code: This is the Tcl code that causes a crash for me, it is slightly pared down to the essence (as opposed to being the full-blown ::Util::Defer).
# ---------------begin script-------------------
package require Itcl
proc ::try_uplevel {} {
return [uplevel 1 [list ::info vars _u_defer_var]]
}
itcl::class ::test_class {
constructor {} {}
public proc test_via_proc {} {
::try_uplevel
}
}
::test_class::test_via_proc
# ---------------end script-------------------
The pattern you describe is a supported one; it shouldn't crash (and indeed I can't reproduce the crash with 8.6.3 or the tip of the 8.6 support branch). The only problem it has is that if you have an error during the close (or any other deferred script) it won't report it, as you can see from this snippet (% is prompt):
% apply {{} {
::Util::Defer [list error boo]
puts hi
}}
hi
%
This is part of why I went to quite a bit of effort to provide a try command in 8.6. With that, you can do this:
proc test {filename} {
set f [open $filename]
try {
# Do stuff with $f
} finally {
close $f
}
}
It also takes care of tricky things like stitching errors thrown inside the body and the finally clause together (the body exception info is in the -during option of the finally clause's error exception info) so that if both places error you can find out about both.
% catch {
try {
error a
} finally {
error b
}
} x y
1
% puts $x
b
% puts $y
-errorstack {INNER {returnImm b {}}} -errorcode NONE -errorinfo {b
while executing
"error b"} -errorline 5 -during {-code 1 -level 0 -errorstack {INNER {returnImm a {}}} -errorcode NONE -errorinfo {a
while executing
"error a"} -errorline 3} -code 1 -level 0
Personally, I'd be more inclined to write this:
proc withreadfile {varName filename body} {
upvar 1 $varName f
set f [open $filename]
try {
return [uplevel 1 $body]
} finally {
close $f
}
}
proc test {file} {
withreadfile fh $file {
# Do stuff with $fh
}
}
Your mileage may vary.
Untested code (this exact snippet, I've used this pattern many times):
proc test file {
try {
open $file
} on ok fh {
# do stuff with fh
# more stuff
} finally {
catch {close $fh}
}
}
should be about the same. Regardless of whether you handle errors with the try structure or not, (or whether you get errors or not) the code in the finally clause is run when it ends. If you want to be able to cancel the action, use a simple if inside the clause.
Edit
In case one wants to see any errors generated when the channel is closed, it's a bad idea to just wrap it in a catch, which is necessary if the file couldn't be opened and the channel-id variable wasn't created. Alternatives include:
Checking for existence: if {[info exists fh]} {close $fh}
Propagate the closing error: using the result and options variable name arguments to catch.
Over the weekend this heavyweight solution came to mind. It leverages the itcl::local functionality to achieve the same effect. It does depend on Itcl - but since the problem is an interaction with Itcl, that seems a reasonable solution, even though it is not purely Tcl.
itcl::class Defer_impl {
constructor {cmd} {} {
set _to_eval $cmd
}
destructor {
uplevel 1 $_to_eval
}
private variable _to_eval {}
}
proc ::Util::Defer {cmd} {
uplevel 1 [list itcl::local ::Defer_impl #auto $cmd]
}
I'm trying to write a TclOO wrapper around the http package. The idea is to create an object passing the arguments that you would normally pass to http::geturl and have code, data, ncode and meta methods to return the same data as the corresponding http:: proc. To avoid lots of typing, I hit upon the following:
oo::class create myHttp {
constructor {url args} {
set responses {data code ncode meta}
foreach response $responses {
oo::objdefine [self object] variable -append m_$response
oo::objdefine [self object] method $response {} [subst -nocommands {
puts stdout [lsort [info vars *]]
return [set m_$response]
}]
}
set tok [http::geturl $url {*}$args]
foreach response $responses {
set m_$response [http::$response $tok]
}
http::cleanup $tok
}
Sadly it doesn't work.
% set h [myHttp new http://www.google.co.uk]
% $h code
m_code m_data m_meta m_ncode
can't read "m_code": no such variable
What's going on here? The output of [info vars] suggests that m_code exists, but the error says it doesn't. Accessing the variables directly from the [info object namespace $h] namespace shows that they all exist and have the expected values but all the accessor methods fail with the same error.
Is there a better way to "auto-generate" the methods and variables? I freely admit that I haven't quite got my head around defining methods using oo::objdefine rather than in an oo::class create statement, and I've tried adding, semi-randomly, my variable m_$response and variable m_$response statements in the $reponse methods to no avail. I'm concerned to find myself using subst here as I've usually found on later review that a simple list would have worked adequately and less opaquely.
For completeness, I'm using Tcl 8.6.4 using an ActiveState distribution on Windows 7, and debugging with TkCon.
I'd write it as
oo::class create myHttp {
variable tok
constructor {url args} {
set tok [http::geturl $url {*}$args]
foreach response {data code ncode meta} {
oo::objdefine [self] forward $response http::$response $tok
}
}
destructor {
http::cleanup $tok
}
}
but if you really need the variables for some purpose, that obviously won't work.
There is a TCL script which has multiple procedure definitions with similar name func in different namespaces. Procedures look like this:
proc func {a} {
puts $a
}
All that kind of procedures have only one argument a . All that kind of procedures are called from one single line in whole script:
func $a
I need to create another procedure definition also with similar name func in other namespace. But that procedure will have two parameters. That procedure is also need to be called from the same line that other procedures with same name. Procedure looks like this:
proc func {a b} {
puts $a
puts $b
}
I need now to modify the line that calls all that procedures func $a so, that it can call all procedures with one parameter and new procedure which has two parameters. But procedures definitions with one parameter must not be changed. What line that calls all these procedures func $a should look like?
If you want an optional parameter, and you know what the optional value should be if not supplied, you do this:
proc func {a {b "the default"}} {
puts "a is $a"
puts "b is $b"
}
If you need to compute the default value at runtime, the simplest technique is a magic sentinel value that is very unlikely to occur in real input. Such as two ASCII NUL characters (== Unicode U+000000):
proc func {a {b "\u0000\u0000"}} {
if {$b eq "\u0000\u0000"} {
set b "default:$a"
}
puts "a is $a"
puts "b is $b"
}
Otherwise, you can use the magic args value to get the complete list of arguments and do all the work “by hand”:
proc func {a args} {
if {[llength $args] == 0} {
set b "the default..."
} elseif {[llength $args] == 1} {
set b [lindex $args 0]
} else {
error "bad number of arguments!"
}
puts "a is $a"
puts "b is $b"
}
If you're doing that, the info level introspector can help, but things can get complicated…
To call one of two implementations of a command depending on the number of arguments is rather unusual in Tcl code. You can do it providing neither implementation of the command is in the global namespace and you are not wanting the switching behaviour when calling from the namespaces containing the implementations in question.
What you do is you create a procedure in the global namespace (which every other namespace will look for commands in if not present locally) which then chains explicitly to the desired implementation. The main thing you need to enable this is some way of working out which implementation you want in a particular case (such as looking at the length of the argument list).
For Tcl 8.6, you can use tailcall for the chaining for maximum efficiency:
proc ::func args {
if {[llength $args] == 1} {
tailcall ::impl1::func {*}$args
} else {
tailcall ::impl2::func {*}$args
}
}
In Tcl 8.5 you'd write this instead (which is an optimised case in the interpreter):
proc ::func args {
if {[llength $args] == 1} {
return [uplevel 1 [list ::impl1::func {*}$args]]
} else {
return [uplevel 1 [list ::impl2::func {*}$args]]
}
}
In older Tcl versions, you'd use something like this (which is slower):
proc ::func args {
if {[llength $args] == 1} {
return [uplevel 1 ::impl1::func $args]
} else {
return [uplevel 1 ::impl2::func $args]
}
}
None of this is perfect at handling getting the right sort of error messages when you call with entirely the wrong number of arguments, especially if neither implementation formally has optional arguments. Determining that automatically is probably wholly impractical! You end up having to write extra boilerplate code (which is pretty obvious and works in all versions of Tcl in a straight-forward way):
proc ::func args {
if {[llength $args] == 1} {
tailcall ::impl1::func {*}$args
} elseif {[llength $args] == 2} {
tailcall ::impl2::func {*}$args
} else {
# Using the -errorcode is optional really
return -code error -errorcode {TCL WRONGARGS} \
"wrong # args: should be \"func a ?b?\""
}
}
I found the solution from that answer: https://stackoverflow.com/a/22933188/1601703 . We can get the number of argument that procedure accepts and make coresponding if statments that will use corresponding procedure call:
set num [llength [info args func]]
if {$num == 1} {
func $a
} elseif {$num == 2} {
func $a $b
}
Is there any way to list all the procedures(proc) in a myFile.tcl using another tcl file or in the same file.
You can use [info procs] before and after sourcing the file in question and compare the results to determine which procs were added. For example:
proc diff {before after} {
set result [list]
foreach name $before {
set procs($name) 1
}
foreach name $after {
if { ![info exists procs($name)] } {
lappend result $name
}
}
return [lsort $result]
}
set __before [info procs]
source myFile.tcl
set __after [info procs]
puts "Added procs: [diff $__before $__after]"
One thing I like about this solution is that the diff procedure is really just a generic set differencing utility -- it's not specific to comparing lists of defined procedures.
The cheapest way is to just open the file and use regexp to pick out the names. It's not perfectly accurate, but it does a reasonably good job.
set f [open "sourcefile.tcl"]
set data [read $f]
close $f
foreach {dummy procName} [regexp -all -inline -line {^[\s:]*proc (\S+)} $data] {
puts "Found procedure $procName"
}
Does it deal with all cases? No. Does it deal with a useful subset? Yes. Is the subset large enough for you? Quite possibly.
Yes it is, although not that easy. The basic idea is to source the file in a modified slave interp that only executes some commands:
proc proc_handler {name arguments body} {
puts $name
}
set i [interp create -safe]
interp eval $i {proc unknown args {}}
interp alias $i proc {} proc_handler
interp invokehidden source yourfile.tcl
This approach will fail if the file requires other packages (package require will not work), relies on the result of some usually auto_load'ed commands etc..
It also does not take namespaces into account. (namespace eval ::foo {proc bar a {}} creates a proc with the name ::foo::bar
For a more complex implementation you could look into auto.tcl's auto_mkindex, which has a similar goal.
Here is a different approach:
Create a temporary namespace
Source (include) the script in question, then
Use the info procs command to get a list of procs
Delete the temporary namespace upon finish
Here is my script, *list_procs.tcl*:
#!/usr/bin/env tclsh
# Script to scan a Tcl script and list all the procs
proc listProcsFromFile {fileName} {
namespace eval TempNamespace {
source $fileName
set procsList [info procs]
}
set result $::TempNamespace::procsList
namespace delete TempNamespace
return $result
}
set fileName [lindex $::argv 0]
set procsList [listProcsFromFile $fileName]
puts "File $fileName contains the following procs: $procsList"
For example, if you have the following script, procs.tcl:
proc foo {a b c} {}
proc bar {a} {}
Then running the script will produce:
$ tclsh list_procs.tcl procs.tcl
File procs.tcl contains the following procs: foo bar
I need a procedure that will be able to access, read and change a variable from the namespace of the caller. The variable is called _current_selection. I have tried to do it using upvar in several different ways, but nothing worked. (I've written small test proc just to test the upvar mechanism). Here are my attempts:
call to proc:
select_shape $this _current_selection
proc:
proc select_shape {main_gui var_name} {
upvar $var_name curr_sel
puts " previously changed: $curr_sel"
set curr_sel [$curr_sel + 1]
}
For my second attempt:
call to proc:
select_shape $this
proc:
proc select_shape {main_gui} {
upvar _current_selection curr_sel
puts " previously changed: $curr_sel"
set curr_sel [$curr_sel + 1]
}
In all the attempts, once it reaches this area in the code it says can't read "curr_sel": no such variable
What am I doing wrong?
EDIT:
The call for the function is made from a bind command:
$this/zinc bind current <Button-1> [list select_shape $this _current_selection]
at start I thought that it doesn't matter. but maybe It does.
I believe that bind commands operate in the global namespace, so that's where the variable is expected to be found. This might work:
$this/zinc bind current <Button-1> \
[list select_shape $this [namespace current]::_current_selection]
for upvar to work the variable must exist in the scope that you are calling it in. consider the following:
proc t {varName} {
upvar $varName var
puts $var
}
#set x 1
t x
If you run it as it is you'll get the error you are reporting, uncomment the set x 1 line and it will work.
In the example below I've tried to cover the most variants of changing variables from other namespace. It 100% works for me. Maybe it will help.
proc select_shape {main_gui var_name} {
upvar $var_name curr_sel
puts " previously changed: $curr_sel"
incr curr_sel
}
namespace eval N {
variable _current_selection 1
variable this "some_value"
proc testN1 {} {
variable _current_selection
variable this
select_shape $this _current_selection
puts " new: $_current_selection"
}
# using absolute namespace name
proc testN2 {} {
select_shape [set [namespace current]::this] [namespace current]::_current_selection
puts " new: [set [namespace current]::_current_selection]"
}
select_shape $this _current_selection
puts " new: $_current_selection"
}
N::testN1
N::testN2
#-------------------------------------
# Example with Itcl class
package require Itcl
itcl::class C {
private variable _current_selection 10
public method testC {} {
select_shape $this [itcl::scope _current_selection]
puts " new: $_current_selection"
}
}
set c [C #auto]
$c testC