Tcl Source Code

Check-in [38ef030047]
Login
Bounty program for improvements to Tcl and certain Tcl packages.
Tcl 2019 Conference, Houston/TX, US, Nov 4-8
Send your abstracts to [email protected]
or submit via the online form by Sep 9.

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:cherry pick over ranges of 8.7 only changes.
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | mistake
Files: files | file ages | folders
SHA3-256: 38ef030047c1c15444e92596ce2262fe36aeda4281a5e755f834b9d7abd9d61a
User & Date: dgp 2018-03-14 22:52:52
Context
2018-03-14
22:56
another range check-in: b285990627 user: dgp tags: mistake
22:52
cherry pick over ranges of 8.7 only changes. check-in: 38ef030047 user: dgp tags: mistake
22:39
Rebase the memleak work. check-in: 29b72b7167 user: dgp tags: memleak-87
2018-03-12
14:14
Implement TIP 499: Custom locale search list for msgcat check-in: c37cf7f1dd user: dgp tags: core-8-branch
Changes
Hide Diffs Side-by-Side Diffs Ignore Whitespace Patch

Changes to changes.

  8875   8875   2017-06-23 (TIP 472) Support 0d as prefix of decimal numbers (iyer,griffin)
  8876   8876   
  8877   8877   2017-08-31 (bug)[2a9465] http state 100 continue handling broken (oehlmann)
  8878   8878   
  8879   8879   2017-09-02 (bug)[0e4d88] replace command, delete trace kills namespace (porter)
  8880   8880   
  8881   8881   --- Released 8.7a1, September 8, 2017 --- http://core.tcl.tk/tcl/ for details
         8882  +
         8883  +2018-03-12 (TIP 490) add oo support for msgcat => msgcat 1.7.0 (oehlmann)
         8884  +
         8885  +2018-03-12 (TIP 499) custom locale preference list (nijtmans)
         8886  +=> msgcat 1.7.0

Changes to generic/tclBasic.c.

   815    815       TclInitDictCmd(interp);
   816    816       TclInitEncodingCmd(interp);
   817    817       TclInitFileCmd(interp);
   818    818       TclInitInfoCmd(interp);
   819    819       TclInitNamespaceCmd(interp);
   820    820       TclInitStringCmd(interp);
   821    821       TclInitPrefixCmd(interp);
          822  +    TclInitProcessCmd(interp);
   822    823   
   823    824       /*
   824    825        * Register "clock" subcommands. These *do* go through
   825    826        * Tcl_CreateObjCommand, since they aren't in the global namespace and
   826    827        * involve ensembles.
   827    828        */
   828    829   

Changes to generic/tclInt.h.

  4062   4062   
  4063   4063   MODULE_SCOPE int	TclCompareObjKeys(void *keyPtr, Tcl_HashEntry *hPtr);
  4064   4064   MODULE_SCOPE void	TclFreeObjEntry(Tcl_HashEntry *hPtr);
  4065   4065   MODULE_SCOPE TCL_HASH_TYPE TclHashObjKey(Tcl_HashTable *tablePtr, void *keyPtr);
  4066   4066   
  4067   4067   MODULE_SCOPE int	TclFullFinalizationRequested(void);
  4068   4068   
         4069  +/*
         4070  + * TIP #462.
         4071  + */
         4072  +
         4073  +/*
         4074  + * The following enum values give the status of a spawned process.
         4075  + */
         4076  +
         4077  +typedef enum TclProcessWaitStatus {
         4078  +    TCL_PROCESS_ERROR = -1,	/* Error waiting for process to exit */
         4079  +    TCL_PROCESS_UNCHANGED = 0,	/* No change since the last call. */
         4080  +    TCL_PROCESS_EXITED = 1,	/* Process has exited. */
         4081  +    TCL_PROCESS_SIGNALED = 2,	/* Child killed because of a signal. */
         4082  +    TCL_PROCESS_STOPPED = 3,	/* Child suspended because of a signal. */
         4083  +    TCL_PROCESS_UNKNOWN_STATUS = 4 
         4084  +				/* Child wait status didn't make sense. */
         4085  +} TclProcessWaitStatus;
         4086  +
         4087  +MODULE_SCOPE Tcl_Command TclInitProcessCmd(Tcl_Interp *interp);
         4088  +MODULE_SCOPE void	TclProcessCreated(Tcl_Pid pid);
         4089  +MODULE_SCOPE TclProcessWaitStatus TclProcessWait(Tcl_Pid pid, int options,
         4090  +			    int *codePtr, Tcl_Obj **msgObjPtr,
         4091  +			    Tcl_Obj **errorObjPtr);
         4092  +
  4069   4093   /*
  4070   4094    * Utility routines for encoding index values as integers. Used by both
  4071   4095    * some of the command compilers and by [lsort] and [lsearch].
  4072   4096    */
  4073   4097   
  4074   4098   MODULE_SCOPE int	TclIndexEncode(Tcl_Interp *interp, Tcl_Obj *objPtr,
  4075   4099   			    int before, int after, int *indexPtr);

Changes to generic/tclPipe.c.

   217    217    */
   218    218   
   219    219   void
   220    220   Tcl_ReapDetachedProcs(void)
   221    221   {
   222    222       register Detached *detPtr;
   223    223       Detached *nextPtr, *prevPtr;
   224         -    int status;
   225         -    Tcl_Pid pid;
          224  +    int status, code;
   226    225   
   227    226       Tcl_MutexLock(&pipeMutex);
   228    227       for (detPtr = detList, prevPtr = NULL; detPtr != NULL; ) {
   229         -	pid = Tcl_WaitPid(detPtr->pid, &status, WNOHANG);
   230         -	if ((pid == 0) || ((pid == (Tcl_Pid) -1) && (errno != ECHILD))) {
          228  +	status = TclProcessWait(detPtr->pid, WNOHANG, &code, NULL, NULL);
          229  +	if (status == TCL_PROCESS_UNCHANGED || (status == TCL_PROCESS_ERROR
          230  +		&& code != ECHILD)) {
   231    231   	    prevPtr = detPtr;
   232    232   	    detPtr = detPtr->nextPtr;
   233    233   	    continue;
   234    234   	}
   235    235   	nextPtr = detPtr->nextPtr;
   236    236   	if (prevPtr == NULL) {
   237    237   	    detList = detPtr->nextPtr;
................................................................................
   273    273       Tcl_Pid *pidPtr,		/* Array of process ids of children. */
   274    274       Tcl_Channel errorChan)	/* Channel for file containing stderr output
   275    275   				 * from pipeline. NULL means there isn't any
   276    276   				 * stderr output. */
   277    277   {
   278    278       int result = TCL_OK;
   279    279       int i, abnormalExit, anyErrorInfo;
   280         -    Tcl_Pid pid;
   281         -    int waitStatus;
   282         -    const char *msg;
   283         -    unsigned long resolvedPid;
          280  +    TclProcessWaitStatus waitStatus;
          281  +    int code;
          282  +    Tcl_Obj *msg, *error;
   284    283   
   285    284       abnormalExit = 0;
   286    285       for (i = 0; i < numPids; i++) {
   287         -	/*
   288         -	 * We need to get the resolved pid before we wait on it as the windows
   289         -	 * implementation of Tcl_WaitPid deletes the information such that any
   290         -	 * following calls to TclpGetPid fail.
   291         -	 */
   292         -
   293         -	resolvedPid = TclpGetPid(pidPtr[i]);
   294         -	pid = Tcl_WaitPid(pidPtr[i], &waitStatus, 0);
   295         -	if (pid == (Tcl_Pid) -1) {
          286  +	waitStatus = TclProcessWait(pidPtr[i], 0, &code, &msg, &error);
          287  +	if (waitStatus == TCL_PROCESS_ERROR) {
   296    288   	    result = TCL_ERROR;
   297    289   	    if (interp != NULL) {
   298         -		msg = Tcl_PosixError(interp);
   299         -		if (errno == ECHILD) {
   300         -		    /*
   301         -		     * This changeup in message suggested by Mark Diekhans to
   302         -		     * remind people that ECHILD errors can occur on some
   303         -		     * systems if SIGCHLD isn't in its default state.
   304         -		     */
   305         -
   306         -		    msg =
   307         -			"child process lost (is SIGCHLD ignored or trapped?)";
   308         -		}
   309         -		Tcl_SetObjResult(interp, Tcl_ObjPrintf(
   310         -			"error waiting for process to exit: %s", msg));
          290  +		Tcl_SetObjErrorCode(interp, error);
          291  +		Tcl_SetObjResult(interp, msg);
   311    292   	    }
          293  +	    Tcl_DecrRefCount(error);
          294  +	    Tcl_DecrRefCount(msg);
   312    295   	    continue;
   313    296   	}
   314    297   
   315    298   	/*
   316    299   	 * Create error messages for unusual process exits. An extra newline
   317    300   	 * gets appended to each error message, but it gets removed below (in
   318    301   	 * the same fashion that an extra newline in the command's output is
   319    302   	 * removed).
   320    303   	 */
   321    304   
   322         -	if (!WIFEXITED(waitStatus) || (WEXITSTATUS(waitStatus) != 0)) {
   323         -	    char msg1[TCL_INTEGER_SPACE], msg2[TCL_INTEGER_SPACE];
   324         -
          305  +	if (waitStatus != TCL_PROCESS_EXITED || code != 0) {
   325    306   	    result = TCL_ERROR;
   326         -	    sprintf(msg1, "%lu", resolvedPid);
   327         -	    if (WIFEXITED(waitStatus)) {
          307  +	    if (waitStatus == TCL_PROCESS_EXITED) {
   328    308   		if (interp != NULL) {
   329         -		    sprintf(msg2, "%u", WEXITSTATUS(waitStatus));
   330         -		    Tcl_SetErrorCode(interp, "CHILDSTATUS", msg1, msg2, NULL);
          309  +		    Tcl_SetObjErrorCode(interp, error);
   331    310   		}
   332    311   		abnormalExit = 1;
   333    312   	    } else if (interp != NULL) {
   334         -		const char *p;
   335         -
   336         -		if (WIFSIGNALED(waitStatus)) {
   337         -		    p = Tcl_SignalMsg(WTERMSIG(waitStatus));
   338         -		    Tcl_SetErrorCode(interp, "CHILDKILLED", msg1,
   339         -			    Tcl_SignalId(WTERMSIG(waitStatus)), p, NULL);
   340         -		    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
   341         -			    "child killed: %s\n", p));
   342         -		} else if (WIFSTOPPED(waitStatus)) {
   343         -		    p = Tcl_SignalMsg(WSTOPSIG(waitStatus));
   344         -		    Tcl_SetErrorCode(interp, "CHILDSUSP", msg1,
   345         -			    Tcl_SignalId(WSTOPSIG(waitStatus)), p, NULL);
   346         -		    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
   347         -			    "child suspended: %s\n", p));
   348         -		} else {
   349         -		    Tcl_SetObjResult(interp, Tcl_NewStringObj(
   350         -			    "child wait status didn't make sense\n", -1));
   351         -		    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC",
   352         -			    "ODDWAITRESULT", msg1, NULL);
   353         -		}
          313  +		Tcl_SetObjErrorCode(interp, error);
          314  +		Tcl_SetObjResult(interp, msg);
   354    315   	    }
          316  +	    Tcl_DecrRefCount(error);
          317  +	    Tcl_DecrRefCount(msg);
   355    318   	}
   356    319       }
   357    320   
   358    321       /*
   359    322        * Read the standard error file. If there's anything there, then return an
   360    323        * error and add the file's contents to the result string.
   361    324        */
................................................................................
   932    895   	if (result != TCL_OK) {
   933    896   	    goto error;
   934    897   	}
   935    898   	Tcl_DStringFree(&execBuffer);
   936    899   
   937    900   	pidPtr[numPids] = pid;
   938    901   	numPids++;
          902  +	TclProcessCreated(pid);
   939    903   
   940    904   	/*
   941    905   	 * Close off our copies of file descriptors that were set up for this
   942    906   	 * child, then set up the input for the next child.
   943    907   	 */
   944    908   
   945    909   	if ((curInFile != NULL) && (curInFile != inputFile)) {

Added generic/tclProcess.c.

            1  +/*
            2  + * tclProcess.c --
            3  + *
            4  + *	This file implements the "tcl::process" ensemble for subprocess 
            5  + *	management as defined by TIP #462.
            6  + *
            7  + * Copyright (c) 2017 Frederic Bonnet.
            8  + *
            9  + * See the file "license.terms" for information on usage and redistribution of
           10  + * this file, and for a DISCLAIMER OF ALL WARRANTIES.
           11  + */
           12  +
           13  +#include "tclInt.h"
           14  +
           15  +/*
           16  + * Autopurge flag. Process-global because of the way Tcl manages child 
           17  + * processes (see tclPipe.c).
           18  + */
           19  +
           20  +static int autopurge = 1;	/* Autopurge flag. */
           21  +
           22  +/*
           23  + * Hash tables that keeps track of all child process statuses. Keys are the 
           24  + * child process ids and resolved pids, values are (ProcessInfo *).
           25  + */
           26  +
           27  +typedef struct ProcessInfo {
           28  +    Tcl_Pid pid;		/* Process id. */
           29  +    int resolvedPid;		/* Resolved process id. */
           30  +    int purge;			/* Purge eventualy. */
           31  +    TclProcessWaitStatus status;/* Process status. */
           32  +    int code;			/* Error code, exit status or signal 
           33  +				   number. */
           34  +    Tcl_Obj *msg;		/* Error message. */
           35  +    Tcl_Obj *error;		/* Error code. */
           36  +} ProcessInfo;
           37  +static Tcl_HashTable infoTablePerPid;
           38  +static Tcl_HashTable infoTablePerResolvedPid;
           39  +static int infoTablesInitialized = 0;	/* 0 means not yet initialized. */
           40  +TCL_DECLARE_MUTEX(infoTablesMutex)
           41  +
           42  + /*
           43  + * Prototypes for functions defined later in this file:
           44  + */
           45  +
           46  +static void		InitProcessInfo(ProcessInfo *info, Tcl_Pid pid,
           47  +			    int resolvedPid);
           48  +static void		FreeProcessInfo(ProcessInfo *info);
           49  +static int		RefreshProcessInfo(ProcessInfo *info, int options);
           50  +static TclProcessWaitStatus WaitProcessStatus(Tcl_Pid pid, int resolvedPid, 
           51  +			    int options, int *codePtr, Tcl_Obj **msgPtr,
           52  +			    Tcl_Obj **errorObjPtr);
           53  +static Tcl_Obj *	BuildProcessStatusObj(ProcessInfo *info);
           54  +static int		ProcessListObjCmd(ClientData clientData,
           55  +			    Tcl_Interp *interp, int objc,
           56  +			    Tcl_Obj *const objv[]);
           57  +static int		ProcessStatusObjCmd(ClientData clientData,
           58  +			    Tcl_Interp *interp, int objc,
           59  +			    Tcl_Obj *const objv[]);
           60  +static int		ProcessPurgeObjCmd(ClientData clientData,
           61  +			    Tcl_Interp *interp, int objc,
           62  +			    Tcl_Obj *const objv[]);
           63  +static int		ProcessAutopurgeObjCmd(ClientData clientData,
           64  +			    Tcl_Interp *interp, int objc,
           65  +			    Tcl_Obj *const objv[]);
           66  +
           67  +/*
           68  + *----------------------------------------------------------------------
           69  + *
           70  + * InitProcessInfo --
           71  + *
           72  + *	Initializes the ProcessInfo structure.
           73  + *
           74  + * Results:
           75  + *	None.
           76  + *
           77  + * Side effects:
           78  + *	Memory written.
           79  + *
           80  + *----------------------------------------------------------------------
           81  + */
           82  +
           83  +void
           84  +InitProcessInfo(
           85  +    ProcessInfo *info,		/* Structure to initialize. */
           86  +    Tcl_Pid pid,		/* Process id. */
           87  +    int resolvedPid)		/* Resolved process id. */
           88  +{
           89  +    info->pid = pid;
           90  +    info->resolvedPid = resolvedPid;
           91  +    info->purge = 0;
           92  +    info->status = TCL_PROCESS_UNCHANGED;
           93  +    info->code = 0;
           94  +    info->msg = NULL;
           95  +    info->error = NULL;
           96  +}
           97  +
           98  +/*
           99  + *----------------------------------------------------------------------
          100  + *
          101  + * FreeProcessInfo --
          102  + *
          103  + *	Free the ProcessInfo structure.
          104  + *
          105  + * Results:
          106  + *	None.
          107  + *
          108  + * Side effects:
          109  + *	Memory deallocated, Tcl_Obj refcount decreased.
          110  + *
          111  + *----------------------------------------------------------------------
          112  + */
          113  +
          114  +void
          115  +FreeProcessInfo(
          116  +    ProcessInfo *info)		/* Structure to free. */
          117  +{
          118  +    /*
          119  +     * Free stored Tcl_Objs.
          120  +     */
          121  +
          122  +    if (info->msg) {
          123  +	Tcl_DecrRefCount(info->msg);
          124  +    }
          125  +    if (info->error) {
          126  +	Tcl_DecrRefCount(info->error);
          127  +    }
          128  +
          129  +    /*
          130  +     * Free allocated structure.
          131  +     */
          132  +
          133  +    ckfree(info);
          134  +}
          135  +
          136  +/*
          137  + *----------------------------------------------------------------------
          138  + *
          139  + * RefreshProcessInfo --
          140  + *
          141  + *	Refresh process info.
          142  + *
          143  + * Results:
          144  + *	Nonzero if state changed, else zero.
          145  + *
          146  + * Side effects:
          147  + *	May call WaitProcessStatus, which can block if WNOHANG option is set.
          148  + *
          149  + *----------------------------------------------------------------------
          150  + */
          151  +
          152  +int
          153  +RefreshProcessInfo(
          154  +    ProcessInfo *info,		/* Structure to refresh. */
          155  +    int options			/* Options passed to WaitProcessStatus. */
          156  +)
          157  +{
          158  +    if (info->status == TCL_PROCESS_UNCHANGED) {
          159  +	/*
          160  +	 * Refresh & store status.
          161  +	 */
          162  +
          163  +	info->status = WaitProcessStatus(info->pid, info->resolvedPid, 
          164  +		options, &info->code, &info->msg, &info->error);
          165  +	if (info->msg) Tcl_IncrRefCount(info->msg);
          166  +	if (info->error) Tcl_IncrRefCount(info->error);
          167  +	return (info->status != TCL_PROCESS_UNCHANGED);
          168  +    } else {
          169  +	/*
          170  +	 * No change.
          171  +	 */
          172  +
          173  +	return 0;
          174  +    }
          175  +}
          176  +
          177  +/*
          178  + *----------------------------------------------------------------------
          179  + *
          180  + * WaitProcessStatus --
          181  + *
          182  + *	Wait for process status to change.
          183  + *
          184  + * Results:
          185  + *	TclProcessWaitStatus enum value.
          186  + *
          187  + * Side effects:
          188  + *	May call WaitProcessStatus, which can block if WNOHANG option is set.
          189  + *
          190  + *----------------------------------------------------------------------
          191  + */
          192  +
          193  +TclProcessWaitStatus
          194  +WaitProcessStatus(
          195  +    Tcl_Pid pid,		/* Process id. */
          196  +    int resolvedPid,		/* Resolved process id. */
          197  +    int options,		/* Options passed to Tcl_WaitPid. */
          198  +    int *codePtr,		/* If non-NULL, will receive either:
          199  +				 *  - 0 for normal exit.
          200  +				 *  - errno in case of error.
          201  +				 *  - non-zero exit code for abormal exit.
          202  +				 *  - signal number if killed or suspended.
          203  +				 *  - Tcl_WaitPid status in all other cases.
          204  +				 */
          205  +    Tcl_Obj **msgObjPtr,	/* If non-NULL, will receive error message. */
          206  +    Tcl_Obj **errorObjPtr)	/* If non-NULL, will receive error code. */
          207  +{
          208  +    int waitStatus;
          209  +    Tcl_Obj *errorStrings[5];
          210  +    const char *msg;
          211  +
          212  +    pid = Tcl_WaitPid(pid, &waitStatus, options);
          213  +    if ((pid == 0)) {
          214  +	/*
          215  +	 * No change.
          216  +	 */
          217  +	
          218  +	return TCL_PROCESS_UNCHANGED;
          219  +    }
          220  +
          221  +    /*
          222  +     * Get process status.
          223  +     */
          224  +
          225  +    if (pid == (Tcl_Pid) -1) {
          226  +	/*
          227  +	 * POSIX errName msg
          228  +	 */
          229  +
          230  +	msg = Tcl_ErrnoMsg(errno);
          231  +	if (errno == ECHILD) {
          232  +	    /*
          233  +	     * This changeup in message suggested by Mark Diekhans to
          234  +	     * remind people that ECHILD errors can occur on some
          235  +	     * systems if SIGCHLD isn't in its default state.
          236  +	     */
          237  +
          238  +	    msg = "child process lost (is SIGCHLD ignored or trapped?)";
          239  +	}
          240  +	if (codePtr) *codePtr = errno;
          241  +	if (msgObjPtr) *msgObjPtr = Tcl_ObjPrintf(
          242  +		"error waiting for process to exit: %s", msg);
          243  +	if (errorObjPtr) {
          244  +	    errorStrings[0] = Tcl_NewStringObj("POSIX", -1);
          245  +	    errorStrings[1] = Tcl_NewStringObj(Tcl_ErrnoId(), -1);
          246  +	    errorStrings[2] = Tcl_NewStringObj(msg, -1);
          247  +	    *errorObjPtr = Tcl_NewListObj(3, errorStrings);
          248  +	}
          249  +	return TCL_PROCESS_ERROR;
          250  +    } else if (WIFEXITED(waitStatus)) {
          251  +	if (codePtr) *codePtr = WEXITSTATUS(waitStatus);
          252  +	if (!WEXITSTATUS(waitStatus)) {
          253  +	    /*
          254  +	     * Normal exit.
          255  +	     */
          256  +
          257  +	    if (msgObjPtr) *msgObjPtr = NULL;
          258  +	    if (errorObjPtr) *errorObjPtr = NULL;
          259  +	} else {
          260  +	    /*
          261  +	     * CHILDSTATUS pid code
          262  +	     *
          263  +	     * Child exited with a non-zero exit status.
          264  +	     */
          265  +
          266  +	    if (msgObjPtr) *msgObjPtr = Tcl_NewStringObj(
          267  +		    "child process exited abnormally", -1);
          268  +	    if (errorObjPtr) {
          269  +		errorStrings[0] = Tcl_NewStringObj("CHILDSTATUS", -1);
          270  +		errorStrings[1] = Tcl_NewIntObj(resolvedPid);
          271  +		errorStrings[2] = Tcl_NewIntObj(WEXITSTATUS(waitStatus));
          272  +		*errorObjPtr = Tcl_NewListObj(3, errorStrings);
          273  +	    }
          274  +	}
          275  +	return TCL_PROCESS_EXITED;
          276  +    } else if (WIFSIGNALED(waitStatus)) {
          277  +	/*
          278  +	 * CHILDKILLED pid sigName msg
          279  +	 *
          280  +	 * Child killed because of a signal.
          281  +	 */
          282  +
          283  +	msg = Tcl_SignalMsg(WTERMSIG(waitStatus));
          284  +	if (codePtr) *codePtr = WTERMSIG(waitStatus);
          285  +	if (msgObjPtr) *msgObjPtr = Tcl_ObjPrintf(
          286  +		"child killed: %s", msg);
          287  +	if (errorObjPtr) {
          288  +	    errorStrings[0] = Tcl_NewStringObj("CHILDKILLED", -1);
          289  +	    errorStrings[1] = Tcl_NewIntObj(resolvedPid);
          290  +	    errorStrings[2] = Tcl_NewStringObj(Tcl_SignalId(WTERMSIG(waitStatus)), -1);
          291  +	    errorStrings[3] = Tcl_NewStringObj(msg, -1);
          292  +	    *errorObjPtr = Tcl_NewListObj(4, errorStrings);
          293  +	}
          294  +	return TCL_PROCESS_SIGNALED;
          295  +    } else if (WIFSTOPPED(waitStatus)) {
          296  +	/*
          297  +	 * CHILDSUSP pid sigName msg
          298  +	 *
          299  +	 * Child suspended because of a signal.
          300  +	 */
          301  +
          302  +	msg = Tcl_SignalMsg(WSTOPSIG(waitStatus));
          303  +	if (codePtr) *codePtr = WSTOPSIG(waitStatus);
          304  +	if (msgObjPtr) *msgObjPtr = Tcl_ObjPrintf(
          305  +		"child suspended: %s", msg);
          306  +	if (errorObjPtr) {
          307  +	    errorStrings[0] = Tcl_NewStringObj("CHILDSUSP", -1);
          308  +	    errorStrings[1] = Tcl_NewIntObj(resolvedPid);
          309  +	    errorStrings[2] = Tcl_NewStringObj(Tcl_SignalId(WSTOPSIG(waitStatus)), -1);
          310  +	    errorStrings[3] = Tcl_NewStringObj(msg, -1);
          311  +	    *errorObjPtr = Tcl_NewListObj(4, errorStrings);
          312  +	}
          313  +	return TCL_PROCESS_STOPPED;
          314  +    } else {
          315  +	/*
          316  +	 * TCL OPERATION EXEC ODDWAITRESULT
          317  +	 *
          318  +	 * Child wait status didn't make sense.
          319  +	 */
          320  +
          321  +	if (codePtr) *codePtr = waitStatus;
          322  +	if (msgObjPtr) *msgObjPtr = Tcl_NewStringObj(
          323  +		"child wait status didn't make sense\n", -1);
          324  +	if (errorObjPtr) {
          325  +	    errorStrings[0] = Tcl_NewStringObj("TCL", -1);
          326  +	    errorStrings[1] = Tcl_NewStringObj("OPERATION", -1);
          327  +	    errorStrings[2] = Tcl_NewStringObj("EXEC", -1);
          328  +	    errorStrings[3] = Tcl_NewStringObj("ODDWAITRESULT", -1);
          329  +	    errorStrings[4] = Tcl_NewIntObj(resolvedPid);
          330  +	    *errorObjPtr = Tcl_NewListObj(5, errorStrings);
          331  +	}
          332  +	return TCL_PROCESS_UNKNOWN_STATUS;
          333  +    }
          334  +}
          335  +
          336  +
          337  +/*
          338  + *----------------------------------------------------------------------
          339  + *
          340  + * BuildProcessStatusObj --
          341  + *
          342  + *	Build a list object with process status. The first element is always
          343  + *	a standard Tcl return value, which can be either TCL_OK or TCL_ERROR.
          344  + *	In the latter case, the second element is the error message and the
          345  + *	third element is a Tcl error code (see tclvars).
          346  + *
          347  + * Results:
          348  + *	A list object.
          349  + *
          350  + * Side effects:
          351  + *	Tcl_Objs are created.
          352  + *
          353  + *----------------------------------------------------------------------
          354  + */
          355  +
          356  +Tcl_Obj *
          357  +BuildProcessStatusObj(
          358  +    ProcessInfo *info)
          359  +{
          360  +    Tcl_Obj *resultObjs[3];
          361  +
          362  +    if (info->status == TCL_PROCESS_UNCHANGED) {
          363  +	/*
          364  +	 * Process still running, return empty obj.
          365  +	 */
          366  +
          367  +	return Tcl_NewObj();
          368  +    }
          369  +    if (info->status == TCL_PROCESS_EXITED && info->code == 0) {
          370  +	/*
          371  +	 * Normal exit, return TCL_OK.
          372  +	 */
          373  +	
          374  +	return Tcl_NewIntObj(TCL_OK);
          375  +    }
          376  +
          377  +    /*
          378  +     * Abnormal exit, return {TCL_ERROR msg error}
          379  +     */
          380  +
          381  +    resultObjs[0] = Tcl_NewIntObj(TCL_ERROR);
          382  +    resultObjs[1] = info->msg;
          383  +    resultObjs[2] = info->error;
          384  +    return Tcl_NewListObj(3, resultObjs);
          385  +}
          386  +
          387  +/*----------------------------------------------------------------------
          388  + *
          389  + * ProcessListObjCmd --
          390  + *
          391  + *	This function implements the 'tcl::process list' Tcl command. 
          392  + *	Refer to the user documentation for details on what it does.
          393  + *
          394  + * Results:
          395  + *	Returns a standard Tcl result.
          396  + *
          397  + * Side effects:
          398  + *	Access to the internal structures is protected by infoTablesMutex.
          399  + *
          400  + *----------------------------------------------------------------------
          401  + */
          402  +
          403  +static int
          404  +ProcessListObjCmd(
          405  +    ClientData clientData,	/* Not used. */
          406  +    Tcl_Interp *interp,		/* Current interpreter. */
          407  +    int objc,			/* Number of arguments. */
          408  +    Tcl_Obj *const objv[])	/* Argument objects. */
          409  +{
          410  +    Tcl_Obj *list;
          411  +    Tcl_HashEntry *entry;
          412  +    Tcl_HashSearch search;
          413  +    ProcessInfo *info;
          414  +
          415  +    if (objc != 1) {
          416  +	Tcl_WrongNumArgs(interp, 1, objv, NULL);
          417  +	return TCL_ERROR;
          418  +    }
          419  +
          420  +    /*
          421  +     * Return the list of all chid process ids.
          422  +     */
          423  +
          424  +    list = Tcl_NewListObj(0, NULL);
          425  +    Tcl_MutexLock(&infoTablesMutex);
          426  +    for (entry = Tcl_FirstHashEntry(&infoTablePerResolvedPid, &search); 
          427  +	    entry != NULL; entry = Tcl_NextHashEntry(&search)) {
          428  +	info = (ProcessInfo *) Tcl_GetHashValue(entry);
          429  +	Tcl_ListObjAppendElement(interp, list, 
          430  +		Tcl_NewIntObj(info->resolvedPid));
          431  +    }
          432  +    Tcl_MutexUnlock(&infoTablesMutex);
          433  +    Tcl_SetObjResult(interp, list);
          434  +    return TCL_OK;
          435  +}
          436  +
          437  +/*----------------------------------------------------------------------
          438  + *
          439  + * ProcessStatusObjCmd --
          440  + *
          441  + *	This function implements the 'tcl::process status' Tcl command. 
          442  + *	Refer to the user documentation for details on what it does.
          443  + *
          444  + * Results:
          445  + *	Returns a standard Tcl result.
          446  + *
          447  + * Side effects:
          448  + *	Access to the internal structures is protected by infoTablesMutex.
          449  + *	Calls RefreshProcessInfo, which can block if -wait switch is given.
          450  + *
          451  + *----------------------------------------------------------------------
          452  + */
          453  +
          454  +static int
          455  +ProcessStatusObjCmd(
          456  +    ClientData clientData,	/* Not used. */
          457  +    Tcl_Interp *interp,		/* Current interpreter. */
          458  +    int objc,			/* Number of arguments. */
          459  +    Tcl_Obj *const objv[])	/* Argument objects. */
          460  +{
          461  +    Tcl_Obj *dict;
          462  +    int index, options = WNOHANG;
          463  +    Tcl_HashEntry *entry;
          464  +    Tcl_HashSearch search;
          465  +    ProcessInfo *info;
          466  +    int numPids;
          467  +    Tcl_Obj **pidObjs;
          468  +    int result;
          469  +    int i;
          470  +    int pid;
          471  +    Tcl_Obj *const *savedobjv = objv;
          472  +    static const char *const switches[] = {
          473  +	"-wait", "--", NULL
          474  +    };
          475  +    enum switches {
          476  +	STATUS_WAIT, STATUS_LAST
          477  +    };
          478  +
          479  +    while (objc > 1) {
          480  +	if (TclGetString(objv[1])[0] != '-') {
          481  +	    break;
          482  +	}
          483  +	if (Tcl_GetIndexFromObj(interp, objv[1], switches, "switches", 0,
          484  +		&index) != TCL_OK) {
          485  +	    return TCL_ERROR;
          486  +	}
          487  +	++objv; --objc;
          488  +	if (STATUS_WAIT == (enum switches) index) {
          489  +	    options = 0;
          490  +	} else {
          491  +	    break;
          492  +	}
          493  +    }
          494  +
          495  +    if (objc != 1 && objc != 2) {
          496  +	Tcl_WrongNumArgs(interp, 1, savedobjv, "?switches? ?pids?");
          497  +	return TCL_ERROR;
          498  +    }
          499  +
          500  +    if (objc == 1) {
          501  +	/*
          502  +	* Return a dict with all child process statuses.
          503  +	*/
          504  +
          505  +	dict = Tcl_NewDictObj();
          506  +	Tcl_MutexLock(&infoTablesMutex);
          507  +	for (entry = Tcl_FirstHashEntry(&infoTablePerResolvedPid, &search); 
          508  +		entry != NULL; entry = Tcl_NextHashEntry(&search)) {
          509  +	    info = (ProcessInfo *) Tcl_GetHashValue(entry);
          510  +	    RefreshProcessInfo(info, options);
          511  +
          512  +	    if (info->purge && autopurge) {
          513  +		/*
          514  +		 * Purge entry.
          515  +		 */
          516  +		
          517  +		Tcl_DeleteHashEntry(entry);
          518  +		entry = Tcl_FindHashEntry(&infoTablePerPid, info->pid);
          519  +		Tcl_DeleteHashEntry(entry);
          520  +		FreeProcessInfo(info);
          521  +	    } else {
          522  +		/*
          523  +		 * Add to result.
          524  +		 */
          525  +
          526  +		Tcl_DictObjPut(interp, dict, Tcl_NewIntObj(info->resolvedPid), 
          527  +			BuildProcessStatusObj(info));
          528  +	    }
          529  +	}
          530  +	Tcl_MutexUnlock(&infoTablesMutex);
          531  +    } else {
          532  +	/*
          533  +	 * Only return statuses of provided processes.
          534  +	 */
          535  +	
          536  +	result = Tcl_ListObjGetElements(interp, objv[1], &numPids, &pidObjs);
          537  +	if (result != TCL_OK) {
          538  +	    return result;
          539  +	}
          540  +	dict = Tcl_NewDictObj();
          541  +	Tcl_MutexLock(&infoTablesMutex);
          542  +	for (i = 0; i < numPids; i++) {
          543  +	    result = Tcl_GetIntFromObj(interp, pidObjs[i], (int *) &pid);
          544  +	    if (result != TCL_OK) {
          545  +		Tcl_MutexUnlock(&infoTablesMutex);
          546  +		Tcl_DecrRefCount(dict);
          547  +		return result;
          548  +	    }
          549  +
          550  +	    entry = Tcl_FindHashEntry(&infoTablePerResolvedPid, INT2PTR(pid));
          551  +	    if (!entry) {
          552  +		/*
          553  +		 * Skip unknown process.
          554  +		 */
          555  +		
          556  +		continue;
          557  +	    }
          558  +	    
          559  +	    info = (ProcessInfo *) Tcl_GetHashValue(entry);
          560  +	    RefreshProcessInfo(info, options);
          561  +
          562  +	    if (info->purge && autopurge) {
          563  +		/*
          564  +		 * Purge entry.
          565  +		 */
          566  +		
          567  +		Tcl_DeleteHashEntry(entry);
          568  +		entry = Tcl_FindHashEntry(&infoTablePerPid, info->pid);
          569  +		Tcl_DeleteHashEntry(entry);
          570  +		FreeProcessInfo(info);
          571  +	    } else {
          572  +		/*
          573  +		 * Add to result.
          574  +		 */
          575  +
          576  +		Tcl_DictObjPut(interp, dict, Tcl_NewIntObj(info->resolvedPid), 
          577  +			BuildProcessStatusObj(info));
          578  +	    }
          579  +	}
          580  +	Tcl_MutexUnlock(&infoTablesMutex);
          581  +    }
          582  +    Tcl_SetObjResult(interp, dict);
          583  +    return TCL_OK;
          584  +}
          585  +
          586  +/*----------------------------------------------------------------------
          587  + *
          588  + * ProcessPurgeObjCmd --
          589  + *
          590  + *	This function implements the 'tcl::process purge' Tcl command. 
          591  + *	Refer to the user documentation for details on what it does.
          592  + *
          593  + * Results:
          594  + *	Returns a standard Tcl result.
          595  + *
          596  + * Side effects:
          597  + *	Frees all ProcessInfo structures with their purge flag set.
          598  + *
          599  + *----------------------------------------------------------------------
          600  + */
          601  +
          602  +static int
          603  +ProcessPurgeObjCmd(
          604  +    ClientData clientData,	/* Not used. */
          605  +    Tcl_Interp *interp,		/* Current interpreter. */
          606  +    int objc,			/* Number of arguments. */
          607  +    Tcl_Obj *const objv[])	/* Argument objects. */
          608  +{
          609  +    Tcl_HashEntry *entry;
          610  +    Tcl_HashSearch search;
          611  +    ProcessInfo *info;
          612  +    int numPids;
          613  +    Tcl_Obj **pidObjs;
          614  +    int result;
          615  +    int i;
          616  +    int pid;
          617  +
          618  +    if (objc != 1 && objc != 2) {
          619  +	Tcl_WrongNumArgs(interp, 1, objv, "?pids?");
          620  +	return TCL_ERROR;
          621  +    }
          622  +
          623  +    /*
          624  +     * First reap detached procs so that their purge flag is up-to-date.
          625  +     */
          626  +
          627  +    Tcl_ReapDetachedProcs();
          628  +
          629  +    if (objc == 1) {
          630  +	/*
          631  +	 * Purge all terminated processes.
          632  +	 */
          633  +
          634  +	Tcl_MutexLock(&infoTablesMutex);
          635  +	for (entry = Tcl_FirstHashEntry(&infoTablePerResolvedPid, &search); 
          636  +		entry != NULL; entry = Tcl_NextHashEntry(&search)) {
          637  +	    info = (ProcessInfo *) Tcl_GetHashValue(entry);
          638  +	    if (info->purge) {
          639  +		Tcl_DeleteHashEntry(entry);
          640  +		entry = Tcl_FindHashEntry(&infoTablePerPid, info->pid);
          641  +		Tcl_DeleteHashEntry(entry);
          642  +		FreeProcessInfo(info);
          643  +	    }
          644  +	}
          645  +	Tcl_MutexUnlock(&infoTablesMutex);
          646  +    } else {
          647  +	/*
          648  +	 * Purge only provided processes.
          649  +	 */
          650  +	
          651  +	result = Tcl_ListObjGetElements(interp, objv[1], &numPids, &pidObjs);
          652  +	if (result != TCL_OK) {
          653  +	    return result;
          654  +	}
          655  +	Tcl_MutexLock(&infoTablesMutex);
          656  +	for (i = 0; i < numPids; i++) {
          657  +	    result = Tcl_GetIntFromObj(interp, pidObjs[i], (int *) &pid);
          658  +	    if (result != TCL_OK) {
          659  +		Tcl_MutexUnlock(&infoTablesMutex);
          660  +		return result;
          661  +	    }
          662  +
          663  +	    entry = Tcl_FindHashEntry(&infoTablePerResolvedPid, INT2PTR(pid));
          664  +	    if (!entry) {
          665  +		/*
          666  +		 * Skip unknown process.
          667  +		 */
          668  +		
          669  +		continue;
          670  +	    }
          671  +
          672  +	    info = (ProcessInfo *) Tcl_GetHashValue(entry);
          673  +	    if (info->purge) {
          674  +		Tcl_DeleteHashEntry(entry);
          675  +		entry = Tcl_FindHashEntry(&infoTablePerPid, info->pid);
          676  +		Tcl_DeleteHashEntry(entry);
          677  +		FreeProcessInfo(info);
          678  +	    }
          679  +	}
          680  +	Tcl_MutexUnlock(&infoTablesMutex);
          681  +    }
          682  +
          683  +    return TCL_OK;
          684  +}
          685  +
          686  +/*----------------------------------------------------------------------
          687  + *
          688  + * ProcessAutopurgeObjCmd --
          689  + *
          690  + *	This function implements the 'tcl::process autopurge' Tcl command. 
          691  + *	Refer to the user documentation for details on what it does.
          692  + *
          693  + * Results:
          694  + *	Returns a standard Tcl result.
          695  + *
          696  + * Side effects:
          697  + *	Alters detached process handling by Tcl_ReapDetachedProcs().
          698  + *
          699  + *----------------------------------------------------------------------
          700  + */
          701  +
          702  +static int
          703  +ProcessAutopurgeObjCmd(
          704  +    ClientData clientData,	/* Not used. */
          705  +    Tcl_Interp *interp,		/* Current interpreter. */
          706  +    int objc,			/* Number of arguments. */
          707  +    Tcl_Obj *const objv[])	/* Argument objects. */
          708  +{
          709  +    if (objc != 1 && objc != 2) {
          710  +	Tcl_WrongNumArgs(interp, 1, objv, "?flag?");
          711  +	return TCL_ERROR;
          712  +    }
          713  +
          714  +    if (objc == 2) {
          715  +	/*
          716  +	 * Set given value.
          717  +	 */
          718  +	
          719  +	int flag;
          720  +	int result = Tcl_GetBooleanFromObj(interp, objv[1], &flag);
          721  +	if (result != TCL_OK) {
          722  +	    return result;
          723  +	}
          724  +
          725  +	autopurge = !!flag;
          726  +    }
          727  +
          728  +    /* 
          729  +     * Return current value. 
          730  +     */
          731  +
          732  +    Tcl_SetObjResult(interp, Tcl_NewBooleanObj(autopurge));
          733  +    return TCL_OK;
          734  +}
          735  +
          736  +/*
          737  + *----------------------------------------------------------------------
          738  + *
          739  + * TclInitProcessCmd --
          740  + *
          741  + *	This procedure creates the "tcl::process" Tcl command. See the user
          742  + *	documentation for details on what it does.
          743  + *
          744  + * Results:
          745  + *	A standard Tcl result.
          746  + *
          747  + * Side effects:
          748  + *	See the user documentation.
          749  + *
          750  + *----------------------------------------------------------------------
          751  + */
          752  +
          753  +Tcl_Command
          754  +TclInitProcessCmd(
          755  +    Tcl_Interp *interp)		/* Current interpreter. */
          756  +{
          757  +    static const EnsembleImplMap processImplMap[] = {
          758  +	{"list", ProcessListObjCmd, TclCompileBasic0ArgCmd, NULL, NULL, 1},
          759  +	{"status", ProcessStatusObjCmd, TclCompileBasicMin0ArgCmd, NULL, NULL, 1},
          760  +	{"purge", ProcessPurgeObjCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 1},
          761  +	{"autopurge", ProcessAutopurgeObjCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 1},
          762  +	{NULL, NULL, NULL, NULL, NULL, 0}
          763  +    };
          764  +    Tcl_Command processCmd;
          765  +
          766  +    if (infoTablesInitialized == 0) {
          767  +	Tcl_MutexLock(&infoTablesMutex);
          768  +	if (infoTablesInitialized == 0) {
          769  +	    Tcl_InitHashTable(&infoTablePerPid, TCL_ONE_WORD_KEYS);
          770  +	    Tcl_InitHashTable(&infoTablePerResolvedPid, TCL_ONE_WORD_KEYS);
          771  +	    infoTablesInitialized = 1;
          772  +	}
          773  +	Tcl_MutexUnlock(&infoTablesMutex);
          774  +    }
          775  +
          776  +    processCmd = TclMakeEnsemble(interp, "::tcl::process", processImplMap);
          777  +    Tcl_Export(interp, Tcl_FindNamespace(interp, "::tcl", NULL, 0),
          778  +	    "process", 0);
          779  +    return processCmd;
          780  +}
          781  +
          782  +/*
          783  + *----------------------------------------------------------------------
          784  + *
          785  + * TclProcessCreated --
          786  + *
          787  + *	Called when a child process has been created by Tcl.
          788  + *
          789  + * Results:
          790  + *	None.
          791  + *
          792  + * Side effects:
          793  + *	Internal structures are updated with a new ProcessInfo.
          794  + *
          795  + *----------------------------------------------------------------------
          796  + */
          797  +
          798  +void
          799  +TclProcessCreated(
          800  +    Tcl_Pid pid)		/* Process id. */
          801  +{
          802  +    int resolvedPid;
          803  +    Tcl_HashEntry *entry, *entry2;
          804  +    int isNew;
          805  +    ProcessInfo *info;
          806  +
          807  +    /*
          808  +     * Get resolved pid first.
          809  +     */
          810  +
          811  +    resolvedPid = TclpGetPid(pid);
          812  +
          813  +    Tcl_MutexLock(&infoTablesMutex);
          814  +
          815  +    /*
          816  +     * Create entry in pid table.
          817  +     */
          818  +
          819  +    entry = Tcl_CreateHashEntry(&infoTablePerPid, pid, &isNew);
          820  +    if (!isNew) {
          821  +	/*
          822  +	 * Pid was reused, free old info and reuse structure.
          823  +	 */
          824  +	
          825  +	info = (ProcessInfo *) Tcl_GetHashValue(entry);
          826  +	entry2 = Tcl_FindHashEntry(&infoTablePerResolvedPid, 
          827  +		INT2PTR(resolvedPid));
          828  +	if (entry2) Tcl_DeleteHashEntry(entry2);
          829  +	FreeProcessInfo(info);
          830  +    }
          831  +
          832  +    /*
          833  +     * Allocate and initialize info structure.
          834  +     */
          835  +
          836  +    info = (ProcessInfo *) ckalloc(sizeof(ProcessInfo));
          837  +    InitProcessInfo(info, pid, resolvedPid);
          838  +
          839  +    /*
          840  +     * Add entry to tables.
          841  +     */
          842  +
          843  +    Tcl_SetHashValue(entry, info);
          844  +    entry = Tcl_CreateHashEntry(&infoTablePerResolvedPid, INT2PTR(resolvedPid),
          845  +	    &isNew);
          846  +    Tcl_SetHashValue(entry, info);
          847  +
          848  +    Tcl_MutexUnlock(&infoTablesMutex);
          849  +}
          850  +
          851  +/*
          852  + *----------------------------------------------------------------------
          853  + *
          854  + * TclProcessWait --
          855  + *
          856  + *	Wait for process status to change.
          857  + *
          858  + * Results:
          859  + *	TclProcessWaitStatus enum value.
          860  + *
          861  + * Side effects:
          862  + *	Completed process info structures are purged immediately (autopurge on)
          863  + *	or eventually (autopurge off).
          864  + *
          865  + *----------------------------------------------------------------------
          866  + */
          867  +
          868  +TclProcessWaitStatus
          869  +TclProcessWait(
          870  +    Tcl_Pid pid,		/* Process id. */
          871  +    int options,		/* Options passed to WaitProcessStatus. */
          872  +    int *codePtr,		/* If non-NULL, will receive either:
          873  +				 *  - 0 for normal exit.
          874  +				 *  - errno in case of error.
          875  +				 *  - non-zero exit code for abormal exit.
          876  +				 *  - signal number if killed or suspended.
          877  +				 *  - Tcl_WaitPid status in all other cases.
          878  +				 */
          879  +    Tcl_Obj **msgObjPtr,	/* If non-NULL, will receive error message. */
          880  +    Tcl_Obj **errorObjPtr)	/* If non-NULL, will receive error code. */
          881  +{
          882  +    Tcl_HashEntry *entry;
          883  +    ProcessInfo *info;
          884  +    TclProcessWaitStatus result;
          885  +
          886  +    /*
          887  +     * First search for pid in table.
          888  +     */
          889  +
          890  +    entry = Tcl_FindHashEntry(&infoTablePerPid, pid);
          891  +    if (!entry) {
          892  +	/*
          893  +	 * Unknown process, just call WaitProcessStatus and return.
          894  +	 */
          895  +	
          896  +	result = WaitProcessStatus(pid, TclpGetPid(pid), options, codePtr, 
          897  +		msgObjPtr, errorObjPtr);
          898  +	if (msgObjPtr && *msgObjPtr) Tcl_IncrRefCount(*msgObjPtr);
          899  +	if (errorObjPtr && *errorObjPtr) Tcl_IncrRefCount(*errorObjPtr);
          900  +	return result;
          901  +    }
          902  +
          903  +    info = (ProcessInfo *) Tcl_GetHashValue(entry);
          904  +    if (info->purge) {
          905  +	/*
          906  +	 * Process has completed but TclProcessWait has already been called,
          907  +	 * so report no change.
          908  +	 */
          909  +	
          910  +	return TCL_PROCESS_UNCHANGED;
          911  +    }
          912  +
          913  +    RefreshProcessInfo(info, options);
          914  +    if (info->status == TCL_PROCESS_UNCHANGED) {
          915  +	/*
          916  +	 * No change, stop there.
          917  +	 */
          918  +	
          919  +	return TCL_PROCESS_UNCHANGED;
          920  +    }
          921  +
          922  +    /*
          923  +     * Set return values.
          924  +     */
          925  +
          926  +    result = info->status;
          927  +    if (codePtr) *codePtr = info->code;
          928  +    if (msgObjPtr) *msgObjPtr = info->msg;
          929  +    if (errorObjPtr) *errorObjPtr = info->error;
          930  +    if (msgObjPtr && *msgObjPtr) Tcl_IncrRefCount(*msgObjPtr);
          931  +    if (errorObjPtr && *errorObjPtr) Tcl_IncrRefCount(*errorObjPtr);
          932  +
          933  +    if (autopurge) {
          934  +	/*
          935  +	 * Purge now.
          936  +	 */
          937  +
          938  +	Tcl_DeleteHashEntry(entry);
          939  +	entry = Tcl_FindHashEntry(&infoTablePerResolvedPid, 
          940  +		INT2PTR(info->resolvedPid));
          941  +	Tcl_DeleteHashEntry(entry);
          942  +	FreeProcessInfo(info);
          943  +    } else {
          944  +	/*
          945  +	 * Eventually purge. Subsequent calls will return
          946  +	 * TCL_PROCESS_UNCHANGED.
          947  +	 */
          948  +
          949  +	info->purge = 1;
          950  +    }
          951  +    return result;
          952  +}

Changes to library/msgcat/msgcat.tcl.

     7      7   # Copyright (c) 2010-2015 by Harald Oehlmann.
     8      8   # Copyright (c) 1998-2000 by Ajuba Solutions.
     9      9   # Copyright (c) 1998 by Mark Harrison.
    10     10   #
    11     11   # See the file "license.terms" for information on usage and redistribution
    12     12   # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
    13     13   
    14         -package require Tcl 8.5-
           14  +package require Tcl 8.6-
    15     15   # When the version number changes, be sure to update the pkgIndex.tcl file,
    16     16   # and the installation directory in the Makefiles.
    17         -package provide msgcat 1.6.1
           17  +package provide msgcat 1.7.0
    18     18   
    19     19   namespace eval msgcat {
    20         -    namespace export mc mcexists mcload mclocale mcmax mcmset mcpreferences mcset\
           20  +    namespace export mc mcn mcexists mcload mclocale mcmax\
           21  +	    mcmset mcpreferences mcset\
    21     22               mcunknown mcflset mcflmset mcloadedlocales mcforgetpackage\
    22         -	    mcpackageconfig mcpackagelocale
           23  +	    mcpackagenamespaceget mcpackageconfig mcpackagelocale mcutil
    23     24   
    24     25       # Records the list of locales to search
    25     26       variable Loclist {}
    26     27   
    27     28       # List of currently loaded locales
    28     29       variable LoadedLocales {}
    29     30   
................................................................................
    37     38   	    unknowncmd {} loadedlocales {} loclist {}]
    38     39   
    39     40       # Records the mapping between source strings and translated strings.  The
    40     41       # dict key is of the form "<namespace> <locale> <src>", where locale and
    41     42       # namespace should be themselves dict values and the value is
    42     43       # the translated string.
    43     44       variable Msgs [dict create]
           45  +}
    44     46   
           47  +# create ensemble namespace for mcutil command
           48  +namespace eval msgcat::mcutil {
           49  +    namespace export getsystemlocale getpreferences
           50  +    namespace ensemble create -prefix 0
           51  +    
    45     52       # Map of language codes used in Windows registry to those of ISO-639
    46     53       if {[info sharedlibextension] eq ".dll"} {
    47     54   	variable WinRegToISO639 [dict create  {*}{
    48     55   	    01 ar 0401 ar_SA 0801 ar_IQ 0c01 ar_EG 1001 ar_LY 1401 ar_DZ
    49     56   		  1801 ar_MA 1c01 ar_TN 2001 ar_OM 2401 ar_YE 2801 ar_SY
    50     57   		  2c01 ar_JO 3001 ar_LB 3401 ar_KW 3801 ar_AE 3c01 ar_BH
    51     58   		  4001 ar_QA
................................................................................
   188    195   #	src	The string to translate.
   189    196   #	args	Args to pass to the format command
   190    197   #
   191    198   # Results:
   192    199   #	Returns the translated string.  Propagates errors thrown by the
   193    200   #	format command.
   194    201   
   195         -proc msgcat::mc {src args} {
   196         -    # this may be replaced by:
   197         -    # return [mcget -namespace [uplevel 1 [list ::namespace current]] --\
   198         -    #	    $src {*}$args]
          202  +proc msgcat::mc {args} {
          203  +    tailcall mcn [PackageNamespaceGet] {*}$args
          204  +}
          205  +
          206  +# msgcat::mcn --
          207  +#
          208  +#	Find the translation for the given string based on the current
          209  +#	locale setting. Check the passed namespace first, then look in each
          210  +#	parent namespace until the source is found.  If additional args are
          211  +#	specified, use the format command to work them into the traslated
          212  +#	string.
          213  +#	If no catalog item is found, mcunknown is called in the caller frame
          214  +#	and its result is returned.
          215  +#
          216  +# Arguments:
          217  +#	ns	Package namespace of the translation
          218  +#	src	The string to translate.
          219  +#	args	Args to pass to the format command
          220  +#
          221  +# Results:
          222  +#	Returns the translated string.  Propagates errors thrown by the
          223  +#	format command.
          224  +
          225  +proc msgcat::mcn {ns src args} {
   199    226   
   200    227       # Check for the src in each namespace starting from the local and
   201    228       # ending in the global.
   202    229   
   203    230       variable Msgs
   204    231       variable Loclist
   205    232   
   206         -    set ns [uplevel 1 [list ::namespace current]]
   207    233       set loclist [PackagePreferences $ns]
   208    234   
   209    235       set nscur $ns
   210    236       while {$nscur != ""} {
   211    237   	foreach loc $loclist {
   212    238   	    if {[dict exists $Msgs $nscur $loc $src]} {
   213    239   		return [DefaultUnknown "" [dict get $Msgs $nscur $loc $src]\
................................................................................
   215    241   	    }
   216    242   	}
   217    243   	set nscur [namespace parent $nscur]
   218    244       }
   219    245       # call package local or default unknown command
   220    246       set args [linsert $args 0 [lindex $loclist 0] $src]
   221    247       switch -exact -- [Invoke unknowncmd $args $ns result 1] {
   222         -	0 { return [uplevel 1 [linsert $args 0 [namespace origin mcunknown]]] }
          248  +	0 { tailcall mcunknown {*}$args }
   223    249   	1 { return [DefaultUnknown {*}$args] }
   224    250   	default { return $result }
   225    251       }
   226    252   }
   227    253   
   228    254   # msgcat::mcexists --
   229    255   #
................................................................................
   241    267   
   242    268   proc msgcat::mcexists {args} {
   243    269   
   244    270       variable Msgs
   245    271       variable Loclist
   246    272       variable PackageConfig
   247    273   
   248         -    set ns [uplevel 1 [list ::namespace current]]
   249         -    set loclist [PackagePreferences $ns]
   250         -
   251    274       while {[llength $args] != 1} {
   252    275   	set args [lassign $args option]
   253    276   	switch -glob -- $option {
   254         -	    -exactnamespace { set exactnamespace 1 }
   255         -	    -exactlocale { set loclist [lrange $loclist 0 0] }
          277  +	    -exactnamespace - -exactlocale { set $option 1 }
          278  +	    -namespace {
          279  +		if {[llength $args] < 2} {
          280  +		    return -code error\
          281  +			    "Argument missing for switch \"-namespace\""
          282  +		}
          283  +		set args [lassign $args ns]
          284  +	    }
   256    285   	    -* { return -code error "unknown option \"$option\"" }
   257    286   	    default {
   258    287   		return -code error "wrong # args: should be\
   259    288   			\"[lindex [info level 0] 0] ?-exactnamespace?\
   260         -			?-exactlocale? src\""
          289  +			?-exactlocale? ?-namespace ns? src\""
   261    290   	    }
   262    291   	}
   263    292       }
   264    293       set src [lindex $args 0]
          294  +    
          295  +    if {![info exists ns]} { set ns [PackageNamespaceGet] }
          296  +
          297  +    set loclist [PackagePreferences $ns]
          298  +    if {[info exists -exactlocale]} { set loclist [lrange $loclist 0 0] }
   265    299   
   266    300       while {$ns ne ""} {
   267    301   	foreach loc $loclist {
   268    302   	    if {[dict exists $Msgs $ns $loc $src]} {
   269    303   		return 1
   270    304   	    }
   271    305   	}
   272         -	if {[info exists exactnamespace]} {return 0}
          306  +	if {[info exists -exactnamespace]} {return 0}
   273    307   	set ns [namespace parent $ns]
   274    308       }
   275    309       return 0
   276    310   }
   277    311   
   278    312   # msgcat::mclocale --
   279    313   #
................................................................................
   299    333   
   300    334       if {$len == 1} {
   301    335   	set newLocale [string tolower [lindex $args 0]]
   302    336   	if {$newLocale ne [file tail $newLocale]} {
   303    337   	    return -code error "invalid newLocale value \"$newLocale\":\
   304    338   		    could be path to unsafe code."
   305    339   	}
   306         -	if {[lindex $Loclist 0] ne $newLocale} {
   307         -	    set Loclist [GetPreferences $newLocale]
   308         -
   309         -	    # locale not loaded jet
   310         -	    LoadAll $Loclist
   311         -	    # Invoke callback
   312         -	    Invoke changecmd $Loclist
   313         -	}
          340  +	mcpreferences {*}[mcutil getpreferences $newLocale]
   314    341       }
   315    342       return [lindex $Loclist 0]
   316    343   }
   317    344   
   318         -# msgcat::GetPreferences --
          345  +# msgcat::mcutil::getpreferences --
   319    346   #
   320    347   #	Get list of locales from a locale.
   321    348   #	The first element is always the lowercase locale.
   322    349   #	Other elements have one component separated by "_" less.
   323    350   #	Multiple "_" are seen as one separator: de__ch_spec de__ch de {}
          351  +#
          352  +#	This method is part of the ensemble mcutil
   324    353   #
   325    354   # Arguments:
   326    355   #	Locale.
   327    356   #
   328    357   # Results:
   329    358   #	Locale list
   330    359   
   331         -proc msgcat::GetPreferences {locale} {
          360  +proc msgcat::mcutil::getpreferences {locale} {
   332    361       set locale [string tolower $locale]
   333    362       set loclist [list $locale]
   334    363       while {-1 !=[set pos [string last "_" $locale]]} {
   335    364   	set locale [string range $locale 0 $pos-1]
   336    365   	if { "_" ne [string index $locale end] } {
   337    366   	    lappend loclist $locale
   338    367   	}
................................................................................
   345    374   
   346    375   # msgcat::mcpreferences --
   347    376   #
   348    377   #	Fetch the list of locales used to look up strings, ordered from
   349    378   #	most preferred to least preferred.
   350    379   #
   351    380   # Arguments:
   352         -#	None.
          381  +#	New location list
   353    382   #
   354    383   # Results:
   355    384   #	Returns an ordered list of the locales preferred by the user.
   356    385   
   357         -proc msgcat::mcpreferences {} {
          386  +proc msgcat::mcpreferences {args} {
   358    387       variable Loclist
          388  +
          389  +    if {[llength $args] > 0} {
          390  +	# args is the new loclist
          391  +	if {![ListEqualString $args $Loclist]} {
          392  +	    set Loclist $args
          393  +
          394  +	    # locale not loaded jet
          395  +	    LoadAll $Loclist
          396  +	    # Invoke callback
          397  +	    Invoke changecmd $Loclist
          398  +	}
          399  +    }
   359    400       return $Loclist
   360    401   }
          402  +
          403  +# msgcat::ListStringEqual --
          404  +#
          405  +#	Compare two strings for equal string contents
          406  +#
          407  +# Arguments:
          408  +#	list1		first list
          409  +#	list2		second list
          410  +#
          411  +# Results:
          412  +#	1 if lists of strings are identical, 0 otherwise
          413  +
          414  +proc msgcat::ListEqualString {list1 list2} {
          415  +    if {[llength $list1] != [llength $list2]} {
          416  +	return 0
          417  +    }
          418  +    foreach item1 $list1 item2 $list2 {
          419  +	if {$item1 ne $item2} {
          420  +	    return 0
          421  +	}
          422  +    }
          423  +    return 1
          424  +}
   361    425   
   362    426   # msgcat::mcloadedlocales --
   363    427   #
   364    428   #	Get or change the list of currently loaded default locales
   365    429   #
   366    430   #	The following subcommands are available:
   367    431   #	loaded
................................................................................
   438    502   # Arguments:
   439    503   #	subcommand		see list above
   440    504   #	locale			package locale (only set subcommand)
   441    505   #
   442    506   # Results:
   443    507   #	Empty string, if not stated differently for the subcommand
   444    508   
   445         -proc msgcat::mcpackagelocale {subcommand {locale ""}} {
          509  +proc msgcat::mcpackagelocale {subcommand args} {
   446    510       # todo: implement using an ensemble
   447    511       variable Loclist
   448    512       variable LoadedLocales
   449    513       variable Msgs
   450    514       variable PackageConfig
   451    515       # Check option
   452    516       # check if required item is exactly provided
   453         -    if {[llength [info level 0]] == 2} {
   454         -	# locale not given
   455         -	unset locale
   456         -    } else {
   457         -	# locale given
   458         -	if {$subcommand in
   459         -		{"get" "isset" "unset" "preferences" "loaded" "clear"} } {
   460         -	    return -code error "wrong # args: should be\
   461         -		    \"[lrange [info level 0] 0 1]\""
   462         -	}
   463         -        set locale [string tolower $locale]
          517  +    if {    [llength $args] > 0
          518  +	    && $subcommand in {"get" "isset" "unset" "loaded" "clear"} } {
          519  +	return -code error "wrong # args: should be\
          520  +		\"[lrange [info level 0] 0 1]\""
   464    521       }
   465         -    set ns [uplevel 1 {::namespace current}]
          522  +    set ns [PackageNamespaceGet]
   466    523   
   467    524       switch -exact -- $subcommand {
   468    525   	get { return [lindex [PackagePreferences $ns] 0] }
   469         -	preferences { return [PackagePreferences $ns] }
   470    526   	loaded { return [PackageLocales $ns] }
   471         -	present { return [expr {$locale in [PackageLocales $ns]} ]}
          527  +	present {
          528  +	    if {[llength $args] != 1} {
          529  +		return -code error "wrong # args: should be\
          530  +			\"[lrange [info level 0] 0 1] locale\""
          531  +	    }
          532  +	    return [expr {[string tolower [lindex $args 0]]
          533  +		    in [PackageLocales $ns]} ]
          534  +	}
   472    535   	isset { return [dict exists $PackageConfig loclist $ns] }
   473         -	set { # set a package locale or add a package locale
          536  +	set - preferences {
          537  +	    # set a package locale or add a package locale
          538  +	    set fSet [expr {$subcommand eq "set"}]
          539  +	    
          540  +	    # Check parameter
          541  +	    if {$fSet && 1 < [llength $args] } {
          542  +		return -code error "wrong # args: should be\
          543  +			\"[lrange [info level 0] 0 1] ?locale?\""
          544  +	    }
          545  +
          546  +	    # > Return preferences if no parameter
          547  +	    if {!$fSet && 0 == [llength $args] } {
          548  +		return [PackagePreferences $ns]
          549  +	    }
   474    550   
   475    551   	    # Copy the default locale if no package locale set so far
   476    552   	    if {![dict exists $PackageConfig loclist $ns]} {
   477    553   		dict set PackageConfig loclist $ns $Loclist
   478    554   		dict set PackageConfig loadedlocales $ns $LoadedLocales
   479    555   	    }
   480    556   
   481         -	    # Check if changed
   482         -	    set loclist [dict get $PackageConfig loclist $ns]
   483         -	    if {! [info exists locale] || $locale eq [lindex $loclist 0] } {
   484         -		return [lindex $loclist 0]
          557  +	    # No argument for set: return current package locale
          558  +	    # The difference to no argument and subcommand "preferences" is,
          559  +	    # that "preferences" does not set the package locale property.
          560  +	    # This case is processed above, so no check for fSet here
          561  +	    if { 0 == [llength $args] } {
          562  +		return [lindex [dict get $PackageConfig loclist $ns] 0]
          563  +	    }
          564  +
          565  +	    # Get new loclist
          566  +	    if {$fSet} {
          567  +		set loclist [mcutil getpreferences [lindex $args 0]]
          568  +	    } else {
          569  +		set loclist $args
          570  +	    }
          571  +
          572  +	    # Check if not changed to return imediately
          573  +	    if {    [ListEqualString $loclist\
          574  +			[dict get $PackageConfig loclist $ns]] } {
          575  +		if {$fSet} {
          576  +		    return [lindex $loclist 0]
          577  +		}
          578  +		return $loclist
   485    579   	    }
   486    580   
   487    581   	    # Change loclist
   488         -	    set loclist [GetPreferences $locale]
   489         -	    set locale [lindex $loclist 0]
   490    582   	    dict set PackageConfig loclist $ns $loclist
   491    583   
   492    584   	    # load eventual missing locales
   493    585   	    set loadedLocales [dict get $PackageConfig loadedlocales $ns]
   494         -	    if {$locale in $loadedLocales} { return $locale }
   495    586   	    set loadLocales [ListComplement $loadedLocales $loclist]
   496    587   	    dict set PackageConfig loadedlocales $ns\
   497    588   		    [concat $loadedLocales $loadLocales]
   498    589   	    Load $ns $loadLocales
   499         -	    return $locale
          590  +	    if {$fSet} {
          591  +		return [lindex $loclist 0]
          592  +	    }
          593  +	    return $loclist
   500    594   	}
   501    595   	clear { # Remove all locales not contained in Loclist
   502    596   	    if {![dict exists $PackageConfig loclist $ns]} {
   503    597   		return -code error "clear only when package locale set"
   504    598   	    }
   505    599   	    set loclist [dict get $PackageConfig loclist $ns]
   506    600   	    dict set PackageConfig loadedlocales $ns $loclist
................................................................................
   547    641   #	Remove any data of the calling package from msgcat
   548    642   #
   549    643   
   550    644   proc msgcat::mcforgetpackage {} {
   551    645       # todo: this may be implemented using an ensemble
   552    646       variable PackageConfig
   553    647       variable Msgs
   554         -    set ns [uplevel 1 {::namespace current}]
          648  +    set ns [PackageNamespaceGet]
   555    649       # Remove MC items
   556    650       dict unset Msgs $ns
   557    651       # Remove config items
   558    652       foreach key [dict keys $PackageConfig] {
   559    653   	dict unset PackageConfig $key $ns
   560    654       }
   561    655       return
   562    656   }
          657  +
          658  +# msgcat::mcgetmynamespace --
          659  +#
          660  +#	Return the package namespace of the caller
          661  +#	This consideres to be called from a class or object.
          662  +
          663  +proc msgcat::mcpackagenamespaceget {} {
          664  +    return [PackageNamespaceGet]
          665  +}
   563    666   
   564    667   # msgcat::mcpackageconfig --
   565    668   #
   566    669   #	Get or modify the per caller namespace (e.g. packages) config options.
   567    670   #
   568    671   #	Available subcommands are:
   569    672   #
................................................................................
   612    715   #
   613    716   # Results:
   614    717   #	Depends on the subcommand and option and is described there
   615    718   
   616    719   proc msgcat::mcpackageconfig {subcommand option {value ""}} {
   617    720       variable PackageConfig
   618    721       # get namespace
   619         -    set ns [uplevel 1 {::namespace current}]
          722  +    set ns [PackageNamespaceGet]
   620    723   
   621    724       if {$option ni {"mcfolder" "loadcmd" "changecmd" "unknowncmd"}} {
   622    725   	return -code error "bad option \"$option\": must be mcfolder, loadcmd,\
   623    726   		changecmd, or unknowncmd"
   624    727       }
   625    728   
   626    729       # check if value argument is exactly provided
................................................................................
   752    855   # Arguments:
   753    856   #	langdir		The directory to search.
   754    857   #
   755    858   # Results:
   756    859   #	Returns the number of message catalogs that were loaded.
   757    860   
   758    861   proc msgcat::mcload {langdir} {
   759         -    return [uplevel 1 [list\
   760         -	    [namespace origin mcpackageconfig] set mcfolder $langdir]]
          862  +    tailcall mcpackageconfig set mcfolder $langdir
   761    863   }
   762    864   
   763    865   # msgcat::LoadAll --
   764    866   #
   765    867   #	Load a list of locales for all packages not having a package locale
   766    868   #	list.
   767    869   #
................................................................................
   919   1021   
   920   1022   proc msgcat::mcset {locale src {dest ""}} {
   921   1023       variable Msgs
   922   1024       if {[llength [info level 0]] == 3} { ;# dest not specified
   923   1025   	set dest $src
   924   1026       }
   925   1027   
   926         -    set ns [uplevel 1 [list ::namespace current]]
         1028  +    set ns [PackageNamespaceGet]
   927   1029   
   928   1030       set locale [string tolower $locale]
   929   1031   
   930   1032       dict set Msgs $ns $locale $src $dest
   931   1033       return $dest
   932   1034   }
   933   1035   
................................................................................
   947   1049       variable FileLocale
   948   1050       variable Msgs
   949   1051   
   950   1052       if {![info exists FileLocale]} {
   951   1053   	return -code error "must only be used inside a message catalog loaded\
   952   1054   		with ::msgcat::mcload"
   953   1055       }
   954         -    return [uplevel 1 [list [namespace origin mcset] $FileLocale $src $dest]]
         1056  +    tailcall mcset $FileLocale $src $dest
   955   1057   }
   956   1058   
   957   1059   # msgcat::mcmset --
   958   1060   #
   959   1061   #	Set the translation for multiple strings in a specified locale.
   960   1062   #
   961   1063   # Arguments:
................................................................................
   971   1073       set length [llength $pairs]
   972   1074       if {$length % 2} {
   973   1075   	return -code error "bad translation list:\
   974   1076   		should be \"[lindex [info level 0] 0] locale {src dest ...}\""
   975   1077       }
   976   1078   
   977   1079       set locale [string tolower $locale]
   978         -    set ns [uplevel 1 [list ::namespace current]]
         1080  +    set ns [PackageNamespaceGet]
   979   1081   
   980   1082       foreach {src dest} $pairs {
   981   1083   	dict set Msgs $ns $locale $src $dest
   982   1084       }
   983   1085   
   984   1086       return [expr {$length / 2}]
   985   1087   }
................................................................................
   998   1100       variable FileLocale
   999   1101       variable Msgs
  1000   1102   
  1001   1103       if {![info exists FileLocale]} {
  1002   1104   	return -code error "must only be used inside a message catalog loaded\
  1003   1105   		with ::msgcat::mcload"
  1004   1106       }
  1005         -    return [uplevel 1 [list [namespace origin mcmset] $FileLocale $pairs]]
         1107  +    tailcal mcmset $FileLocale $pairs
  1006   1108   }
  1007   1109   
  1008   1110   # msgcat::mcunknown --
  1009   1111   #
  1010   1112   #	This routine is called by msgcat::mc if a translation cannot
  1011   1113   #	be found for a string and no unknowncmd is set for the current
  1012   1114   #	package. This routine is intended to be replaced
................................................................................
  1020   1122   #	src		The string to be translated.
  1021   1123   #	args		Args to pass to the format command
  1022   1124   #
  1023   1125   # Results:
  1024   1126   #	Returns the translated value.
  1025   1127   
  1026   1128   proc msgcat::mcunknown {args} {
  1027         -    return [uplevel 1 [list [namespace origin DefaultUnknown] {*}$args]]
         1129  +    tailcall DefaultUnknown {*}$args
  1028   1130   }
  1029   1131   
  1030   1132   # msgcat::DefaultUnknown --
  1031   1133   #
  1032   1134   #	This routine is called by msgcat::mc if a translation cannot
  1033   1135   #	be found for a string in the following circumstances:
  1034   1136   #	- Default global handler, if mcunknown is not redefined.
................................................................................
  1063   1165   #	args	strings to translate.
  1064   1166   #
  1065   1167   # Results:
  1066   1168   #	Returns the length of the longest translated string.
  1067   1169   
  1068   1170   proc msgcat::mcmax {args} {
  1069   1171       set max 0
         1172  +    set ns [PackageNamespaceGet]
  1070   1173       foreach string $args {
  1071         -	set translated [uplevel 1 [list [namespace origin mc] $string]]
         1174  +	set translated [uplevel 1 [list [namespace origin mcn] $ns $string]]
  1072   1175   	set len [string length $translated]
  1073   1176   	if {$len>$max} {
  1074   1177   	    set max $len
  1075   1178   	}
  1076   1179       }
  1077   1180       return $max
  1078   1181   }
  1079   1182   
  1080   1183   # Convert the locale values stored in environment variables to a form
  1081   1184   # suitable for passing to [mclocale]
  1082         -proc msgcat::ConvertLocale {value} {
         1185  +proc msgcat::mcutil::ConvertLocale {value} {
  1083   1186       # Assume $value is of form: $language[_$territory][.$codeset][@modifier]
  1084   1187       # Convert to form: $language[_$territory][_$modifier]
  1085   1188       #
  1086   1189       # Comment out expanded RE version -- bugs alleged
  1087   1190       # regexp -expanded {
  1088   1191       #	^		# Match all the way to the beginning
  1089   1192       #	([^[email protected]]*)	# Match "lanugage"; ends with _, ., or @
................................................................................
  1102   1205       }
  1103   1206       if {[string length $modifier]} {
  1104   1207   	append ret _$modifier
  1105   1208       }
  1106   1209       return $ret
  1107   1210   }
  1108   1211   
         1212  +# helper function to find package namespace of stack-frame -2
         1213  +# There are 4 possibilities:
         1214  +# - called from a proc
         1215  +# - called within a class definition script
         1216  +# - called from an class defined oo object
         1217  +# - called from a classless oo object
         1218  +proc ::msgcat::PackageNamespaceGet {} {
         1219  +    uplevel 2 {
         1220  +	# Check for no object
         1221  +	switch -exact -- [namespace which self] {
         1222  +	    {::oo::define::self} {
         1223  +		# We are within a class definition
         1224  +		return [namespace qualifiers [self]]
         1225  +	    }
         1226  +	    {::oo::Helpers::self} {
         1227  +		# We are within an object
         1228  +		set Class [info object class [self]]
         1229  +		# Check for classless defined object
         1230  +		if {$Class eq {::oo::object}} {
         1231  +		    return [namespace qualifiers [self]]
         1232  +		}
         1233  +		# Class defined object
         1234  +		return [namespace qualifiers $Class]
         1235  +	    }
         1236  +	    default {
         1237  +		# Not in object environment
         1238  +		return [namespace current]
         1239  +	    }
         1240  +	}
         1241  +    }
         1242  +}
         1243  +  
  1109   1244   # Initialize the default locale
  1110         -proc msgcat::Init {} {
         1245  +proc msgcat::mcutil::getsystemlocale {} {
  1111   1246       global env
  1112   1247   
  1113   1248       #
  1114   1249       # set default locale, try to get from environment
  1115   1250       #
  1116   1251       foreach varName {LC_ALL LC_MESSAGES LANG} {
  1117   1252   	if {[info exists env($varName)] && ("" ne $env($varName))} {
  1118         -	    if {![catch {
  1119         -		mclocale [ConvertLocale $env($varName)]
  1120         -	    }]} {
  1121         -		return
         1253  +	    if {![catch { ConvertLocale $env($varName) } locale]} {
         1254  +		return $locale
  1122   1255   	    }
  1123   1256   	}
  1124   1257       }
  1125   1258       #
  1126   1259       # On Darwin, fallback to current CFLocale identifier if available.
  1127   1260       #
  1128   1261       if {[info exists ::tcl::mac::locale] && $::tcl::mac::locale ne ""} {
  1129         -	if {![catch {
  1130         -	    mclocale [ConvertLocale $::tcl::mac::locale]
  1131         -	}]} {
  1132         -	    return
         1262  +	if {![catch { ConvertLocale $::tcl::mac::locale] } locale]} {
         1263  +	    return $locale
  1133   1264   	}
  1134   1265       }
  1135   1266       #
  1136   1267       # The rest of this routine is special processing for Windows or
  1137   1268       # Cygwin. All other platforms, get out now.
  1138   1269       #
  1139   1270       if {([info sharedlibextension] ne ".dll")
  1140   1271   	    || [catch {package require registry}]} {
  1141         -	mclocale C
  1142         -	return
         1272  +	return C
  1143   1273       }
  1144   1274       #
  1145   1275       # On Windows or Cygwin, try to set locale depending on registry
  1146   1276       # settings, or fall back on locale of "C".
  1147   1277       #
  1148   1278   
  1149   1279       # On Vista and later:
................................................................................
  1166   1296   	    if {"" ne $territory} {
  1167   1297   		append locale _ $territory
  1168   1298   	    }
  1169   1299   	    set modifierDict [dict create latn latin cyrl cyrillic]
  1170   1300   	    if {[dict exists $modifierDict $script]} {
  1171   1301   		append locale @ [dict get $modifierDict $script]
  1172   1302   	    }
  1173         -	    if {![catch {mclocale [ConvertLocale $locale]}]} {
  1174         -		return
         1303  +	    if {![catch {ConvertLocale $locale} locale]} {
         1304  +		return $locale
  1175   1305   	    }
  1176   1306   	}
  1177   1307       }
  1178   1308   
  1179   1309       # then check value locale which contains a numerical language ID
  1180   1310       if {[catch {
  1181   1311   	set locale [registry get $key "locale"]
  1182   1312       }]} {
  1183         -	mclocale C
  1184         -	return
         1313  +	return C
  1185   1314       }
  1186   1315       #
  1187   1316       # Keep trying to match against smaller and smaller suffixes
  1188   1317       # of the registry value, since the latter hexadigits appear
  1189   1318       # to determine general language and earlier hexadigits determine
  1190   1319       # more precise information, such as territory.  For example,
  1191   1320       #     0409 - English - United States
................................................................................
  1192   1321       #     0809 - English - United Kingdom
  1193   1322       # Add more translations to the WinRegToISO639 array above.
  1194   1323       #
  1195   1324       variable WinRegToISO639
  1196   1325       set locale [string tolower $locale]
  1197   1326       while {[string length $locale]} {
  1198   1327   	if {![catch {
  1199         -	    mclocale [ConvertLocale [dict get $WinRegToISO639 $locale]]
  1200         -	}]} {
  1201         -	    return
         1328  +	    ConvertLocale [dict get $WinRegToISO639 $locale]
         1329  +	} localeOut]} {
         1330  +	    return $localeOut
  1202   1331   	}
  1203   1332   	set locale [string range $locale 1 end]
  1204   1333       }
  1205   1334       #
  1206   1335       # No translation known.  Fall back on "C" locale
  1207   1336       #
  1208         -    mclocale C
         1337  +    return C
  1209   1338   }
  1210         -msgcat::Init
         1339  +msgcat::mclocale [msgcat::mcutil getsystemlocale]

Changes to library/msgcat/pkgIndex.tcl.

     1         -if {![package vsatisfies [package provide Tcl] 8.5-]} {return}
     2         -package ifneeded msgcat 1.6.1 [list source [file join $dir msgcat.tcl]]
            1  +if {![package vsatisfies [package provide Tcl] 8.5]} {return}
            2  +if {![package vsatisfies [package provide Tcl] 8.6-]} {return}
            3  +package ifneeded msgcat 1.7.0 [list source [file join $dir msgcat.tcl]]

Changes to tests/msgcat.test.

   189    189       test msgcat-1.13 {mclocale set, reject evil input} -setup {
   190    190   	variable locale [mclocale]
   191    191       } -cleanup {
   192    192   	mclocale $locale
   193    193       } -body {
   194    194   	mclocale looks/ok/../../../../but/is/path/to/evil/code
   195    195       } -returnCodes error -match glob -result {invalid newLocale value *}
          196  +
          197  +    test msgcat-1.14 {mcpreferences, custom locale preferences} -setup {
          198  +	variable locale [mclocale]
          199  +	mclocale en
          200  +	mcpreferences fr en {}
          201  +    } -cleanup {
          202  +	mclocale $locale
          203  +    } -body {
          204  +	mcpreferences
          205  +    } -result {fr en {}}
          206  +
          207  +    test msgcat-1.15 {mcpreferences, overwrite custom locale preferences}\
          208  +    -setup {
          209  +	variable locale [mclocale]
          210  +	mcpreferences fr en {}
          211  +	mclocale en
          212  +    } -cleanup {
          213  +	mclocale $locale
          214  +    } -body {
          215  +	mcpreferences
          216  +    } -result {en {}}
          217  +
   196    218   
   197    219       # Tests msgcat-2.*: [mcset], [mcmset], namespace partitioning
   198    220   
   199    221       test msgcat-2.1 {mcset, global scope} {
   200    222   	namespace eval :: ::msgcat::mcset  foo_BAR text1 text2
   201    223       } {text2}
   202    224   
................................................................................
   684    706       removeDirectory msgdir3
   685    707   
   686    708       # Tests msgcat-9.*: [mcexists]
   687    709   
   688    710   	test msgcat-9.1 {mcexists no parameter} -body {
   689    711   	    mcexists
   690    712   	} -returnCodes 1\
   691         -	-result {wrong # args: should be "mcexists ?-exactnamespace? ?-exactlocale? src"}
          713  +	-result {wrong # args: should be "mcexists ?-exactnamespace? ?-exactlocale? ?-namespace ns? src"}
   692    714   
   693    715   	test msgcat-9.2 {mcexists unknown option} -body {
   694    716   	    mcexists -unknown src
   695    717   	} -returnCodes 1\
   696    718   	-result {unknown option "-unknown"}
   697    719   
   698    720   	test msgcat-9.3 {mcexists} -setup {
................................................................................
   720    742   	test msgcat-9.5 {mcexists parent namespace} -setup {
   721    743   	    mcforgetpackage
   722    744   	    variable locale [mclocale]
   723    745   	    mclocale foo_bar
   724    746   	    mcset foo k1 v1
   725    747   	} -cleanup {
   726    748   	    mclocale $locale
          749  +	    namespace delete ::foo
   727    750   	} -body {
   728         -	    namespace eval ::msgcat::test::sub {
          751  +	    namespace eval ::foo {
          752  +		list [::msgcat::mcexists k1]\
          753  +			[::msgcat::mcexists -namespace ::msgcat::test k1]
          754  +	    }
          755  +	} -result {0 1}
          756  +
          757  +	test msgcat-9.6 {mcexists -namespace ns parameter} -setup {
          758  +	    mcforgetpackage
          759  +	    variable locale [mclocale]
          760  +	    mclocale foo_bar
          761  +	    mcset foo k1 v1
          762  +	} -cleanup {
          763  +	    mclocale $locale
          764  +	    namespace delete ::foo
          765  +	} -body {
          766  +	    namespace eval ::foo {
   729    767   		list [::msgcat::mcexists k1]\
   730         -			[::msgcat::mcexists -exactnamespace k1]
          768  +			[::msgcat::mcexists -namespace ::msgcat::test k1]
   731    769   	    }
   732         -	} -result {1 0}
          770  +	} -result {0 1}
          771  +
          772  +	test msgcat-9.7 {mcexists -namespace - ns argument missing} -body {
          773  +	    mcexists -namespace src
          774  +	} -returnCodes 1\
          775  +	-result {Argument missing for switch "-namespace"}
          776  +
   733    777   
   734    778       # Tests msgcat-10.*: [mcloadedlocales]
   735    779   
   736    780   	test msgcat-10.1 {mcloadedlocales no arg} -body {
   737    781   	    mcloadedlocales
   738    782   	} -returnCodes 1\
   739    783   	-result {wrong # args: should be "mcloadedlocales subcommand"}
................................................................................
   807    851   	} -result {1 0}
   808    852   
   809    853       # Tests msgcat-12.*: [mcpackagelocale]
   810    854   
   811    855   	test msgcat-12.1 {mcpackagelocale no subcommand} -body {
   812    856   	    mcpackagelocale
   813    857   	} -returnCodes 1\
   814         -	-result {wrong # args: should be "mcpackagelocale subcommand ?locale?"}
          858  +	-result {wrong # args: should be "mcpackagelocale subcommand ?arg ...?"}
   815    859   
   816    860   	test msgcat-12.2 {mclpackagelocale wrong subcommand} -body {
   817    861   	    mcpackagelocale junk
   818    862   	} -returnCodes 1\
   819    863   	-result {unknown subcommand "junk": must be clear, get, isset, loaded, present, set, or unset}
   820    864   
          865  +	test msgcat-12.2.1 {mclpackagelocale set multiple args} -body {
          866  +	    mcpackagelocale set a b
          867  +	} -returnCodes 1\
          868  +	-result {wrong # args: should be "mcpackagelocale set ?locale?"}
          869  +
   821    870   	test msgcat-12.3 {mcpackagelocale set} -setup {
   822    871   	    variable locale [mclocale]
   823    872   	} -cleanup {
   824    873   	    mclocale $locale
   825    874   	    mcforgetpackage
   826    875   	} -body {
   827    876   	    mclocale foo
................................................................................
   918    967   	    mcloadedlocales clear
   919    968   	    mclocale foo
   920    969   	    mcpackagelocale set bar
   921    970   	    mcpackagelocale clear
   922    971   	    list [mcpackagelocale present foo] [mcpackagelocale present bar]
   923    972   	} -result {0 1}
   924    973   
          974  +	test msgcat-12.11 {mcpackagelocale custom preferences} -setup {
          975  +	    variable locale [mclocale]
          976  +	} -cleanup {
          977  +	    mclocale $locale
          978  +	    mcforgetpackage
          979  +	} -body {
          980  +	    mclocale foo
          981  +	    set res [list [mcpackagelocale preferences]]
          982  +	    mcpackagelocale preferences bar {}
          983  +	    lappend res [mcpackagelocale preferences]
          984  +	} -result {{foo {}} {bar {}}}
          985  +
          986  +	test msgcat-12.12 {mcpackagelocale preferences -> no isset} -setup {
          987  +	    variable locale [mclocale]
          988  +	} -cleanup {
          989  +	    mclocale $locale
          990  +	    mcforgetpackage
          991  +	} -body {
          992  +	    mclocale foo
          993  +	    mcpackagelocale preferences
          994  +	    mcpackagelocale isset
          995  +	} -result {0}
          996  +
          997  +	
   925    998       # Tests msgcat-13.*: [mcpackageconfig subcmds]
   926    999   
   927   1000   	test msgcat-13.1 {mcpackageconfig no subcommand} -body {
   928   1001   	    mcpackageconfig
   929   1002   	} -returnCodes 1\
   930   1003   	-result {wrong # args: should be "mcpackageconfig subcommand option ?value?"}
   931   1004   
................................................................................
  1068   1141   	    mcforgetpackage
  1069   1142   	} -body {
  1070   1143   	    mcpackageconfig set unknowncmd [namespace code callbackfailproc]
  1071   1144   	    mclocale foo_bar
  1072   1145   	    mc k1
  1073   1146   	} -returnCodes 1\
  1074   1147   	-result {fail}
         1148  +
         1149  +
         1150  +    # Tests msgcat-15.*: tcloo coverage
         1151  +    
         1152  +    # There are 4 use-cases, where 3 must be tested now:
         1153  +    # - namespace defined, in class definition, class defined oo, classless
         1154  +
         1155  +    test msgcat-15.1 {mc in class setup} -setup {
         1156  +	# full namespace is ::msgcat::test:bar
         1157  +	namespace eval bar {
         1158  +	    ::msgcat::mcset foo_BAR con2 con2bar
         1159  +	    oo::class create ClassCur
         1160  +	}
         1161  +	variable locale [mclocale]
         1162  +	mclocale foo_BAR
         1163  +    } -cleanup {
         1164  +	mclocale $locale
         1165  +	namespace eval bar {::msgcat::mcforgetpackage}
         1166  +	namespace delete bar
         1167  +    } -body {
         1168  +	oo::define bar::ClassCur msgcat::mc con2
         1169  +    } -result con2bar
         1170  +
         1171  +    test msgcat-15.2 {mc in class} -setup {
         1172  +	# full namespace is ::msgcat::test:bar
         1173  +	namespace eval bar {
         1174  +	    ::msgcat::mcset foo_BAR con2 con2bar
         1175  +	    oo::class create ClassCur
         1176  +	    oo::define ClassCur method method1 {} {::msgcat::mc con2}
         1177  +	}
         1178  +	# full namespace is ::msgcat::test:baz
         1179  +	namespace eval baz {
         1180  +            set ObjCur [::msgcat::test::bar::ClassCur new]
         1181  +	}
         1182  +	variable locale [mclocale]
         1183  +	mclocale foo_BAR
         1184  +    } -cleanup {
         1185  +	mclocale $locale
         1186  +	namespace eval bar {::msgcat::mcforgetpackage}
         1187  +	namespace delete bar baz
         1188  +    } -body {
         1189  +	$baz::ObjCur method1
         1190  +    } -result con2bar
         1191  +
         1192  +    test msgcat-15.3 {mc in classless object} -setup {
         1193  +	# full namespace is ::msgcat::test:bar
         1194  +	namespace eval bar {
         1195  +	    ::msgcat::mcset foo_BAR con2 con2bar
         1196  +	    oo::object create ObjCur
         1197  +	    oo::objdefine ObjCur method method1 {} {::msgcat::mc con2}
         1198  +	}
         1199  +	variable locale [mclocale]
         1200  +	mclocale foo_BAR
         1201  +    } -cleanup {
         1202  +	mclocale $locale
         1203  +	namespace eval bar {::msgcat::mcforgetpackage}
         1204  +	namespace delete bar
         1205  +    } -body {
         1206  +	bar::ObjCur method1
         1207  +    } -result con2bar
         1208  +    
         1209  +    test msgcat-15.4 {mc in classless object with explicite namespace eval}\
         1210  +    -setup {
         1211  +	# full namespace is ::msgcat::test:bar
         1212  +	namespace eval bar {
         1213  +	    ::msgcat::mcset foo_BAR con2 con2bar
         1214  +	    oo::object create ObjCur
         1215  +	    oo::objdefine ObjCur method method1 {} {
         1216  +		namespace eval ::msgcat::test::baz {
         1217  +		    ::msgcat::mc con2
         1218  +		}
         1219  +	    }
         1220  +	}
         1221  +	namespace eval baz {
         1222  +	    ::msgcat::mcset foo_BAR con2 con2baz
         1223  +	}
         1224  +	variable locale [mclocale]
         1225  +	mclocale foo_BAR
         1226  +    } -cleanup {
         1227  +	mclocale $locale
         1228  +	namespace eval bar {::msgcat::mcforgetpackage}
         1229  +	namespace eval baz {::msgcat::mcforgetpackage}
         1230  +	namespace delete bar baz
         1231  +    } -body {
         1232  +	bar::ObjCur method1
         1233  +    } -result con2baz
         1234  +    
         1235  +    # Test msgcat-16.*: command mcpackagenamespaceget
         1236  +
         1237  +    test msgcat-16.1 {mcpackagenamespaceget in namespace procedure} -body {
         1238  +	namespace eval baz {msgcat::mcpackagenamespaceget}
         1239  +    } -result ::msgcat::test::baz
         1240  +
         1241  +    test msgcat-16.2 {mcpackagenamespaceget in class setup} -setup {
         1242  +	namespace eval bar {
         1243  +	    oo::class create ClassCur
         1244  +	    oo::define ClassCur variable a
         1245  +	}
         1246  +    } -cleanup {
         1247  +	namespace delete bar
         1248  +    } -body {
         1249  +	oo::define bar::ClassCur msgcat::mcpackagenamespaceget
         1250  +    } -result ::msgcat::test::bar
         1251  +
         1252  +    test msgcat-16.3 {mcpackagenamespaceget in class} -setup {
         1253  +	namespace eval bar {
         1254  +	    oo::class create ClassCur
         1255  +	    oo::define ClassCur method method1 {} {msgcat::mcpackagenamespaceget}
         1256  +	}
         1257  +	namespace eval baz {
         1258  +            set ObjCur [::msgcat::test::bar::ClassCur new]
         1259  +	}
         1260  +    } -cleanup {
         1261  +	namespace delete bar baz
         1262  +    } -body {
         1263  +	$baz::ObjCur method1
         1264  +    } -result ::msgcat::test::bar
         1265  +
         1266  +    test msgcat-16.4 {mcpackagenamespaceget in classless object} -setup {
         1267  +	namespace eval bar {
         1268  +	    oo::object create ObjCur
         1269  +	    oo::objdefine ObjCur method method1 {} {msgcat::mcpackagenamespaceget}
         1270  +	}
         1271  +    } -cleanup {
         1272  +	namespace delete bar
         1273  +    } -body {
         1274  +	bar::ObjCur method1
         1275  +    } -result ::msgcat::test::bar
         1276  +
         1277  +    test msgcat-16.5\
         1278  +    {mcpackagenamespaceget in classless object with explicite namespace eval}\
         1279  +    -setup {
         1280  +	namespace eval bar {
         1281  +	    oo::object create ObjCur
         1282  +	    oo::objdefine ObjCur method method1 {} {
         1283  +		namespace eval ::msgcat::test::baz {
         1284  +		    msgcat::mcpackagenamespaceget
         1285  +		}
         1286  +	    }
         1287  +	}
         1288  +    } -cleanup {
         1289  +	namespace delete bar baz
         1290  +    } -body {
         1291  +	bar::ObjCur method1
         1292  +    } -result ::msgcat::test::baz
         1293  +
         1294  +
         1295  +    # Test msgcat-17.*: mcn command
         1296  +    
         1297  +    test msgcat-17.1 {mcn no parameters} -body {
         1298  +	mcn
         1299  +    } -returnCodes 1\
         1300  +    -result {wrong # args: should be "mcn ns src ?arg ...?"}
         1301  +
         1302  +    test msgcat-17.2 {mcn} -setup {
         1303  +	namespace eval bar {::msgcat::mcset foo_BAR con1 con1bar}
         1304  +	variable locale [mclocale]
         1305  +	mclocale foo_BAR
         1306  +    } -cleanup {
         1307  +	mclocale $locale
         1308  +    } -body {
         1309  +	::msgcat::mcn [namespace current]::bar con1
         1310  +    } -result con1bar
         1311  +
  1075   1312   
  1076   1313       interp bgerror {} $bgerrorsaved
  1077   1314   
         1315  +    # Tests msgcat-15.*: [mcutil]
         1316  +
         1317  +    test msgcat-15.1 {mcutil - no argument} -body {
         1318  +	mcutil
         1319  +    } -returnCodes 1\
         1320  +    -result {wrong # args: should be "mcutil subcommand ?arg ...?"}
         1321  +
         1322  +    test msgcat-15.2 {mcutil - wrong argument} -body {
         1323  +	mcutil junk
         1324  +    } -returnCodes 1\
         1325  +    -result {unknown subcommand "junk": must be getpreferences, or getsystemlocale}
         1326  +    
         1327  +    test msgcat-15.3 {mcutil - partial argument} -body {
         1328  +	mcutil getsystem
         1329  +    } -returnCodes 1\
         1330  +    -result {unknown subcommand "getsystem": must be getpreferences, or getsystemlocale}
         1331  +    
         1332  +    test msgcat-15.4 {mcutil getpreferences - no argument} -body {
         1333  +	mcutil getpreferences
         1334  +    } -returnCodes 1\
         1335  +    -result {wrong # args: should be "mcutil getpreferences locale"}
         1336  +    
         1337  +    test msgcat-15.5 {mcutil getpreferences - DE_de} -body {
         1338  +	mcutil getpreferences DE_de
         1339  +    } -result {de_de de {}}
         1340  +    
         1341  +    test msgcat-15.6 {mcutil getsystemlocale - wrong argument} -body {
         1342  +	mcutil getsystemlocale DE_de
         1343  +    } -returnCodes 1\
         1344  +    -result {wrong # args: should be "mcutil getsystemlocale"}
         1345  +    
         1346  +    # The result is system dependent
         1347  +    # So just test if it runs
         1348  +    # The environment variable version was test with test 0.x
         1349  +    test msgcat-15.7 {mcutil getsystemlocale} -body {
         1350  +	mcutil getsystemlocale
         1351  +	set ok ok
         1352  +    } -result {ok}
         1353  +    
         1354  +    
  1078   1355       cleanupTests
  1079   1356   }
  1080   1357   namespace delete ::msgcat::test
  1081   1358   return
  1082   1359   
  1083   1360   # Local Variables:
  1084   1361   # mode: tcl
  1085   1362   # End:

Added tests/process.test.

            1  +# process.test --
            2  +#
            3  +# This file contains a collection of tests for the tcl::process ensemble.
            4  +# Sourcing this file into Tcl runs the tests and generates output for
            5  +# errors.  No output means no errors were found.
            6  +#
            7  +# Copyright (c) 2017 Frederic Bonnet
            8  +# See the file "license.terms" for information on usage and redistribution of
            9  +# this file, and for a DISCLAIMER OF ALL WARRANTIES.
           10  +
           11  +if {[lsearch [namespace children] ::tcltest] == -1} {
           12  +    package require tcltest 2
           13  +    namespace import -force ::tcltest::*
           14  +}
           15  +
           16  +test process-1.1 {tcl::process command basic syntax} -returnCodes error -body {
           17  +    tcl::process
           18  +} -result {wrong # args: should be "tcl::process subcommand ?arg ...?"}
           19  +test process-1.2 {tcl::process command basic syntax} -returnCodes error -body {
           20  +    tcl::process ?
           21  +} -match glob -result {unknown or ambiguous subcommand "?": must be autopurge, list, purge, or status}
           22  +
           23  +test process-2.1 {tcl::process autopurge get} {tcl::process autopurge} {1}
           24  +test process-2.2 {tcl::process autopurge set true} {
           25  +    tcl::process autopurge true
           26  +    tcl::process autopurge
           27  +} {1}
           28  +test process-2.3 {tcl::process autopurge set false} {
           29  +    tcl::process autopurge false
           30  +    tcl::process autopurge
           31  +} {0}

Changes to unix/Makefile.in.

   299    299   	tclEnv.o tclEvent.o tclExecute.o tclFCmd.o tclFileName.o tclGet.o \
   300    300   	tclHash.o tclHistory.o tclIndexObj.o tclInterp.o tclIO.o tclIOCmd.o \
   301    301   	tclIORChan.o tclIORTrans.o tclIOGT.o tclIOSock.o tclIOUtil.o \
   302    302   	tclLink.o tclListObj.o \
   303    303   	tclLiteral.o tclLoad.o tclMain.o tclNamesp.o tclNotify.o \
   304    304   	tclObj.o tclOptimize.o tclPanic.o tclParse.o tclPathObj.o tclPipe.o \
   305    305   	tclPkg.o tclPkgConfig.o tclPosixStr.o \
   306         -	tclPreserve.o tclProc.o tclRegexp.o \
          306  +	tclPreserve.o tclProc.o tclProcess.o tclRegexp.o \
   307    307   	tclResolve.o tclResult.o tclScan.o tclStringObj.o \
   308    308   	tclStrToD.o tclThread.o \
   309    309   	tclThreadAlloc.o tclThreadJoin.o tclThreadStorage.o tclStubInit.o \
   310    310   	tclTimer.o tclTrace.o tclUtf.o tclUtil.o tclVar.o tclZlib.o \
   311    311   	tclTomMathInterface.o
   312    312   
   313    313   OO_OBJS = tclOO.o tclOOBasic.o tclOOCall.o tclOODefineCmds.o tclOOInfo.o \
................................................................................
   440    440   	$(GENERIC_DIR)/tclPathObj.c \
   441    441   	$(GENERIC_DIR)/tclPipe.c \
   442    442   	$(GENERIC_DIR)/tclPkg.c \
   443    443   	$(GENERIC_DIR)/tclPkgConfig.c \
   444    444   	$(GENERIC_DIR)/tclPosixStr.c \
   445    445   	$(GENERIC_DIR)/tclPreserve.c \
   446    446   	$(GENERIC_DIR)/tclProc.c \
          447  +	$(GENERIC_DIR)/tclProcess.c \
   447    448   	$(GENERIC_DIR)/tclRegexp.c \
   448    449   	$(GENERIC_DIR)/tclResolve.c \
   449    450   	$(GENERIC_DIR)/tclResult.c \
   450    451   	$(GENERIC_DIR)/tclScan.c \
   451    452   	$(GENERIC_DIR)/tclStubInit.c \
   452    453   	$(GENERIC_DIR)/tclStringObj.c \
   453    454   	$(GENERIC_DIR)/tclStrToD.c \
................................................................................
   846    847   	@echo "Installing package http 2.8.12 as a Tcl Module";
   847    848   	@$(INSTALL_DATA) $(TOP_DIR)/library/http/http.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.6/http-2.8.12.tm;
   848    849   	@echo "Installing package opt0.4 files to $(SCRIPT_INSTALL_DIR)/opt0.4/";
   849    850   	@for i in $(TOP_DIR)/library/opt/*.tcl ; \
   850    851   	    do \
   851    852   	    $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"/opt0.4; \
   852    853   	    done;
   853         -	@echo "Installing package msgcat 1.6.1 as a Tcl Module";
   854         -	@$(INSTALL_DATA) $(TOP_DIR)/library/msgcat/msgcat.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/msgcat-1.6.1.tm;
          854  +	@echo "Installing package msgcat 1.7.0 as a Tcl Module";
          855  +	@$(INSTALL_DATA) $(TOP_DIR)/library/msgcat/msgcat.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.6/msgcat-1.7.0.tm;
   855    856   	@echo "Installing package tcltest 2.4.1 as a Tcl Module";
   856    857   	@$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/tcltest-2.4.1.tm;
   857    858   
   858    859   	@echo "Installing package platform 1.0.14 as a Tcl Module";
   859    860   	@$(INSTALL_DATA) $(TOP_DIR)/library/platform/platform.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.4/platform-1.0.14.tm;
   860    861   	@echo "Installing package platform::shell 1.1.4 as a Tcl Module";
   861    862   	@$(INSTALL_DATA) $(TOP_DIR)/library/platform/shell.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.4/platform/shell-1.1.4.tm;
................................................................................
  1284   1285   
  1285   1286   tclPreserve.o: $(GENERIC_DIR)/tclPreserve.c
  1286   1287   	$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclPreserve.c
  1287   1288   
  1288   1289   tclProc.o: $(GENERIC_DIR)/tclProc.c $(COMPILEHDR) $(NREHDR)
  1289   1290   	$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclProc.c
  1290   1291   
         1292  +tclProcess.o: $(GENERIC_DIR)/tclProcess.c
         1293  +	$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclProcess.c
         1294  +
  1291   1295   tclRegexp.o: $(GENERIC_DIR)/tclRegexp.c $(TCLREHDRS)
  1292   1296   	$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclRegexp.c
  1293   1297   
  1294   1298   tclResolve.o: $(GENERIC_DIR)/tclResolve.c
  1295   1299   	$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclResolve.c
  1296   1300   
  1297   1301   tclResult.o: $(GENERIC_DIR)/tclResult.c

Changes to win/Makefile.in.

   281    281   	tclPathObj.$(OBJEXT) \
   282    282   	tclPipe.$(OBJEXT) \
   283    283   	tclPkg.$(OBJEXT) \
   284    284   	tclPkgConfig.$(OBJEXT) \
   285    285   	tclPosixStr.$(OBJEXT) \
   286    286   	tclPreserve.$(OBJEXT) \
   287    287   	tclProc.$(OBJEXT) \
          288  +	tclProcess.$(OBJEXT) \
   288    289   	tclRegexp.$(OBJEXT) \
   289    290   	tclResolve.$(OBJEXT) \
   290    291   	tclResult.$(OBJEXT) \
   291    292   	tclScan.$(OBJEXT) \
   292    293   	tclStringObj.$(OBJEXT) \
   293    294   	tclStrToD.$(OBJEXT) \
   294    295   	tclStubInit.$(OBJEXT) \
................................................................................
   655    656   	@echo "Installing package http 2.8.12 as a Tcl Module";
   656    657   	@$(COPY) $(ROOT_DIR)/library/http/http.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.6/http-2.8.12.tm;
   657    658   	@echo "Installing library opt0.4 directory";
   658    659   	@for j in $(ROOT_DIR)/library/opt/*.tcl; \
   659    660   	    do \
   660    661   	    $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/opt0.4"; \
   661    662   	    done;
   662         -	@echo "Installing package msgcat 1.6.1 as a Tcl Module";
   663         -	@$(COPY) $(ROOT_DIR)/library/msgcat/msgcat.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/msgcat-1.6.1.tm;
          663  +	@echo "Installing package msgcat 1.7.0 as a Tcl Module";
          664  +	@$(COPY) $(ROOT_DIR)/library/msgcat/msgcat.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.6/msgcat-1.7.0.tm;
   664    665   	@echo "Installing package tcltest 2.4.0 as a Tcl Module";
   665    666   	@$(COPY) $(ROOT_DIR)/library/tcltest/tcltest.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/tcltest-2.4.0.tm;
   666    667   	@echo "Installing package platform 1.0.14 as a Tcl Module";
   667    668   	@$(COPY) $(ROOT_DIR)/library/platform/platform.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.4/platform-1.0.14.tm;
   668    669   	@echo "Installing package platform::shell 1.1.4 as a Tcl Module";
   669    670   	@$(COPY) $(ROOT_DIR)/library/platform/shell.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.4/platform/shell-1.1.4.tm;
   670    671   	@echo "Installing encodings";

Changes to win/buildall.vc.bat.

    34     34   if defined WINDOWSSDKDIR (goto :startBuilding)
    35     35   
    36     36   :: We need to run the development environment batch script that comes
    37     37   :: with developer studio (v4,5,6,7,etc...)  All have it.  This path
    38     38   :: might not be correct.  You should call it yourself prior to running
    39     39   :: this batchfile.
    40     40   ::
    41         -call "C:\Program Files\Microsoft Developer Studio\vc98\bin\vcvars32.bat"
           41  +REM call "C:\Program Files\Microsoft Developer Studio\vc98\bin\vcvars32.bat"
           42  +set "VSCMD_START_DIR=%CD%"
           43  +call "C:\Program Files (x86)\Microsoft Visual Studio\2017\Community\Common7\Tools\VsDevCmd.bat"
    42     44   if errorlevel 1 (goto no_vcvars)
    43     45   
    44     46   :startBuilding
    45     47   
    46     48   echo.
    47     49   echo Sit back and have a cup of coffee while this grinds through ;)
    48     50   echo You asked for *everything*, remember?

Changes to win/makefile.vc.

   214    214   	$(TMP_DIR)\tclPathObj.obj \
   215    215   	$(TMP_DIR)\tclPipe.obj \
   216    216   	$(TMP_DIR)\tclPkg.obj \
   217    217   	$(TMP_DIR)\tclPkgConfig.obj \
   218    218   	$(TMP_DIR)\tclPosixStr.obj \
   219    219   	$(TMP_DIR)\tclPreserve.obj \
   220    220   	$(TMP_DIR)\tclProc.obj \
          221  +	$(TMP_DIR)\tclProcess.obj \
   221    222   	$(TMP_DIR)\tclRegexp.obj \
   222    223   	$(TMP_DIR)\tclResolve.obj \
   223    224   	$(TMP_DIR)\tclResult.obj \
   224    225   	$(TMP_DIR)\tclScan.obj \
   225    226   	$(TMP_DIR)\tclStringObj.obj \
   226    227   	$(TMP_DIR)\tclStrToD.obj \
   227    228   	$(TMP_DIR)\tclStubInit.obj \

Changes to win/tcl.dsp.

  1259   1259   SOURCE=..\generic\tclPreserve.c
  1260   1260   # End Source File
  1261   1261   # Begin Source File
  1262   1262   
  1263   1263   SOURCE=..\generic\tclProc.c
  1264   1264   # End Source File
  1265   1265   # Begin Source File
         1266  +
         1267  +SOURCE=..\generic\tclProcess.c
         1268  +# End Source File
         1269  +# Begin Source File
  1266   1270   
  1267   1271   SOURCE=..\generic\tclRegexp.c
  1268   1272   # End Source File
  1269   1273   # Begin Source File
  1270   1274   
  1271   1275   SOURCE=..\generic\tclRegexp.h
  1272   1276   # End Source File

Changes to win/tclWinPipe.c.

   865    865   {
   866    866       ProcInfo *infoPtr;
   867    867   
   868    868       PipeInit();
   869    869   
   870    870       Tcl_MutexLock(&pipeMutex);
   871    871       for (infoPtr = procList; infoPtr != NULL; infoPtr = infoPtr->nextPtr) {
   872         -	if (infoPtr->hProcess == (HANDLE) pid) {
          872  +	if (infoPtr->dwProcessId == (DWORD) pid) {
   873    873   	    Tcl_MutexUnlock(&pipeMutex);
   874    874   	    return infoPtr->dwProcessId;
   875    875   	}
   876    876       }
   877    877       Tcl_MutexUnlock(&pipeMutex);
   878    878       return (unsigned long) -1;
   879    879   }
................................................................................
  1159   1159        * CreateProcess() and CloseHandle(), the problem does not occur." PSS ID
  1160   1160        * Number: Q124121
  1161   1161        */
  1162   1162   
  1163   1163       WaitForInputIdle(procInfo.hProcess, 5000);
  1164   1164       CloseHandle(procInfo.hThread);
  1165   1165   
  1166         -    *pidPtr = (Tcl_Pid) procInfo.hProcess;
         1166  +    *pidPtr = (Tcl_Pid) procInfo.dwProcessId;
  1167   1167       if (*pidPtr != 0) {
  1168   1168   	TclWinAddProcess(procInfo.hProcess, procInfo.dwProcessId);
  1169   1169       }
  1170   1170       result = TCL_OK;
  1171   1171   
  1172   1172     end:
  1173   1173       Tcl_DStringFree(&cmdLine);
................................................................................
  2343   2343        * Find the process and cut it from the process list.
  2344   2344        */
  2345   2345   
  2346   2346       Tcl_MutexLock(&pipeMutex);
  2347   2347       prevPtrPtr = &procList;
  2348   2348       for (infoPtr = procList; infoPtr != NULL;
  2349   2349   	    prevPtrPtr = &infoPtr->nextPtr, infoPtr = infoPtr->nextPtr) {
  2350         -	 if (infoPtr->hProcess == (HANDLE) pid) {
         2350  +	 if (infoPtr->dwProcessId == (DWORD) pid) {
  2351   2351   	    *prevPtrPtr = infoPtr->nextPtr;
  2352   2352   	    break;
  2353   2353   	}
  2354   2354       }
  2355   2355       Tcl_MutexUnlock(&pipeMutex);
  2356   2356   
  2357   2357       /*