~li-anye-0/+junk/tcl-stuff

# exec2.tcl

# exec2 - subprocess invocation

##################################################################

# Copyright (C) 2011 by Anye Li

# Permission is hereby granted, free of charge, to any person
# obtaining a copy of this software and associated documentation
# files (the "Software"), to deal in the Software without
# restriction, including without limitation the rights to use,
# copy, modify, merge, publish, distribute, sublicense, and/or
# sell copies of the Software, and to permit persons to whom
# the Software is furnished to do so, subject to the following
# conditions:

# The above copyright notice and this permission notice shall be
# included in all copies or substantial portions of the Software.

# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY
# KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE
# WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE
# AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
# HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
# WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
# FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
# OTHER DEALINGS IN THE SOFTWARE.

##################################################################

# INTRODUCTION

# Tcl's built-in exec and open | mechanisms are powerful,
# but taking them beyond their designed usage can be pretty
# cumbersome. In particular, it really shouldn't be so hard to get

#  the exit status from exec,

#  stderr output without having to wait for the process to die,
#  without using error handling

#  any kind of output when the process exits abnormally

#  a separate stdin and stdout channel, not to mention an stderr
#  channel at the end of the pipeline, not to mention stderr
#  channels in the middle of the pipeline, ...

# I propose a new proc, exec2, that provides this functionality
# with a simple and concise syntax.  Originally I proposed a
# second proc, popen2, to handle the background processing,
# but I suspect people are already used to the idea of adding
# an ampersand at the end of the command line for completely
# different output, and in the case of exec2, a different
# input format.

# I don't propose to replace exec or open |, since my interface
# has different return values, and exec and open | may be exactly
# what you want in many cases.

# This is a UNIX-only implementation, is really only meant to be
# a proof of concept. There are probably some bugs and the use of
# mktemp(1) and mkfifo(1) introduces potential race conditions.

# Behavior described under LIMITATIONS is due to defects in the
# implementation and is not part of the design.


# Anye Li
# 2011-02-17
# 2011-02-26

##################################################################

# FUTURE DIRECTIONS

# There are several things I would do but can't because of
# limitations on exec itself.

# If I were to rewrite this as an extension in C, I would
# introduce a quote character, say ' to allow for redirection
# operators. I suggest ' because it is a common quoting characater
# that need not be escaped because it is not a Tcl quote
# character, and is relatively uncommon in file names and command
# line switches due to it being a shell quote character. Thus a
# command line could be easily and safely quoted without confusing
# word boundaries with something like:

#  exec2 command '$arg1 '$arg2 ...

# Since my interface is incompatible with exec, I would also
# ditch the csh-style >& and special case 2>@1 and use Bourne
# shell redirection operators, which give the full power of
# dup2. The @ operators are still valuable because they provide
# interoperability with Tcl channels.

# I would also add a wait command and event, which would make the
# pids much more useful.


# Anye Li
# 2011-02-26

##################################################################

# REQUIREMENTS

# 8.6 is needed for try/trap/on/finally
# 8.6b1 actually uses the pure Tcl reference implementation,
# so you could just use that and remove the following line.
package require Tcl 8.6

# You also must have working mktemp(1) and mkfifo(1) commands
# available in your PATH.

##################################################################

# DRIVERS

proc exec2 args {
# exec2 arg ?arg ...? ?&?

# [exec2 arg ?arg ...?] behaves like [exec arg ?arg ...? with the
# following differences:

# Returns exit status instead of output
# Printing to standard error is never considered an error
# Output is assigned via the following operators:

#     >%    var
#     >>%   var
#     >*%   var
#     >>*%  var
#        Assign stdout output to var
#     2>%   var
#     2>>%  var
#     2>*%  var
#     2>>*% var
#        Assign stderr output to var
#     >&%   var
#     >>&%  var
#     >&*%  var
#     >>&*% var
#        Assign stdout and stderr output to var
#
#     >> variants append instead of set.
#     *  variants keep the final newline.

# Because standard error and discarding of final newlines are
# handled by the new operators, there are no switches.

# exec2 arg ?arg ...? & behaves like [exec arg ... ?arg? &] with
# the following differences.

# Channels are assigned using new operators

#     <%    var
#        Assign stdin  channel to var
#     >%    var
#        Assign stdout channel to var
#     2>%   var
#        Assign stderr channel to var
#     >&%   var
#        Assign stdout and stderr channel to var

# All standard exec redirection operators remain valid.

# LIMITATIONS

# [exec arg ?arg ...?]

# If appending multiple outputs to the same variable, the full
# output of each stream will be concatenated in order rather than
# the output being appended as it is produced.

# [exec arg ?arg ...? &]

# <% may only occur once, only during the first command, and other
# redirection operators may not be present

# If <% is not present, then the final output must not be
# redirected to anything but a single >% or >&%.

# Closing the channel connected to %< if present forces a wait. If
# <% is not present, then closing the channel connected to the >%
# or >&% of the final command forces the wait. If none of <%, or a
# final command >% or >&% are present, then [exec ... &] is used
# and there is no way to wait on the process or recover the exit
# status. Personally, I would rather have a child status event
# like wait(2).

# Error messages are big and ugly.

# There are some potential race conditions due to mktemp and
# tempfifo. Using [chan pipe] might have been cleaner, but I
# didn't want channels associated with the child processes' end of
# the pipe.

   # 8.5/8.6 redirection ops
   set ops0 {<[<@]?|>[>&@]?|2>[>@]?|>>&|>&@}

   if {[lindex $args end] ne {&}} {
      # [exec arg ?arg ...?]

      # New redirection ops
      set ops1 {>[>&]?\*?%|2>>?\*?%|>>&\*?%}

      lassign {} args1 redirects
      set n [llength $args]
      try {
         for {set i 0} {$i<$n} {incr i} {
            # Scan for redirection ops
            set arg [lindex $args $i]
            if {$arg ne {2>@1} &&
                  [regexp ^$ops0|$ops1 $arg op]} {
               set m [string length $op]
               if {$m==[string length $arg]} {
                  # Eat the next arg if the op stands alone
                  if {[incr i]==$n} {
                     error "can't specify \"$op\"\
                        as last word in command"
                  }
                  set arg [lindex $args $i]
                  # No op to trim from the arg
                  set m 0
                  if {[string index $op end] ne {%}} {
                     # This not one of our new ops
                     # Push the arg as is
                     lappend args1 $op
                  }
               }
               if {[string index $op end] eq {%}} {
                  # This is one of our new ops
                  # Strip the %
                  set op [string range $op 0 end-1]
                  set f [tempfile]
                  lappend redirects $f $op\
                     [string range $arg $m end]
                  # Strip the optional %
                  if {[string index $op end] eq "*"} {
                     set op [string range $op 0 end-1]
                  }
                  if {[string index $op end] eq {&}} {
                     lappend args1 >&@ $f
                  } elseif {[string index $op 0] eq {2}} {
                     lappend args1 2>@ $f
                  } else {
                     lappend args1 >@ $f
                  }
                  continue
               }
            }
            # This not one of our new ops
            # Push the arg as is
            lappend args1 $arg
         }
         # Exec the modified command line
         # Exit status will be in the return options
         try {
            exec -ignorestderr -- {*}$args1
         } trap CHILDSTATUS {result options} {
            set status [lindex [dict get $options -errorcode] 2]
         } on ok {} {
            set status 0
         }
         # Slurp the output from the temp files
         foreach {f op var} $redirects {
            flush $f
            seek $f 0 start
            if {[string index $op end] eq "*"} {
               set s [read $f]
            } else {
               set s [read -nonewline $f]
            }
            upvar 1 $var output
            if {[string match *>>* $op]} {
               append output $s
            } else {
               set output $s
            }
         }
         return $status
      } finally {
         foreach {f op var} $redirects {
            close $f
         }
      }
   } else {
      # [exec arg ?arg ...? &]
      set args [lrange $args 0 end-1]

      # New redirection ops
      set ops1 {<%|>&?%|2>%}

      lassign {} argls args1 args2 files chans redirects
      set cmdno 0
      set pipein 0
      set pipeout 0
      set n [llength $args]
      try {
         for {set i 0} {$i<$n} {incr i} {
            # Scan for redirection ops
            set arg [lindex $args $i]
            if {$arg ne {2>@1} &&
                  [regexp ^$ops0|$ops1 $arg op]} {
               set m [string length $op]
               if {$m==[string length $arg]} {
                  # Eat the next arg if the op stands alone
                  if {[incr i]==$n} {
                     error "can't specify \"$op\"\
                        as last word in command"
                  }
                  set arg [lindex $args $i]
                  # No op to trim from the arg
                  set m 0
                  if {[string index $op end] ne {%}} {
                     # This not one of our new ops
                     # Push the arg as is
                     lappend args1 $op
                  }
               }
               if {[string index $op end] eq {%}} {
                  # This is one of our new ops
                  # Strip the %
                  set op [string range $op 0 end-1]
                  set var [string range $arg $m end]
                  if {$op eq {<}} {
                     if {$pipein} {
                        error "<% may only be used once"
                     }
                     if {$cmdno>0} {
                        error "<% must be in first command"
                     }
                     set pipein 1
                     set invar $var
                  } elseif {$op eq {2>}} {
                     upvar 1 $var f
                     set f [tempfifo file]
                     lappend files $file
                     lappend chans $f
                     fconfigure $f -blocking 1
                     lappend args1 $op $file
                  } else {
                     # push this redirect on to the list;
                     # we'll deal with it later
                     set pipeout 1
                     lappend argls $args1
                     set args1 {}
                     lappend redirects $op $var
                  }
                  continue
               } elseif {[string index $op 0] eq {>}} {
                  # Redirect to stdout
                  set pipeout 0
               }
            } elseif {[string index $arg 0] eq {|}} {
               # Anything beginning with | is assumed to start a
               # new command
               # This breaks command lines with arguments that
               # start with |, but exec is broken in this sense
               # anyway
               incr cmdno
               set pipeout 0
            }
            # This not one of our new ops
            # Push the arg as is
            lappend args1 $arg
         }
         try {
            # Insert the output redirects
            if {$pipeout&&!$pipein} {
               set redirects [lassign $redirects outop outvar]
               set argls [lassign $argls argl]
               set args1 [concat $argl $args1]
            }
            foreach argl $argls {op var} $redirects {
               upvar 1 $var f
               set f [tempfifo file]
               lappend files $file
               lappend chans $chans
               fconfigure $f -blocking 1
               lappend args2 $argl $op $file
            }
            lappend args2 $args1
            set args1 [join $args2]

            if {$pipein} {
               # %< present; we must obtain the channel from
               # [open |cmd w] as there seems to be no other
               # way to open the pipeline without blocking
               upvar 1 $invar g
               set g [open |$args1 w]
            } elseif {$pipeout} {
               # %< not present, >% or >&% present on final
               # command
               upvar 1 $outvar g
               if {$outop eq {>&}} {
                  if {[lindex $args1 end] ne {2>@1}} {
                     lappend args1 2>@1
                  }
               }
               set g [open |$args1 r]
            } else {
               # Don't want stdin or stdout channels
               return [exec -ignorestderr -- {*}$args1 &]
            }
            return [pid $g]
         } on error {result options} {
            foreach f $chans {
               close $f
            }
            return -options $options $result
         }
      } finally {
         file delete {*}$files
      }
   }
}

##################################################################

# HELPERS

proc tempfile {} {
# Incomplete UNIX implementation of TIP #210
   set file [exec mktemp]
   try {
      return [open $file r+]
   } finally {
      file delete $file
   }
}

proc tempfifo filevar {
# Create a temporary named UNIX pipe 
   upvar 1 $filevar file
   set file [exec mktemp]
   file delete $file
   exec mkfifo $file
   if {[catch {open $file {RDONLY NONBLOCK}} result options]} {
      file delete $file
   }
   return -options $options $result
}

##################################################################

# EXAMPLES
return

set status [exec2 sh -c\
   "echo hello world; echo >&2 hello error; false" >%out 2>%err]
puts [list $status $out $err]

puts [exec2 sh -c\
   "echo hello world; echo >&2 hello error" >%out 2>%err &]
puts [read -nonewline $out]
close $out
puts [read -nonewline $err]
close $err

puts [exec2 sh -c\
   "echo hello world; echo >&2 hello error" >%out &]
puts [read -nonewline $out]
catch {close $out}

puts [exec2 sh -c\
   "echo hello world; echo >&2 hello error" 2>%err &]
puts [read -nonewline $err]
close $err

puts [exec2 sh -c\
   "echo hello world; echo >&2 hello error" >&%out &]
puts [read -nonewline $out]
catch {close $out}

puts [exec2 sh -c\
   "echo hello world; echo >&2 hello error" 2>%err &]
puts [read -nonewline $err]
close $err

puts [exec2 sh -c\
   "echo hello world; cat >&2" <%in >%out 2>%err &]
puts $in "hello error"
close $in
puts [read -nonewline $out]
close $out
puts [read -nonewline $err]
close $err