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]
}
Related
I am using the following TCL code:
proc RunCSM { scen } {
catch { $scen start }
if { "[$scen status]" != "SUCCESS" } {
puts "$scen FAILED. Error Info:"
puts "[$scen errorInfo]" ...
I need also the line number of the code that fails. In 8.5 and onwards this is achieved by this nice solution
How can I get the code line number along with errorinfo?
How is it possible to achieve the same but in version 8.4?
The easiest approach is to parse the errorInfo variable. Here's what an example looks like:
% parray foo
"foo" isn't an array
% set errorInfo
"foo" isn't an array
while executing
"error "\"$a\" isn't an array""
(procedure "parray" line 4)
invoked from within
"parray foo"
Parsing that with regexp isn't too hard, provided we use the -line option.
proc getLineFromErrorInfo {} {
global errorInfo
if {[regexp -line { line (\d+)\)$} $errorInfo -> line]} {
return $line
} else {
# No guarantee that there's information there...
return "unknown"
}
}
On our example from before, we can then do:
getLineFromErrorInfo
and it will return 4. You might want to extend the RE to also capture the name of the procedure; line numbers in 8.4 and before are always relative to their procedure. (This is also mostly true in 8.5 onwards; this is an area where backward compatibility is a bit painful IMO.) Here's how you might do that:
proc getLocusFromErrorInfo {} {
global errorInfo
if {[regexp -line {\(procedure "(.*?)" line (\d+)\)$} $errorInfo -> proc line]} {
return [list $proc $line]
} else {
# No guarantee that there's information there...
return "unknown"
}
}
Note that merely knowing where the error came from doesn't necessarily tell you where the problem is, especially in production code, since it could be due to bad arguments elsewhere that have been passed around a bit…
I was wondering how you would find the name of the test you're running in tcl from the test itself? I couldn't find this on google.
I'm calling another proc and passing the name of the test that is calling it, as an argument. So I would like to know which tcl command can do that for me.
This isn't an encouraged use case… but you can use info frame 1 to get the information if you use it directly inside the test.
proc example {contextTest} {
puts "Called from $contextTest"
return ok
}
tcltest::test foo-1.1 {testing the foo} {
example [lindex [dict get [info frame 1] cmd] 1]
} ok
This assumes that you're using Tcl 8.5 or later, but Tcl 8.5 is the oldest currently-supported Tcl version so that's a reasonable restriction.
I read your comments ("source ... instade of my test name") as follows: You seem to source the Tcl script file containing the tests (and Donal's instrumented tcltest), rather than batch-running the script from the command line: tclsh /path/to/your/file.tcl In this setting, there will be an extra ("eval") stack frame which distorts introspection.
To turn Donal's instrumentation more robust, I suggest actually walking the Tcl stack and watching out for a valid tcltest frame. This could look as follows:
package req tcltest
proc example {} {
for {set i 1} {$i<=[info frame]} {incr i} {
set frameInfo [info frame $i]
set frameType [dict get $frameInfo type]
set cmd [dict get $frameInfo cmd]
if {$frameType eq "source" && [lindex $cmd 0] eq "tcltest::test"} {
puts "Called from [lindex $cmd 1]"
return ok
}
}
return notok
}
tcltest::test foo-1.1 {testing the foo} {
example
} ok
This will return "Called from foo-1.1" both, when called as:
$ tclsh test.tcl
Called from foo-1.1
and
$ tclsh
% source test.tcl
Called from foo-1.1
% exit
The Tcl version used (8.5, 8.6) is not relevant. However, your are advised to upgrade to 8.6, 8.5 has reached its end of life.
I have a variable, let's say xx, with a list of index 0 and index 1 values. I want to modify a script (not mine) which previously defines a function, pptable, i.e.,
proc pptable {l1 l2} {
foreach i1 $l1 i2 $l2 {
puts " [format %6.2f $i1]\t[format %6.2f $i2]"
}
}
so that it displays the output into two columns using
pptable [lindex $xx 1] [lindex $xx 0]
However, I want to write the output directly to a file. Could you tell me how I can send the data to a file instead to the display?
One of the neatest ways of doing this is to stack on a channel transform that redirects stdout to where you want it to go. This works even if the write to stdout happens from C code or in a different thread as it plugs into the channel machinery. The code is a little bit long (and requires Tcl 8.6) but is reliable and actually mostly very simple.
package require Tcl 8.6; # *REQUIRED* for [chan push] and [chan pop]
proc RedirectorCallback {targetHandle op args} {
# The switch/lassign pattern is simplest way of doing this in one procedure
switch $op {
initialize {
lassign $args handle mode
# Sanity check
if {$mode ne "write"} {
close $targetHandle
error "this is just a write transform"
}
# List of supported subcommands
return {initialize finalize write}
}
finalize {
lassign $args handle
# All we need to do here is close the target file handle
close $targetHandle
}
write {
lassign $args handle buffer
# Write the data to *real* destination; this does the redirect
puts -nonewline $targetHandle $buffer
# Stop the data going to *true* stdout by returning empty string
return ""
# If we returned the data instead, this would do a 'tee'
}
default {
error "unsupported subcommand"
}
}
}
# Here's a wrapper to make the transform easy to use
proc redirectStdout {file script} {
# Stack the transform onto stdout with the file handle to write to
# (which is going to be $targetHandle in [redirector])
chan push stdout [list RedirectorCallback [open $file "wb"]]
# Run the script and *definitely* pop the transform after it finishes
try {
uplevel 1 $script
} finally {
chan pop stdout
}
}
How would we actually use this? It's really very easy in practice:
# Exactly the code you started with
proc pptable {l1 l2} {
foreach i1 $l1 i2 $l2 {
puts " [format %6.2f $i1]\t[format %6.2f $i2]"
}
}
# Demonstrate that stdout is working as normal
puts "before"
# Our wrapped call that we're capturing the output from; pick your own filename!
redirectStdout "foo.txt" {
pptable {1.2 1.3 1.4} {6.9 6.8 6.7}
}
# Demonstrate that stdout is working as normal again
puts "after"
When I run that code, I get this:
bash$ tclsh8.6 stdout-redirect-example.tcl
before
after
bash$ cat foo.txt
1.20 6.90
1.30 6.80
1.40 6.70
I believe that's precisely what you are looking for.
You can do this with less code if you use Tcllib and TclOO to help deal with the machinery:
package require Tcl 8.6
package require tcl::transform::core
oo::class create WriteRedirector {
superclass tcl::transform::core
variable targetHandle
constructor {targetFile} {
set targetHandle [open $targetFile "wb"]
}
destructor {
close $targetHandle
}
method write {handle buffer} {
puts -nonewline $targetHandle $buffer
return ""
}
# This is the wrapper, as a class method
self method redirectDuring {channel targetFile script} {
chan push $channel [my new $targetFile]
try {
uplevel 1 $script
} finally {
chan pop $channel
}
}
}
Usage example:
proc pptable {l1 l2} {
foreach i1 $l1 i2 $l2 {
puts " [format %6.2f $i1]\t[format %6.2f $i2]"
}
}
puts "before"
WriteRedirector redirectDuring stdout "foo.txt" {
pptable {1.2 1.3 1.4 1.5} {6.9 6.8 6.7 6.6}
}
puts "after"
I assume you don't want or can't modify the existing script and proc pptable, correct?
If so, there are different options, depending on your exact situation:
Redirect stdout: tclsh yourscript.tcl > your.out
Redefine puts (for a clearly defined scope):
rename ::puts ::puts.orig
proc puts args {
set fh [open your.out w];
::puts.orig $fh $args;
close $fh
}
# run pptable, source the script
This theme has been covered before, e.g., tcl stop all output going to stdout channel?
Rewire Tcl's stdout channel (not necessarily recommended):
close stdout
open your.out w
# run pptable, source the script
This has also been elaborated on before, e.g. Tracing stdout and stderr in Tcl
I know this question has been asked several times here. I have looked at the responses, but couldn't figure out the way it worked.Can you please help me understand.
Here it goes:
I'm trying to source a tcl script on the tclsh command line, and I want to redirect the output of that script into a file.
$ source my_script.tcl
The script my_script.tcl is something like this:
set output_file final_result
set OUT [open $output_file w]
proc calculate{} {
<commands>
return $result
}
foreach value [calculate] {
puts $output_file "$value"
}
This script still throws out the output onto the stdout, while I expected it to redirect the output into a file specified as "final_result"
Can you please help me understand where I went wrong ?
As you've described here, your program looks OK (apart from minor obvious issues). Your problem is that calculate must not write to stdout, but rather needs to return a value. Or list of values in your case, actually (since you're stuffing them through foreach).
Thus, if you're doing:
proc calculate {} {
set result {}
puts [expr {1 + 2 * 3}]
return $result
}
Then you're going to get output written stdout and an empty final_result (since it's an empty list). If you change that to:
proc calculate {} {
set result {}
lappend result [expr {1 + 2 * 3}]
return $result
}
then your code will do as expected. That is, from puts to lappend result. This is what I recommend you do.
You can capture “stdout” by overriding puts. This is a hack!
rename puts _puts
proc puts {args} {
# Detect where we're running. IMPORTANT!
if {[info level] > 1 && [lindex [info level -1] 0] eq "calculate"} {
upvar 1 result r
lappend r [lindex $args end]
} else {
_puts {*}$args
}
return
}
I'm not convinced that the code to detect whether to capture the value is what it ought to be, but it works in informal testing. (It's also possible to capture stdout itself by a few tricks, but the least horrible — a stacked “transformation” that intercepts the channel — takes a lot more code… and the other alternatives are worse in terms of subtleties.)
Assuming that calculate doesn't write to stdout, and all the other good stuff pointed out and suggested by #DonalFellows has been done...
You need to change the puts in the main script to
puts $OUT "$value"
The script as posted writes to a channel named final_result which almost certainly doesn't exist. I'd expect an error from the puts statement inside the foreach loop.
Don't forget to close the output file - either by exiting from the tclsh interpreter, or preferrably by executing
close $OUT
before you check for anything in it,
I'm relatively new in TCL, in TCL prompt, when we invoke a proc with some return value, the proc's return value is echoed back by tcl. Is there a way to stop it (without affecting puts or similar functionality) as an example
bash$ tclsh
% proc a {} { puts "hello"; return 34; }
% a
hello
34
%
Now how do i suppress the 34 coming to the screen? Any help is appreciated.
Update:
Actually the proc is a part of another tool, earlier it did not have any return value, but now conditionally it can return a value.
it can be called from a script and there won't be any problem (as Bryan pointed out). and it can be called from interactive prompt, then after all the necessary outputs, the return value is getting printed unnecessarily.
So 1) I don't have the facility of changing a user's tclshrc 2) existing scripts should continue to work.
And it seems strange that every time the proc is called, after all the necessary outputs, a number gets printed. To a user, this is a needless information unless he has caught the value and wants to do something. So i wanted the value to be delivered to user, but without getting printed to prompt/UI (hope i'm clear )
The interactive shell code in tclsh and wish will print any non-empty result. To get nothing printed, you have to have the last command on the “line” produce an empty result. But which command to use?
Many commands will produce an empty result:
if 1 {}
subst ""
format ""
However, the shortest is probably:
list
Thus, you could write your code like:
a;list
Of course, this only really becomes useful when your command actually produces a large result that you don't want to see. In those cases, I often find that it is most useful to use something that measures the size of the result, such as:
set tmp [something_which_produces a_gigantic result]; string length $tmp
The most useful commands I find for that are string length, llength and dict size.
If you absolutely must not print the result of the command, you have to write your own interactive loop. There are two ways to do this, depending on whether you are running inside the event loop or not:
Without the event loop
This simplistic version just checks to see if the command name is in what the user typed. It's probably not a good idea to arbitrarily throw away results otherwise!
set accum ""
while {[gets stdin line] >= 0} {
append accum $line "\n"
if {[info complete $accum]} {
if {[catch $accum msg]} {
puts stderr $msg
} elseif {$msg ne "" && ![string match *TheSpecialCommand* $accum]} {
puts $msg
}
set accum ""
}
}
With the event loop
This is just handling the blocking IO case; that's the correct thing when input is from a cooked terminal (i.e., the default)
fileevent stdin readable handleInput
set accum ""
proc handleInput {} {
global accum
if {[gets stdin line] < 0} {
exit; # Or whatever
}
append accum $line "\n"
if {[info complete $accum]} {
if {[catch {uplevel "#0" $accum} msg]} {
puts stderr $msg
} elseif {$msg ne "" && ![string match *TheSpecialCommand* $accum]} {
puts $msg
}
set accum ""
}
}
vwait forever; # Assuming you're not in wish or have some other event loop...
How to detect the command is being executed
The code above uses ![string match *TheSpecialCommand* $accum] to decide whether to throw away the command results, but this is very ugly. A more elegant approach that leverages Tcl's own built-in hooks is to use an execution trace to detect whether the command has been called (I'll just show the non-event-loop version here, for brevity). The other advantage of this is that it is simple to extend to suppressing the output from multiple commands: just add the trace to each of them.
trace add execution TheSpecialCommand enter SuppressOutput
proc SuppressOutput args {
# Important; do not suppress when it is called inside another command
if {[info level] == 1} {
set ::SuppressTheOutput 1
}
}
# Mostly very similar from here on
set accum ""
while {[gets stdin line] >= 0} {
append accum $line "\n"
if {[info complete $accum]} {
set SuppressTheOutput 0; # <<<<<< Note this!
if {[catch $accum msg]} {
puts stderr $msg
} elseif {$msg ne "" && !$SuppressTheOutput} { # <<<<<< Note this!
puts $msg
}
set accum ""
}
}
To be clear, I wouldn't ever do this in my own code! I'd just suppress the output manually if it mattered.
You could make an empty procedure in .tclshrc...
proc void {} {}
...and when you don't need a return value, end the line with ;void.
Use tcl_interactive variable to enable the return of of the value, although I'm not sure where this would be useful...
proc a {} {
puts "hello"
if { [info exist tcl_interactive] } {
return {};
} else {
return 34;
}
}