Many hyperlinks are disabled.
Use anonymous login
to enable hyperlinks.
Overview
| Comment: | merge 8.7 |
|---|---|
| Downloads: | Tarball | ZIP archive | SQL archive |
| Timelines: | family | ancestors | descendants | both | trunk |
| Files: | files | file ages | folders |
| SHA3-256: |
e2316b333f409a51f3d513a03f7359f9 |
| User & Date: | dgp 2018-03-12 14:49:44 |
Context
|
2018-03-12
| ||
| 16:00 | merge 8.7 check-in: b8ddebf088 user: dgp tags: trunk | |
| 14:49 | merge 8.7 check-in: e2316b333f user: dgp tags: trunk | |
| 14:41 | Revert change that broke usage with Tcl 9 check-in: 8791050e93 user: dgp tags: core-8-branch | |
|
2018-03-11
| ||
| 21:42 | merge 8.7 check-in: 3108218eee user: dgp tags: trunk | |
Changes
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.
779 779 TclInitDictCmd(interp); 780 780 TclInitEncodingCmd(interp); 781 781 TclInitFileCmd(interp); 782 782 TclInitInfoCmd(interp); 783 783 TclInitNamespaceCmd(interp); 784 784 TclInitStringCmd(interp); 785 785 TclInitPrefixCmd(interp); 786 + TclInitProcessCmd(interp); 786 787 787 788 /* 788 789 * Register "clock" subcommands. These *do* go through 789 790 * Tcl_CreateObjCommand, since they aren't in the global namespace and 790 791 * involve ensembles. 791 792 */ 792 793
Changes to generic/tclCmdMZ.c.
2299 2299 static int 2300 2300 StringRplcCmd( 2301 2301 ClientData dummy, /* Not used. */ 2302 2302 Tcl_Interp *interp, /* Current interpreter. */ 2303 2303 int objc, /* Number of arguments. */ 2304 2304 Tcl_Obj *const objv[]) /* Argument objects. */ 2305 2305 { 2306 - Tcl_UniChar *ustring; 2307 - int first, last, length; 2306 + int first, last, length, end; 2308 2307 2309 2308 if (objc < 4 || objc > 5) { 2310 2309 Tcl_WrongNumArgs(interp, 1, objv, "string first last ?string?"); 2311 2310 return TCL_ERROR; 2312 2311 } 2313 2312 2314 - ustring = Tcl_GetUnicodeFromObj(objv[1], &length); 2315 - length--; 2313 + (void) Tcl_GetUnicodeFromObj(objv[1], &length); 2314 + end = length - 1; 2316 2315 2317 - if (TclGetIntForIndexM(interp, objv[2], length, &first) != TCL_OK || 2318 - TclGetIntForIndexM(interp, objv[3], length, &last) != TCL_OK){ 2316 + if (TclGetIntForIndexM(interp, objv[2], end, &first) != TCL_OK || 2317 + TclGetIntForIndexM(interp, objv[3], end, &last) != TCL_OK){ 2319 2318 return TCL_ERROR; 2320 2319 } 2321 2320 2322 - if ((last < first) || (last < 0) || (first > length)) { 2321 + /* 2322 + * [string replace] does not replace empty strings. This is 2323 + * unwise, but since it is true, here we quickly screen out 2324 + * index pairs that demarcate an empty substring. 2325 + */ 2326 + 2327 + if ((last < 0) || /* Range ends before start of string */ 2328 + (first > end) || /* Range begins after end of string */ 2329 + (last < first)) { /* Range begins after it starts */ 2323 2330 Tcl_SetObjResult(interp, objv[1]); 2324 2331 } else { 2325 2332 Tcl_Obj *resultPtr; 2326 2333 2327 - ustring = Tcl_GetUnicodeFromObj(objv[1], &length); 2328 - length--; 2334 + /* 2335 + * We are re-fetching in case the string argument is same value as 2336 + * an index argument, and shimmering cost us our ustring. 2337 + */ 2338 + 2339 + Tcl_UniChar *ustring = Tcl_GetUnicodeFromObj(objv[1], &length); 2340 + 2341 + end = length - 1; 2329 2342 2330 2343 if (first < 0) { 2331 2344 first = 0; 2332 2345 } 2333 2346 2334 2347 resultPtr = Tcl_NewUnicodeObj(ustring, first); 2335 2348 if (objc == 5) { 2336 2349 Tcl_AppendObjToObj(resultPtr, objv[4]); 2337 2350 } 2338 - if (last < length) { 2351 + if (last < end) { 2339 2352 Tcl_AppendUnicodeToObj(resultPtr, ustring + last + 1, 2340 - length - last); 2353 + end - last); 2341 2354 } 2342 2355 Tcl_SetObjResult(interp, resultPtr); 2343 2356 } 2344 2357 return TCL_OK; 2345 2358 } 2346 2359 2347 2360 /*
Changes to generic/tclInt.h.
3993 3993 3994 3994 MODULE_SCOPE int TclCompareObjKeys(void *keyPtr, Tcl_HashEntry *hPtr); 3995 3995 MODULE_SCOPE void TclFreeObjEntry(Tcl_HashEntry *hPtr); 3996 3996 MODULE_SCOPE TCL_HASH_TYPE TclHashObjKey(Tcl_HashTable *tablePtr, void *keyPtr); 3997 3997 3998 3998 MODULE_SCOPE int TclFullFinalizationRequested(void); 3999 3999 4000 +/* 4001 + * TIP #462. 4002 + */ 4003 + 4004 +/* 4005 + * The following enum values give the status of a spawned process. 4006 + */ 4007 + 4008 +typedef enum TclProcessWaitStatus { 4009 + TCL_PROCESS_ERROR = -1, /* Error waiting for process to exit */ 4010 + TCL_PROCESS_UNCHANGED = 0, /* No change since the last call. */ 4011 + TCL_PROCESS_EXITED = 1, /* Process has exited. */ 4012 + TCL_PROCESS_SIGNALED = 2, /* Child killed because of a signal. */ 4013 + TCL_PROCESS_STOPPED = 3, /* Child suspended because of a signal. */ 4014 + TCL_PROCESS_UNKNOWN_STATUS = 4 4015 + /* Child wait status didn't make sense. */ 4016 +} TclProcessWaitStatus; 4017 + 4018 +MODULE_SCOPE Tcl_Command TclInitProcessCmd(Tcl_Interp *interp); 4019 +MODULE_SCOPE void TclProcessCreated(Tcl_Pid pid); 4020 +MODULE_SCOPE TclProcessWaitStatus TclProcessWait(Tcl_Pid pid, int options, 4021 + int *codePtr, Tcl_Obj **msgObjPtr, 4022 + Tcl_Obj **errorObjPtr); 4023 + 4000 4024 /* 4001 4025 * Utility routines for encoding index values as integers. Used by both 4002 4026 * some of the command compilers and by [lsort] and [lsearch]. 4003 4027 */ 4004 4028 4005 4029 MODULE_SCOPE int TclIndexEncode(Tcl_Interp *interp, Tcl_Obj *objPtr, 4006 4030 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.6-]} {return} 2 +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)"/../tcl9/9.0/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)"/../tcl9/9.0/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)"/../tcl9/9.0/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)"/../tcl9/9.0/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)"/../tcl9/9.0/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)"/../tcl9/9.0/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)/../tcl9/9.0/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)/../tcl9/9.0/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)/../tcl9/9.0/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)/../tcl9/9.0/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)/../tcl9/9.0/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)/../tcl9/9.0/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 /*