Completed [tcl::process autopurge] semantics and added [tcl::process purge] implementation along with the necessary internal functions TclpGetChildPid/TclReapPids

6 files changed, 148 insertions, 6 deletions

diff --git a/generic/tclInt.h b/generic/tclInt.h
index a602e6c..3e99f91 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -4028,6 +4028,8 @@ MODULE_SCOPE int	TclFullFinalizationRequested(void);
 MODULE_SCOPE Tcl_Command TclInitProcessCmd(Tcl_Interp *interp);
 MODULE_SCOPE int	TclProcessGetAutopurge(void);
 MODULE_SCOPE void	TclProcessSetAutopurge(int flag);
+MODULE_SCOPE void	TclReapPids(int numPids, Tcl_Pid *pidPtr);
+MODULE_SCOPE Tcl_Pid	TclpGetChildPid(int id);
 
 /*
  *----------------------------------------------------------------
diff --git a/generic/tclIntPlatDecls.h b/generic/tclIntPlatDecls.h
index 494d6f1..4770747 100644
--- a/generic/tclIntPlatDecls.h
+++ b/generic/tclIntPlatDecls.h
@@ -562,6 +562,8 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr;
 #else
 #   undef TclpGetPid
 #   define TclpGetPid(pid) ((unsigned long) (pid))
+#   undef TclpGetChildPid
+#   define TclpGetChildPid(id) ((Tcl_Pid) (id))
 #endif
 
 #endif /* _TCLINTPLATDECLS */
diff --git a/generic/tclPipe.c b/generic/tclPipe.c
index d6cd188..c98ee7e 100644
--- a/generic/tclPipe.c
+++ b/generic/tclPipe.c
@@ -247,6 +247,61 @@ Tcl_ReapDetachedProcs(void)
 /*
  *----------------------------------------------------------------------
  *
+ * TclReapPids --
+ *
+ *	This function is similar to Tcl_ReapDetachedProcs but works on a
+ *	subset of processes.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	Processes are waited on, so that they can be reaped by the system.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclReapPids(
+    int numPids,		/* Number of pids to detach: gives size of
+				 * array pointed to by pidPtr. */
+    Tcl_Pid *pidPtr)		/* Array of pids to detach. */
+{
+    register Detached *detPtr;
+    Detached *nextPtr, *prevPtr;
+    int status;
+    Tcl_Pid pid;
+    int i;
+
+    Tcl_MutexLock(&pipeMutex);
+    for (detPtr = detList, prevPtr = NULL; detPtr != NULL; ) {
+	pid = 0;
+	for (i = 0; i < numPids; i++) {
+	    if (detPtr->pid == pidPtr[i]) {
+		pid = Tcl_WaitPid(detPtr->pid, &status, WNOHANG);
+		break;
+	    }
+	}
+	if ((pid == 0) || ((pid == (Tcl_Pid) -1) && (errno != ECHILD))) {
+	    prevPtr = detPtr;
+	    detPtr = detPtr->nextPtr;
+	    continue;
+	}
+	nextPtr = detPtr->nextPtr;
+	if (prevPtr == NULL) {
+	    detList = detPtr->nextPtr;
+	} else {
+	    prevPtr->nextPtr = detPtr->nextPtr;
+	}
+	ckfree(detPtr);
+	detPtr = nextPtr;
+    }
+    Tcl_MutexUnlock(&pipeMutex);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
  * TclCleanupChildren --
  *
  *	This is a utility function used to wait for child processes to exit,
@@ -854,7 +909,9 @@ TclCreatePipeline(
      * arguments between the "|" characters.
      */
 
-    Tcl_ReapDetachedProcs();
+    if (TclProcessGetAutopurge()) {
+	Tcl_ReapDetachedProcs();
+    }
     pidPtr = ckalloc(cmdCount * sizeof(Tcl_Pid));
 
     curInFile = inputFile;
diff --git a/generic/tclProcess.c b/generic/tclProcess.c
index 23ba4de..2557067 100644
--- a/generic/tclProcess.c
+++ b/generic/tclProcess.c
@@ -123,8 +123,47 @@ ProcessPurgeObjCmd(
 	return TCL_ERROR;
     }
 
-    /* TODO */
-    return TCL_ERROR;
+    if (objc == 1) {
+        /*
+         * Purge all detached processes.
+         */
+        
+        Tcl_ReapDetachedProcs();
+    } else {
+        int result;
+        int numPids;
+        Tcl_Obj **pidObjs;
+        Tcl_Pid *pids;
+        int id;
+        int i;
+
+        /*
+         * Get pids from argument.
+         */
+        
+        result = Tcl_ListObjGetElements(interp, objv[1], &numPids, &pidObjs);
+        if (result != TCL_OK) {
+            return result;
+        }
+        pids = (Tcl_Pid *) TclStackAlloc(interp, numPids * sizeof(Tcl_Pid));
+        for (i = 0; i < numPids; i++) {
+            result = Tcl_GetIntFromObj(interp, pidObjs[i], (int *) &id);
+            if (result != TCL_OK) {
+                TclStackFree(interp, (void *) pids);
+                return result;
+            }
+            pids[i] = TclpGetChildPid(id);
+        }
+
+        /*
+         * Purge only provided processes.
+         */
+        
+        TclReapPids(numPids, pids);
+        TclStackFree(interp, (void *) pids);
+    }
+    
+    return TCL_OK;
  }
 
 /*----------------------------------------------------------------------
@@ -138,7 +177,7 @@ ProcessPurgeObjCmd(
  *	Returns a standard Tcl result.
  *
  * Side effects:
- *	None.TODO
+ *	Alters detached process handling by Tcl_ReapDetachedProcs().
  *
  *----------------------------------------------------------------------
  */
diff --git a/unix/tclUnixPipe.c b/unix/tclUnixPipe.c
index be7b4eb..3d8e680 100644
--- a/unix/tclUnixPipe.c
+++ b/unix/tclUnixPipe.c
@@ -986,7 +986,9 @@ PipeClose2Proc(
 	 */
 
 	Tcl_DetachPids(pipePtr->numPids, pipePtr->pidPtr);
-	Tcl_ReapDetachedProcs();
+	if (TclProcessGetAutopurge()) {
+	    Tcl_ReapDetachedProcs();
+	}
 
 	if (pipePtr->errorFile) {
 	    TclpCloseFile(pipePtr->errorFile);
diff --git a/win/tclWinPipe.c b/win/tclWinPipe.c
index 4666deb..6dd2173 100644
--- a/win/tclWinPipe.c
+++ b/win/tclWinPipe.c
@@ -884,6 +884,44 @@ TclpGetPid(
     Tcl_MutexUnlock(&pipeMutex);
     return (unsigned long) -1;
 }
+
+/*
+ *--------------------------------------------------------------------------
+ *
+ * TclpGetChildPid --
+ *
+ *	Given a process id of a child process, return the HANDLE for that
+ *	child process.
+ *
+ * Results:
+ *	Returns the HANDLE for the child process. If the id was not known
+ *	by Tcl, either because the id was not created by Tcl or the child
+ *	process has already been reaped, NULL is returned.
+ *
+ * Side effects:
+ *	None.
+ *
+ *--------------------------------------------------------------------------
+ */
+
+Tcl_Pid
+TclpGetChildPid(
+    int id)			/* The process id of the child process. */
+{
+    ProcInfo *infoPtr;
+
+    PipeInit();
+
+    Tcl_MutexLock(&pipeMutex);
+    for (infoPtr = procList; infoPtr != NULL; infoPtr = infoPtr->nextPtr) {
+	if (infoPtr->dwProcessId == (DWORD) id) {
+	    Tcl_MutexUnlock(&pipeMutex);
+	    return (Tcl_Pid) infoPtr->hProcess;
+	}
+    }
+    Tcl_MutexUnlock(&pipeMutex);
+    return (Tcl_Pid) NULL;
+}
 
 /*
  *----------------------------------------------------------------------
@@ -1991,7 +2029,9 @@ PipeClose2Proc(
 	 */
 
 	Tcl_DetachPids(pipePtr->numPids, pipePtr->pidPtr);
-	Tcl_ReapDetachedProcs();
+	if (TclProcessGetAutopurge()) {
+	    Tcl_ReapDetachedProcs();
+	}
 
 	if (pipePtr->errorFile) {
 	    if (TclpCloseFile(pipePtr->errorFile) != 0) {