Implement 'pid handle'

Signed-off-by: Steve Bennett <steveb@workware.net.au>

4 files changed, 99 insertions, 11 deletions

diff --git a/examples/popen.tcl b/examples/popen.tcl
index 8a6b6e3..f330fc9 100644
--- a/examples/popen.tcl
+++ b/examples/popen.tcl
@@ -4,14 +4,15 @@
 
 # Write to a pipe
 set f [open |[list cat | sed -e "s/line/This is line/" >temp.out] w]
+puts "Creating temp.out with pids: [pid $f]"
 foreach n {1 2 3 4 5} {
 	puts $f "line $n"
 }
 close $f
-puts "Created temp.out"
 
 # Read from a pipe
 set f [open "|cat temp.out"]
+puts "Reading temp.out with pids: [pid $f]"
 while {[gets $f buf] >= 0} {
 	puts $buf
 }
diff --git a/jim_tcl.txt b/jim_tcl.txt
index eb2cec6..fa2387b 100644
--- a/jim_tcl.txt
+++ b/jim_tcl.txt
@@ -78,9 +78,10 @@ Since v0.62:
 16. Event handlers works better if an error occurs. eof handler has been removed.
 17. 'exec' now sets $::errorCode, and catch sets opts(-errorcode) for exit status
 18. Command pipelines via open "|..." are now supported
-19. Add 'info references'
-20. Add support for 'after *ms*', 'after idle', 'after info', 'update'
-21. 'exec' now sets environment based on $::env
+19. 'pid' can now return pids of a command pipeline
+20. Add 'info references'
+21. Add support for 'after *ms*', 'after idle', 'after info', 'update'
+22. 'exec' now sets environment based on $::env
 
 Since v0.61:
 
@@ -2817,6 +2818,8 @@ open
 ~~~~
 +*open* 'fileName ?access?'+
 
++*open* '|command-pipeline ?access?'+
+
 Opens a file and returns an identifier
 that may be used in future invocations
 of commands like 'read', 'puts', and 'close'.
@@ -2866,7 +2869,10 @@ by the command. If read-only access is used (e.g. *access* is r),
 standard input for the pipeline is taken from the current standard
 input unless overridden by the command.
 
-See also 'socket'
+The 'pid' command may be used to return the process ids of the commands
+forming the command pipeline.
+
+See also 'socket', 'pid', 'exec'
 
 package
 ~~~~~~~
@@ -2891,7 +2897,16 @@ pid
 ~~~
 +*pid*+
 
-Returns the process identifier of the current process.
++*pid* 'fileId'+
+
+The first form returns the process identifier of the current process.
+
+The second form accepts a handle returned by 'open' and returns a list
+of the process ids forming the pipeline in the same form as 'exec ... &'.
+If 'fileId' represents a regular file handle rather than a command pipeline, 
+the empty string is returned instead.
+
+See also 'open', 'exec'
 
 proc
 ~~~~
@@ -4237,6 +4252,8 @@ by the Tcl library.
     Reading an element will return the value of the corresponding
     environment variable.
     This array is initialised at startup from the 'env' command.
+	It may be modified and will affect the environment passed to
+	commands invoked with 'exec'.
 
 +*auto_path*+::
     This variable contains a list of paths to search for packages.
diff --git a/tclcompat.tcl b/tclcompat.tcl
index 6c981b7..c632103 100644
--- a/tclcompat.tcl
+++ b/tclcompat.tcl
@@ -163,19 +163,26 @@ proc {file copy} {{force {}} source target} {
 }
 
 # 'open "|..." ?mode?" will invoke this wrapper around exec/pipe
+# Note that we return a lambda which also provides the 'pid' command
 proc popen {cmd {mode r}} {
 	lassign [socket pipe] r w
 	try {
 		if {[string match "w*" $mode]} {
 			lappend cmd <@$r &
-			exec {*}$cmd
+			set pids [exec {*}$cmd]
 			$r close
-			return $w
+			set f $w
 		} else {
 			lappend cmd >@$w &
-			exec {*}$cmd
+			set pids [exec {*}$cmd]
 			$w close
-			return $r
+			set f $r
+		}
+		lambda {cmd args} {f pids} {
+			if {$cmd eq "pid"} {
+				return $pids
+			}
+			tailcall $f $cmd {*}$args
 		}
 	} on error {error opts} {
 		$r close
@@ -184,6 +191,21 @@ proc popen {cmd {mode r}} {
 	}
 }
 
+# A wrapper around 'pid' which can return the pids for 'popen'
+rename pid .pid
+proc pid {{chan {}}} {
+	if {$chan eq ""} {
+		tailcall .pid
+	}
+	if {[catch {$chan tell}} {
+		return -code error "can not find channel named \"$chan\""
+	}
+	if {[catch {$chan pid} pids} {
+		return ""
+	}
+	return $pids
+}
+
 # try/on/finally conceptually similar to Tcl 8.6
 #
 # Usage: try ?catchopts? script ?onclause ...? ?finallyclause?
@@ -260,4 +282,4 @@ proc throw {code {msg ""}} {
 	return -code $code $msg
 }
 
-set ::tcl_platform(platform) unix
+set tcl_platform(platform) unix
diff --git a/tests/pid.test b/tests/pid.test
new file mode 100644
index 0000000..c539fc4
--- /dev/null
+++ b/tests/pid.test
@@ -0,0 +1,48 @@
+# Commands covered:  pid
+#
+# This file contains a collection of tests for one or more of the Tcl
+# built-in commands.  Sourcing this file into Tcl runs the tests and
+# generates output for errors.  No output means no errors were found.
+#
+# Copyright (c) 1991-1993 The Regents of the University of California.
+# Copyright (c) 1994-1995 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: pid.test,v 1.6 2000/04/10 17:19:03 ericm Exp $
+
+source testing.tcl
+
+file delete test1
+
+test pid-1.1 {pid command} {
+    regexp {(^[0-9]+$)|(^0x[0-9a-fA-F]+$)} [pid]
+} 1
+test pid-1.2 {pid command} {
+    set f [open {| echo foo | cat >test1} w]
+    set pids [pid $f]
+    close $f
+    catch {removeFile test1}
+    list [llength $pids] [regexp {^[0-9]+$} [lindex $pids 0]] \
+       [regexp {^[0-9]+$} [lindex $pids 1]] \
+       [expr {[lindex $pids 0] == [lindex $pids 1]}]
+} {2 1 1 0}
+test pid-1.3 {pid command} {
+    set f [open test1 w]
+    set pids [pid $f]
+    close $f
+    set pids
+} {}
+test pid-1.4 {pid command} {
+    list [catch {pid a b} msg] $msg
+} {1 {wrong # args: should be "pid ?chan?"}}
+test pid-1.5 {pid command} {
+    list [catch {pid gorp} msg] $msg
+} {1 {can not find channel named "gorp"}}
+
+# cleanup
+file delete test1
+
+testreport