summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--doc/process.n131
-rw-r--r--generic/tclInt.decls4
-rw-r--r--generic/tclIntPlatDecls.h6
-rw-r--r--tests/process.test262
-rw-r--r--unix/tclUnixFCmd.c2
-rw-r--r--unix/tclUnixFile.c2
-rw-r--r--unix/tclUnixPort.h4
-rw-r--r--unix/tclUnixThrd.c2
-rw-r--r--win/makefile.vc4
9 files changed, 395 insertions, 22 deletions
diff --git a/doc/process.n b/doc/process.n
new file mode 100644
index 0000000..fbe307b
--- /dev/null
+++ b/doc/process.n
@@ -0,0 +1,131 @@
+'\"
+'\" Copyright (c) 2017 Frederic Bonnet.
+'\"
+'\" See the file "license.terms" for information on usage and redistribution
+'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+'\"
+.TH process n 8.7 Tcl "Tcl Built-In Commands"
+.so man.macros
+.BS
+'\" Note: do not modify the .SH NAME line immediately below!
+.SH NAME
+tcl::process \- Subprocess management
+.SH SYNOPSIS
+\fB::tcl::process \fIoption \fR?\fIarg arg ...\fR?
+.BE
+.SH DESCRIPTION
+.PP
+This command provides a way to manage subprocesses created by the \fBopen\fR
+and \fBexec\fR commands. The legal \fIoptions\fR (which may be abbreviated) are:
+.TP
+\fB::tcl::process list\fR
+.
+Returns the list of subprocess PIDs.
+.TP
+\fB::tcl::process status\fR ?\fIswitches\fR? ?\fIpids\fR?
+.
+Returns a dictionary mapping subprocess PIDs to their respective status. If
+\fIpids\fR is specified as a list of PIDs then the command only returns the
+status of the matching subprocesses if they exist, and raises an error
+otherwise. For active processes, the status is an empty value. For terminated
+processes, the status is a list with the following format:
+.QW "{code ?\fImsg errorCode\fR?}" ,
+where:
+.RS
+.TP
+\fBcode\fR\0
+.
+is a standard Tcl return code,
+.TP
+\fBmsg\fR\0
+.
+is the human-readable error message,
+.TP
+\fBerrorCode\fR\0
+.
+uses the same format as the \fBerrorCode\fR global variable
+.RE
+Note that \fBmsg\fR and \fBerrorCode\fR are only present for abnormally
+terminated processes (i.e. those where \fBcode\fR is nonzero). Under the hood
+this command calls \fBTcl_WaitPid\fR with the \fBWNOHANG\fR flag set for
+non-blocking behavior, unless the \fB\-wait\fR switch is set (see below).
+.RS
+.PP
+Additionally, \fB::tcl::process status\fR accepts the following switches:
+.TP
+\fB\-wait\fR\0
+.
+By default the command returns immediately (the underlying \fBTcl_WaitPid\fR is
+called with the \fBWNOHANG\fR flag set) unless this switch is set. If \fBpids\fR
+is specified as a list of PIDs then the command waits until the status of the
+matching subprocesses are available. If \fBpids\fR is not specified then it
+waits for all known subprocesses.
+.TP
+\fB\-\|\-\fR
+.
+Marks the end of switches. The argument following this one will
+be treated as the first \fIarg\fR even if it starts with a \fB\-\fR.
+.RE
+.TP
+\fB::tcl::process purge ?\fIpids\fR?
+.
+Cleans up all data associated with terminated subprocesses. If \fBpids\fR is
+specified as a list of PIDs then the command only cleanup data for the matching
+subprocesses if they exist, and raises an error otherwise. If the process is
+still active then it does nothing.
+.TP
+\fB::tcl::process autopurge ?\fIflag\fR?
+.
+Automatic purge facility. If \fBflag\fR is specified as a boolean value then it
+activates or deactivate autopurge. In all cases it returns the current status as
+a boolean value. When autopurge is active, \fBTcl_ReapDetachedProcs\fR is called
+each time the exec command is executed or a pipe channel created by open is
+closed. When autopurge is inactive, \fB::tcl::process\fR purge must be called
+explicitly. By default autopurge is active.
+.RE
+.SH "EXAMPLES"
+.PP
+.CS
+\fB::tcl::process autopurge\fR
+ \fI\(-> true\fR
+\fB::tcl::process autopurge\fR false
+ \fI\(-> false\fR
+
+set pid1 [exec command1 a b c | command2 d e f &]
+ \fI\(-> 123 456\fR
+set chan [open "|command1 a b c | command2 d e f"]
+ \fI\(-> file123\fR
+set pid2 [pid $chan]
+ \fI\(-> 789 1011\fR
+
+\fB::tcl::process list\fR
+ \fI\(-> 123 456 789 1011\fR
+
+\fB::tcl::process status\fR
+ \fI\(-> 123 0 456 {1 "child killed: write on pipe with no readers" {CHILDKILLED 456 SIGPIPE "write on pipe with no readers"}} 789 {1 "child suspended: background tty read" {CHILDSUSP 789 SIGTTIN "background tty read"}} 1011 {}\fR
+
+\fB::tcl::process status\fR 123
+ \fI\(-> 123 0\fR
+
+\fB::tcl::process status\fR 1011
+ \fI\(-> 1011 {}\fR
+
+\fB::tcl::process status\fR -wait
+ \fI\(-> 123 0 456 {1 "child killed: write on pipe with no readers" {CHILDKILLED 456 SIGPIPE "write on pipe with no readers"}} 789 {1 "child suspended: background tty read" {CHILDSUSP 789 SIGTTIN "background tty read"}} 1011 {1 "child process exited abnormally" {CHILDSTATUS 1011 -1}}\fR
+
+\fB::tcl::process status\fR 1011
+ \fI\(-> 1011 {1 "child process exited abnormally" {CHILDSTATUS 1011 -1}}\fR
+
+\fB::tcl::process purge\fR
+exec command1 1 2 3 &
+ \fI\(-> 1213\fR
+\fB::tcl::process list\fR
+ \fI\(-> 1213\fR
+.CE
+.SH "SEE ALSO"
+exec(n), open(n), Tcl_DetachPids(3), Tcl_WaitPid(3), Tcl_ReapDetachedProcs(3)
+.SH "KEYWORDS"
+background, child, detach, process, wait
+'\" Local Variables:
+'\" mode: nroff
+'\" End:
diff --git a/generic/tclInt.decls b/generic/tclInt.decls
index 08cc863..9865609 100644
--- a/generic/tclInt.decls
+++ b/generic/tclInt.decls
@@ -1110,7 +1110,7 @@ declare 8 win {
#}
# Removed in 9.0:
#declare 10 win {
-# Tcl_DirEntry *TclpReaddir(DIR *dir)
+# Tcl_DirEntry *TclpReaddir(TclDIR *dir)
#}
# Removed in 8.3.1 (for Win32s only):
#declare 10 win {
@@ -1251,7 +1251,7 @@ declare 9 unix {
# Removed in 9.0:
#declare 10 unix {
-# Tcl_DirEntry *TclpReaddir(DIR *dir)
+# Tcl_DirEntry *TclpReaddir(TclDIR *dir)
#}
# Removed in 9.0:
#declare 11 unix {
diff --git a/generic/tclIntPlatDecls.h b/generic/tclIntPlatDecls.h
index e4caf72..5ec0544 100644
--- a/generic/tclIntPlatDecls.h
+++ b/generic/tclIntPlatDecls.h
@@ -13,12 +13,6 @@
#ifndef _TCLINTPLATDECLS
#define _TCLINTPLATDECLS
-#ifdef _WIN32
-# define Tcl_DirEntry void
-# define DIR void
-# define Tcl_Dir void
-#endif
-
#undef TCL_STORAGE_CLASS
#ifdef BUILD_tcl
# define TCL_STORAGE_CLASS DLLEXPORT
diff --git a/tests/process.test b/tests/process.test
index fb3a5e2..5454a31 100644
--- a/tests/process.test
+++ b/tests/process.test
@@ -13,19 +13,269 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
namespace import -force ::tcltest::*
}
+# Utilities
+set path(sleep) [makeFile {
+ after [expr $argv*1000]
+ exit
+} sleep]
+set path(exit) [makeFile {
+ exit $argv
+} exit]
+
+# Basic syntax checking
test process-1.1 {tcl::process command basic syntax} -returnCodes error -body {
tcl::process
} -result {wrong # args: should be "tcl::process subcommand ?arg ...?"}
-test process-1.2 {tcl::process command basic syntax} -returnCodes error -body {
+test process-1.2 {tcl::process subcommands} -returnCodes error -body {
tcl::process ?
} -match glob -result {unknown or ambiguous subcommand "?": must be autopurge, list, purge, or status}
-test process-2.1 {tcl::process autopurge get} {tcl::process autopurge} {1}
-test process-2.2 {tcl::process autopurge set true} {
+# Autopurge flag
+# - Default state
+test process-2.1 {autopurge default} -body {
+ tcl::process autopurge
+} -result {1}
+# - Enabling autopurge
+test process-2.2 {enable autopurge} -body {
tcl::process autopurge true
tcl::process autopurge
-} {1}
-test process-2.3 {tcl::process autopurge set false} {
+} -result {1}
+# - Disabling autopurge
+test process-2.3 {disable autopurge} -body {
tcl::process autopurge false
tcl::process autopurge
-} {0}
+} -result {0} -cleanup {tcl::process autopurge true}
+
+# Subprocess list & status
+test process-3.1 {empty subprocess list} -body {
+ llength [tcl::process list]
+} -result {0}
+test process-3.2 {empty subprocess status} -body {
+ dict size [tcl::process status]
+} -result {0}
+
+# Spawn subprocesses using [exec]
+# - One child
+test process-4.1 {exec one child} -body {
+ tcl::process autopurge 0
+ set pid [exec [interpreter] $path(exit) 0 &]
+ set list [tcl::process list]
+ set statuses [tcl::process status -wait]
+ set status [lindex [tcl::process status $pid] 1]
+ expr {
+ [llength $list] eq 1
+ && [lindex $list 0] eq $pid
+ && [dict size $statuses] eq 1
+ && [dict get $statuses $pid] eq $status
+ && $status eq 0
+ }
+} -result {1} -cleanup {
+ tcl::process purge
+ tcl::process autopurge 1
+}
+# - Two children
+test process-4.2 {exec two children in parallel} -body {
+ tcl::process autopurge 0
+ set pid1 [exec [interpreter] $path(exit) 0 &]
+ set pid2 [exec [interpreter] $path(exit) 0 &]
+ set list [tcl::process list]
+ set statuses [tcl::process status -wait]
+ set status1 [lindex [tcl::process status $pid1] 1]
+ set status2 [lindex [tcl::process status $pid2] 1]
+ expr {
+ [llength $list] eq 2
+ && [lsearch $list $pid1] >= 0
+ && [lsearch $list $pid2] >= 0
+ && [dict size $statuses] eq 2
+ && [dict get $statuses $pid1] eq $status1
+ && [dict get $statuses $pid2] eq $status2
+ && $status1 eq 0
+ && $status2 eq 0
+ }
+} -result {1} -cleanup {
+ tcl::process purge
+ tcl::process autopurge 1
+}
+# - 3-stage pipe
+test process-4.3 {exec 3-stage pipe} -body {
+ tcl::process autopurge 0
+ set pids [exec \
+ [interpreter] $path(exit) 0 \
+ | [interpreter] $path(exit) 0 \
+ | [interpreter] $path(exit) 0 \
+ &]
+ lassign $pids pid1 pid2 pid3
+ set list [tcl::process list]
+ set statuses [tcl::process status -wait]
+ set status1 [lindex [tcl::process status $pid1] 1]
+ set status2 [lindex [tcl::process status $pid2] 1]
+ set status3 [lindex [tcl::process status $pid3] 1]
+ expr {
+ [llength $pids] eq 3
+ && [llength $list] eq 3
+ && [lsearch $list $pid1] >= 0
+ && [lsearch $list $pid2] >= 0
+ && [lsearch $list $pid3] >= 0
+ && [dict size $statuses] eq 3
+ && [dict get $statuses $pid1] eq $status1
+ && [dict get $statuses $pid2] eq $status2
+ && [dict get $statuses $pid3] eq $status3
+ && $status1 eq 0
+ && $status2 eq 0
+ && $status3 eq 0
+ }
+} -result {1} -cleanup {
+ tcl::process purge
+ tcl::process autopurge 1
+}
+
+# Spawn subprocesses using [open "|"]
+# - One child
+test process-5.1 {exec one child} -body {
+ tcl::process autopurge 0
+ set f [open "|\"[interpreter]\" \"$path(exit)\" 0"]
+ set pid [pid $f]
+ set list [tcl::process list]
+ set statuses [tcl::process status -wait]
+ set status [lindex [tcl::process status $pid] 1]
+ expr {
+ [llength $list] eq 1
+ && [lindex $list 0] eq $pid
+ && [dict size $statuses] eq 1
+ && [dict get $statuses $pid] eq $status
+ && $status eq 0
+ }
+} -result {1} -cleanup {
+ close $f
+ tcl::process purge
+ tcl::process autopurge 1
+}
+# - Two children
+test process-5.2 {exec two children in parallel} -body {
+ tcl::process autopurge 0
+ set f1 [open "|\"[interpreter]\" \"$path(exit)\" 0"]
+ set f2 [open "|\"[interpreter]\" \"$path(exit)\" 0"]
+ set pid1 [pid $f1]
+ set pid2 [pid $f2]
+ set list [tcl::process list]
+ set statuses [tcl::process status -wait]
+ set status1 [lindex [tcl::process status $pid1] 1]
+ set status2 [lindex [tcl::process status $pid2] 1]
+ expr {
+ [llength $list] eq 2
+ && [lsearch $list $pid1] >= 0
+ && [lsearch $list $pid2] >= 0
+ && [dict size $statuses] eq 2
+ && [dict get $statuses $pid1] eq $status1
+ && [dict get $statuses $pid2] eq $status2
+ && $status1 eq 0
+ && $status2 eq 0
+ }
+} -result {1} -cleanup {
+ close $f1
+ close $f2
+ tcl::process purge
+ tcl::process autopurge 1
+}
+# - 3-stage pipe
+test process-5.3 {exec 3-stage pipe} -body {
+ tcl::process autopurge 0
+ set f [open "|
+ \"[interpreter]\" \"$path(exit)\" 0
+ | \"[interpreter]\" \"$path(exit)\" 0
+ | \"[interpreter]\" \"$path(exit)\" 0
+ "]
+ set pids [pid $f]
+ lassign $pids pid1 pid2 pid3
+ set list [tcl::process list]
+ set statuses [tcl::process status -wait]
+ set status1 [lindex [tcl::process status $pid1] 1]
+ set status2 [lindex [tcl::process status $pid2] 1]
+ set status3 [lindex [tcl::process status $pid3] 1]
+ expr {
+ [llength $pids] eq 3
+ && [llength $list] eq 3
+ && [lsearch $list $pid1] >= 0
+ && [lsearch $list $pid2] >= 0
+ && [lsearch $list $pid3] >= 0
+ && [dict size $statuses] eq 3
+ && [dict get $statuses $pid1] eq $status1
+ && [dict get $statuses $pid2] eq $status2
+ && [dict get $statuses $pid3] eq $status3
+ && $status1 eq 0
+ && $status2 eq 0
+ && $status3 eq 0
+ }
+} -result {1} -cleanup {
+ close $f
+ tcl::process purge
+ tcl::process autopurge 1
+}
+
+# Async child status
+test process-6.1 {async status} -body {
+ tcl::process autopurge 0
+ set pid [exec [interpreter] $path(sleep) 1 &]
+ set status1 [lindex [tcl::process status $pid] 1]
+ set status2 [lindex [tcl::process status -wait $pid] 1]
+ expr {
+ $status1 eq {}
+ && $status2 eq 0
+ }
+} -result {1} -cleanup {
+ tcl::process purge
+ tcl::process autopurge 1
+}
+test process-6.2 {selective wait} -body {
+ tcl::process autopurge 0
+ # Child 1 sleeps 1s
+ set pid1 [exec [interpreter] $path(sleep) 1 &]
+ # Child 2 sleeps 1s
+ set pid2 [exec [interpreter] $path(sleep) 2 &]
+ # Initial status
+ set status1_1 [lindex [tcl::process status $pid1] 1]
+ set status1_2 [lindex [tcl::process status $pid2] 1]
+ # Wait until child 1 termination
+ set status2_1 [lindex [tcl::process status -wait $pid1] 1]
+ set status2_2 [lindex [tcl::process status $pid2] 1]
+ # Wait until child 2 termination
+ set status3_2 [lindex [tcl::process status -wait $pid2] 1]
+ set status3_1 [lindex [tcl::process status $pid1] 1]
+ expr {
+ $status1_1 eq {}
+ && $status1_2 eq {}
+ && $status2_1 eq 0
+ && $status2_2 eq {}
+ && $status3_1 eq 0
+ && $status3_2 eq 0
+ }
+} -result {1} -cleanup {
+ tcl::process purge
+ tcl::process autopurge 1
+}
+
+# Error codes
+test process-7.1 {normal exit} -body {
+ tcl::process autopurge 0
+ set pid [exec [interpreter] $path(exit) 0 &]
+ lindex [tcl::process status -wait $pid] 1
+} -result {0} -cleanup {
+ tcl::process purge
+ tcl::process autopurge 1
+}
+test process-7.2 {abnormal exit} -body {
+ tcl::process autopurge 0
+ set pid [exec [interpreter] $path(exit) 1 &]
+ lindex [tcl::process status -wait $pid] 1
+} -match glob -result {1 {child process exited abnormally} {CHILDSTATUS * 1}} -cleanup {
+ tcl::process purge
+ tcl::process autopurge 1
+}
+test process-7.3 {child killed} -body {
+ tcl::process autopurge 0
+ set pid [exec [interpreter] $path(exit) -1 &]
+ lindex [tcl::process status -wait $pid] 1
+} -match glob -result {1 {child killed: unknown signal} {CHILDKILLED * {unknown signal} {unknown signal}}} -cleanup {
+ tcl::process purge
+ tcl::process autopurge 1
+}
diff --git a/unix/tclUnixFCmd.c b/unix/tclUnixFCmd.c
index d4bb376..8d1de2c 100644
--- a/unix/tclUnixFCmd.c
+++ b/unix/tclUnixFCmd.c
@@ -369,7 +369,7 @@ DoRenameFile(
if (errno == EINVAL && haveRealpath) {
char srcPath[MAXPATHLEN], dstPath[MAXPATHLEN];
- Tcl_Dir *dirPtr;
+ TclDIR *dirPtr;
Tcl_DirEntry *dirEntPtr;
if ((Realpath((char *) src, srcPath) != NULL) /* INTL: Native. */
diff --git a/unix/tclUnixFile.c b/unix/tclUnixFile.c
index 9772867..8cb93b4 100644
--- a/unix/tclUnixFile.c
+++ b/unix/tclUnixFile.c
@@ -259,7 +259,7 @@ TclpMatchInDirectory(
Tcl_DecrRefCount(tailPtr);
Tcl_DecrRefCount(fileNamePtr);
} else {
- Tcl_Dir *d;
+ TclDIR *d;
Tcl_DirEntry *entryPtr;
const char *dirName;
size_t dirLength, nativeDirLen;
diff --git a/unix/tclUnixPort.h b/unix/tclUnixPort.h
index 6cc6836..fec27d0 100644
--- a/unix/tclUnixPort.h
+++ b/unix/tclUnixPort.h
@@ -57,14 +57,14 @@
*/
#ifdef HAVE_STRUCT_DIRENT64
-typedef DIR64 Tcl_Dir;
+typedef DIR64 TclDIR;
typedef struct dirent64 Tcl_DirEntry;
# define TclOSreaddir readdir64
# define TclOSopendir opendir64
# define TclOSrewinddir rewinddir64
# define TclOSclosedir closedir64
#else
-typedef DIR Tcl_Dir;
+typedef DIR TclDIR;
typedef struct dirent Tcl_DirEntry;
# define TclOSreaddir readdir
# define TclOSopendir opendir
diff --git a/unix/tclUnixThrd.c b/unix/tclUnixThrd.c
index bb78e51..5d825fd 100644
--- a/unix/tclUnixThrd.c
+++ b/unix/tclUnixThrd.c
@@ -615,9 +615,7 @@ TclpFinalizeCondition(
*condPtr = NULL;
}
}
-#endif /* TCL_THREADS */
-#ifdef TCL_THREADS
/*
* Additions by AOL for specialized thread memory allocator.
*/
diff --git a/win/makefile.vc b/win/makefile.vc
index e74ceb8..03e0817 100644
--- a/win/makefile.vc
+++ b/win/makefile.vc
@@ -496,10 +496,10 @@ genstubs:
!if !exist($(TCLSH))
@echo Build tclsh first!
!else
- $(TCLSH) $(TOOLSDIR:\=/)/genStubs.tcl $(GENERICDIR:\=/) \
+ tclsh8.7 $(TOOLSDIR:\=/)/genStubs.tcl $(GENERICDIR:\=/) \
$(GENERICDIR:\=/)/tcl.decls $(GENERICDIR:\=/)/tclInt.decls \
$(GENERICDIR:\=/)/tclTomMath.decls
- $(TCLSH) $(TOOLSDIR:\=/)/genStubs.tcl $(GENERICDIR:\=/) \
+ tclsh8.7 $(TOOLSDIR:\=/)/genStubs.tcl $(GENERICDIR:\=/) \
$(GENERICDIR:\=/)/tclOO.decls
!endif
generated by cgit v0.12 at 2024-10-22 01:52:38 (GMT)