##********************************************************
 ## 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 Bonfield]


----

An 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 (laurent.riesterer@free.fr)
----
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:
   1. 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'''
   1. We create two additional server sockets in the master to represent '''stdout''' and '''stderr'''
   1. We let the slave close '''stdout''' channel and connect to the masters '''stdout''' server socket
   1. We let the slave close '''stderr''' channel and connect to the masters '''stderr''' server socket

Now every output to '''stdout''' and '''stderr''' will be send via the socket connections to the server without the need to overlay puts or to define new commands, simply by using the feature to close a standard channel and to open a new channel to replace the closed standard channel

And now we can stop using a pipe and can switch to use exec (with &).

If sample code is wanted, than please send an email!

Now I will try to replace '''stdin''' and to replace it by a sockect channel too. Results will be reported.

[male] - June 25th, 2004 (Update):

Wow, I never thought it will work even with replacing the '''stdin''' channel by a socket channel!
So, I redirected '''stdin''', '''stdout''', and '''stderr''' of a tcl shell via sockets to a controlling application.

----

'''[chuckles] - 2009-06-25 12:32:52'''

A 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
>                   }
>               }
======
----
[Category Command] | [Category Dev. Tools]