##********************************************************
## Name: stdout
##
## Description:
##
## Switch stdout handling by puts command from the usual
## behaviour to a state where stdout is redefined to be
## another file.
##
## Native puts command error handling is unimpaired and
## a dangling filehandle is never generated.
##
##
## Calling convention:
##
## stdout off - redirects stdout to nowhere
##
## stdout off /tmp/foo - redirects stdout to /tmp/foo
##
## stdout on - restores normal behaviour
##
##
## by: Phil Ehrens for the LIGO Lab at Caltech 09/02
## valuable contributions by: Bruce Hartweg
##********************************************************
proc stdout { switch { file "" } } {
if { ! [ llength [ info command __puts ] ] && \
[ string equal off $switch ] } {
rename puts __puts
if { [ string length $file ] } {
eval [ subst -nocommands {proc puts { args } {
set fid [ open $file a+ ]
if { [ llength \$args ] > 1 && \
[ lsearch \$args stdout ] == 0 } {
set args [ lreplace \$args 0 0 \$fid ]
} elseif { [ llength \$args ] == 1 } {
set args [ list \$fid \$args ]
}
if { [ catch {
eval __puts \$args
} err ] } {
close \$fid
return -code error \$err
}
close \$fid
}} ]
} else {
eval [ subst -nocommands {proc puts { args } {
if { [ llength \$args ] > 1 && \
[ lsearch \$args stdout ] == 0 || \
[ llength \$args ] == 1 } {
# no-op
} else {
eval __puts \$args
}
}} ]
}
} elseif { [ llength [ info command __puts ] ] && \
[ string equal on $switch ] } {
rename puts {}
rename __puts puts
}
}BBH To make it platform agnostic without a big switch, instead of redirecting to /dev/null, just make a puts to stdout be a complete no-op when it is turned off.
Well, the idea is that people will specify a file to redirect to, but you're right, it should just do nothing if no file is specified, so now it does ;^)---On a related note we use the following command to redirect any command producing stdout output to a tcl variable. It works by redirecting to a temporary file, although to do this it uses several UNIX specific calls though. (Actually we used to use this, but now we have no real need for it so it hasn't been tested it a while.)
#include <tcl.h>
#include <fcntl.h>
#include <sys/types.h>
#include <sys/stat.h>
#include <unistd.h>
#include "os.h"
#include "capture.h"
#include "misc.h"
int tcl_capture(ClientData clientData, Tcl_Interp *interp,
int argc, char **argv) {
int old_stdout;
static int fd = 0;
char *buf;
struct stat statbuf;
char *tmpfile;
int result;
if (argc != 2 && argc != 3) {
Tcl_AppendResult(interp, "wrong # args: should be \"",
argv[0], " command ?varName?\"", NULL);
return TCL_ERROR;
}
/* File descriptor mangling */
if (!fd) {
tmpfile = tmpnam(NULL);
fd = open(tmpfile, O_RDWR|O_CREAT|O_TRUNC, 0666);
} else {
lseek(fd, 0, SEEK_SET);
}
old_stdout = dup(1);
close(1);
dup2(fd, 1);
/* Run the command */
result = Tcl_Eval(interp, argv[1]);
/* Reset file descriptors */
dup2(old_stdout, 1);
close(old_stdout);
/* Reload the output */
fstat(fd, &statbuf);
if (NULL == (buf = (char *)xmalloc(statbuf.st_size+1)))
return TCL_ERROR;
lseek(fd, 0, SEEK_SET);
read(fd, buf, statbuf.st_size);
buf[statbuf.st_size]=0;
/* Return it to Tcl */
if (argc == 3) {
Tcl_ResetResult(interp);
sprintf(interp->result, "%d", result);
return Tcl_SetVar(interp, argv[2], buf, 0) ? TCL_OK : TCL_ERROR;
} else {
Tcl_SetResult(interp, buf, TCL_DYNAMIC);
}
return TCL_OK;
}James BonfieldAn other approach using the Memchan extension (warning: the current distribution has a bug, I have submitted a patch to the author).The idea is to close the standard channels (as explain in Tcl doc) and reopen them using a FIFO. The application can then work in a console or with Tk without any change in the code.
package require Tk
package require Memchan
text .t
.t tag configure stdout -font {Courier 10}
.t tag configure stderr -font {Courier 10} -foreground red
pack .t
# install new stdout
close stdout
set stdout [fifo]
fileevent $stdout readable ".t insert end \[read $stdout\] stdout; .t see end"
# install new stderr
close stderr
set stderr [fifo]
fileevent $stderr readable ".t insert end \[read $stderr\] stderr; .t see end"
# test it
puts "this is stdout"
puts stderr "this is stderr"Laurent Riesterer ([email protected])I am developing a Tcl/Tk application (call it rs) and I want to redirect stdout to a text box in my Tcl/Tk application. I am using Memchan to achieve this (I statically linked Memchan into my application). But I am unable to rename the fifo channel I created as stderr.For example, in the following snippet, I am closing stderr and then opening fifo as stderr but fifo channel remains named as fifo0 not as stderr.
$ rs rs> package require Memchan 2.3 rs> chan names stdin stdout stderr rs> close stderr rs> chan names stdin stdout rs> set stderr [fifo] fifo0 rs> chan names fifo0 stdin stdoutI expected stderr instead of fifo0 when I typed in the last of the chan names command.But when I use tclsh8.5 the above sequence produces the desired effect i.e fifo is renamed as stderr
$ tclsh8.5 % package req Memchan 2.3 % chan names stdin stdout stderr % close stderr % chan names stdin stdout % set stderr [fifo] fifo0 % chan names stderr stdin stdoutNote: no fifo0 but we get the desired stderr.Can someone point out how to reproduce the behavior in tclsh8.5 in my Tcl/Tk application rs.(Anand R) May 11 2011Update May 12 2011 Stackoverflow
Donal FellowsSince memchan doesn't produce channels backed up by a file descriptor, it can't replace the standard channels (which always correspond to FDs 0, 1 and 2).We had some problems with piped executables, even tcl shells with added "external" code using cout and printf. None of the output came via the pipe to our calling tcl application.Our calling tcl application (master) starts the tcl shell via pipe (open |...) and is connected to the called tcl shell (slave) via a socket to send commands and to receive command results.So we thought about redefining stdout, stderr in this way:
- We don't use in our C(++) the cout or printf, but only Tcl_Write or an encapsulated version of Tcl_Write on stdout or stderr
- We create two additional server sockets in the master to represent stdout and stderr
- We let the slave close stdout channel and connect to the masters stdout server socket
- We let the slave close stderr channel and connect to the masters stderr server socket
[chuckles] - 2009-06-25 12:32:52A small tweak here will allow a 'dup' of stdout:
1a2
> ##
18a20
> ## stdout dup /tmp/foo - sends all output to stdout as well as /tmp/foo
29c31
< [ string equal off $switch ] } {
---
> [ regexp {off|dup} $switch ] } {
32a35,41
> if {[string equal dup $switch]} {
> if { [ catch {
> eval __puts \$args
> } err ] } {
> return -code error \$err
> }
> }[newb] - 2011-09-02 08:58:54I am newbie in TCL. I was able to call this procedure, however in output file, every line is enclosed by {}. How to get rid of these {} for every line?
[Stave] - 2012-05-14 20:11:09Replacing
set args [list \$fid \$args]with
set args [concat \$fid \$args]may solve the problem you're seeing, "newb"
