diff options
| -rw-r--r-- | changes | 5 | ||||
| -rw-r--r-- | generic/tclBasic.c | 1 | ||||
| -rw-r--r-- | generic/tclCmdMZ.c | 35 | ||||
| -rw-r--r-- | generic/tclInt.h | 24 | ||||
| -rw-r--r-- | generic/tclPipe.c | 78 | ||||
| -rw-r--r-- | generic/tclProcess.c | 952 | ||||
| -rw-r--r-- | library/msgcat/msgcat.tcl | 297 | ||||
| -rw-r--r-- | library/msgcat/pkgIndex.tcl | 4 | ||||
| -rw-r--r-- | tests/msgcat.test | 287 | ||||
| -rw-r--r-- | tests/process.test | 31 | ||||
| -rw-r--r-- | unix/Makefile.in | 10 | ||||
| -rw-r--r-- | win/Makefile.in | 5 | ||||
| -rw-r--r-- | win/buildall.vc.bat | 4 | ||||
| -rw-r--r-- | win/makefile.vc | 1 | ||||
| -rw-r--r-- | win/tcl.dsp | 4 | ||||
| -rw-r--r-- | win/tclWinPipe.c | 6 |
16 files changed, 1576 insertions, 168 deletions
@@ -8879,3 +8879,8 @@ in this changeset (new minor version) rather than bug fixes: 2017-09-02 (bug)[0e4d88] replace command, delete trace kills namespace (porter) --- Released 8.7a1, September 8, 2017 --- http://core.tcl.tk/tcl/ for details + +2018-03-12 (TIP 490) add oo support for msgcat => msgcat 1.7.0 (oehlmann) + +2018-03-12 (TIP 499) custom locale preference list (nijtmans) +=> msgcat 1.7.0 diff --git a/generic/tclBasic.c b/generic/tclBasic.c index ff02acc..d92acb9 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -783,6 +783,7 @@ Tcl_CreateInterp(void) TclInitNamespaceCmd(interp); TclInitStringCmd(interp); TclInitPrefixCmd(interp); + TclInitProcessCmd(interp); /* * Register "clock" subcommands. These *do* go through diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 6f0299f..9cb8931 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -2303,29 +2303,42 @@ StringRplcCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - Tcl_UniChar *ustring; - int first, last, length; + int first, last, length, end; if (objc < 4 || objc > 5) { Tcl_WrongNumArgs(interp, 1, objv, "string first last ?string?"); return TCL_ERROR; } - ustring = Tcl_GetUnicodeFromObj(objv[1], &length); - length--; + (void) Tcl_GetUnicodeFromObj(objv[1], &length); + end = length - 1; - if (TclGetIntForIndexM(interp, objv[2], length, &first) != TCL_OK || - TclGetIntForIndexM(interp, objv[3], length, &last) != TCL_OK){ + if (TclGetIntForIndexM(interp, objv[2], end, &first) != TCL_OK || + TclGetIntForIndexM(interp, objv[3], end, &last) != TCL_OK){ return TCL_ERROR; } - if ((last < first) || (last < 0) || (first > length)) { + /* + * [string replace] does not replace empty strings. This is + * unwise, but since it is true, here we quickly screen out + * index pairs that demarcate an empty substring. + */ + + if ((last < 0) || /* Range ends before start of string */ + (first > end) || /* Range begins after end of string */ + (last < first)) { /* Range begins after it starts */ Tcl_SetObjResult(interp, objv[1]); } else { Tcl_Obj *resultPtr; - ustring = Tcl_GetUnicodeFromObj(objv[1], &length); - length--; + /* + * We are re-fetching in case the string argument is same value as + * an index argument, and shimmering cost us our ustring. + */ + + Tcl_UniChar *ustring = Tcl_GetUnicodeFromObj(objv[1], &length); + + end = length - 1; if (first < 0) { first = 0; @@ -2335,9 +2348,9 @@ StringRplcCmd( if (objc == 5) { Tcl_AppendObjToObj(resultPtr, objv[4]); } - if (last < length) { + if (last < end) { Tcl_AppendUnicodeToObj(resultPtr, ustring + last + 1, - length - last); + end - last); } Tcl_SetObjResult(interp, resultPtr); } diff --git a/generic/tclInt.h b/generic/tclInt.h index 316bfe2..9f5e38c 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3998,6 +3998,30 @@ MODULE_SCOPE TCL_HASH_TYPE TclHashObjKey(Tcl_HashTable *tablePtr, void *keyPtr); MODULE_SCOPE int TclFullFinalizationRequested(void); /* + * TIP #462. + */ + +/* + * The following enum values give the status of a spawned process. + */ + +typedef enum TclProcessWaitStatus { + TCL_PROCESS_ERROR = -1, /* Error waiting for process to exit */ + TCL_PROCESS_UNCHANGED = 0, /* No change since the last call. */ + TCL_PROCESS_EXITED = 1, /* Process has exited. */ + TCL_PROCESS_SIGNALED = 2, /* Child killed because of a signal. */ + TCL_PROCESS_STOPPED = 3, /* Child suspended because of a signal. */ + TCL_PROCESS_UNKNOWN_STATUS = 4 + /* Child wait status didn't make sense. */ +} TclProcessWaitStatus; + +MODULE_SCOPE Tcl_Command TclInitProcessCmd(Tcl_Interp *interp); +MODULE_SCOPE void TclProcessCreated(Tcl_Pid pid); +MODULE_SCOPE TclProcessWaitStatus TclProcessWait(Tcl_Pid pid, int options, + int *codePtr, Tcl_Obj **msgObjPtr, + Tcl_Obj **errorObjPtr); + +/* * Utility routines for encoding index values as integers. Used by both * some of the command compilers and by [lsort] and [lsearch]. */ diff --git a/generic/tclPipe.c b/generic/tclPipe.c index b679ec4..f94fe5c 100644 --- a/generic/tclPipe.c +++ b/generic/tclPipe.c @@ -221,13 +221,13 @@ Tcl_ReapDetachedProcs(void) { register Detached *detPtr; Detached *nextPtr, *prevPtr; - int status; - Tcl_Pid pid; + int status, code; Tcl_MutexLock(&pipeMutex); for (detPtr = detList, prevPtr = NULL; detPtr != NULL; ) { - pid = Tcl_WaitPid(detPtr->pid, &status, WNOHANG); - if ((pid == 0) || ((pid == (Tcl_Pid) -1) && (errno != ECHILD))) { + status = TclProcessWait(detPtr->pid, WNOHANG, &code, NULL, NULL); + if (status == TCL_PROCESS_UNCHANGED || (status == TCL_PROCESS_ERROR + && code != ECHILD)) { prevPtr = detPtr; detPtr = detPtr->nextPtr; continue; @@ -277,38 +277,21 @@ TclCleanupChildren( { int result = TCL_OK; int i, abnormalExit, anyErrorInfo; - Tcl_Pid pid; - int waitStatus; - const char *msg; - unsigned long resolvedPid; + TclProcessWaitStatus waitStatus; + int code; + Tcl_Obj *msg, *error; abnormalExit = 0; for (i = 0; i < numPids; i++) { - /* - * We need to get the resolved pid before we wait on it as the windows - * implementation of Tcl_WaitPid deletes the information such that any - * following calls to TclpGetPid fail. - */ - - resolvedPid = TclpGetPid(pidPtr[i]); - pid = Tcl_WaitPid(pidPtr[i], &waitStatus, 0); - if (pid == (Tcl_Pid) -1) { + waitStatus = TclProcessWait(pidPtr[i], 0, &code, &msg, &error); + if (waitStatus == TCL_PROCESS_ERROR) { result = TCL_ERROR; if (interp != NULL) { - msg = Tcl_PosixError(interp); - 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?)"; - } - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "error waiting for process to exit: %s", msg)); + Tcl_SetObjErrorCode(interp, error); + Tcl_SetObjResult(interp, msg); } + Tcl_DecrRefCount(error); + Tcl_DecrRefCount(msg); continue; } @@ -319,39 +302,19 @@ TclCleanupChildren( * removed). */ - if (!WIFEXITED(waitStatus) || (WEXITSTATUS(waitStatus) != 0)) { - char msg1[TCL_INTEGER_SPACE], msg2[TCL_INTEGER_SPACE]; - + if (waitStatus != TCL_PROCESS_EXITED || code != 0) { result = TCL_ERROR; - sprintf(msg1, "%lu", resolvedPid); - if (WIFEXITED(waitStatus)) { + if (waitStatus == TCL_PROCESS_EXITED) { if (interp != NULL) { - sprintf(msg2, "%u", WEXITSTATUS(waitStatus)); - Tcl_SetErrorCode(interp, "CHILDSTATUS", msg1, msg2, NULL); + Tcl_SetObjErrorCode(interp, error); } abnormalExit = 1; } else if (interp != NULL) { - const char *p; - - if (WIFSIGNALED(waitStatus)) { - p = Tcl_SignalMsg(WTERMSIG(waitStatus)); - Tcl_SetErrorCode(interp, "CHILDKILLED", msg1, - Tcl_SignalId(WTERMSIG(waitStatus)), p, NULL); - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "child killed: %s\n", p)); - } else if (WIFSTOPPED(waitStatus)) { - p = Tcl_SignalMsg(WSTOPSIG(waitStatus)); - Tcl_SetErrorCode(interp, "CHILDSUSP", msg1, - Tcl_SignalId(WSTOPSIG(waitStatus)), p, NULL); - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "child suspended: %s\n", p)); - } else { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "child wait status didn't make sense\n", -1)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", - "ODDWAITRESULT", msg1, NULL); - } + Tcl_SetObjErrorCode(interp, error); + Tcl_SetObjResult(interp, msg); } + Tcl_DecrRefCount(error); + Tcl_DecrRefCount(msg); } } @@ -936,6 +899,7 @@ TclCreatePipeline( pidPtr[numPids] = pid; numPids++; + TclProcessCreated(pid); /* * Close off our copies of file descriptors that were set up for this diff --git a/generic/tclProcess.c b/generic/tclProcess.c new file mode 100644 index 0000000..8d98a23 --- /dev/null +++ b/generic/tclProcess.c @@ -0,0 +1,952 @@ +/* + * tclProcess.c -- + * + * This file implements the "tcl::process" ensemble for subprocess + * management as defined by TIP #462. + * + * 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. + */ + +#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. */ + int 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, + int resolvedPid); +static void FreeProcessInfo(ProcessInfo *info); +static int RefreshProcessInfo(ProcessInfo *info, int options); +static TclProcessWaitStatus WaitProcessStatus(Tcl_Pid pid, int resolvedPid, + int options, int *codePtr, Tcl_Obj **msgPtr, + Tcl_Obj **errorObjPtr); +static Tcl_Obj * BuildProcessStatusObj(ProcessInfo *info); +static int ProcessListObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +static int ProcessStatusObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +static int ProcessPurgeObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +static int ProcessAutopurgeObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); + +/* + *---------------------------------------------------------------------- + * + * InitProcessInfo -- + * + * Initializes the ProcessInfo structure. + * + * Results: + * None. + * + * Side effects: + * Memory written. + * + *---------------------------------------------------------------------- + */ + +void +InitProcessInfo( + ProcessInfo *info, /* Structure to initialize. */ + Tcl_Pid pid, /* Process id. */ + int 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. */ + int 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); + errorStrings[1] = Tcl_NewIntObj(resolvedPid); + errorStrings[2] = Tcl_NewIntObj(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); + errorStrings[1] = Tcl_NewIntObj(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); + errorStrings[1] = Tcl_NewIntObj(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); + errorStrings[4] = Tcl_NewIntObj(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. + */ + + return Tcl_NewObj(); + } + if (info->status == TCL_PROCESS_EXITED && info->code == 0) { + /* + * Normal exit, return TCL_OK. + */ + + return Tcl_NewIntObj(TCL_OK); + } + + /* + * Abnormal exit, return {TCL_ERROR msg error} + */ + + resultObjs[0] = Tcl_NewIntObj(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( + ClientData clientData, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + Tcl_Obj *list; + 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); + Tcl_ListObjAppendElement(interp, list, + Tcl_NewIntObj(info->resolvedPid)); + } + 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( + ClientData clientData, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + Tcl_Obj *dict; + int index, options = WNOHANG; + Tcl_HashEntry *entry; + Tcl_HashSearch search; + ProcessInfo *info; + int numPids; + Tcl_Obj **pidObjs; + int result; + int i; + int pid; + Tcl_Obj *const *savedobjv = objv; + static const char *const switches[] = { + "-wait", "--", NULL + }; + enum switches { + 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 switches) 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. + */ + + Tcl_DictObjPut(interp, dict, Tcl_NewIntObj(info->resolvedPid), + BuildProcessStatusObj(info)); + } + } + Tcl_MutexUnlock(&infoTablesMutex); + } else { + /* + * Only return statuses of provided processes. + */ + + result = Tcl_ListObjGetElements(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], (int *) &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. + */ + + Tcl_DictObjPut(interp, dict, Tcl_NewIntObj(info->resolvedPid), + 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( + ClientData clientData, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + Tcl_HashEntry *entry; + Tcl_HashSearch search; + ProcessInfo *info; + int numPids; + Tcl_Obj **pidObjs; + int result; + int i; + 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 = Tcl_ListObjGetElements(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], (int *) &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( + ClientData clientData, /* Not used. */ + 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. */ +{ + int 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. + */ + + 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); + return result; + } + + info = (ProcessInfo *) Tcl_GetHashValue(entry); + if (info->purge) { + /* + * Process has completed but TclProcessWait has already been called, + * so report no change. + */ + + return TCL_PROCESS_UNCHANGED; + } + + RefreshProcessInfo(info, options); + if (info->status == TCL_PROCESS_UNCHANGED) { + /* + * No change, stop there. + */ + + 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; + } + return result; +} diff --git a/library/msgcat/msgcat.tcl b/library/msgcat/msgcat.tcl index 646bc17..96b0110 100644 --- a/library/msgcat/msgcat.tcl +++ b/library/msgcat/msgcat.tcl @@ -11,15 +11,16 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require Tcl 8.5- +package require Tcl 8.6- # When the version number changes, be sure to update the pkgIndex.tcl file, # and the installation directory in the Makefiles. -package provide msgcat 1.6.1 +package provide msgcat 1.7.0 namespace eval msgcat { - namespace export mc mcexists mcload mclocale mcmax mcmset mcpreferences mcset\ + namespace export mc mcn mcexists mcload mclocale mcmax\ + mcmset mcpreferences mcset\ mcunknown mcflset mcflmset mcloadedlocales mcforgetpackage\ - mcpackageconfig mcpackagelocale + mcpackagenamespaceget mcpackageconfig mcpackagelocale mcutil # Records the list of locales to search variable Loclist {} @@ -41,7 +42,13 @@ namespace eval msgcat { # namespace should be themselves dict values and the value is # the translated string. variable Msgs [dict create] +} +# create ensemble namespace for mcutil command +namespace eval msgcat::mcutil { + namespace export getsystemlocale getpreferences + namespace ensemble create -prefix 0 + # Map of language codes used in Windows registry to those of ISO-639 if {[info sharedlibextension] eq ".dll"} { variable WinRegToISO639 [dict create {*}{ @@ -192,10 +199,30 @@ namespace eval msgcat { # Returns the translated string. Propagates errors thrown by the # format command. -proc msgcat::mc {src args} { - # this may be replaced by: - # return [mcget -namespace [uplevel 1 [list ::namespace current]] --\ - # $src {*}$args] +proc msgcat::mc {args} { + tailcall mcn [PackageNamespaceGet] {*}$args +} + +# msgcat::mcn -- +# +# Find the translation for the given string based on the current +# locale setting. Check the passed namespace first, then look in each +# parent namespace until the source is found. If additional args are +# specified, use the format command to work them into the traslated +# string. +# If no catalog item is found, mcunknown is called in the caller frame +# and its result is returned. +# +# Arguments: +# ns Package namespace of the translation +# src The string to translate. +# args Args to pass to the format command +# +# Results: +# Returns the translated string. Propagates errors thrown by the +# format command. + +proc msgcat::mcn {ns src args} { # Check for the src in each namespace starting from the local and # ending in the global. @@ -203,7 +230,6 @@ proc msgcat::mc {src args} { variable Msgs variable Loclist - set ns [uplevel 1 [list ::namespace current]] set loclist [PackagePreferences $ns] set nscur $ns @@ -219,7 +245,7 @@ proc msgcat::mc {src args} { # call package local or default unknown command set args [linsert $args 0 [lindex $loclist 0] $src] switch -exact -- [Invoke unknowncmd $args $ns result 1] { - 0 { return [uplevel 1 [linsert $args 0 [namespace origin mcunknown]]] } + 0 { tailcall mcunknown {*}$args } 1 { return [DefaultUnknown {*}$args] } default { return $result } } @@ -245,23 +271,31 @@ proc msgcat::mcexists {args} { variable Loclist variable PackageConfig - set ns [uplevel 1 [list ::namespace current]] - set loclist [PackagePreferences $ns] - while {[llength $args] != 1} { set args [lassign $args option] switch -glob -- $option { - -exactnamespace { set exactnamespace 1 } - -exactlocale { set loclist [lrange $loclist 0 0] } + -exactnamespace - -exactlocale { set $option 1 } + -namespace { + if {[llength $args] < 2} { + return -code error\ + "Argument missing for switch \"-namespace\"" + } + set args [lassign $args ns] + } -* { return -code error "unknown option \"$option\"" } default { return -code error "wrong # args: should be\ \"[lindex [info level 0] 0] ?-exactnamespace?\ - ?-exactlocale? src\"" + ?-exactlocale? ?-namespace ns? src\"" } } } set src [lindex $args 0] + + if {![info exists ns]} { set ns [PackageNamespaceGet] } + + set loclist [PackagePreferences $ns] + if {[info exists -exactlocale]} { set loclist [lrange $loclist 0 0] } while {$ns ne ""} { foreach loc $loclist { @@ -269,7 +303,7 @@ proc msgcat::mcexists {args} { return 1 } } - if {[info exists exactnamespace]} {return 0} + if {[info exists -exactnamespace]} {return 0} set ns [namespace parent $ns] } return 0 @@ -303,32 +337,27 @@ proc msgcat::mclocale {args} { return -code error "invalid newLocale value \"$newLocale\":\ could be path to unsafe code." } - if {[lindex $Loclist 0] ne $newLocale} { - set Loclist [GetPreferences $newLocale] - - # locale not loaded jet - LoadAll $Loclist - # Invoke callback - Invoke changecmd $Loclist - } + mcpreferences {*}[mcutil getpreferences $newLocale] } return [lindex $Loclist 0] } -# msgcat::GetPreferences -- +# msgcat::mcutil::getpreferences -- # # Get list of locales from a locale. # The first element is always the lowercase locale. # Other elements have one component separated by "_" less. # Multiple "_" are seen as one separator: de__ch_spec de__ch de {} # +# This method is part of the ensemble mcutil +# # Arguments: # Locale. # # Results: # Locale list -proc msgcat::GetPreferences {locale} { +proc msgcat::mcutil::getpreferences {locale} { set locale [string tolower $locale] set loclist [list $locale] while {-1 !=[set pos [string last "_" $locale]]} { @@ -349,16 +378,51 @@ proc msgcat::GetPreferences {locale} { # most preferred to least preferred. # # Arguments: -# None. +# New location list # # Results: # Returns an ordered list of the locales preferred by the user. -proc msgcat::mcpreferences {} { +proc msgcat::mcpreferences {args} { variable Loclist + + if {[llength $args] > 0} { + # args is the new loclist + if {![ListEqualString $args $Loclist]} { + set Loclist $args + + # locale not loaded jet + LoadAll $Loclist + # Invoke callback + Invoke changecmd $Loclist + } + } return $Loclist } +# msgcat::ListStringEqual -- +# +# Compare two strings for equal string contents +# +# Arguments: +# list1 first list +# list2 second list +# +# Results: +# 1 if lists of strings are identical, 0 otherwise + +proc msgcat::ListEqualString {list1 list2} { + if {[llength $list1] != [llength $list2]} { + return 0 + } + foreach item1 $list1 item2 $list2 { + if {$item1 ne $item2} { + return 0 + } + } + return 1 +} + # msgcat::mcloadedlocales -- # # Get or change the list of currently loaded default locales @@ -442,7 +506,7 @@ proc msgcat::mcloadedlocales {subcommand} { # Results: # Empty string, if not stated differently for the subcommand -proc msgcat::mcpackagelocale {subcommand {locale ""}} { +proc msgcat::mcpackagelocale {subcommand args} { # todo: implement using an ensemble variable Loclist variable LoadedLocales @@ -450,27 +514,39 @@ proc msgcat::mcpackagelocale {subcommand {locale ""}} { variable PackageConfig # Check option # check if required item is exactly provided - if {[llength [info level 0]] == 2} { - # locale not given - unset locale - } else { - # locale given - if {$subcommand in - {"get" "isset" "unset" "preferences" "loaded" "clear"} } { - return -code error "wrong # args: should be\ - \"[lrange [info level 0] 0 1]\"" - } - set locale [string tolower $locale] + if { [llength $args] > 0 + && $subcommand in {"get" "isset" "unset" "loaded" "clear"} } { + return -code error "wrong # args: should be\ + \"[lrange [info level 0] 0 1]\"" } - set ns [uplevel 1 {::namespace current}] + set ns [PackageNamespaceGet] switch -exact -- $subcommand { get { return [lindex [PackagePreferences $ns] 0] } - preferences { return [PackagePreferences $ns] } loaded { return [PackageLocales $ns] } - present { return [expr {$locale in [PackageLocales $ns]} ]} + present { + if {[llength $args] != 1} { + return -code error "wrong # args: should be\ + \"[lrange [info level 0] 0 1] locale\"" + } + return [expr {[string tolower [lindex $args 0]] + in [PackageLocales $ns]} ] + } isset { return [dict exists $PackageConfig loclist $ns] } - set { # set a package locale or add a package locale + set - preferences { + # set a package locale or add a package locale + set fSet [expr {$subcommand eq "set"}] + + # Check parameter + if {$fSet && 1 < [llength $args] } { + return -code error "wrong # args: should be\ + \"[lrange [info level 0] 0 1] ?locale?\"" + } + + # > Return preferences if no parameter + if {!$fSet && 0 == [llength $args] } { + return [PackagePreferences $ns] + } # Copy the default locale if no package locale set so far if {![dict exists $PackageConfig loclist $ns]} { @@ -478,25 +554,43 @@ proc msgcat::mcpackagelocale {subcommand {locale ""}} { dict set PackageConfig loadedlocales $ns $LoadedLocales } - # Check if changed - set loclist [dict get $PackageConfig loclist $ns] - if {! [info exists locale] || $locale eq [lindex $loclist 0] } { - return [lindex $loclist 0] + # No argument for set: return current package locale + # The difference to no argument and subcommand "preferences" is, + # that "preferences" does not set the package locale property. + # This case is processed above, so no check for fSet here + if { 0 == [llength $args] } { + return [lindex [dict get $PackageConfig loclist $ns] 0] + } + + # Get new loclist + if {$fSet} { + set loclist [mcutil getpreferences [lindex $args 0]] + } else { + set loclist $args + } + + # Check if not changed to return imediately + if { [ListEqualString $loclist\ + [dict get $PackageConfig loclist $ns]] } { + if {$fSet} { + return [lindex $loclist 0] + } + return $loclist } # Change loclist - set loclist [GetPreferences $locale] - set locale [lindex $loclist 0] dict set PackageConfig loclist $ns $loclist # load eventual missing locales set loadedLocales [dict get $PackageConfig loadedlocales $ns] - if {$locale in $loadedLocales} { return $locale } set loadLocales [ListComplement $loadedLocales $loclist] dict set PackageConfig loadedlocales $ns\ [concat $loadedLocales $loadLocales] Load $ns $loadLocales - return $locale + if {$fSet} { + return [lindex $loclist 0] + } + return $loclist } clear { # Remove all locales not contained in Loclist if {![dict exists $PackageConfig loclist $ns]} { @@ -551,7 +645,7 @@ proc msgcat::mcforgetpackage {} { # todo: this may be implemented using an ensemble variable PackageConfig variable Msgs - set ns [uplevel 1 {::namespace current}] + set ns [PackageNamespaceGet] # Remove MC items dict unset Msgs $ns # Remove config items @@ -561,6 +655,15 @@ proc msgcat::mcforgetpackage {} { return } +# msgcat::mcgetmynamespace -- +# +# Return the package namespace of the caller +# This consideres to be called from a class or object. + +proc msgcat::mcpackagenamespaceget {} { + return [PackageNamespaceGet] +} + # msgcat::mcpackageconfig -- # # Get or modify the per caller namespace (e.g. packages) config options. @@ -616,7 +719,7 @@ proc msgcat::mcforgetpackage {} { proc msgcat::mcpackageconfig {subcommand option {value ""}} { variable PackageConfig # get namespace - set ns [uplevel 1 {::namespace current}] + set ns [PackageNamespaceGet] if {$option ni {"mcfolder" "loadcmd" "changecmd" "unknowncmd"}} { return -code error "bad option \"$option\": must be mcfolder, loadcmd,\ @@ -756,8 +859,7 @@ proc msgcat::ListComplement {list1 list2 {inlistname ""}} { # Returns the number of message catalogs that were loaded. proc msgcat::mcload {langdir} { - return [uplevel 1 [list\ - [namespace origin mcpackageconfig] set mcfolder $langdir]] + tailcall mcpackageconfig set mcfolder $langdir } # msgcat::LoadAll -- @@ -923,7 +1025,7 @@ proc msgcat::mcset {locale src {dest ""}} { set dest $src } - set ns [uplevel 1 [list ::namespace current]] + set ns [PackageNamespaceGet] set locale [string tolower $locale] @@ -951,7 +1053,7 @@ proc msgcat::mcflset {src {dest ""}} { return -code error "must only be used inside a message catalog loaded\ with ::msgcat::mcload" } - return [uplevel 1 [list [namespace origin mcset] $FileLocale $src $dest]] + tailcall mcset $FileLocale $src $dest } # msgcat::mcmset -- @@ -975,7 +1077,7 @@ proc msgcat::mcmset {locale pairs} { } set locale [string tolower $locale] - set ns [uplevel 1 [list ::namespace current]] + set ns [PackageNamespaceGet] foreach {src dest} $pairs { dict set Msgs $ns $locale $src $dest @@ -1002,7 +1104,7 @@ proc msgcat::mcflmset {pairs} { return -code error "must only be used inside a message catalog loaded\ with ::msgcat::mcload" } - return [uplevel 1 [list [namespace origin mcmset] $FileLocale $pairs]] + tailcal mcmset $FileLocale $pairs } # msgcat::mcunknown -- @@ -1024,7 +1126,7 @@ proc msgcat::mcflmset {pairs} { # Returns the translated value. proc msgcat::mcunknown {args} { - return [uplevel 1 [list [namespace origin DefaultUnknown] {*}$args]] + tailcall DefaultUnknown {*}$args } # msgcat::DefaultUnknown -- @@ -1067,8 +1169,9 @@ proc msgcat::DefaultUnknown {locale src args} { proc msgcat::mcmax {args} { set max 0 + set ns [PackageNamespaceGet] foreach string $args { - set translated [uplevel 1 [list [namespace origin mc] $string]] + set translated [uplevel 1 [list [namespace origin mcn] $ns $string]] set len [string length $translated] if {$len>$max} { set max $len @@ -1079,7 +1182,7 @@ proc msgcat::mcmax {args} { # Convert the locale values stored in environment variables to a form # suitable for passing to [mclocale] -proc msgcat::ConvertLocale {value} { +proc msgcat::mcutil::ConvertLocale {value} { # Assume $value is of form: $language[_$territory][.$codeset][@modifier] # Convert to form: $language[_$territory][_$modifier] # @@ -1106,8 +1209,40 @@ proc msgcat::ConvertLocale {value} { return $ret } +# helper function to find package namespace of stack-frame -2 +# There are 4 possibilities: +# - called from a proc +# - called within a class definition script +# - called from an class defined oo object +# - called from a classless oo object +proc ::msgcat::PackageNamespaceGet {} { + uplevel 2 { + # Check for no object + switch -exact -- [namespace which self] { + {::oo::define::self} { + # We are within a class definition + return [namespace qualifiers [self]] + } + {::oo::Helpers::self} { + # We are within an object + set Class [info object class [self]] + # Check for classless defined object + if {$Class eq {::oo::object}} { + return [namespace qualifiers [self]] + } + # Class defined object + return [namespace qualifiers $Class] + } + default { + # Not in object environment + return [namespace current] + } + } + } +} + # Initialize the default locale -proc msgcat::Init {} { +proc msgcat::mcutil::getsystemlocale {} { global env # @@ -1115,10 +1250,8 @@ proc msgcat::Init {} { # foreach varName {LC_ALL LC_MESSAGES LANG} { if {[info exists env($varName)] && ("" ne $env($varName))} { - if {![catch { - mclocale [ConvertLocale $env($varName)] - }]} { - return + if {![catch { ConvertLocale $env($varName) } locale]} { + return $locale } } } @@ -1126,10 +1259,8 @@ proc msgcat::Init {} { # On Darwin, fallback to current CFLocale identifier if available. # if {[info exists ::tcl::mac::locale] && $::tcl::mac::locale ne ""} { - if {![catch { - mclocale [ConvertLocale $::tcl::mac::locale] - }]} { - return + if {![catch { ConvertLocale $::tcl::mac::locale] } locale]} { + return $locale } } # @@ -1138,8 +1269,7 @@ proc msgcat::Init {} { # if {([info sharedlibextension] ne ".dll") || [catch {package require registry}]} { - mclocale C - return + return C } # # On Windows or Cygwin, try to set locale depending on registry @@ -1170,8 +1300,8 @@ proc msgcat::Init {} { if {[dict exists $modifierDict $script]} { append locale @ [dict get $modifierDict $script] } - if {![catch {mclocale [ConvertLocale $locale]}]} { - return + if {![catch {ConvertLocale $locale} locale]} { + return $locale } } } @@ -1180,8 +1310,7 @@ proc msgcat::Init {} { if {[catch { set locale [registry get $key "locale"] }]} { - mclocale C - return + return C } # # Keep trying to match against smaller and smaller suffixes @@ -1196,15 +1325,15 @@ proc msgcat::Init {} { set locale [string tolower $locale] while {[string length $locale]} { if {![catch { - mclocale [ConvertLocale [dict get $WinRegToISO639 $locale]] - }]} { - return + ConvertLocale [dict get $WinRegToISO639 $locale] + } localeOut]} { + return $localeOut } set locale [string range $locale 1 end] } # # No translation known. Fall back on "C" locale # - mclocale C + return C } -msgcat::Init +msgcat::mclocale [msgcat::mcutil getsystemlocale] diff --git a/library/msgcat/pkgIndex.tcl b/library/msgcat/pkgIndex.tcl index 72c5dc0..2feb9c6 100644 --- a/library/msgcat/pkgIndex.tcl +++ b/library/msgcat/pkgIndex.tcl @@ -1,2 +1,2 @@ -if {![package vsatisfies [package provide Tcl] 8.5-]} {return} -package ifneeded msgcat 1.6.1 [list source [file join $dir msgcat.tcl]] +if {![package vsatisfies [package provide Tcl] 8.6-]} {return} +package ifneeded msgcat 1.7.0 [list source [file join $dir msgcat.tcl]] diff --git a/tests/msgcat.test b/tests/msgcat.test index 1c3ce58..7ab9bcf 100644 --- a/tests/msgcat.test +++ b/tests/msgcat.test @@ -194,6 +194,28 @@ namespace eval ::msgcat::test { mclocale looks/ok/../../../../but/is/path/to/evil/code } -returnCodes error -match glob -result {invalid newLocale value *} + test msgcat-1.14 {mcpreferences, custom locale preferences} -setup { + variable locale [mclocale] + mclocale en + mcpreferences fr en {} + } -cleanup { + mclocale $locale + } -body { + mcpreferences + } -result {fr en {}} + + test msgcat-1.15 {mcpreferences, overwrite custom locale preferences}\ + -setup { + variable locale [mclocale] + mcpreferences fr en {} + mclocale en + } -cleanup { + mclocale $locale + } -body { + mcpreferences + } -result {en {}} + + # Tests msgcat-2.*: [mcset], [mcmset], namespace partitioning test msgcat-2.1 {mcset, global scope} { @@ -688,7 +710,7 @@ namespace eval ::msgcat::test { test msgcat-9.1 {mcexists no parameter} -body { mcexists } -returnCodes 1\ - -result {wrong # args: should be "mcexists ?-exactnamespace? ?-exactlocale? src"} + -result {wrong # args: should be "mcexists ?-exactnamespace? ?-exactlocale? ?-namespace ns? src"} test msgcat-9.2 {mcexists unknown option} -body { mcexists -unknown src @@ -724,12 +746,34 @@ namespace eval ::msgcat::test { mcset foo k1 v1 } -cleanup { mclocale $locale + namespace delete ::foo } -body { - namespace eval ::msgcat::test::sub { + namespace eval ::foo { list [::msgcat::mcexists k1]\ - [::msgcat::mcexists -exactnamespace k1] + [::msgcat::mcexists -namespace ::msgcat::test k1] } - } -result {1 0} + } -result {0 1} + + test msgcat-9.6 {mcexists -namespace ns parameter} -setup { + mcforgetpackage + variable locale [mclocale] + mclocale foo_bar + mcset foo k1 v1 + } -cleanup { + mclocale $locale + namespace delete ::foo + } -body { + namespace eval ::foo { + list [::msgcat::mcexists k1]\ + [::msgcat::mcexists -namespace ::msgcat::test k1] + } + } -result {0 1} + + test msgcat-9.7 {mcexists -namespace - ns argument missing} -body { + mcexists -namespace src + } -returnCodes 1\ + -result {Argument missing for switch "-namespace"} + # Tests msgcat-10.*: [mcloadedlocales] @@ -811,13 +855,18 @@ namespace eval ::msgcat::test { test msgcat-12.1 {mcpackagelocale no subcommand} -body { mcpackagelocale } -returnCodes 1\ - -result {wrong # args: should be "mcpackagelocale subcommand ?locale?"} + -result {wrong # args: should be "mcpackagelocale subcommand ?arg ...?"} test msgcat-12.2 {mclpackagelocale wrong subcommand} -body { mcpackagelocale junk } -returnCodes 1\ -result {unknown subcommand "junk": must be clear, get, isset, loaded, present, set, or unset} + test msgcat-12.2.1 {mclpackagelocale set multiple args} -body { + mcpackagelocale set a b + } -returnCodes 1\ + -result {wrong # args: should be "mcpackagelocale set ?locale?"} + test msgcat-12.3 {mcpackagelocale set} -setup { variable locale [mclocale] } -cleanup { @@ -922,6 +971,30 @@ namespace eval ::msgcat::test { list [mcpackagelocale present foo] [mcpackagelocale present bar] } -result {0 1} + test msgcat-12.11 {mcpackagelocale custom preferences} -setup { + variable locale [mclocale] + } -cleanup { + mclocale $locale + mcforgetpackage + } -body { + mclocale foo + set res [list [mcpackagelocale preferences]] + mcpackagelocale preferences bar {} + lappend res [mcpackagelocale preferences] + } -result {{foo {}} {bar {}}} + + test msgcat-12.12 {mcpackagelocale preferences -> no isset} -setup { + variable locale [mclocale] + } -cleanup { + mclocale $locale + mcforgetpackage + } -body { + mclocale foo + mcpackagelocale preferences + mcpackagelocale isset + } -result {0} + + # Tests msgcat-13.*: [mcpackageconfig subcmds] test msgcat-13.1 {mcpackageconfig no subcommand} -body { @@ -1073,8 +1146,212 @@ namespace eval ::msgcat::test { } -returnCodes 1\ -result {fail} + + # Tests msgcat-15.*: tcloo coverage + + # There are 4 use-cases, where 3 must be tested now: + # - namespace defined, in class definition, class defined oo, classless + + test msgcat-15.1 {mc in class setup} -setup { + # full namespace is ::msgcat::test:bar + namespace eval bar { + ::msgcat::mcset foo_BAR con2 con2bar + oo::class create ClassCur + } + variable locale [mclocale] + mclocale foo_BAR + } -cleanup { + mclocale $locale + namespace eval bar {::msgcat::mcforgetpackage} + namespace delete bar + } -body { + oo::define bar::ClassCur msgcat::mc con2 + } -result con2bar + + test msgcat-15.2 {mc in class} -setup { + # full namespace is ::msgcat::test:bar + namespace eval bar { + ::msgcat::mcset foo_BAR con2 con2bar + oo::class create ClassCur + oo::define ClassCur method method1 {} {::msgcat::mc con2} + } + # full namespace is ::msgcat::test:baz + namespace eval baz { + set ObjCur [::msgcat::test::bar::ClassCur new] + } + variable locale [mclocale] + mclocale foo_BAR + } -cleanup { + mclocale $locale + namespace eval bar {::msgcat::mcforgetpackage} + namespace delete bar baz + } -body { + $baz::ObjCur method1 + } -result con2bar + + test msgcat-15.3 {mc in classless object} -setup { + # full namespace is ::msgcat::test:bar + namespace eval bar { + ::msgcat::mcset foo_BAR con2 con2bar + oo::object create ObjCur + oo::objdefine ObjCur method method1 {} {::msgcat::mc con2} + } + variable locale [mclocale] + mclocale foo_BAR + } -cleanup { + mclocale $locale + namespace eval bar {::msgcat::mcforgetpackage} + namespace delete bar + } -body { + bar::ObjCur method1 + } -result con2bar + + test msgcat-15.4 {mc in classless object with explicite namespace eval}\ + -setup { + # full namespace is ::msgcat::test:bar + namespace eval bar { + ::msgcat::mcset foo_BAR con2 con2bar + oo::object create ObjCur + oo::objdefine ObjCur method method1 {} { + namespace eval ::msgcat::test::baz { + ::msgcat::mc con2 + } + } + } + namespace eval baz { + ::msgcat::mcset foo_BAR con2 con2baz + } + variable locale [mclocale] + mclocale foo_BAR + } -cleanup { + mclocale $locale + namespace eval bar {::msgcat::mcforgetpackage} + namespace eval baz {::msgcat::mcforgetpackage} + namespace delete bar baz + } -body { + bar::ObjCur method1 + } -result con2baz + + # Test msgcat-16.*: command mcpackagenamespaceget + + test msgcat-16.1 {mcpackagenamespaceget in namespace procedure} -body { + namespace eval baz {msgcat::mcpackagenamespaceget} + } -result ::msgcat::test::baz + + test msgcat-16.2 {mcpackagenamespaceget in class setup} -setup { + namespace eval bar { + oo::class create ClassCur + oo::define ClassCur variable a + } + } -cleanup { + namespace delete bar + } -body { + oo::define bar::ClassCur msgcat::mcpackagenamespaceget + } -result ::msgcat::test::bar + + test msgcat-16.3 {mcpackagenamespaceget in class} -setup { + namespace eval bar { + oo::class create ClassCur + oo::define ClassCur method method1 {} {msgcat::mcpackagenamespaceget} + } + namespace eval baz { + set ObjCur [::msgcat::test::bar::ClassCur new] + } + } -cleanup { + namespace delete bar baz + } -body { + $baz::ObjCur method1 + } -result ::msgcat::test::bar + + test msgcat-16.4 {mcpackagenamespaceget in classless object} -setup { + namespace eval bar { + oo::object create ObjCur + oo::objdefine ObjCur method method1 {} {msgcat::mcpackagenamespaceget} + } + } -cleanup { + namespace delete bar + } -body { + bar::ObjCur method1 + } -result ::msgcat::test::bar + + test msgcat-16.5\ + {mcpackagenamespaceget in classless object with explicite namespace eval}\ + -setup { + namespace eval bar { + oo::object create ObjCur + oo::objdefine ObjCur method method1 {} { + namespace eval ::msgcat::test::baz { + msgcat::mcpackagenamespaceget + } + } + } + } -cleanup { + namespace delete bar baz + } -body { + bar::ObjCur method1 + } -result ::msgcat::test::baz + + + # Test msgcat-17.*: mcn command + + test msgcat-17.1 {mcn no parameters} -body { + mcn + } -returnCodes 1\ + -result {wrong # args: should be "mcn ns src ?arg ...?"} + + test msgcat-17.2 {mcn} -setup { + namespace eval bar {::msgcat::mcset foo_BAR con1 con1bar} + variable locale [mclocale] + mclocale foo_BAR + } -cleanup { + mclocale $locale + } -body { + ::msgcat::mcn [namespace current]::bar con1 + } -result con1bar + + interp bgerror {} $bgerrorsaved + # Tests msgcat-15.*: [mcutil] + + test msgcat-15.1 {mcutil - no argument} -body { + mcutil + } -returnCodes 1\ + -result {wrong # args: should be "mcutil subcommand ?arg ...?"} + + test msgcat-15.2 {mcutil - wrong argument} -body { + mcutil junk + } -returnCodes 1\ + -result {unknown subcommand "junk": must be getpreferences, or getsystemlocale} + + test msgcat-15.3 {mcutil - partial argument} -body { + mcutil getsystem + } -returnCodes 1\ + -result {unknown subcommand "getsystem": must be getpreferences, or getsystemlocale} + + test msgcat-15.4 {mcutil getpreferences - no argument} -body { + mcutil getpreferences + } -returnCodes 1\ + -result {wrong # args: should be "mcutil getpreferences locale"} + + test msgcat-15.5 {mcutil getpreferences - DE_de} -body { + mcutil getpreferences DE_de + } -result {de_de de {}} + + test msgcat-15.6 {mcutil getsystemlocale - wrong argument} -body { + mcutil getsystemlocale DE_de + } -returnCodes 1\ + -result {wrong # args: should be "mcutil getsystemlocale"} + + # The result is system dependent + # So just test if it runs + # The environment variable version was test with test 0.x + test msgcat-15.7 {mcutil getsystemlocale} -body { + mcutil getsystemlocale + set ok ok + } -result {ok} + + cleanupTests } namespace delete ::msgcat::test diff --git a/tests/process.test b/tests/process.test new file mode 100644 index 0000000..fb3a5e2 --- /dev/null +++ b/tests/process.test @@ -0,0 +1,31 @@ +# process.test -- +# +# This file contains a collection of tests for the tcl::process ensemble. +# Sourcing this file into Tcl runs the tests and generates output for +# errors. No output means no errors were found. +# +# 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. + +if {[lsearch [namespace children] ::tcltest] == -1} { + package require tcltest 2 + namespace import -force ::tcltest::* +} + +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 { + 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} { + tcl::process autopurge true + tcl::process autopurge +} {1} +test process-2.3 {tcl::process autopurge set false} { + tcl::process autopurge false + tcl::process autopurge +} {0} diff --git a/unix/Makefile.in b/unix/Makefile.in index d8744fd..c356606 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -303,7 +303,7 @@ GENERIC_OBJS = regcomp.o regexec.o regfree.o regerror.o tclAlloc.o \ tclLiteral.o tclLoad.o tclMain.o tclNamesp.o tclNotify.o \ tclObj.o tclOptimize.o tclPanic.o tclParse.o tclPathObj.o tclPipe.o \ tclPkg.o tclPkgConfig.o tclPosixStr.o \ - tclPreserve.o tclProc.o tclRegexp.o \ + tclPreserve.o tclProc.o tclProcess.o tclRegexp.o \ tclResolve.o tclResult.o tclScan.o tclStringObj.o \ tclStrToD.o tclThread.o \ tclThreadAlloc.o tclThreadJoin.o tclThreadStorage.o tclStubInit.o \ @@ -444,6 +444,7 @@ GENERIC_SRCS = \ $(GENERIC_DIR)/tclPosixStr.c \ $(GENERIC_DIR)/tclPreserve.c \ $(GENERIC_DIR)/tclProc.c \ + $(GENERIC_DIR)/tclProcess.c \ $(GENERIC_DIR)/tclRegexp.c \ $(GENERIC_DIR)/tclResolve.c \ $(GENERIC_DIR)/tclResult.c \ @@ -850,8 +851,8 @@ install-libraries: libraries do \ $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"/opt0.4; \ done; - @echo "Installing package msgcat 1.6.1 as a Tcl Module"; - @$(INSTALL_DATA) $(TOP_DIR)/library/msgcat/msgcat.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl9/9.0/msgcat-1.6.1.tm; + @echo "Installing package msgcat 1.7.0 as a Tcl Module"; + @$(INSTALL_DATA) $(TOP_DIR)/library/msgcat/msgcat.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl9/9.0/msgcat-1.7.0.tm; @echo "Installing package tcltest 2.4.1 as a Tcl Module"; @$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl9/9.0/tcltest-2.4.1.tm; @@ -1288,6 +1289,9 @@ tclPreserve.o: $(GENERIC_DIR)/tclPreserve.c tclProc.o: $(GENERIC_DIR)/tclProc.c $(COMPILEHDR) $(NREHDR) $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclProc.c +tclProcess.o: $(GENERIC_DIR)/tclProcess.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclProcess.c + tclRegexp.o: $(GENERIC_DIR)/tclRegexp.c $(TCLREHDRS) $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclRegexp.c diff --git a/win/Makefile.in b/win/Makefile.in index a05572b..1c96ac8 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -285,6 +285,7 @@ GENERIC_OBJS = \ tclPosixStr.$(OBJEXT) \ tclPreserve.$(OBJEXT) \ tclProc.$(OBJEXT) \ + tclProcess.$(OBJEXT) \ tclRegexp.$(OBJEXT) \ tclResolve.$(OBJEXT) \ tclResult.$(OBJEXT) \ @@ -659,8 +660,8 @@ install-libraries: libraries install-tzdata install-msgs do \ $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/opt0.4"; \ done; - @echo "Installing package msgcat 1.6.1 as a Tcl Module"; - @$(COPY) $(ROOT_DIR)/library/msgcat/msgcat.tcl $(SCRIPT_INSTALL_DIR)/../tcl9/9.0/msgcat-1.6.1.tm; + @echo "Installing package msgcat 1.7.0 as a Tcl Module"; + @$(COPY) $(ROOT_DIR)/library/msgcat/msgcat.tcl $(SCRIPT_INSTALL_DIR)/../tcl9/9.0/msgcat-1.7.0.tm; @echo "Installing package tcltest 2.4.0 as a Tcl Module"; @$(COPY) $(ROOT_DIR)/library/tcltest/tcltest.tcl $(SCRIPT_INSTALL_DIR)/../tcl9/9.0/tcltest-2.4.0.tm; @echo "Installing package platform 1.0.14 as a Tcl Module"; diff --git a/win/buildall.vc.bat b/win/buildall.vc.bat index deb9e39..cb136be 100644 --- a/win/buildall.vc.bat +++ b/win/buildall.vc.bat @@ -38,7 +38,9 @@ if defined WINDOWSSDKDIR (goto :startBuilding) :: might not be correct. You should call it yourself prior to running
:: this batchfile.
::
-call "C:\Program Files\Microsoft Developer Studio\vc98\bin\vcvars32.bat"
+REM call "C:\Program Files\Microsoft Developer Studio\vc98\bin\vcvars32.bat"
+set "VSCMD_START_DIR=%CD%"
+call "C:\Program Files (x86)\Microsoft Visual Studio\2017\Community\Common7\Tools\VsDevCmd.bat"
if errorlevel 1 (goto no_vcvars)
:startBuilding
diff --git a/win/makefile.vc b/win/makefile.vc index f29d940..e74ceb8 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -218,6 +218,7 @@ COREOBJS = \ $(TMP_DIR)\tclPosixStr.obj \
$(TMP_DIR)\tclPreserve.obj \
$(TMP_DIR)\tclProc.obj \
+ $(TMP_DIR)\tclProcess.obj \
$(TMP_DIR)\tclRegexp.obj \
$(TMP_DIR)\tclResolve.obj \
$(TMP_DIR)\tclResult.obj \
diff --git a/win/tcl.dsp b/win/tcl.dsp index 520b466..8785c6a 100644 --- a/win/tcl.dsp +++ b/win/tcl.dsp @@ -1264,6 +1264,10 @@ SOURCE=..\generic\tclProc.c # End Source File
# Begin Source File
+SOURCE=..\generic\tclProcess.c
+# End Source File
+# Begin Source File
+
SOURCE=..\generic\tclRegexp.c
# End Source File
# Begin Source File
diff --git a/win/tclWinPipe.c b/win/tclWinPipe.c index d1b0596..a357412 100644 --- a/win/tclWinPipe.c +++ b/win/tclWinPipe.c @@ -869,7 +869,7 @@ TclpGetPid( Tcl_MutexLock(&pipeMutex); for (infoPtr = procList; infoPtr != NULL; infoPtr = infoPtr->nextPtr) { - if (infoPtr->hProcess == (HANDLE) pid) { + if (infoPtr->dwProcessId == (DWORD) pid) { Tcl_MutexUnlock(&pipeMutex); return infoPtr->dwProcessId; } @@ -1163,7 +1163,7 @@ TclpCreateProcess( WaitForInputIdle(procInfo.hProcess, 5000); CloseHandle(procInfo.hThread); - *pidPtr = (Tcl_Pid) procInfo.hProcess; + *pidPtr = (Tcl_Pid) procInfo.dwProcessId; if (*pidPtr != 0) { TclWinAddProcess(procInfo.hProcess, procInfo.dwProcessId); } @@ -2347,7 +2347,7 @@ Tcl_WaitPid( prevPtrPtr = &procList; for (infoPtr = procList; infoPtr != NULL; prevPtrPtr = &infoPtr->nextPtr, infoPtr = infoPtr->nextPtr) { - if (infoPtr->hProcess == (HANDLE) pid) { + if (infoPtr->dwProcessId == (DWORD) pid) { *prevPtrPtr = infoPtr->nextPtr; break; } |