diff options
Diffstat (limited to 'generic/tclProcess.c')
| -rw-r--r-- | generic/tclProcess.c | 951 |
1 files changed, 0 insertions, 951 deletions
diff --git a/generic/tclProcess.c b/generic/tclProcess.c deleted file mode 100644 index 1a4bf8c..0000000 --- a/generic/tclProcess.c +++ /dev/null @@ -1,951 +0,0 @@ -/* - * tclProcess.c -- - * - * This file implements the "tcl::process" ensemble for subprocess - * management as defined by TIP #462. - * - * Copyright © 2017 Frederic Bonnet. - * - * See the file "license.terms" for information on usage and redistribution of - * this file, and for a DISCLAIMER OF ALL WARRANTIES. - */ - -#include "tclInt.h" - -/* - * Autopurge flag. Process-global because of the way Tcl manages child - * processes (see tclPipe.c). - */ - -static int autopurge = 1; /* Autopurge flag. */ - -/* - * Hash tables that keeps track of all child process statuses. Keys are the - * child process ids and resolved pids, values are (ProcessInfo *). - */ - -typedef struct ProcessInfo { - Tcl_Pid pid; /* Process id. */ - Tcl_Size resolvedPid; /* Resolved process id. */ - int purge; /* Purge eventualy. */ - TclProcessWaitStatus status;/* Process status. */ - int code; /* Error code, exit status or signal - number. */ - Tcl_Obj *msg; /* Error message. */ - Tcl_Obj *error; /* Error code. */ -} ProcessInfo; -static Tcl_HashTable infoTablePerPid; -static Tcl_HashTable infoTablePerResolvedPid; -static int infoTablesInitialized = 0; /* 0 means not yet initialized. */ -TCL_DECLARE_MUTEX(infoTablesMutex) - - /* - * Prototypes for functions defined later in this file: - */ - -static void InitProcessInfo(ProcessInfo *info, Tcl_Pid pid, - Tcl_Size resolvedPid); -static void FreeProcessInfo(ProcessInfo *info); -static int RefreshProcessInfo(ProcessInfo *info, int options); -static TclProcessWaitStatus WaitProcessStatus(Tcl_Pid pid, Tcl_Size resolvedPid, - int options, int *codePtr, Tcl_Obj **msgPtr, - Tcl_Obj **errorObjPtr); -static Tcl_Obj * BuildProcessStatusObj(ProcessInfo *info); -static Tcl_ObjCmdProc ProcessListObjCmd; -static Tcl_ObjCmdProc ProcessStatusObjCmd; -static Tcl_ObjCmdProc ProcessPurgeObjCmd; -static Tcl_ObjCmdProc ProcessAutopurgeObjCmd; - -/* - *---------------------------------------------------------------------- - * - * InitProcessInfo -- - * - * Initializes the ProcessInfo structure. - * - * Results: - * None. - * - * Side effects: - * Memory written. - * - *---------------------------------------------------------------------- - */ - -void -InitProcessInfo( - ProcessInfo *info, /* Structure to initialize. */ - Tcl_Pid pid, /* Process id. */ - Tcl_Size resolvedPid) /* Resolved process id. */ -{ - info->pid = pid; - info->resolvedPid = resolvedPid; - info->purge = 0; - info->status = TCL_PROCESS_UNCHANGED; - info->code = 0; - info->msg = NULL; - info->error = NULL; -} - -/* - *---------------------------------------------------------------------- - * - * FreeProcessInfo -- - * - * Free the ProcessInfo structure. - * - * Results: - * None. - * - * Side effects: - * Memory deallocated, Tcl_Obj refcount decreased. - * - *---------------------------------------------------------------------- - */ - -void -FreeProcessInfo( - ProcessInfo *info) /* Structure to free. */ -{ - /* - * Free stored Tcl_Objs. - */ - - if (info->msg) { - Tcl_DecrRefCount(info->msg); - } - if (info->error) { - Tcl_DecrRefCount(info->error); - } - - /* - * Free allocated structure. - */ - - ckfree(info); -} - -/* - *---------------------------------------------------------------------- - * - * RefreshProcessInfo -- - * - * Refresh process info. - * - * Results: - * Nonzero if state changed, else zero. - * - * Side effects: - * May call WaitProcessStatus, which can block if WNOHANG option is set. - * - *---------------------------------------------------------------------- - */ - -int -RefreshProcessInfo( - ProcessInfo *info, /* Structure to refresh. */ - int options /* Options passed to WaitProcessStatus. */ -) -{ - if (info->status == TCL_PROCESS_UNCHANGED) { - /* - * Refresh & store status. - */ - - info->status = WaitProcessStatus(info->pid, info->resolvedPid, - options, &info->code, &info->msg, &info->error); - if (info->msg) Tcl_IncrRefCount(info->msg); - if (info->error) Tcl_IncrRefCount(info->error); - return (info->status != TCL_PROCESS_UNCHANGED); - } else { - /* - * No change. - */ - - return 0; - } -} - -/* - *---------------------------------------------------------------------- - * - * WaitProcessStatus -- - * - * Wait for process status to change. - * - * Results: - * TclProcessWaitStatus enum value. - * - * Side effects: - * May call WaitProcessStatus, which can block if WNOHANG option is set. - * - *---------------------------------------------------------------------- - */ - -TclProcessWaitStatus -WaitProcessStatus( - Tcl_Pid pid, /* Process id. */ - Tcl_Size resolvedPid, /* Resolved process id. */ - int options, /* Options passed to Tcl_WaitPid. */ - int *codePtr, /* If non-NULL, will receive either: - * - 0 for normal exit. - * - errno in case of error. - * - non-zero exit code for abormal exit. - * - signal number if killed or suspended. - * - Tcl_WaitPid status in all other cases. - */ - Tcl_Obj **msgObjPtr, /* If non-NULL, will receive error message. */ - Tcl_Obj **errorObjPtr) /* If non-NULL, will receive error code. */ -{ - int waitStatus; - Tcl_Obj *errorStrings[5]; - const char *msg; - - pid = Tcl_WaitPid(pid, &waitStatus, options); - if (pid == 0) { - /* - * No change. - */ - - return TCL_PROCESS_UNCHANGED; - } - - /* - * Get process status. - */ - - if (pid == (Tcl_Pid)-1) { - /* - * POSIX errName msg - */ - - msg = Tcl_ErrnoMsg(errno); - if (errno == ECHILD) { - /* - * This changeup in message suggested by Mark Diekhans to - * remind people that ECHILD errors can occur on some - * systems if SIGCHLD isn't in its default state. - */ - - msg = "child process lost (is SIGCHLD ignored or trapped?)"; - } - if (codePtr) *codePtr = errno; - if (msgObjPtr) *msgObjPtr = Tcl_ObjPrintf( - "error waiting for process to exit: %s", msg); - if (errorObjPtr) { - errorStrings[0] = Tcl_NewStringObj("POSIX", -1); - errorStrings[1] = Tcl_NewStringObj(Tcl_ErrnoId(), -1); - errorStrings[2] = Tcl_NewStringObj(msg, -1); - *errorObjPtr = Tcl_NewListObj(3, errorStrings); - } - return TCL_PROCESS_ERROR; - } else if (WIFEXITED(waitStatus)) { - if (codePtr) *codePtr = WEXITSTATUS(waitStatus); - if (!WEXITSTATUS(waitStatus)) { - /* - * Normal exit. - */ - - if (msgObjPtr) *msgObjPtr = NULL; - if (errorObjPtr) *errorObjPtr = NULL; - } else { - /* - * CHILDSTATUS pid code - * - * Child exited with a non-zero exit status. - */ - - if (msgObjPtr) *msgObjPtr = Tcl_NewStringObj( - "child process exited abnormally", -1); - if (errorObjPtr) { - errorStrings[0] = Tcl_NewStringObj("CHILDSTATUS", -1); - TclNewIntObj(errorStrings[1], resolvedPid); - TclNewIntObj(errorStrings[2], WEXITSTATUS(waitStatus)); - *errorObjPtr = Tcl_NewListObj(3, errorStrings); - } - } - return TCL_PROCESS_EXITED; - } else if (WIFSIGNALED(waitStatus)) { - /* - * CHILDKILLED pid sigName msg - * - * Child killed because of a signal. - */ - - msg = Tcl_SignalMsg(WTERMSIG(waitStatus)); - if (codePtr) *codePtr = WTERMSIG(waitStatus); - if (msgObjPtr) *msgObjPtr = Tcl_ObjPrintf( - "child killed: %s", msg); - if (errorObjPtr) { - errorStrings[0] = Tcl_NewStringObj("CHILDKILLED", -1); - TclNewIntObj(errorStrings[1], resolvedPid); - errorStrings[2] = Tcl_NewStringObj(Tcl_SignalId(WTERMSIG(waitStatus)), -1); - errorStrings[3] = Tcl_NewStringObj(msg, -1); - *errorObjPtr = Tcl_NewListObj(4, errorStrings); - } - return TCL_PROCESS_SIGNALED; - } else if (WIFSTOPPED(waitStatus)) { - /* - * CHILDSUSP pid sigName msg - * - * Child suspended because of a signal. - */ - - msg = Tcl_SignalMsg(WSTOPSIG(waitStatus)); - if (codePtr) *codePtr = WSTOPSIG(waitStatus); - if (msgObjPtr) *msgObjPtr = Tcl_ObjPrintf( - "child suspended: %s", msg); - if (errorObjPtr) { - errorStrings[0] = Tcl_NewStringObj("CHILDSUSP", -1); - TclNewIntObj(errorStrings[1], resolvedPid); - errorStrings[2] = Tcl_NewStringObj(Tcl_SignalId(WSTOPSIG(waitStatus)), -1); - errorStrings[3] = Tcl_NewStringObj(msg, -1); - *errorObjPtr = Tcl_NewListObj(4, errorStrings); - } - return TCL_PROCESS_STOPPED; - } else { - /* - * TCL OPERATION EXEC ODDWAITRESULT - * - * Child wait status didn't make sense. - */ - - if (codePtr) *codePtr = waitStatus; - if (msgObjPtr) *msgObjPtr = Tcl_NewStringObj( - "child wait status didn't make sense\n", -1); - if (errorObjPtr) { - errorStrings[0] = Tcl_NewStringObj("TCL", -1); - errorStrings[1] = Tcl_NewStringObj("OPERATION", -1); - errorStrings[2] = Tcl_NewStringObj("EXEC", -1); - errorStrings[3] = Tcl_NewStringObj("ODDWAITRESULT", -1); - TclNewIntObj(errorStrings[4], resolvedPid); - *errorObjPtr = Tcl_NewListObj(5, errorStrings); - } - return TCL_PROCESS_UNKNOWN_STATUS; - } -} - - -/* - *---------------------------------------------------------------------- - * - * BuildProcessStatusObj -- - * - * Build a list object with process status. The first element is always - * a standard Tcl return value, which can be either TCL_OK or TCL_ERROR. - * In the latter case, the second element is the error message and the - * third element is a Tcl error code (see tclvars). - * - * Results: - * A list object. - * - * Side effects: - * Tcl_Objs are created. - * - *---------------------------------------------------------------------- - */ - -Tcl_Obj * -BuildProcessStatusObj( - ProcessInfo *info) -{ - Tcl_Obj *resultObjs[3]; - - if (info->status == TCL_PROCESS_UNCHANGED) { - /* - * Process still running, return empty obj. - */ - Tcl_Obj *obj; - TclNewObj(obj); - return obj; - } - if (info->status == TCL_PROCESS_EXITED && info->code == 0) { - /* - * Normal exit, return TCL_OK. - */ - - return Tcl_NewWideIntObj(TCL_OK); - } - - /* - * Abnormal exit, return {TCL_ERROR msg error} - */ - - TclNewIntObj(resultObjs[0], TCL_ERROR); - resultObjs[1] = info->msg; - resultObjs[2] = info->error; - return Tcl_NewListObj(3, resultObjs); -} - -/*---------------------------------------------------------------------- - * - * ProcessListObjCmd -- - * - * This function implements the 'tcl::process list' Tcl command. - * Refer to the user documentation for details on what it does. - * - * Results: - * Returns a standard Tcl result. - * - * Side effects: - * Access to the internal structures is protected by infoTablesMutex. - * - *---------------------------------------------------------------------- - */ - -static int -ProcessListObjCmd( - TCL_UNUSED(void *), - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - Tcl_Obj *list, *elemPtr; - Tcl_HashEntry *entry; - Tcl_HashSearch search; - ProcessInfo *info; - - if (objc != 1) { - Tcl_WrongNumArgs(interp, 1, objv, NULL); - return TCL_ERROR; - } - - /* - * Return the list of all chid process ids. - */ - - list = Tcl_NewListObj(0, NULL); - Tcl_MutexLock(&infoTablesMutex); - for (entry = Tcl_FirstHashEntry(&infoTablePerResolvedPid, &search); - entry != NULL; entry = Tcl_NextHashEntry(&search)) { - info = (ProcessInfo *) Tcl_GetHashValue(entry); - TclNewIntObj(elemPtr, info->resolvedPid); - Tcl_ListObjAppendElement(interp, list, elemPtr); - } - Tcl_MutexUnlock(&infoTablesMutex); - Tcl_SetObjResult(interp, list); - return TCL_OK; -} - -/*---------------------------------------------------------------------- - * - * ProcessStatusObjCmd -- - * - * This function implements the 'tcl::process status' Tcl command. - * Refer to the user documentation for details on what it does. - * - * Results: - * Returns a standard Tcl result. - * - * Side effects: - * Access to the internal structures is protected by infoTablesMutex. - * Calls RefreshProcessInfo, which can block if -wait switch is given. - * - *---------------------------------------------------------------------- - */ - -static int -ProcessStatusObjCmd( - TCL_UNUSED(void *), - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - Tcl_Obj *dict, *elemPtr; - int index, options = WNOHANG; - Tcl_HashEntry *entry; - Tcl_HashSearch search; - ProcessInfo *info; - int i, numPids; - Tcl_Obj **pidObjs; - int result; - int pid; - Tcl_Obj *const *savedobjv = objv; - static const char *const switches[] = { - "-wait", "--", NULL - }; - enum switchesEnum { - STATUS_WAIT, STATUS_LAST - }; - - while (objc > 1) { - if (TclGetString(objv[1])[0] != '-') { - break; - } - if (Tcl_GetIndexFromObj(interp, objv[1], switches, "switches", 0, - &index) != TCL_OK) { - return TCL_ERROR; - } - ++objv; --objc; - if (STATUS_WAIT == (enum switchesEnum) index) { - options = 0; - } else { - break; - } - } - - if (objc != 1 && objc != 2) { - Tcl_WrongNumArgs(interp, 1, savedobjv, "?switches? ?pids?"); - return TCL_ERROR; - } - - if (objc == 1) { - /* - * Return a dict with all child process statuses. - */ - - dict = Tcl_NewDictObj(); - Tcl_MutexLock(&infoTablesMutex); - for (entry = Tcl_FirstHashEntry(&infoTablePerResolvedPid, &search); - entry != NULL; entry = Tcl_NextHashEntry(&search)) { - info = (ProcessInfo *) Tcl_GetHashValue(entry); - RefreshProcessInfo(info, options); - - if (info->purge && autopurge) { - /* - * Purge entry. - */ - - Tcl_DeleteHashEntry(entry); - entry = Tcl_FindHashEntry(&infoTablePerPid, info->pid); - Tcl_DeleteHashEntry(entry); - FreeProcessInfo(info); - } else { - /* - * Add to result. - */ - - TclNewIntObj(elemPtr, info->resolvedPid); - Tcl_DictObjPut(interp, dict, elemPtr, - BuildProcessStatusObj(info)); - } - } - Tcl_MutexUnlock(&infoTablesMutex); - } else { - /* - * Only return statuses of provided processes. - */ - - result = TclListObjGetElements(interp, objv[1], &numPids, &pidObjs); - if (result != TCL_OK) { - return result; - } - dict = Tcl_NewDictObj(); - Tcl_MutexLock(&infoTablesMutex); - for (i = 0; i < numPids; i++) { - result = Tcl_GetIntFromObj(interp, pidObjs[i], &pid); - if (result != TCL_OK) { - Tcl_MutexUnlock(&infoTablesMutex); - Tcl_DecrRefCount(dict); - return result; - } - - entry = Tcl_FindHashEntry(&infoTablePerResolvedPid, INT2PTR(pid)); - if (!entry) { - /* - * Skip unknown process. - */ - - continue; - } - - info = (ProcessInfo *) Tcl_GetHashValue(entry); - RefreshProcessInfo(info, options); - - if (info->purge && autopurge) { - /* - * Purge entry. - */ - - Tcl_DeleteHashEntry(entry); - entry = Tcl_FindHashEntry(&infoTablePerPid, info->pid); - Tcl_DeleteHashEntry(entry); - FreeProcessInfo(info); - } else { - /* - * Add to result. - */ - - TclNewIntObj(elemPtr, info->resolvedPid); - Tcl_DictObjPut(interp, dict, elemPtr, - BuildProcessStatusObj(info)); - } - } - Tcl_MutexUnlock(&infoTablesMutex); - } - Tcl_SetObjResult(interp, dict); - return TCL_OK; -} - -/*---------------------------------------------------------------------- - * - * ProcessPurgeObjCmd -- - * - * This function implements the 'tcl::process purge' Tcl command. - * Refer to the user documentation for details on what it does. - * - * Results: - * Returns a standard Tcl result. - * - * Side effects: - * Frees all ProcessInfo structures with their purge flag set. - * - *---------------------------------------------------------------------- - */ - -static int -ProcessPurgeObjCmd( - TCL_UNUSED(void *), - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - Tcl_HashEntry *entry; - Tcl_HashSearch search; - ProcessInfo *info; - Tcl_Size i, numPids; - Tcl_Obj **pidObjs; - int result; - int pid; - - if (objc != 1 && objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "?pids?"); - return TCL_ERROR; - } - - /* - * First reap detached procs so that their purge flag is up-to-date. - */ - - Tcl_ReapDetachedProcs(); - - if (objc == 1) { - /* - * Purge all terminated processes. - */ - - Tcl_MutexLock(&infoTablesMutex); - for (entry = Tcl_FirstHashEntry(&infoTablePerResolvedPid, &search); - entry != NULL; entry = Tcl_NextHashEntry(&search)) { - info = (ProcessInfo *) Tcl_GetHashValue(entry); - if (info->purge) { - Tcl_DeleteHashEntry(entry); - entry = Tcl_FindHashEntry(&infoTablePerPid, info->pid); - Tcl_DeleteHashEntry(entry); - FreeProcessInfo(info); - } - } - Tcl_MutexUnlock(&infoTablesMutex); - } else { - /* - * Purge only provided processes. - */ - - result = TclListObjGetElements(interp, objv[1], &numPids, &pidObjs); - if (result != TCL_OK) { - return result; - } - Tcl_MutexLock(&infoTablesMutex); - for (i = 0; i < numPids; i++) { - result = Tcl_GetIntFromObj(interp, pidObjs[i], &pid); - if (result != TCL_OK) { - Tcl_MutexUnlock(&infoTablesMutex); - return result; - } - - entry = Tcl_FindHashEntry(&infoTablePerResolvedPid, INT2PTR(pid)); - if (!entry) { - /* - * Skip unknown process. - */ - - continue; - } - - info = (ProcessInfo *) Tcl_GetHashValue(entry); - if (info->purge) { - Tcl_DeleteHashEntry(entry); - entry = Tcl_FindHashEntry(&infoTablePerPid, info->pid); - Tcl_DeleteHashEntry(entry); - FreeProcessInfo(info); - } - } - Tcl_MutexUnlock(&infoTablesMutex); - } - - return TCL_OK; -} - -/*---------------------------------------------------------------------- - * - * ProcessAutopurgeObjCmd -- - * - * This function implements the 'tcl::process autopurge' Tcl command. - * Refer to the user documentation for details on what it does. - * - * Results: - * Returns a standard Tcl result. - * - * Side effects: - * Alters detached process handling by Tcl_ReapDetachedProcs(). - * - *---------------------------------------------------------------------- - */ - -static int -ProcessAutopurgeObjCmd( - TCL_UNUSED(void *), - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - - if (objc != 1 && objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "?flag?"); - return TCL_ERROR; - } - - if (objc == 2) { - /* - * Set given value. - */ - - int flag; - int result = Tcl_GetBooleanFromObj(interp, objv[1], &flag); - if (result != TCL_OK) { - return result; - } - - autopurge = !!flag; - } - - /* - * Return current value. - */ - - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(autopurge)); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclInitProcessCmd -- - * - * This procedure creates the "tcl::process" Tcl command. See the user - * documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - -Tcl_Command -TclInitProcessCmd( - Tcl_Interp *interp) /* Current interpreter. */ -{ - static const EnsembleImplMap processImplMap[] = { - {"list", ProcessListObjCmd, TclCompileBasic0ArgCmd, NULL, NULL, 1}, - {"status", ProcessStatusObjCmd, TclCompileBasicMin0ArgCmd, NULL, NULL, 1}, - {"purge", ProcessPurgeObjCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 1}, - {"autopurge", ProcessAutopurgeObjCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 1}, - {NULL, NULL, NULL, NULL, NULL, 0} - }; - Tcl_Command processCmd; - - if (infoTablesInitialized == 0) { - Tcl_MutexLock(&infoTablesMutex); - if (infoTablesInitialized == 0) { - Tcl_InitHashTable(&infoTablePerPid, TCL_ONE_WORD_KEYS); - Tcl_InitHashTable(&infoTablePerResolvedPid, TCL_ONE_WORD_KEYS); - infoTablesInitialized = 1; - } - Tcl_MutexUnlock(&infoTablesMutex); - } - - processCmd = TclMakeEnsemble(interp, "::tcl::process", processImplMap); - Tcl_Export(interp, Tcl_FindNamespace(interp, "::tcl", NULL, 0), - "process", 0); - return processCmd; -} - -/* - *---------------------------------------------------------------------- - * - * TclProcessCreated -- - * - * Called when a child process has been created by Tcl. - * - * Results: - * None. - * - * Side effects: - * Internal structures are updated with a new ProcessInfo. - * - *---------------------------------------------------------------------- - */ - -void -TclProcessCreated( - Tcl_Pid pid) /* Process id. */ -{ - Tcl_Size resolvedPid; - Tcl_HashEntry *entry, *entry2; - int isNew; - ProcessInfo *info; - - /* - * Get resolved pid first. - */ - - resolvedPid = TclpGetPid(pid); - - Tcl_MutexLock(&infoTablesMutex); - - /* - * Create entry in pid table. - */ - - entry = Tcl_CreateHashEntry(&infoTablePerPid, pid, &isNew); - if (!isNew) { - /* - * Pid was reused, free old info and reuse structure. - */ - - info = (ProcessInfo *) Tcl_GetHashValue(entry); - entry2 = Tcl_FindHashEntry(&infoTablePerResolvedPid, - INT2PTR(resolvedPid)); - if (entry2) Tcl_DeleteHashEntry(entry2); - FreeProcessInfo(info); - } - - /* - * Allocate and initialize info structure. - */ - - info = (ProcessInfo *)ckalloc(sizeof(ProcessInfo)); - InitProcessInfo(info, pid, resolvedPid); - - /* - * Add entry to tables. - */ - - Tcl_SetHashValue(entry, info); - entry = Tcl_CreateHashEntry(&infoTablePerResolvedPid, INT2PTR(resolvedPid), - &isNew); - Tcl_SetHashValue(entry, info); - - Tcl_MutexUnlock(&infoTablesMutex); -} - -/* - *---------------------------------------------------------------------- - * - * TclProcessWait -- - * - * Wait for process status to change. - * - * Results: - * TclProcessWaitStatus enum value. - * - * Side effects: - * Completed process info structures are purged immediately (autopurge on) - * or eventually (autopurge off). - * - *---------------------------------------------------------------------- - */ - -TclProcessWaitStatus -TclProcessWait( - Tcl_Pid pid, /* Process id. */ - int options, /* Options passed to WaitProcessStatus. */ - int *codePtr, /* If non-NULL, will receive either: - * - 0 for normal exit. - * - errno in case of error. - * - non-zero exit code for abormal exit. - * - signal number if killed or suspended. - * - Tcl_WaitPid status in all other cases. - */ - Tcl_Obj **msgObjPtr, /* If non-NULL, will receive error message. */ - Tcl_Obj **errorObjPtr) /* If non-NULL, will receive error code. */ -{ - Tcl_HashEntry *entry; - ProcessInfo *info; - TclProcessWaitStatus result; - - /* - * First search for pid in table. - */ - - Tcl_MutexLock(&infoTablesMutex); - entry = Tcl_FindHashEntry(&infoTablePerPid, pid); - if (!entry) { - /* - * Unknown process, just call WaitProcessStatus and return. - */ - - result = WaitProcessStatus(pid, TclpGetPid(pid), options, codePtr, - msgObjPtr, errorObjPtr); - if (msgObjPtr && *msgObjPtr) Tcl_IncrRefCount(*msgObjPtr); - if (errorObjPtr && *errorObjPtr) Tcl_IncrRefCount(*errorObjPtr); - Tcl_MutexUnlock(&infoTablesMutex); - return result; - } - - info = (ProcessInfo *) Tcl_GetHashValue(entry); - if (info->purge) { - /* - * Process has completed but TclProcessWait has already been called, - * so report no change. - */ - Tcl_MutexUnlock(&infoTablesMutex); - - return TCL_PROCESS_UNCHANGED; - } - - RefreshProcessInfo(info, options); - if (info->status == TCL_PROCESS_UNCHANGED) { - /* - * No change, stop there. - */ - Tcl_MutexUnlock(&infoTablesMutex); - - return TCL_PROCESS_UNCHANGED; - } - - /* - * Set return values. - */ - - result = info->status; - if (codePtr) *codePtr = info->code; - if (msgObjPtr) *msgObjPtr = info->msg; - if (errorObjPtr) *errorObjPtr = info->error; - if (msgObjPtr && *msgObjPtr) Tcl_IncrRefCount(*msgObjPtr); - if (errorObjPtr && *errorObjPtr) Tcl_IncrRefCount(*errorObjPtr); - - if (autopurge) { - /* - * Purge now. - */ - - Tcl_DeleteHashEntry(entry); - entry = Tcl_FindHashEntry(&infoTablePerResolvedPid, - INT2PTR(info->resolvedPid)); - Tcl_DeleteHashEntry(entry); - FreeProcessInfo(info); - } else { - /* - * Eventually purge. Subsequent calls will return - * TCL_PROCESS_UNCHANGED. - */ - - info->purge = 1; - } - Tcl_MutexUnlock(&infoTablesMutex); - return result; -} |