From 14143230c875cfddb154eef9698c9344bbb905d5 Mon Sep 17 00:00:00 2001 From: sebres Date: Thu, 16 Apr 2020 11:54:34 +0000 Subject: added (reworked) patch suggested by aku in [f70ce1fead]: recognize stream is done (and unget the unprocessed data back to input channel) --- generic/tclZlib.c | 26 +++++++++++++++++++++----- 1 file changed, 21 insertions(+), 5 deletions(-) diff --git a/generic/tclZlib.c b/generic/tclZlib.c index 002c6ae..1ee8919 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -128,6 +128,10 @@ typedef struct { Tcl_Obj *compDictObj; /* Byte-array object containing compression * dictionary (not dictObj!) to use if * necessary. */ + int over; /* Number of bytes we read to far in the + * underlying stream */ + int skip; /* Bytes processed in the last read before + * the overshot */ } ZlibChannelData; /* @@ -137,11 +141,14 @@ typedef struct { * the input compressor. * OUT_HEADER - Whether the outputHeader field has been registered * with the output decompressor. + * STREAM_DONE - Flag to signal stream end up to transform + * input. */ -#define ASYNC 0x1 -#define IN_HEADER 0x2 -#define OUT_HEADER 0x4 +#define ASYNC 0x01 +#define IN_HEADER 0x02 +#define OUT_HEADER 0x04 +#define STREAM_DONE 0x10 /* * Size of buffers allocated by default, and the range it can be set to. The @@ -2949,6 +2956,10 @@ ZlibTransformClose( (void) inflateEnd(&cd->inStream); } + if (cd->over) { + Tcl_Ungets (cd->parent, cd->inBuffer + cd->skip, cd->over, 0); + } + /* * Release all memory. */ @@ -3010,7 +3021,7 @@ ZlibTransformInput( buf += copied; gotBytes += copied; - if (toRead == 0) { + if (toRead == 0 || (cd->flags & STREAM_DONE)) { return gotBytes; } @@ -3830,8 +3841,13 @@ ResultGenerate( * The cases where we're definitely done. */ + if (e == Z_STREAM_END) { + cd->flags |= STREAM_DONE; + cd->over = cd->inStream.avail_in; + cd->skip = n - cd->over; + return TCL_OK; + } if (((flush == Z_SYNC_FLUSH) && (e == Z_BUF_ERROR)) - || (e == Z_STREAM_END) || (e == Z_OK && written == 0)) { return TCL_OK; } -- cgit v0.12 From b7f84c7bc0a87376cd9d151b61beadb68ab18e03 Mon Sep 17 00:00:00 2001 From: sebres Date: Thu, 16 Apr 2020 13:28:49 +0000 Subject: zlib: performance - set default read ahead limit to DEFAULT_BUFFER_SIZE (4K); better fix avoiding BO (replacement for [54605d16b9]) --- generic/tclZlib.c | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/generic/tclZlib.c b/generic/tclZlib.c index 1ee8919..23472cf 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -2371,7 +2371,7 @@ ZlibPushSubcmd( const char *const *pushOptions = pushDecompressOptions; enum pushOptions {poDictionary, poHeader, poLevel, poLimit}; Tcl_Obj *headerObj = NULL, *compDictObj = NULL; - int limit = 1, dummy; + int limit = DEFAULT_BUFFER_SIZE, dummy; if (objc < 4) { Tcl_WrongNumArgs(interp, 2, objv, "mode channel ?options...?"); @@ -3661,6 +3661,9 @@ ZlibStackChannelTransform( goto error; } cd->inAllocated = DEFAULT_BUFFER_SIZE; + if (cd->inAllocated < cd->readAheadLimit) { + cd->inAllocated = cd->readAheadLimit; + } cd->inBuffer = ckalloc(cd->inAllocated); if (cd->flags & IN_HEADER) { if (inflateGetHeader(&cd->inStream, &cd->inHeader.header) != Z_OK) { -- cgit v0.12 From 3577e36e79a96a06a2d61bb7c773987768fccdbb Mon Sep 17 00:00:00 2001 From: sebres Date: Thu, 16 Apr 2020 13:43:07 +0000 Subject: zlib: optimize ZlibTransformInput, if inflate is done no read and no generate needed anymore --- generic/tclZlib.c | 50 +++++++++++++++++++++++++------------------------- 1 file changed, 25 insertions(+), 25 deletions(-) diff --git a/generic/tclZlib.c b/generic/tclZlib.c index 23472cf..53949a5 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -3011,20 +3011,13 @@ ZlibTransformInput( gotBytes = 0; while (toRead > 0) { - /* - * Loop until the request is satisfied (or no data available from - * below, possibly EOF). + /* + * If done - no read (and no genearate) needed anymore, check we have + * to copy decompressed data, otherwise return with size (or 0 for Eof) */ - - copied = ResultCopy(cd, buf, toRead); - toRead -= copied; - buf += copied; - gotBytes += copied; - - if (toRead == 0 || (cd->flags & STREAM_DONE)) { - return gotBytes; + if (cd->flags & STREAM_DONE) { + goto copyDecompressed; } - /* * The buffer is exhausted, but the caller wants even more. We now * have to go to the underlying channel, get more bytes and then @@ -3032,10 +3025,6 @@ ZlibTransformInput( * or temporarily out of data). * * Length (cd->decompressed) == 0, toRead > 0 here. - * - * The zlib transform allows us to read at most one character from the - * underlying channel to properly identify Z_STREAM_END without - * reading over the border. */ readBytes = Tcl_ReadRaw(cd->parent, cd->inBuffer, cd->readAheadLimit); @@ -3054,7 +3043,7 @@ ZlibTransformInput( /* See ReflectInput() in tclIORTrans.c */ if (Tcl_InputBlocked(cd->parent) && (gotBytes > 0)) { - return gotBytes; + break; } *errorCodePtr = Tcl_GetErrno(); @@ -3072,14 +3061,6 @@ ZlibTransformInput( return -1; } - if (Tcl_DStringLength(&cd->decompressed) == 0) { - /* - * The drain delivered nothing. Time to deliver what we've - * got. - */ - - return gotBytes; - } } else /* readBytes > 0 */ { /* * Transform the read chunk, which was not empty. Anything we get @@ -3092,6 +3073,25 @@ ZlibTransformInput( return -1; } } + +copyDecompressed: + + if (Tcl_DStringLength(&cd->decompressed) == 0) { + /* + * The drain delivered nothing. Time to deliver what we've + * got. + */ + break; + } + /* + * Loop until the request is satisfied (or no data available from + * above, possibly EOF). + */ + + copied = ResultCopy(cd, buf, toRead); + toRead -= copied; + buf += copied; + gotBytes += copied; } return gotBytes; } -- cgit v0.12 From fb7b5ca9d3d2253238c7a1923dcb211d5cdee7fb Mon Sep 17 00:00:00 2001 From: sebres Date: Thu, 16 Apr 2020 14:05:24 +0000 Subject: small amend combining similar parts --- generic/tclZlib.c | 30 ++++++++++-------------------- 1 file changed, 10 insertions(+), 20 deletions(-) diff --git a/generic/tclZlib.c b/generic/tclZlib.c index 53949a5..b3a6ac2 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -3049,29 +3049,19 @@ ZlibTransformInput( *errorCodePtr = Tcl_GetErrno(); return -1; } - if (readBytes == 0) { - /* - * Eof in parent. - * - * Now this is a bit different. The partial data waiting is - * converted and returned. - */ - if (ResultGenerate(cd, 0, Z_SYNC_FLUSH, errorCodePtr) != TCL_OK) { - return -1; - } - - } else /* readBytes > 0 */ { - /* - * Transform the read chunk, which was not empty. Anything we get - * back is a transformation result to be put into our buffers, and - * the next iteration will put it into the result. - */ + /* + * Transform the read chunk, if not empty. Anything we get + * back is a transformation result to be put into our buffers, and + * the next iteration will put it into the result. + * For the case readBytes is 0 which signaling Eof in parent, the + * partial data waiting is converted and returned. + */ - if (ResultGenerate(cd, readBytes, Z_NO_FLUSH, + if (ResultGenerate(cd, readBytes, + (readBytes != 0) ? Z_NO_FLUSH : Z_SYNC_FLUSH, errorCodePtr) != TCL_OK) { - return -1; - } + return -1; } copyDecompressed: -- cgit v0.12 From becf4bcc18eb7b7114f65c271b21d9d7d6c94d2a Mon Sep 17 00:00:00 2001 From: sebres Date: Thu, 16 Apr 2020 14:37:05 +0000 Subject: few documentation changes (limit default and handling is changed) --- doc/zlib.n | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/doc/zlib.n b/doc/zlib.n index fd29e0d..994a063 100644 --- a/doc/zlib.n +++ b/doc/zlib.n @@ -193,10 +193,12 @@ How hard to compress the data. Must be an integer from 0 (uncompressed) to 9 .TP \fB\-limit\fI readaheadLimit\fR . -The maximum number of bytes ahead to read when decompressing. This defaults to -1, which ensures that data is always decompressed correctly, but may be -increased to improve performance. This is more useful when the channel is -non-blocking. +The maximum number of bytes ahead to read when decompressing. This can be set +to 1 to find the border for multi-stream inflate or mixed data, to ensure it +would handle correctly e. g. some operations on following streams after first +caused to due time. +Otherwise Tcl would try to automatically return previously read extra data +to input stream back. .PP Both compressing and decompressing channel transformations add extra configuration options that may be accessed through \fBchan configure\fR. The @@ -238,10 +240,8 @@ off the data stream. \fB\-limit\fI readaheadLimit\fR . This read-write option is used by decompressing channels to control the -maximum number of bytes ahead to read from the underlying data source. This -defaults to 1, which ensures that data is always decompressed correctly, but -may be increased to improve performance. This is more useful when the channel -is non-blocking. +maximum number of bytes ahead to read from the underlying data source. See +above for more information. .RE .SS "STREAMING SUBCOMMAND" .TP -- cgit v0.12 From b0791473e99d375f6f3b65b13f99728e552f2b5a Mon Sep 17 00:00:00 2001 From: sebres Date: Thu, 16 Apr 2020 19:08:57 +0000 Subject: code simplification, no interim copy/move buffers, no decompression d-string, the inflate occurring in single step (ResultDecompress combines ResultGenerate and ResultCopy); better handling in non-blocking mode (also recognizes or distinguish no data/EAGAIN cases) --- generic/tclZlib.c | 230 ++++++++++++++++++++++++------------------------------ 1 file changed, 103 insertions(+), 127 deletions(-) diff --git a/generic/tclZlib.c b/generic/tclZlib.c index b3a6ac2..68bdf92 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -124,14 +124,9 @@ typedef struct { GzipHeader outHeader; /* Header to write to an output stream, when * compressing a gzip stream. */ Tcl_TimerToken timer; /* Timer used for keeping events fresh. */ - Tcl_DString decompressed; /* Buffer for decompression results. */ Tcl_Obj *compDictObj; /* Byte-array object containing compression * dictionary (not dictObj!) to use if * necessary. */ - int over; /* Number of bytes we read to far in the - * underlying stream */ - int skip; /* Bytes processed in the last read before - * the overshot */ } ZlibChannelData; /* @@ -141,13 +136,14 @@ typedef struct { * the input compressor. * OUT_HEADER - Whether the outputHeader field has been registered * with the output decompressor. - * STREAM_DONE - Flag to signal stream end up to transform - * input. + * STREAM_DECOMPRESS - Signal decompress pending data. + * STREAM_DONE - Flag to signal stream end up to transform input. */ #define ASYNC 0x01 #define IN_HEADER 0x02 #define OUT_HEADER 0x04 +#define STREAM_DECOMPRESS 0x08 #define STREAM_DONE 0x10 /* @@ -191,10 +187,8 @@ static int GenerateHeader(Tcl_Interp *interp, Tcl_Obj *dictObj, GzipHeader *headerPtr, int *extraSizePtr); static int ZlibPushSubcmd(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -static inline int ResultCopy(ZlibChannelData *cd, char *buf, - int toRead); -static int ResultGenerate(ZlibChannelData *cd, int n, int flush, - int *errorCodePtr); +static int ResultDecompress(ZlibChannelData *cd, char *buf, + int toRead, int flush, int *errorCodePtr); static Tcl_Channel ZlibStackChannelTransform(Tcl_Interp *interp, int mode, int format, int level, int limit, Tcl_Channel channel, Tcl_Obj *gzipHeaderDictPtr, @@ -2953,11 +2947,15 @@ ZlibTransformClose( } while (e != Z_STREAM_END); (void) deflateEnd(&cd->outStream); } else { - (void) inflateEnd(&cd->inStream); - } + /* + * If we have rest of read input (overshot by Z_STREAM_END or on possible error), + * unget this part of buffer back to the parent channel. + */ + if (cd->inStream.avail_in) { + Tcl_Ungets (cd->parent, (char *)cd->inStream.next_in, cd->inStream.avail_in, 0); + } - if (cd->over) { - Tcl_Ungets (cd->parent, cd->inBuffer + cd->skip, cd->over, 0); + (void) inflateEnd(&cd->inStream); } /* @@ -2968,7 +2966,6 @@ ZlibTransformClose( Tcl_DecrRefCount(cd->compDictObj); cd->compDictObj = NULL; } - Tcl_DStringFree(&cd->decompressed); if (cd->inBuffer) { ckfree(cd->inBuffer); @@ -3002,7 +2999,7 @@ ZlibTransformInput( ZlibChannelData *cd = instanceData; Tcl_DriverInputProc *inProc = Tcl_ChannelInputProc(Tcl_GetChannelType(cd->parent)); - int readBytes, gotBytes, copied; + int readBytes, gotBytes; if (cd->mode == TCL_ZLIB_STREAM_DEFLATE) { return inProc(Tcl_GetChannelInstanceData(cd->parent), buf, toRead, @@ -3010,12 +3007,20 @@ ZlibTransformInput( } gotBytes = 0; - while (toRead > 0) { + readBytes = cd->inStream.avail_in; /* how many bytes in buffer now */ + while (!(cd->flags & STREAM_DONE) && toRead > 0) { + int n, decBytes; + + /* if starting from scratch or continuation after full decompression */ + if (!cd->inStream.avail_in) { + /* buffer to start, we can read to whole available buffer */ + cd->inStream.next_in = (Bytef *) cd->inBuffer; + } /* - * If done - no read (and no genearate) needed anymore, check we have - * to copy decompressed data, otherwise return with size (or 0 for Eof) + * If done - no read needed anymore, check we have to copy rest of + * decompressed data, otherwise return with size (or 0 for Eof) */ - if (cd->flags & STREAM_DONE) { + if (cd->flags & STREAM_DECOMPRESS) { goto copyDecompressed; } /* @@ -3023,11 +3028,21 @@ ZlibTransformInput( * have to go to the underlying channel, get more bytes and then * transform them for delivery. We may not get what we want (full EOF * or temporarily out of data). - * - * Length (cd->decompressed) == 0, toRead > 0 here. */ - readBytes = Tcl_ReadRaw(cd->parent, cd->inBuffer, cd->readAheadLimit); + /* Check free buffer size and adjust size of next chunk to read. */ + n = cd->inAllocated - ((char *)cd->inStream.next_in - cd->inBuffer); + if (n <= 0) { + /* Normally unreachable: not enough input buffer to uncompress. + * Todo: firstly try to realloc inBuffer upto MAX_BUFFER_SIZE. + */ + *errorCodePtr = ENOBUFS; + return -1; + } + if (n > cd->readAheadLimit) { + n = cd->readAheadLimit; + } + readBytes = Tcl_ReadRaw(cd->parent, (char *)cd->inStream.next_in, n); /* * Three cases here: @@ -3050,6 +3065,11 @@ ZlibTransformInput( return -1; } + /* more bytes (or Eof if readBytes == 0) */ + cd->inStream.avail_in += readBytes; + +copyDecompressed: + /* * Transform the read chunk, if not empty. Anything we get * back is a transformation result to be put into our buffers, and @@ -3058,31 +3078,39 @@ ZlibTransformInput( * partial data waiting is converted and returned. */ - if (ResultGenerate(cd, readBytes, + decBytes = ResultDecompress(cd, buf, toRead, (readBytes != 0) ? Z_NO_FLUSH : Z_SYNC_FLUSH, - errorCodePtr) != TCL_OK) { + errorCodePtr); + if (decBytes == -1) { return -1; } + gotBytes += decBytes; + buf += decBytes; + toRead -= decBytes; -copyDecompressed: - - if (Tcl_DStringLength(&cd->decompressed) == 0) { + if (((decBytes == 0) || (cd->flags & STREAM_DECOMPRESS))) { /* - * The drain delivered nothing. Time to deliver what we've - * got. + * The drain delivered nothing (or buffer too small to decompress). + * Time to deliver what we've got. */ + if (!gotBytes && !(cd->flags & STREAM_DONE)) { + /* if no-data, but not ready - avoid signaling Eof, + * continue in blocking mode, otherwise EAGAIN */ + if (Tcl_InputBlocked(cd->parent)) { + continue; + } + *errorCodePtr = EAGAIN; + return -1; + } break; } + /* * Loop until the request is satisfied (or no data available from * above, possibly EOF). */ - - copied = ResultCopy(cd, buf, toRead); - toRead -= copied; - buf += copied; - gotBytes += copied; } + return gotBytes; } @@ -3465,7 +3493,7 @@ ZlibTransformWatch( watchProc = Tcl_ChannelWatchProc(Tcl_GetChannelType(cd->parent)); watchProc(Tcl_GetChannelInstanceData(cd->parent), mask); - if (!(mask & TCL_READABLE) || Tcl_DStringLength(&cd->decompressed) == 0) { + if (!(mask & TCL_READABLE) || !(cd->flags & STREAM_DECOMPRESS)) { ZlibTransformEventTimerKill(cd); } else if (cd->timer == NULL) { cd->timer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME, @@ -3684,8 +3712,6 @@ ZlibStackChannelTransform( } } - Tcl_DStringInit(&cd->decompressed); - chan = Tcl_StackChannel(interp, &zlibChannelType, cd, Tcl_GetChannelMode(channel), channel); if (chan == NULL) { @@ -3715,96 +3741,37 @@ ZlibStackChannelTransform( /* *---------------------------------------------------------------------- * - * ResultCopy -- - * - * Copies the requested number of bytes from the buffer into the - * specified array and removes them from the buffer afterward. Copies - * less if there is not enough data in the buffer. - * - * Side effects: - * See above. - * - * Result: - * The number of actually copied bytes, possibly less than 'toRead'. - * - *---------------------------------------------------------------------- - */ - -static inline int -ResultCopy( - ZlibChannelData *cd, /* The location of the buffer to read from. */ - char *buf, /* The buffer to copy into */ - int toRead) /* Number of requested bytes */ -{ - int have = Tcl_DStringLength(&cd->decompressed); - - if (have == 0) { - /* - * Nothing to copy in the case of an empty buffer. - */ - - return 0; - } else if (have > toRead) { - /* - * The internal buffer contains more than requested. Copy the - * requested subset to the caller, shift the remaining bytes down, and - * truncate. - */ - - char *src = Tcl_DStringValue(&cd->decompressed); - - memcpy(buf, src, toRead); - memmove(src, src + toRead, have - toRead); - - Tcl_DStringSetLength(&cd->decompressed, have - toRead); - return toRead; - } else /* have <= toRead */ { - /* - * There is just or not enough in the buffer to fully satisfy the - * caller, so take everything as best effort. - */ - - memcpy(buf, Tcl_DStringValue(&cd->decompressed), have); - TclDStringClear(&cd->decompressed); - return have; - } -} - -/* - *---------------------------------------------------------------------- - * - * ResultGenerate -- + * ResultDecompress -- * * Extract uncompressed bytes from the compression engine and store them - * in our working buffer. + * in our buffer (buf) up to toRead bytes. * * Result: - * TCL_OK/TCL_ERROR (with *errorCodePtr updated with reason). + * Number of bytes decompressed or -1 if error (with *errorCodePtr updated with reason). * * Side effects: - * See above. + * After execution it updates cd->inStream (next_in, avail_in) to reflect + * the data that has been decompressed. * *---------------------------------------------------------------------- */ static int -ResultGenerate( +ResultDecompress( ZlibChannelData *cd, - int n, + char *buf, + int toRead, int flush, int *errorCodePtr) { -#define MAXBUF 1024 - unsigned char buf[MAXBUF]; - int e, written; + int e, written, resBytes = 0; Tcl_Obj *errObj; - cd->inStream.next_in = (Bytef *) cd->inBuffer; - cd->inStream.avail_in = n; - while (1) { - cd->inStream.next_out = (Bytef *) buf; - cd->inStream.avail_out = MAXBUF; + cd->flags &= ~STREAM_DECOMPRESS; + cd->inStream.next_out = (Bytef *) buf; + cd->inStream.avail_out = toRead; + while (cd->inStream.avail_out > 0) { e = inflate(&cd->inStream, flush); if (e == Z_NEED_DICT && cd->compDictObj) { @@ -3813,22 +3780,16 @@ ResultGenerate( /* * A repetition of Z_NEED_DICT is just an error. */ - - cd->inStream.next_out = (Bytef *) buf; - cd->inStream.avail_out = MAXBUF; e = inflate(&cd->inStream, flush); } } /* * avail_out is now the left over space in the output. Therefore - * "MAXBUF - avail_out" is the amount of bytes generated. + * "toRead - avail_out" is the amount of bytes generated. */ - written = MAXBUF - cd->inStream.avail_out; - if (written) { - Tcl_DStringAppend(&cd->decompressed, (char *) buf, written); - } + written = toRead - cd->inStream.avail_out; /* * The cases where we're definitely done. @@ -3836,13 +3797,18 @@ ResultGenerate( if (e == Z_STREAM_END) { cd->flags |= STREAM_DONE; - cd->over = cd->inStream.avail_in; - cd->skip = n - cd->over; - return TCL_OK; + resBytes += written; + break; } - if (((flush == Z_SYNC_FLUSH) && (e == Z_BUF_ERROR)) - || (e == Z_OK && written == 0)) { - return TCL_OK; + if (e == Z_OK) { + if (written == 0) { + break; + } + resBytes += written; + } + + if ((flush == Z_SYNC_FLUSH) && (e == Z_BUF_ERROR)) { + break; } /* @@ -3863,10 +3829,20 @@ ResultGenerate( */ if (cd->inStream.avail_in <= 0 && flush != Z_SYNC_FLUSH) { - return TCL_OK; + break; } } + if (!(cd->flags & STREAM_DONE)) { + /* if we have pending input data, but no available output buffer */ + if (cd->inStream.avail_in && !cd->inStream.avail_out) { + /* next time try to decompress it got readable (new output buffer) */ + cd->flags |= STREAM_DECOMPRESS; + } + } + + return resBytes; + handleError: errObj = Tcl_NewListObj(0, NULL); Tcl_ListObjAppendElement(NULL, errObj, Tcl_NewStringObj("-errorcode",-1)); @@ -3876,7 +3852,7 @@ ResultGenerate( Tcl_NewStringObj(cd->inStream.msg, -1)); Tcl_SetChannelError(cd->parent, errObj); *errorCodePtr = EINVAL; - return TCL_ERROR; + return -1; } /* -- cgit v0.12 From dc1e5ec547a5635acaa9d6c052c696db6bc87849 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 27 May 2020 13:58:09 +0000 Subject: Proposed soution for [a1bd37b719]: clock (free)scan of ISO 8601 timestamp with literal T behaves strange (I like it!) --- doc/clock.n | 5 +- generic/tclDate.c | 132 +++++++++++++++++++++++++++++---------------------- generic/tclGetDate.y | 12 ++++- tests/clock.test | 12 ++++- 4 files changed, 99 insertions(+), 62 deletions(-) diff --git a/doc/clock.n b/doc/clock.n index f0f6c37..8b9982c 100644 --- a/doc/clock.n +++ b/doc/clock.n @@ -913,9 +913,10 @@ An ISO 8601 point-in-time specification, such as where \fBT\fR is the literal .QW T , .QW "\fICCyymmdd hhmmss\fR" , +.QW \fICCyymmdd\fBT\fIhh:mm:ss\fR , or -.QW \fICCyymmdd\fBT\fIhh:mm:ss\fR . -Note that only these three formats are accepted. +.QW \fICCyy-mm-dd\fBT\fIhh:mm:ss\fR. +Note that only these four formats are accepted. The command does \fInot\fR accept the full range of point-in-time specifications specified in ISO8601. Other formats can be recognized by giving an explicit \fB\-format\fR option to the \fBclock scan\fR command. diff --git a/generic/tclDate.c b/generic/tclDate.c index ea1f0f3..7b32604 100644 --- a/generic/tclDate.c +++ b/generic/tclDate.c @@ -129,6 +129,7 @@ * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. + * */ #include "tclInt.h" @@ -281,7 +282,7 @@ typedef union YYSTYPE time_t Number; enum _MERIDIAN Meridian; } -/* Line 187 of yacc.c. */ +/* Line 193 of yacc.c. */ YYSTYPE; # define yystype YYSTYPE /* obsolescent; will be withdrawn */ @@ -534,16 +535,16 @@ union yyalloc /* YYFINAL -- State number of the termination state. */ #define YYFINAL 2 /* YYLAST -- Last index in YYTABLE. */ -#define YYLAST 79 +#define YYLAST 86 /* YYNTOKENS -- Number of terminals. */ #define YYNTOKENS 26 /* YYNNTS -- Number of nonterminals. */ #define YYNNTS 16 /* YYNRULES -- Number of rules. */ -#define YYNRULES 56 +#define YYNRULES 57 /* YYNRULES -- Number of states. */ -#define YYNSTATES 83 +#define YYNSTATES 89 /* YYTRANSLATE(YYLEX) -- Bison symbol number corresponding to YYLEX. */ #define YYUNDEFTOK 2 @@ -593,9 +594,9 @@ static const yytype_uint8 yyprhs[] = 0, 0, 3, 4, 7, 9, 11, 13, 15, 17, 19, 21, 23, 25, 28, 33, 39, 46, 54, 57, 59, 61, 63, 66, 69, 73, 76, 80, 86, 88, - 94, 100, 103, 108, 111, 113, 117, 120, 124, 128, - 136, 139, 144, 147, 149, 153, 156, 159, 163, 165, - 167, 169, 171, 173, 175, 177, 178 + 94, 100, 103, 108, 111, 113, 117, 120, 124, 136, + 140, 148, 151, 156, 159, 161, 165, 168, 171, 175, + 177, 179, 181, 183, 185, 187, 189, 190 }; /* YYRHS -- A `-1'-separated list of the rules' RHS. */ @@ -613,23 +614,25 @@ static const yytype_int8 yyrhs[] = 8, 21, 13, -1, 13, 21, 13, 21, 13, -1, 8, 13, -1, 8, 13, 22, 13, -1, 13, 8, -1, 15, -1, 13, 8, 13, -1, 19, 8, -1, - 19, 13, 8, -1, 17, 14, 17, -1, 17, 14, - 13, 20, 13, 20, 13, -1, 17, 17, -1, 10, - 13, 24, 13, -1, 37, 3, -1, 37, -1, 38, - 13, 39, -1, 13, 39, -1, 19, 39, -1, 19, - 13, 39, -1, 39, -1, 21, -1, 25, -1, 11, - -1, 18, -1, 9, -1, 13, -1, -1, 7, -1 + 19, 13, 8, -1, 13, 21, 13, 21, 13, 14, + 13, 20, 13, 20, 13, -1, 17, 14, 17, -1, + 17, 14, 13, 20, 13, 20, 13, -1, 17, 17, + -1, 10, 13, 24, 13, -1, 37, 3, -1, 37, + -1, 38, 13, 39, -1, 13, 39, -1, 19, 39, + -1, 19, 13, 39, -1, 39, -1, 21, -1, 25, + -1, 11, -1, 18, -1, 9, -1, 13, -1, -1, + 7, -1 }; /* YYRLINE[YYN] -- source line where rule number YYN was defined. */ static const yytype_uint16 yyrline[] = { - 0, 225, 225, 226, 229, 232, 235, 238, 241, 244, - 247, 251, 256, 259, 265, 271, 279, 285, 296, 300, - 304, 310, 314, 318, 322, 326, 332, 336, 341, 346, - 351, 356, 360, 365, 369, 374, 381, 385, 391, 400, - 409, 419, 433, 438, 441, 444, 447, 450, 453, 458, - 461, 466, 470, 474, 480, 498, 501 + 0, 223, 223, 224, 227, 230, 233, 236, 239, 242, + 245, 249, 254, 257, 263, 269, 277, 283, 294, 298, + 302, 308, 312, 316, 320, 324, 330, 334, 339, 344, + 349, 354, 358, 363, 367, 372, 379, 383, 389, 399, + 408, 417, 427, 441, 446, 449, 452, 455, 458, 461, + 466, 469, 474, 478, 482, 488, 506, 509 }; #endif @@ -666,8 +669,8 @@ static const yytype_uint8 yyr1[] = 28, 28, 28, 29, 29, 29, 29, 29, 30, 30, 30, 31, 31, 31, 31, 31, 32, 32, 32, 32, 32, 32, 32, 32, 32, 32, 33, 33, 34, 34, - 34, 35, 36, 36, 37, 37, 37, 37, 37, 38, - 38, 39, 39, 39, 40, 41, 41 + 34, 34, 35, 36, 36, 37, 37, 37, 37, 37, + 38, 38, 39, 39, 39, 40, 41, 41 }; /* YYR2[YYN] -- Number of symbols composing right hand side of rule YYN. */ @@ -676,9 +679,9 @@ static const yytype_uint8 yyr2[] = 0, 2, 0, 2, 1, 1, 1, 1, 1, 1, 1, 1, 1, 2, 4, 5, 6, 7, 2, 1, 1, 1, 2, 2, 3, 2, 3, 5, 1, 5, - 5, 2, 4, 2, 1, 3, 2, 3, 3, 7, - 2, 4, 2, 1, 3, 2, 2, 3, 1, 1, - 1, 1, 1, 1, 1, 0, 1 + 5, 2, 4, 2, 1, 3, 2, 3, 11, 3, + 7, 2, 4, 2, 1, 3, 2, 2, 3, 1, + 1, 1, 1, 1, 1, 1, 0, 1 }; /* YYDEFACT[STATE-NAME] -- Default rule to reduce with in state @@ -686,15 +689,15 @@ static const yytype_uint8 yyr2[] = means the default is an error. */ static const yytype_uint8 yydefact[] = { - 2, 0, 1, 21, 20, 0, 53, 0, 51, 54, - 19, 34, 28, 52, 0, 49, 50, 3, 4, 5, - 8, 6, 7, 10, 11, 9, 43, 0, 48, 12, - 22, 31, 0, 23, 13, 33, 0, 0, 0, 45, - 18, 0, 40, 25, 36, 0, 46, 42, 0, 0, - 0, 35, 55, 0, 0, 26, 0, 38, 37, 47, - 24, 44, 32, 41, 56, 0, 0, 14, 0, 0, - 0, 0, 55, 15, 29, 30, 27, 0, 0, 16, - 0, 17, 39 + 2, 0, 1, 21, 20, 0, 54, 0, 52, 55, + 19, 34, 28, 53, 0, 50, 51, 3, 4, 5, + 8, 6, 7, 10, 11, 9, 44, 0, 49, 12, + 22, 31, 0, 23, 13, 33, 0, 0, 0, 46, + 18, 0, 41, 25, 36, 0, 47, 43, 0, 0, + 0, 35, 56, 0, 0, 26, 0, 39, 37, 48, + 24, 45, 32, 42, 57, 0, 0, 14, 0, 0, + 0, 0, 56, 15, 29, 30, 27, 0, 0, 16, + 0, 0, 17, 0, 40, 0, 0, 0, 38 }; /* YYDEFGOTO[NTERM-NUM]. */ @@ -716,15 +719,15 @@ static const yytype_int8 yypact[] = -22, 15, -22, -22, -22, 48, -22, -22, 43, 50, 51, -22, 17, 44, 46, 45, 52, -22, -22, -22, -22, -22, -22, -22, -22, 56, 57, -22, 58, 60, - 61, 62, -3, -22, -22, -22, -22, 59, 63, -22, - 64, -22, -22 + 61, 62, -3, -22, -22, 63, -22, 59, 65, -22, + 67, 68, -22, 64, -22, 69, 66, 70, -22 }; /* YYPGOTO[NTERM-NUM]. */ static const yytype_int8 yypgoto[] = { -22, -22, -22, -22, -22, -22, -22, -22, -22, -22, - -22, -22, -22, -9, -22, 6 + -22, -22, -22, -9, -22, 4 }; /* YYTABLE[YYPACT[STATE-NUM]]. What to do in state STATE-NUM. If @@ -741,10 +744,11 @@ static const yytype_uint8 yytable[] = 13, 48, 36, 37, 43, 38, 49, 60, 44, 6, 50, 8, 6, 45, 8, 51, 58, 6, 13, 8, 52, 13, 55, 62, 63, 68, 13, 69, 70, 72, - 73, 74, 71, 75, 76, 77, 81, 82, 79, 80 + 73, 74, 71, 75, 76, 77, 79, 80, 82, 81, + 83, 84, 86, 88, 85, 0, 87 }; -static const yytype_uint8 yycheck[] = +static const yytype_int8 yycheck[] = { 9, 22, 0, 8, 7, 14, 4, 5, 13, 13, 8, 9, 10, 11, 13, 13, 14, 15, 21, 17, @@ -753,7 +757,8 @@ static const yytype_uint8 yycheck[] = 18, 13, 20, 21, 4, 23, 22, 4, 8, 9, 24, 11, 9, 13, 11, 13, 8, 9, 18, 11, 13, 18, 13, 13, 13, 21, 18, 21, 23, 13, - 13, 13, 20, 13, 13, 13, 13, 13, 72, 20 + 13, 13, 20, 13, 13, 13, 72, 14, 13, 20, + 13, 13, 13, 13, 20, -1, 20 }; /* YYSTOS[STATE-NUM] -- The (internal number of the) accessing @@ -768,7 +773,7 @@ static const yytype_uint8 yystos[] = 24, 13, 13, 8, 13, 13, 13, 17, 8, 39, 4, 39, 13, 13, 7, 20, 21, 41, 21, 21, 23, 20, 13, 13, 13, 13, 13, 13, 21, 41, - 20, 13, 13 + 14, 20, 13, 13, 13, 20, 13, 20, 13 }; #define yyerrok (yyerrstatus = 0) @@ -1894,6 +1899,19 @@ yyreduce: case 38: { + if ((yyvsp[(6) - (11)].Number) != HOUR( 7)) YYABORT; + yyYear = (yyvsp[(1) - (11)].Number); + yyMonth = (yyvsp[(3) - (11)].Number); + yyDay = (yyvsp[(5) - (11)].Number); + yyHour = (yyvsp[(7) - (11)].Number); + yyMinutes = (yyvsp[(9) - (11)].Number); + yySeconds = (yyvsp[(11) - (11)].Number); + ;} + break; + + case 39: + + { if ((yyvsp[(2) - (3)].Number) != HOUR( 7)) YYABORT; yyYear = (yyvsp[(1) - (3)].Number) / 10000; yyMonth = ((yyvsp[(1) - (3)].Number) % 10000)/100; @@ -1904,7 +1922,7 @@ yyreduce: ;} break; - case 39: + case 40: { if ((yyvsp[(2) - (7)].Number) != HOUR( 7)) YYABORT; @@ -1917,7 +1935,7 @@ yyreduce: ;} break; - case 40: + case 41: { yyYear = (yyvsp[(1) - (2)].Number) / 10000; @@ -1929,7 +1947,7 @@ yyreduce: ;} break; - case 41: + case 42: { /* @@ -1945,7 +1963,7 @@ yyreduce: ;} break; - case 42: + case 43: { yyRelSeconds *= -1; @@ -1954,56 +1972,56 @@ yyreduce: ;} break; - case 44: + case 45: { *yyRelPointer += (yyvsp[(1) - (3)].Number) * (yyvsp[(2) - (3)].Number) * (yyvsp[(3) - (3)].Number); ;} break; - case 45: + case 46: { *yyRelPointer += (yyvsp[(1) - (2)].Number) * (yyvsp[(2) - (2)].Number); ;} break; - case 46: + case 47: { *yyRelPointer += (yyvsp[(2) - (2)].Number); ;} break; - case 47: + case 48: { *yyRelPointer += (yyvsp[(2) - (3)].Number) * (yyvsp[(3) - (3)].Number); ;} break; - case 48: + case 49: { *yyRelPointer += (yyvsp[(1) - (1)].Number); ;} break; - case 49: + case 50: { (yyval.Number) = -1; ;} break; - case 50: + case 51: { (yyval.Number) = 1; ;} break; - case 51: + case 52: { (yyval.Number) = (yyvsp[(1) - (1)].Number); @@ -2011,7 +2029,7 @@ yyreduce: ;} break; - case 52: + case 53: { (yyval.Number) = (yyvsp[(1) - (1)].Number); @@ -2019,7 +2037,7 @@ yyreduce: ;} break; - case 53: + case 54: { (yyval.Number) = (yyvsp[(1) - (1)].Number); @@ -2027,7 +2045,7 @@ yyreduce: ;} break; - case 54: + case 55: { if (yyHaveTime && yyHaveDate && !yyHaveRel) { @@ -2047,14 +2065,14 @@ yyreduce: ;} break; - case 55: + case 56: { (yyval.Meridian) = MER24; ;} break; - case 56: + case 57: { (yyval.Meridian) = (yyvsp[(1) - (1)].Meridian); diff --git a/generic/tclGetDate.y b/generic/tclGetDate.y index ce7c2ce..4ef10d8 100644 --- a/generic/tclGetDate.y +++ b/generic/tclGetDate.y @@ -386,7 +386,17 @@ ordMonth: tNEXT tMONTH { } ; -iso : tISOBASE tZONE tISOBASE { +iso : tUNUMBER '-' tUNUMBER '-' tUNUMBER tZONE + tUNUMBER ':' tUNUMBER ':' tUNUMBER { + if ($6 != HOUR( 7)) YYABORT; + yyYear = $1; + yyMonth = $3; + yyDay = $5; + yyHour = $7; + yyMinutes = $9; + yySeconds = $11; + } + | tISOBASE tZONE tISOBASE { if ($2 != HOUR( 7)) YYABORT; yyYear = $1 / 10000; yyMonth = ($1 % 10000)/100; diff --git a/tests/clock.test b/tests/clock.test index 9c59b03..df0315b 100644 --- a/tests/clock.test +++ b/tests/clock.test @@ -35474,7 +35474,7 @@ test clock-33.5 {clock clicks tests, millisecond timing test} { # 60 msecs seems to be the max time slice under Windows 95/98 expr { ($end > $start) && (($end - $start) <= 60) ? - "ok" : + "ok" : "test should have taken 0-60 ms, actually took [expr $end - $start]"} } {ok} test clock-33.5a {clock tests, millisecond timing test} { @@ -35490,7 +35490,7 @@ test clock-33.5a {clock tests, millisecond timing test} { # 60 msecs seems to be the max time slice under Windows 95/98 expr { ($end > $start) && (($end - $start) <= 60) ? - "ok" : + "ok" : "test should have taken 0-60 ms, actually took [expr $end - $start]"} } {ok} test clock-33.6 {clock clicks, milli with too much abbreviation} { @@ -35664,6 +35664,14 @@ test clock-34.18 {clock scan, ISO 8601 point in time format} { set time [clock scan "19921023T000000"] clock format $time -format {%b %d, %Y %H:%M:%S} } "Oct 23, 1992 00:00:00" +test clock-34.19 {clock scan, ISO 8601 point in time format} { + set time [clock scan "19921023T00:00:00"] + clock format $time -format {%b %d, %Y %H:%M:%S} +} "Oct 23, 1992 00:00:00" +test clock-34.20 {clock scan, ISO 8601 point in time format} { + set time [clock scan "1992-10-23T00:00:00"] + clock format $time -format {%b %d, %Y %H:%M:%S} +} "Oct 23, 1992 00:00:00" # CLOCK SCAN REAL TESTS # We use 5am PST, 31-12-1999 as the base for these scans because irrespective -- cgit v0.12 From 2956fdc0e0aee7805920004202230103f98d11a9 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 27 May 2020 21:11:36 +0000 Subject: clock-iso-2.patch --- generic/tclDate.c | 68 +++++++++++++++++++++++++++------------------------- generic/tclGetDate.y | 58 ++++++++++++++++++++++---------------------- tests/clock.test | 16 +++++++++++++ 3 files changed, 81 insertions(+), 61 deletions(-) diff --git a/generic/tclDate.c b/generic/tclDate.c index 7b32604..3a7e46e 100644 --- a/generic/tclDate.c +++ b/generic/tclDate.c @@ -628,11 +628,11 @@ static const yytype_int8 yyrhs[] = static const yytype_uint16 yyrline[] = { 0, 223, 223, 224, 227, 230, 233, 236, 239, 242, - 245, 249, 254, 257, 263, 269, 277, 283, 294, 298, - 302, 308, 312, 316, 320, 324, 330, 334, 339, 344, - 349, 354, 358, 363, 367, 372, 379, 383, 389, 399, - 408, 417, 427, 441, 446, 449, 452, 455, 458, 461, - 466, 469, 474, 478, 482, 488, 506, 509 + 245, 249, 254, 257, 263, 269, 277, 283, 294, 299, + 304, 310, 314, 318, 322, 326, 332, 336, 341, 346, + 351, 356, 360, 365, 369, 374, 381, 385, 391, 401, + 410, 419, 429, 443, 448, 451, 454, 457, 460, 463, + 468, 471, 476, 480, 484, 490, 508, 511 }; #endif @@ -1733,6 +1733,7 @@ yyreduce: { yyTimezone = (yyvsp[(1) - (2)].Number); + if (yyTimezone > HOUR( 12)) yyTimezone -= HOUR(100); yyDSTmode = DSTon; ;} break; @@ -1741,6 +1742,7 @@ yyreduce: { yyTimezone = (yyvsp[(1) - (1)].Number); + if (yyTimezone > HOUR( 12)) yyTimezone -= HOUR(100); yyDSTmode = DSToff; ;} break; @@ -1899,7 +1901,7 @@ yyreduce: case 38: { - if ((yyvsp[(6) - (11)].Number) != HOUR( 7)) YYABORT; + if ((yyvsp[(6) - (11)].Number) != HOUR( 7) + HOUR(100)) YYABORT; yyYear = (yyvsp[(1) - (11)].Number); yyMonth = (yyvsp[(3) - (11)].Number); yyDay = (yyvsp[(5) - (11)].Number); @@ -1912,7 +1914,7 @@ yyreduce: case 39: { - if ((yyvsp[(2) - (3)].Number) != HOUR( 7)) YYABORT; + if ((yyvsp[(2) - (3)].Number) != HOUR( 7) + HOUR(100)) YYABORT; yyYear = (yyvsp[(1) - (3)].Number) / 10000; yyMonth = ((yyvsp[(1) - (3)].Number) % 10000)/100; yyDay = (yyvsp[(1) - (3)].Number) % 100; @@ -1925,7 +1927,7 @@ yyreduce: case 40: { - if ((yyvsp[(2) - (7)].Number) != HOUR( 7)) YYABORT; + if ((yyvsp[(2) - (7)].Number) != HOUR( 7) + HOUR(100)) YYABORT; yyYear = (yyvsp[(1) - (7)].Number) / 10000; yyMonth = ((yyvsp[(1) - (7)].Number) % 10000)/100; yyDay = (yyvsp[(1) - (7)].Number) % 100; @@ -2476,31 +2478,31 @@ static const TABLE TimezoneTable[] = { */ static const TABLE MilitaryTable[] = { - { "a", tZONE, -HOUR( 1) }, - { "b", tZONE, -HOUR( 2) }, - { "c", tZONE, -HOUR( 3) }, - { "d", tZONE, -HOUR( 4) }, - { "e", tZONE, -HOUR( 5) }, - { "f", tZONE, -HOUR( 6) }, - { "g", tZONE, -HOUR( 7) }, - { "h", tZONE, -HOUR( 8) }, - { "i", tZONE, -HOUR( 9) }, - { "k", tZONE, -HOUR(10) }, - { "l", tZONE, -HOUR(11) }, - { "m", tZONE, -HOUR(12) }, - { "n", tZONE, HOUR( 1) }, - { "o", tZONE, HOUR( 2) }, - { "p", tZONE, HOUR( 3) }, - { "q", tZONE, HOUR( 4) }, - { "r", tZONE, HOUR( 5) }, - { "s", tZONE, HOUR( 6) }, - { "t", tZONE, HOUR( 7) }, - { "u", tZONE, HOUR( 8) }, - { "v", tZONE, HOUR( 9) }, - { "w", tZONE, HOUR( 10) }, - { "x", tZONE, HOUR( 11) }, - { "y", tZONE, HOUR( 12) }, - { "z", tZONE, HOUR( 0) }, + { "a", tZONE, -HOUR( 1) + HOUR(100) }, + { "b", tZONE, -HOUR( 2) + HOUR(100) }, + { "c", tZONE, -HOUR( 3) + HOUR(100) }, + { "d", tZONE, -HOUR( 4) + HOUR(100) }, + { "e", tZONE, -HOUR( 5) + HOUR(100) }, + { "f", tZONE, -HOUR( 6) + HOUR(100) }, + { "g", tZONE, -HOUR( 7) + HOUR(100) }, + { "h", tZONE, -HOUR( 8) + HOUR(100) }, + { "i", tZONE, -HOUR( 9) + HOUR(100) }, + { "k", tZONE, -HOUR(10) + HOUR(100) }, + { "l", tZONE, -HOUR(11) + HOUR(100) }, + { "m", tZONE, -HOUR(12) + HOUR(100) }, + { "n", tZONE, HOUR( 1) + HOUR(100) }, + { "o", tZONE, HOUR( 2) + HOUR(100) }, + { "p", tZONE, HOUR( 3) + HOUR(100) }, + { "q", tZONE, HOUR( 4) + HOUR(100) }, + { "r", tZONE, HOUR( 5) + HOUR(100) }, + { "s", tZONE, HOUR( 6) + HOUR(100) }, + { "t", tZONE, HOUR( 7) + HOUR(100) }, + { "u", tZONE, HOUR( 8) + HOUR(100) }, + { "v", tZONE, HOUR( 9) + HOUR(100) }, + { "w", tZONE, HOUR( 10) + HOUR(100) }, + { "x", tZONE, HOUR( 11) + HOUR(100) }, + { "y", tZONE, HOUR( 12) + HOUR(100) }, + { "z", tZONE, HOUR( 0) + HOUR(100) }, { NULL, 0, 0 } }; diff --git a/generic/tclGetDate.y b/generic/tclGetDate.y index 4ef10d8..2bf211b 100644 --- a/generic/tclGetDate.y +++ b/generic/tclGetDate.y @@ -293,10 +293,12 @@ time : tUNUMBER tMERIDIAN { zone : tZONE tDST { yyTimezone = $1; + if (yyTimezone > HOUR( 12)) yyTimezone -= HOUR(100); yyDSTmode = DSTon; } | tZONE { yyTimezone = $1; + if (yyTimezone > HOUR( 12)) yyTimezone -= HOUR(100); yyDSTmode = DSToff; } | tDAYZONE { @@ -388,7 +390,7 @@ ordMonth: tNEXT tMONTH { iso : tUNUMBER '-' tUNUMBER '-' tUNUMBER tZONE tUNUMBER ':' tUNUMBER ':' tUNUMBER { - if ($6 != HOUR( 7)) YYABORT; + if ($6 != HOUR( 7) + HOUR(100)) YYABORT; yyYear = $1; yyMonth = $3; yyDay = $5; @@ -397,7 +399,7 @@ iso : tUNUMBER '-' tUNUMBER '-' tUNUMBER tZONE yySeconds = $11; } | tISOBASE tZONE tISOBASE { - if ($2 != HOUR( 7)) YYABORT; + if ($2 != HOUR( 7) + HOUR(100)) YYABORT; yyYear = $1 / 10000; yyMonth = ($1 % 10000)/100; yyDay = $1 % 100; @@ -406,7 +408,7 @@ iso : tUNUMBER '-' tUNUMBER '-' tUNUMBER tZONE yySeconds = $3 % 100; } | tISOBASE tZONE tUNUMBER ':' tUNUMBER ':' tUNUMBER { - if ($2 != HOUR( 7)) YYABORT; + if ($2 != HOUR( 7) + HOUR(100)) YYABORT; yyYear = $1 / 10000; yyMonth = ($1 % 10000)/100; yyDay = $1 % 100; @@ -685,31 +687,31 @@ static const TABLE TimezoneTable[] = { */ static const TABLE MilitaryTable[] = { - { "a", tZONE, -HOUR( 1) }, - { "b", tZONE, -HOUR( 2) }, - { "c", tZONE, -HOUR( 3) }, - { "d", tZONE, -HOUR( 4) }, - { "e", tZONE, -HOUR( 5) }, - { "f", tZONE, -HOUR( 6) }, - { "g", tZONE, -HOUR( 7) }, - { "h", tZONE, -HOUR( 8) }, - { "i", tZONE, -HOUR( 9) }, - { "k", tZONE, -HOUR(10) }, - { "l", tZONE, -HOUR(11) }, - { "m", tZONE, -HOUR(12) }, - { "n", tZONE, HOUR( 1) }, - { "o", tZONE, HOUR( 2) }, - { "p", tZONE, HOUR( 3) }, - { "q", tZONE, HOUR( 4) }, - { "r", tZONE, HOUR( 5) }, - { "s", tZONE, HOUR( 6) }, - { "t", tZONE, HOUR( 7) }, - { "u", tZONE, HOUR( 8) }, - { "v", tZONE, HOUR( 9) }, - { "w", tZONE, HOUR( 10) }, - { "x", tZONE, HOUR( 11) }, - { "y", tZONE, HOUR( 12) }, - { "z", tZONE, HOUR( 0) }, + { "a", tZONE, -HOUR( 1) + HOUR(100) }, + { "b", tZONE, -HOUR( 2) + HOUR(100) }, + { "c", tZONE, -HOUR( 3) + HOUR(100) }, + { "d", tZONE, -HOUR( 4) + HOUR(100) }, + { "e", tZONE, -HOUR( 5) + HOUR(100) }, + { "f", tZONE, -HOUR( 6) + HOUR(100) }, + { "g", tZONE, -HOUR( 7) + HOUR(100) }, + { "h", tZONE, -HOUR( 8) + HOUR(100) }, + { "i", tZONE, -HOUR( 9) + HOUR(100) }, + { "k", tZONE, -HOUR(10) + HOUR(100) }, + { "l", tZONE, -HOUR(11) + HOUR(100) }, + { "m", tZONE, -HOUR(12) + HOUR(100) }, + { "n", tZONE, HOUR( 1) + HOUR(100) }, + { "o", tZONE, HOUR( 2) + HOUR(100) }, + { "p", tZONE, HOUR( 3) + HOUR(100) }, + { "q", tZONE, HOUR( 4) + HOUR(100) }, + { "r", tZONE, HOUR( 5) + HOUR(100) }, + { "s", tZONE, HOUR( 6) + HOUR(100) }, + { "t", tZONE, HOUR( 7) + HOUR(100) }, + { "u", tZONE, HOUR( 8) + HOUR(100) }, + { "v", tZONE, HOUR( 9) + HOUR(100) }, + { "w", tZONE, HOUR( 10) + HOUR(100) }, + { "x", tZONE, HOUR( 11) + HOUR(100) }, + { "y", tZONE, HOUR( 12) + HOUR(100) }, + { "z", tZONE, HOUR( 0) + HOUR(100) }, { NULL, 0, 0 } }; diff --git a/tests/clock.test b/tests/clock.test index df0315b..f7da08f 100644 --- a/tests/clock.test +++ b/tests/clock.test @@ -35672,6 +35672,22 @@ test clock-34.20 {clock scan, ISO 8601 point in time format} { set time [clock scan "1992-10-23T00:00:00"] clock format $time -format {%b %d, %Y %H:%M:%S} } "Oct 23, 1992 00:00:00" +test clock-34.21 {clock scan, ISO 8601 invalid TZ} -body { + set time [clock scan "19921023MST000000"] + clock format $time -format {%b %d, %Y %H:%M:%S} +} -returnCodes error -match glob -result {unable to convert date-time string*} +test clock-34.22 {clock scan, ISO 8601 invalid TZ} -body { + set time [clock scan "19921023M000000"] + clock format $time -format {%b %d, %Y %H:%M:%S} +} -returnCodes error -match glob -result {unable to convert date-time string*} +test clock-34.23 {clock scan, ISO 8601 invalid TZ} -body { + set time [clock scan "1992-10-23M00:00:00"] + clock format $time -format {%b %d, %Y %H:%M:%S} +} -returnCodes error -match glob -result {unable to convert date-time string*} +test clock-34.24 {clock scan, ISO 8601 invalid TZ} -body { + set time [clock scan "1992-10-23MST00:00:00"] + clock format $time -format {%b %d, %Y %H:%M:%S} +} -returnCodes error -match glob -result {unable to convert date-time string*} # CLOCK SCAN REAL TESTS # We use 5am PST, 31-12-1999 as the base for these scans because irrespective -- cgit v0.12 From ad53d45452569292a42e5c120a2da8f32d7fdb7c Mon Sep 17 00:00:00 2001 From: culler Date: Sat, 6 Jun 2020 21:23:50 +0000 Subject: Address macOS hangs in Tcl_WaitForEvent. --- macosx/tclMacOSXNotify.c | 29 +++++++++++++++-------------- 1 file changed, 15 insertions(+), 14 deletions(-) diff --git a/macosx/tclMacOSXNotify.c b/macosx/tclMacOSXNotify.c index 9b7bd1a..21d95e5 100644 --- a/macosx/tclMacOSXNotify.c +++ b/macosx/tclMacOSXNotify.c @@ -1243,6 +1243,13 @@ Tcl_WaitForEvent( */ polling = 1; + + /* + * Set a small positive waitTime so that when the runloop is started + * it will process all of its sources. + */ + + waitTime = 0.005; } } @@ -1264,11 +1271,16 @@ Tcl_WaitForEvent( runLoopRunning = tsdPtr->runLoopRunning; tsdPtr->runLoopRunning = 1; - runLoopStatus = CFRunLoopRunInMode(tsdPtr->runLoopServicingEvents || - runLoopRunning ? tclEventsOnlyRunLoopMode : kCFRunLoopDefaultMode, - waitTime, TRUE); + runLoopStatus = CFRunLoopRunInMode( + tsdPtr->runLoopServicingEvents || runLoopRunning ? + tclEventsOnlyRunLoopMode : kCFRunLoopDefaultMode, + waitTime, TRUE); tsdPtr->runLoopRunning = runLoopRunning; + if (polling) { + return tsdPtr->runLoopSourcePerformed ? 0 : 1; + } + LOCK_NOTIFIER_TSD; tsdPtr->polling = 0; UNLOCK_NOTIFIER_TSD; @@ -1384,7 +1396,6 @@ UpdateWaitingListAndServiceEvents( void *info) { ThreadSpecificData *tsdPtr = info; - if (tsdPtr->sleeping) { return; } @@ -1407,16 +1418,6 @@ UpdateWaitingListAndServiceEvents( } tsdPtr->runLoopNestingLevel--; break; - case kCFRunLoopBeforeWaiting: - if (tsdPtr->runLoopTimer && !tsdPtr->runLoopServicingEvents && - (tsdPtr->runLoopNestingLevel > 1 - || !tsdPtr->runLoopRunning)) { - tsdPtr->runLoopServicingEvents = 1; - /* This call seems to simply force event processing through and prevents hangups that have long been observed with Tk-Cocoa. */ - Tcl_ServiceAll(); - tsdPtr->runLoopServicingEvents = 0; - } - break; default: break; } -- cgit v0.12 From b345d9a593684ec1fd404884947fa1b5298d1af9 Mon Sep 17 00:00:00 2001 From: culler Date: Sun, 7 Jun 2020 22:15:28 +0000 Subject: Code simplification and cleanup --- macosx/tclMacOSXNotify.c | 41 ++++++++++++++++------------------------- 1 file changed, 16 insertions(+), 25 deletions(-) diff --git a/macosx/tclMacOSXNotify.c b/macosx/tclMacOSXNotify.c index 21d95e5..6f27e64 100644 --- a/macosx/tclMacOSXNotify.c +++ b/macosx/tclMacOSXNotify.c @@ -494,7 +494,7 @@ Tcl_InitNotifier(void) bzero(&runLoopObserverContext, sizeof(CFRunLoopObserverContext)); runLoopObserverContext.info = tsdPtr; runLoopObserver = CFRunLoopObserverCreate(NULL, - kCFRunLoopEntry|kCFRunLoopExit|kCFRunLoopBeforeWaiting, TRUE, + kCFRunLoopEntry|kCFRunLoopExit, TRUE, LONG_MIN, UpdateWaitingListAndServiceEvents, &runLoopObserverContext); if (!runLoopObserver) { @@ -512,7 +512,7 @@ Tcl_InitNotifier(void) */ runLoopObserverTcl = CFRunLoopObserverCreate(NULL, - kCFRunLoopEntry|kCFRunLoopExit|kCFRunLoopBeforeWaiting, TRUE, + kCFRunLoopEntry|kCFRunLoopExit, TRUE, LONG_MIN, UpdateWaitingListAndServiceEvents, &runLoopObserverContext); if (!runLoopObserverTcl) { @@ -1222,6 +1222,10 @@ Tcl_WaitForEvent( Tcl_Panic("Tcl_WaitForEvent: Notifier not initialized"); } + /* + * A NULL timePtr means wait forever. + */ + if (timePtr) { Tcl_Time vTime = *timePtr; @@ -1235,26 +1239,18 @@ Tcl_WaitForEvent( tclScaleTimeProcPtr(&vTime, tclTimeClientData); waitTime = vTime.sec + 1.0e-6 * vTime.usec; } else { - /* - * Polling: pretend to wait for files and tell the notifier thread - * what we are doing. The notifier thread makes sure it goes - * through select with its select mask in the same state as ours - * currently is. We block until that happens. - */ - - polling = 1; /* - * Set a small positive waitTime so that when the runloop is started - * it will process all of its sources. + * The max block time was set to 0. */ - waitTime = 0.005; + polling = 1; + waitTime = 0; } } StartNotifierThread(); - + LOCK_NOTIFIER_TSD; tsdPtr->polling = polling; UNLOCK_NOTIFIER_TSD; @@ -1262,25 +1258,20 @@ Tcl_WaitForEvent( /* * If the Tcl runloop is already running (e.g. if Tcl_WaitForEvent was - * called recursively) or is servicing events via the runloop observer, - * re-run it in a custom runloop mode containing only the source for the - * notifier thread, otherwise wakeups from other sources added to the - * common runloop modes might get lost or 3rd party event handlers might - * get called when they do not expect to be. + * called recursively) start a new runloop in a custom runloop mode + * containing only the source for the notifier thread. Otherwise wakeups + * from other sources added to the common runloop mode might get lost or + * 3rd party event handlers might get called when they do not expect to + * be. */ runLoopRunning = tsdPtr->runLoopRunning; tsdPtr->runLoopRunning = 1; runLoopStatus = CFRunLoopRunInMode( - tsdPtr->runLoopServicingEvents || runLoopRunning ? - tclEventsOnlyRunLoopMode : kCFRunLoopDefaultMode, + runLoopRunning ? tclEventsOnlyRunLoopMode : kCFRunLoopDefaultMode, waitTime, TRUE); tsdPtr->runLoopRunning = runLoopRunning; - if (polling) { - return tsdPtr->runLoopSourcePerformed ? 0 : 1; - } - LOCK_NOTIFIER_TSD; tsdPtr->polling = 0; UNLOCK_NOTIFIER_TSD; -- cgit v0.12 From 476d33d6b64feb9beb632647c35619343d3fe732 Mon Sep 17 00:00:00 2001 From: culler Date: Thu, 18 Jun 2020 20:02:01 +0000 Subject: Sometimes the waitTime needs to be positive to avoid missing channel io events. --- macosx/tclMacOSXNotify.c | 18 +++++++++++++----- 1 file changed, 13 insertions(+), 5 deletions(-) diff --git a/macosx/tclMacOSXNotify.c b/macosx/tclMacOSXNotify.c index 6f27e64..4ce6786 100644 --- a/macosx/tclMacOSXNotify.c +++ b/macosx/tclMacOSXNotify.c @@ -255,8 +255,6 @@ typedef struct ThreadSpecificData { int runLoopRunning; /* True if this thread's Tcl runLoop is * running. */ int runLoopNestingLevel; /* Level of nested runLoop invocations. */ - int runLoopServicingEvents; /* True if this thread's runLoop is servicing - * Tcl events. */ /* Must hold the notifierLock before accessing the following fields: */ /* Start notifierLock section */ @@ -1225,7 +1223,7 @@ Tcl_WaitForEvent( /* * A NULL timePtr means wait forever. */ - + if (timePtr) { Tcl_Time vTime = *timePtr; @@ -1242,15 +1240,25 @@ Tcl_WaitForEvent( /* * The max block time was set to 0. + * + * If we set the waitTime to 0, then the call to CFRunLoopInMode + * may return without processing all of its sources. The Apple + * documentation says that if the waitTime is 0 "only one pass is + * made through the run loop before returning; if multiple sources + * or timers are ready to fire immediately, only one (possibly two + * if one is a version 0 source) will be fired, regardless of the + * value of returnAfterSourceHandled." This can cause some chanio + * tests to fail. So we use a small positive waitTime unless there + * is another RunLoop running. */ polling = 1; - waitTime = 0; + waitTime = tsdPtr->runLoopRunning ? 0 : 0.0001; } } StartNotifierThread(); - + LOCK_NOTIFIER_TSD; tsdPtr->polling = polling; UNLOCK_NOTIFIER_TSD; -- cgit v0.12 From a0457efe80223c1380e9e0fc6a50c755fc7bbeda Mon Sep 17 00:00:00 2001 From: culler Date: Mon, 22 Jun 2020 16:12:00 +0000 Subject: Use the os_unfair_lock in place of OSSpinLock when the minimum build target is newer than OSX 10.12 --- macosx/tclMacOSXNotify.c | 70 +++++++++++++++++++++++++++++++++++++++++------- 1 file changed, 60 insertions(+), 10 deletions(-) diff --git a/macosx/tclMacOSXNotify.c b/macosx/tclMacOSXNotify.c index 4ce6786..1f9d0ea 100644 --- a/macosx/tclMacOSXNotify.c +++ b/macosx/tclMacOSXNotify.c @@ -14,6 +14,18 @@ */ #include "tclInt.h" + +/* + * In macOS 10.12 the os_unfair_lock was introduced as a replacement for the + * OSSpinLock, and the OSSpinLock was deprecated. + */ + +#if MAC_OS_X_VERSION_MIN_REQUIRED >= 101200 +#define USE_OS_UNFAIR_LOCK +#include +#undef TCL_MAC_DEBUG_NOTIFIER +#endif + #ifdef HAVE_COREFOUNDATION /* Traditional unix select-based notifier is * in tclUnixNotfy.c */ #include @@ -21,6 +33,8 @@ /* #define TCL_MAC_DEBUG_NOTIFIER 1 */ +#if !defined(USE_OS_UNFAIR_LOCK) + /* * We use the Darwin-native spinlock API rather than pthread mutexes for * notifier locking: this radically simplifies the implementation and lowers @@ -102,26 +116,45 @@ extern int _spin_lock_try(OSSpinLock *lock); #define SPINLOCK_INIT 0 #endif /* HAVE_LIBKERN_OSATOMIC_H && HAVE_OSSPINLOCKLOCK */ +#endif /* not using os_unfair_lock */ /* - * These spinlocks lock access to the global notifier state. + * These locks control access to the global notifier state. */ +#if defined(USE_OS_UNFAIR_LOCK) +static os_unfair_lock notifierInitLock = OS_UNFAIR_LOCK_INIT; +static os_unfair_lock notifierLock = OS_UNFAIR_LOCK_INIT; +#else static OSSpinLock notifierInitLock = SPINLOCK_INIT; static OSSpinLock notifierLock = SPINLOCK_INIT; +#endif /* - * Macros abstracting notifier locking/unlocking + * Macros that abstract notifier locking/unlocking */ +#if defined(USE_OS_UNFAIR_LOCK) +#define LOCK_NOTIFIER_INIT os_unfair_lock_lock(¬ifierInitLock) +#define UNLOCK_NOTIFIER_INIT os_unfair_lock_unlock(¬ifierInitLock) +#define LOCK_NOTIFIER os_unfair_lock_lock(¬ifierLock) +#define UNLOCK_NOTIFIER os_unfair_lock_unlock(¬ifierLock) +#define LOCK_NOTIFIER_TSD os_unfair_lock_lock(&tsdPtr->tsdLock) +#define UNLOCK_NOTIFIER_TSD os_unfair_lock_unlock(&tsdPtr->tsdLock) +#else #define LOCK_NOTIFIER_INIT SpinLockLock(¬ifierInitLock) #define UNLOCK_NOTIFIER_INIT SpinLockUnlock(¬ifierInitLock) #define LOCK_NOTIFIER SpinLockLock(¬ifierLock) #define UNLOCK_NOTIFIER SpinLockUnlock(¬ifierLock) #define LOCK_NOTIFIER_TSD SpinLockLock(&tsdPtr->tsdLock) #define UNLOCK_NOTIFIER_TSD SpinLockUnlock(&tsdPtr->tsdLock) +#endif -#ifdef TCL_MAC_DEBUG_NOTIFIER +/* + * The debug version of the Notifier only works if using OSSpinLock. + */ + +#if defined(TCL_MAC_DEBUG_NOTIFIER) && !defined(USE_OS_UNFAIR_LOCK) #define TclMacOSXNotifierDbgMsg(m, ...) \ do { \ fprintf(notifierLog?notifierLog:stderr, "tclMacOSXNotify.c:%d: " \ @@ -148,7 +181,7 @@ static OSSpinLock notifierLock = SPINLOCK_INIT; #undef LOCK_NOTIFIER #define LOCK_NOTIFIER SpinLockLockDbg(¬ifierLock) #undef LOCK_NOTIFIER_TSD -#define LOCK_NOTIFIER_TSD SpinLockLockDbg(&tsdPtr->tsdLock) +#define LOCK_NOTIFIER_TSD SpinLockLockDbg(tsdPtr->tsdLock) #include static FILE *notifierLog = NULL; #ifndef NOTIFIER_LOG @@ -267,9 +300,14 @@ typedef struct ThreadSpecificData { * from these pointers. */ /* End notifierLock section */ +#if defined(USE_OS_UNFAIR_LOCK) + os_unfair_lock tsdLock; +#else OSSpinLock tsdLock; /* Must hold this lock before acessing the * following fields from more than one * thread. */ +#endif + /* Start tsdLock section */ SelectMasks checkMasks; /* This structure is used to build up the * masks to be used in the next call to @@ -455,7 +493,6 @@ Tcl_InitNotifier(void) /* * Initialize support for weakly imported spinlock API. */ - if (pthread_once(&spinLockLockInitControl, SpinLockLockInit)) { Tcl_Panic("Tcl_InitNotifier: pthread_once failed"); } @@ -526,7 +563,11 @@ Tcl_InitNotifier(void) tsdPtr->runLoopObserverTcl = runLoopObserverTcl; tsdPtr->runLoopTimer = NULL; tsdPtr->waitTime = CF_TIMEINTERVAL_FOREVER; +#if defined(USE_OS_UNFAIR_LOCK) + tsdPtr->tsdLock = OS_UNFAIR_LOCK_INIT; +#else tsdPtr->tsdLock = SPINLOCK_INIT; +#endif } LOCK_NOTIFIER_INIT; @@ -584,7 +625,6 @@ Tcl_InitNotifier(void) ENABLE_ASL; notifierCount++; UNLOCK_NOTIFIER_INIT; - return tsdPtr; } @@ -1449,7 +1489,7 @@ OnOffWaitingList( { int changeWaitingList; -#ifdef TCL_MAC_DEBUG_NOTIFIER +#if defined(TCL_MAC_DEBUG_NOTIFIER) && !defined(USE_OS_UNFAIR_LOCK) if (SpinLockTry(¬ifierLock)) { Tcl_Panic("OnOffWaitingList: notifierLock unlocked"); } @@ -1980,9 +2020,19 @@ AtForkChild(void) { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - UNLOCK_NOTIFIER_TSD; - UNLOCK_NOTIFIER; - UNLOCK_NOTIFIER_INIT; + /* + * If a child process unlocks an os_unfair_lock that was created in its parent + * the child will exit with an illegal instruction error. So we reinitialize + * the lock in the child rather than attempt to unlock it. + */ + +#if defined(USE_OS_UNFAIR_LOCK) + tsdPtr->tsdLock = OS_UNFAIR_LOCK_INIT; +#else + UNLOCK_NOTIFIER_TSD; + UNLOCK_NOTIFIER; + UNLOCK_NOTIFIER_INIT; +#endif if (tsdPtr->runLoop) { tsdPtr->runLoop = NULL; if (!noCFafterFork) { -- cgit v0.12 From dbc3e640a2807e90bad8ebaef6f4ebb06178a18c Mon Sep 17 00:00:00 2001 From: aku Date: Tue, 23 Jun 2020 06:37:59 +0000 Subject: Added two tests demonstrating that the tickets [8af92dfb66] (bad stream expansion) and [f70ce1fead] (multi-stream decoding without readahead limit shenanigans) are fixed. Verified that the tests fail with commit [4eb66645d6], just before the zlib fixes. Tweaked the zlib manpage paragraphs about -limit. Tweaked some code comments. Fixed typos in description of two unrelated zlib tests. --- doc/zlib.n | 18 ++++++++++----- generic/tclZlib.c | 5 +++-- tests/assets/zlib.bin | Bin 0 -> 591 bytes tests/zlib.test | 60 ++++++++++++++++++++++++++++++++++++++++++++++++-- 4 files changed, 73 insertions(+), 10 deletions(-) create mode 100644 tests/assets/zlib.bin diff --git a/doc/zlib.n b/doc/zlib.n index 994a063..3714fc1 100644 --- a/doc/zlib.n +++ b/doc/zlib.n @@ -193,12 +193,18 @@ How hard to compress the data. Must be an integer from 0 (uncompressed) to 9 .TP \fB\-limit\fI readaheadLimit\fR . -The maximum number of bytes ahead to read when decompressing. This can be set -to 1 to find the border for multi-stream inflate or mixed data, to ensure it -would handle correctly e. g. some operations on following streams after first -caused to due time. -Otherwise Tcl would try to automatically return previously read extra data -to input stream back. +The maximum number of bytes ahead to read when decompressing. +.RS +.PP +This option has become \fBirrelevant\fR. It was originally introduced +to prevent Tcl from reading beyond the end of a compressed stream in +multi-stream channels to ensure that the data after was left alone for +further reading, at the cost of speed. +.PP +Tcl now automatically returns any bytes it has read beyond the end of +a compressed stream back to the channel, making them appear as unread +to further readers. +.RE .PP Both compressing and decompressing channel transformations add extra configuration options that may be accessed through \fBchan configure\fR. The diff --git a/generic/tclZlib.c b/generic/tclZlib.c index 68bdf92..42d7156 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -2948,8 +2948,9 @@ ZlibTransformClose( (void) deflateEnd(&cd->outStream); } else { /* - * If we have rest of read input (overshot by Z_STREAM_END or on possible error), - * unget this part of buffer back to the parent channel. + * If we have unused bytes from the read input (overshot by + * Z_STREAM_END or on possible error), unget them back to the parent + * channel, so that they appear as not being read yet. */ if (cd->inStream.avail_in) { Tcl_Ungets (cd->parent, (char *)cd->inStream.next_in, cd->inStream.avail_in, 0); diff --git a/tests/assets/zlib.bin b/tests/assets/zlib.bin new file mode 100644 index 0000000..dadb639 Binary files /dev/null and b/tests/assets/zlib.bin differ diff --git a/tests/zlib.test b/tests/zlib.test index c2f7825..e7ffcfe 100644 --- a/tests/zlib.test +++ b/tests/zlib.test @@ -920,7 +920,7 @@ test zlib-10.2 "bug #2818131 (mismatch gets)" -constraints { rename zlibRead {} } -result {error {invalid block type}} -test zlib-11.1 "Bug #3390073: mis-appled gzip filtering" -setup { +test zlib-11.1 "Bug #3390073: mis-applied gzip filtering" -setup { set file [makeFile {} test.input] } -constraints zlib -body { set f [open $file wb] @@ -934,7 +934,7 @@ test zlib-11.1 "Bug #3390073: mis-appled gzip filtering" -setup { } -cleanup { removeFile $file } -result {1000 0} -test zlib-11.2 "Bug #3390073: mis-appled gzip filtering" -setup { +test zlib-11.2 "Bug #3390073: mis-applied gzip filtering" -setup { set file [makeFile {} test.input] } -constraints zlib -body { set f [open $file wb] @@ -1005,6 +1005,62 @@ test zlib-12.2 {Patrick Dunnigan's issue} -constraints zlib -setup { removeFile $filesrc removeFile $filedst } -result 56 + +test zlib-13.1 {Ticket 8af92dfb66 - zlib stream mis-expansion} -constraints zlib -setup { + set pathin [file join $::tcltest::testsDirectory assets zlib.bin] + set chanin [open $pathin rb] + set pathout [file join [pwd] zlib.deflated] + set chanout [open $pathout wb] + zlib push inflate $chanin + fcopy $chanin $chanout + close $chanin + close $chanout +} -body { + file size $pathout +} -cleanup { + file delete $pathout + unset chanin pathin chanout pathout +} -result 458752 + +test zlib-13.2 {Ticket f70ce1fead - zlib multi-stream expansion} -constraints zlib -setup { + # Start from the basic asset + set pathin [file join $::tcltest::testsDirectory assets zlib.bin] + set chanin [open $pathin rb] + # Create a multi-stream by copying the asset twice into it. + set pathout [file join [pwd] zlib.multi] + set chanout [open $pathout wb] + fcopy $chanin $chanout + seek $chanin 0 start + fcopy $chanin $chanout + close $chanin + close $chanout + # The multi-stream file shall be our input + set pathin $pathout + set chanin [open $pathin rb] + # And our destinations + set pathout1 [file join [pwd] zlib.1] + set pathout2 [file join [pwd] zlib.2] +} -body { + # Decode first stream + set chanout [open $pathout1 wb] + zlib push inflate $chanin + fcopy $chanin $chanout + chan pop $chanin + close $chanout + # Decode second stream + set chanout [open $pathout2 wb] + zlib push inflate $chanin + fcopy $chanin $chanout + chan pop $chanin + close $chanout + # + list [file size $pathout1] [file size $pathout2] +} -cleanup { + close $chanin + file delete $pathout $pathout1 $pathout2 + unset chanin pathin chanout pathout pathout1 pathout2 +} -result {458752 458752} + ::tcltest::cleanupTests return -- cgit v0.12 From 75376fc361851e388acdc9c4a64c1987446b808f Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 23 Jun 2020 07:13:15 +0000 Subject: re-generate with bison 3.1 --- generic/tclDate.c | 315 +++++++++++++++++++++++++++++++++++------------------- 1 file changed, 206 insertions(+), 109 deletions(-) diff --git a/generic/tclDate.c b/generic/tclDate.c index daeb1d9..dcb85e9 100644 --- a/generic/tclDate.c +++ b/generic/tclDate.c @@ -1,9 +1,8 @@ -/* A Bison parser, made by GNU Bison 3.4.2. */ +/* A Bison parser, made by GNU Bison 3.1. */ /* Bison implementation for Yacc-like parsers in C - Copyright (C) 1984, 1989-1990, 2000-2015, 2018-2019 Free Software Foundation, - Inc. + Copyright (C) 1984, 1989-1990, 2000-2015, 2018 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by @@ -41,14 +40,11 @@ define necessary library symbols; they are noted "INFRINGES ON USER NAME SPACE" below. */ -/* Undocumented macros, especially those whose name start with YY_, - are private implementation details. Do not rely on them. */ - /* Identify Bison output. */ #define YYBISON 1 /* Bison version. */ -#define YYBISON_VERSION "3.4.2" +#define YYBISON_VERSION "3.1" /* Skeleton name. */ #define YYSKELETON_NAME "yacc.c" @@ -71,7 +67,8 @@ #define yynerrs TclDatenerrs -/* First part of user prologue. */ +/* Copy the first part of user declarations. */ + /* * tclDate.c -- @@ -212,15 +209,12 @@ typedef enum _DSTMODE { + # ifndef YY_NULLPTR -# if defined __cplusplus -# if 201103L <= __cplusplus -# define YY_NULLPTR nullptr -# else -# define YY_NULLPTR 0 -# endif +# if defined __cplusplus && 201103L <= __cplusplus +# define YY_NULLPTR nullptr # else -# define YY_NULLPTR ((void*)0) +# define YY_NULLPTR 0 # endif # endif @@ -268,14 +262,17 @@ extern int TclDatedebug; /* Value type. */ #if ! defined YYSTYPE && ! defined YYSTYPE_IS_DECLARED + union YYSTYPE { + time_t Number; enum _MERIDIAN Meridian; }; + typedef union YYSTYPE YYSTYPE; # define YYSTYPE_IS_TRIVIAL 1 # define YYSTYPE_IS_DECLARED 1 @@ -301,7 +298,8 @@ int TclDateparse (DateInfo* info); -/* Second part of user prologue. */ +/* Copy the second part of user declarations. */ + /* @@ -393,6 +391,15 @@ typedef short yytype_int16; # define YY_ATTRIBUTE_UNUSED YY_ATTRIBUTE ((__unused__)) #endif +#if !defined _Noreturn \ + && (!defined __STDC_VERSION__ || __STDC_VERSION__ < 201112) +# if defined _MSC_VER && 1200 <= _MSC_VER +# define _Noreturn __declspec (noreturn) +# else +# define _Noreturn YY_ATTRIBUTE ((__noreturn__)) +# endif +#endif + /* Suppress unused-variable warnings by "using" E. */ #if ! defined lint || defined __GNUC__ # define YYUSE(E) ((void) (E)) @@ -420,8 +427,6 @@ typedef short yytype_int16; #endif -#define YY_ASSERT(E) ((void) (0 && (E))) - #if ! defined yyoverflow || YYERROR_VERBOSE /* The parser invokes alloca or malloc; define the necessary symbols. */ @@ -566,16 +571,16 @@ union yyalloc /* YYNSTATES -- Number of states. */ #define YYNSTATES 89 +/* YYTRANSLATE[YYX] -- Symbol number corresponding to YYX as returned + by yylex, with out-of-bounds checking. */ #define YYUNDEFTOK 2 #define YYMAXUTOK 274 -/* YYTRANSLATE(TOKEN-NUM) -- Symbol number corresponding to TOKEN-NUM - as returned by yylex, with out-of-bounds checking. */ #define YYTRANSLATE(YYX) \ ((unsigned) (YYX) <= YYMAXUTOK ? yytranslate[YYX] : YYUNDEFTOK) /* YYTRANSLATE[TOKEN-NUM] -- Symbol number corresponding to TOKEN-NUM - as returned by yylex. */ + as returned by yylex, without out-of-bounds checking. */ static const yytype_uint8 yytranslate[] = { 0, 2, 2, 2, 2, 2, 2, 2, 2, 2, @@ -781,22 +786,22 @@ static const yytype_uint8 yyr2[] = #define YYRECOVERING() (!!yyerrstatus) -#define YYBACKUP(Token, Value) \ - do \ - if (yychar == YYEMPTY) \ - { \ - yychar = (Token); \ - yylval = (Value); \ - YYPOPSTACK (yylen); \ - yystate = *yyssp; \ - goto yybackup; \ - } \ - else \ - { \ - yyerror (&yylloc, info, YY_("syntax error: cannot back up")); \ - YYERROR; \ - } \ - while (0) +#define YYBACKUP(Token, Value) \ +do \ + if (yychar == YYEMPTY) \ + { \ + yychar = (Token); \ + yylval = (Value); \ + YYPOPSTACK (yylen); \ + yystate = *yyssp; \ + goto yybackup; \ + } \ + else \ + { \ + yyerror (&yylloc, info, YY_("syntax error: cannot back up")); \ + YYERROR; \ + } \ +while (0) /* Error token number */ #define YYTERROR 1 @@ -855,10 +860,10 @@ do { \ /* Print *YYLOCP on YYO. Private, do not rely on its existence. */ YY_ATTRIBUTE_UNUSED -static int +static unsigned yy_location_print_ (FILE *yyo, YYLTYPE const * const yylocp) { - int res = 0; + unsigned res = 0; int end_col = 0 != yylocp->last_column ? yylocp->last_column - 1 : 0; if (0 <= yylocp->first_line) { @@ -901,43 +906,41 @@ do { \ } while (0) -/*-----------------------------------. -| Print this symbol's value on YYO. | -`-----------------------------------*/ +/*----------------------------------------. +| Print this symbol's value on YYOUTPUT. | +`----------------------------------------*/ static void -yy_symbol_value_print (FILE *yyo, int yytype, YYSTYPE const * const yyvaluep, YYLTYPE const * const yylocationp, DateInfo* info) +yy_symbol_value_print (FILE *yyoutput, int yytype, YYSTYPE const * const yyvaluep, YYLTYPE const * const yylocationp, DateInfo* info) { - FILE *yyoutput = yyo; - YYUSE (yyoutput); + FILE *yyo = yyoutput; + YYUSE (yyo); YYUSE (yylocationp); YYUSE (info); if (!yyvaluep) return; # ifdef YYPRINT if (yytype < YYNTOKENS) - YYPRINT (yyo, yytoknum[yytype], *yyvaluep); + YYPRINT (yyoutput, yytoknum[yytype], *yyvaluep); # endif - YY_IGNORE_MAYBE_UNINITIALIZED_BEGIN YYUSE (yytype); - YY_IGNORE_MAYBE_UNINITIALIZED_END } -/*---------------------------. -| Print this symbol on YYO. | -`---------------------------*/ +/*--------------------------------. +| Print this symbol on YYOUTPUT. | +`--------------------------------*/ static void -yy_symbol_print (FILE *yyo, int yytype, YYSTYPE const * const yyvaluep, YYLTYPE const * const yylocationp, DateInfo* info) +yy_symbol_print (FILE *yyoutput, int yytype, YYSTYPE const * const yyvaluep, YYLTYPE const * const yylocationp, DateInfo* info) { - YYFPRINTF (yyo, "%s %s (", + YYFPRINTF (yyoutput, "%s %s (", yytype < YYNTOKENS ? "token" : "nterm", yytname[yytype]); - YY_LOCATION_PRINT (yyo, *yylocationp); - YYFPRINTF (yyo, ": "); - yy_symbol_value_print (yyo, yytype, yyvaluep, yylocationp, info); - YYFPRINTF (yyo, ")"); + YY_LOCATION_PRINT (yyoutput, *yylocationp); + YYFPRINTF (yyoutput, ": "); + yy_symbol_value_print (yyoutput, yytype, yyvaluep, yylocationp, info); + YYFPRINTF (yyoutput, ")"); } /*------------------------------------------------------------------. @@ -982,7 +985,7 @@ yy_reduce_print (yytype_int16 *yyssp, YYSTYPE *yyvsp, YYLTYPE *yylsp, int yyrule YYFPRINTF (stderr, " $%d = ", yyi + 1); yy_symbol_print (stderr, yystos[yyssp[yyi + 1 - yynrhs]], - &yyvsp[(yyi + 1) - (yynrhs)] + &(yyvsp[(yyi + 1) - (yynrhs)]) , &(yylsp[(yyi + 1) - (yynrhs)]) , info); YYFPRINTF (stderr, "\n"); } @@ -1086,10 +1089,7 @@ yytnamerr (char *yyres, const char *yystr) case '\\': if (*++yyp != '\\') goto do_not_strip_quotes; - else - goto append; - - append: + /* Fall through. */ default: if (yyres) yyres[yyn] = *yyp; @@ -1107,7 +1107,7 @@ yytnamerr (char *yyres, const char *yystr) if (! yyres) return yystrlen (yystr); - return (YYSIZE_T) (yystpcpy (yyres, yystr) - yyres); + return yystpcpy (yyres, yystr) - yyres; } # endif @@ -1185,10 +1185,10 @@ yysyntax_error (YYSIZE_T *yymsg_alloc, char **yymsg, yyarg[yycount++] = yytname[yyx]; { YYSIZE_T yysize1 = yysize + yytnamerr (YY_NULLPTR, yytname[yyx]); - if (yysize <= yysize1 && yysize1 <= YYSTACK_ALLOC_MAXIMUM) - yysize = yysize1; - else + if (! (yysize <= yysize1 + && yysize1 <= YYSTACK_ALLOC_MAXIMUM)) return 2; + yysize = yysize1; } } } @@ -1212,10 +1212,9 @@ yysyntax_error (YYSIZE_T *yymsg_alloc, char **yymsg, { YYSIZE_T yysize1 = yysize + yystrlen (yyformat); - if (yysize <= yysize1 && yysize1 <= YYSTACK_ALLOC_MAXIMUM) - yysize = yysize1; - else + if (! (yysize <= yysize1 && yysize1 <= YYSTACK_ALLOC_MAXIMUM)) return 2; + yysize = yysize1; } if (*yymsg_alloc < yysize) @@ -1367,33 +1366,23 @@ YYLTYPE yylloc = yyloc_default; yylsp[0] = yylloc; goto yysetstate; - /*------------------------------------------------------------. -| yynewstate -- push a new state, which is found in yystate. | +| yynewstate -- Push a new state, which is found in yystate. | `------------------------------------------------------------*/ -yynewstate: + yynewstate: /* In all cases, when you get here, the value and location stacks have just been pushed. So pushing a state here evens the stacks. */ yyssp++; - -/*--------------------------------------------------------------------. -| yynewstate -- set current state (the top of the stack) to yystate. | -`--------------------------------------------------------------------*/ -yysetstate: - YYDPRINTF ((stderr, "Entering state %d\n", yystate)); - YY_ASSERT (0 <= yystate && yystate < YYNSTATES); - *yyssp = (yytype_int16) yystate; + yysetstate: + *yyssp = yystate; if (yyss + yystacksize - 1 <= yyssp) -#if !defined yyoverflow && !defined YYSTACK_RELOCATE - goto yyexhaustedlab; -#else { /* Get the current used size of the three stacks, in elements. */ - YYSIZE_T yysize = (YYSIZE_T) (yyssp - yyss + 1); + YYSIZE_T yysize = yyssp - yyss + 1; -# if defined yyoverflow +#ifdef yyoverflow { /* Give user a chance to reallocate the stack. Use copies of these so that the &'s don't force the real ones into @@ -1411,11 +1400,15 @@ yysetstate: &yyvs1, yysize * sizeof (*yyvsp), &yyls1, yysize * sizeof (*yylsp), &yystacksize); + + yyls = yyls1; yyss = yyss1; yyvs = yyvs1; - yyls = yyls1; } -# else /* defined YYSTACK_RELOCATE */ +#else /* no yyoverflow */ +# ifndef YYSTACK_RELOCATE + goto yyexhaustedlab; +# else /* Extend the stack our own way. */ if (YYMAXDEPTH <= yystacksize) goto yyexhaustedlab; @@ -1432,11 +1425,12 @@ yysetstate: YYSTACK_RELOCATE (yyss_alloc, yyss); YYSTACK_RELOCATE (yyvs_alloc, yyvs); YYSTACK_RELOCATE (yyls_alloc, yyls); -# undef YYSTACK_RELOCATE +# undef YYSTACK_RELOCATE if (yyss1 != yyssa) YYSTACK_FREE (yyss1); } # endif +#endif /* no yyoverflow */ yyssp = yyss + yysize - 1; yyvsp = yyvs + yysize - 1; @@ -1448,18 +1442,19 @@ yysetstate: if (yyss + yystacksize - 1 <= yyssp) YYABORT; } -#endif /* !defined yyoverflow && !defined YYSTACK_RELOCATE */ + + YYDPRINTF ((stderr, "Entering state %d\n", yystate)); if (yystate == YYFINAL) YYACCEPT; goto yybackup; - /*-----------. | yybackup. | `-----------*/ yybackup: + /* Do appropriate processing given the current state. Read a lookahead token if we need one and don't already have one. */ @@ -1532,7 +1527,7 @@ yydefault: /*-----------------------------. -| yyreduce -- do a reduction. | +| yyreduce -- Do a reduction. | `-----------------------------*/ yyreduce: /* yyn is the number of a rule to reduce with. */ @@ -1554,76 +1549,97 @@ yyreduce: YY_REDUCE_PRINT (yyn); switch (yyn) { - case 4: + case 4: + { yyHaveTime++; } + break; case 5: + { yyHaveZone++; } + break; case 6: + { yyHaveDate++; } + break; case 7: + { yyHaveOrdinalMonth++; } + break; case 8: + { yyHaveDay++; } + break; case 9: + { yyHaveRel++; } + break; case 10: + { yyHaveTime++; yyHaveDate++; } + break; case 11: + { yyHaveTime++; yyHaveDate++; yyHaveRel++; } + break; case 13: + { yyHour = (yyvsp[-1].Number); yyMinutes = 0; yySeconds = 0; yyMeridian = (yyvsp[0].Meridian); } + break; case 14: + { yyHour = (yyvsp[-3].Number); yyMinutes = (yyvsp[-1].Number); yySeconds = 0; yyMeridian = (yyvsp[0].Meridian); } + break; case 15: + { yyHour = (yyvsp[-4].Number); yyMinutes = (yyvsp[-2].Number); @@ -1632,18 +1648,22 @@ yyreduce: yyTimezone = ((yyvsp[0].Number) % 100 + ((yyvsp[0].Number) / 100) * 60); ++yyHaveZone; } + break; case 16: + { yyHour = (yyvsp[-5].Number); yyMinutes = (yyvsp[-3].Number); yySeconds = (yyvsp[-1].Number); yyMeridian = (yyvsp[0].Meridian); } + break; case 17: + { yyHour = (yyvsp[-6].Number); yyMinutes = (yyvsp[-4].Number); @@ -1653,158 +1673,200 @@ yyreduce: yyTimezone = ((yyvsp[0].Number) % 100 + ((yyvsp[0].Number) / 100) * 60); ++yyHaveZone; } + break; case 18: + { yyTimezone = (yyvsp[-1].Number); if (yyTimezone > HOUR( 12)) yyTimezone -= HOUR(100); yyDSTmode = DSTon; } + break; case 19: + { yyTimezone = (yyvsp[0].Number); if (yyTimezone > HOUR( 12)) yyTimezone -= HOUR(100); yyDSTmode = DSToff; } + break; case 20: + { yyTimezone = (yyvsp[0].Number); yyDSTmode = DSTon; } + break; case 21: + { yyDayOrdinal = 1; yyDayNumber = (yyvsp[0].Number); } + break; case 22: + { yyDayOrdinal = 1; yyDayNumber = (yyvsp[-1].Number); } + break; case 23: + { yyDayOrdinal = (yyvsp[-1].Number); yyDayNumber = (yyvsp[0].Number); } + break; case 24: + { yyDayOrdinal = (yyvsp[-2].Number) * (yyvsp[-1].Number); yyDayNumber = (yyvsp[0].Number); } + break; case 25: + { yyDayOrdinal = 2; yyDayNumber = (yyvsp[0].Number); } + break; case 26: + { yyMonth = (yyvsp[-2].Number); yyDay = (yyvsp[0].Number); } + break; case 27: + { yyMonth = (yyvsp[-4].Number); yyDay = (yyvsp[-2].Number); yyYear = (yyvsp[0].Number); } + break; case 28: + { yyYear = (yyvsp[0].Number) / 10000; yyMonth = ((yyvsp[0].Number) % 10000)/100; yyDay = (yyvsp[0].Number) % 100; } + break; case 29: + { yyDay = (yyvsp[-4].Number); yyMonth = (yyvsp[-2].Number); yyYear = (yyvsp[0].Number); } + break; case 30: + { yyMonth = (yyvsp[-2].Number); yyDay = (yyvsp[0].Number); yyYear = (yyvsp[-4].Number); } + break; case 31: + { yyMonth = (yyvsp[-1].Number); yyDay = (yyvsp[0].Number); } + break; case 32: + { yyMonth = (yyvsp[-3].Number); yyDay = (yyvsp[-2].Number); yyYear = (yyvsp[0].Number); } + break; case 33: + { yyMonth = (yyvsp[0].Number); yyDay = (yyvsp[-1].Number); } + break; case 34: + { yyMonth = 1; yyDay = 1; yyYear = EPOCH; } + break; case 35: + { yyMonth = (yyvsp[-1].Number); yyDay = (yyvsp[-2].Number); yyYear = (yyvsp[0].Number); } + break; case 36: + { yyMonthOrdinal = 1; yyMonth = (yyvsp[0].Number); } + break; case 37: + { yyMonthOrdinal = (yyvsp[-1].Number); yyMonth = (yyvsp[0].Number); } + break; case 38: + { if ((yyvsp[-5].Number) != HOUR( 7) + HOUR(100)) YYABORT; yyYear = (yyvsp[-10].Number); @@ -1814,9 +1876,11 @@ yyreduce: yyMinutes = (yyvsp[-2].Number); yySeconds = (yyvsp[0].Number); } + break; case 39: + { if ((yyvsp[-1].Number) != HOUR( 7) + HOUR(100)) YYABORT; yyYear = (yyvsp[-2].Number) / 10000; @@ -1826,9 +1890,11 @@ yyreduce: yyMinutes = ((yyvsp[0].Number) % 10000)/100; yySeconds = (yyvsp[0].Number) % 100; } + break; case 40: + { if ((yyvsp[-5].Number) != HOUR( 7) + HOUR(100)) YYABORT; yyYear = (yyvsp[-6].Number) / 10000; @@ -1838,9 +1904,11 @@ yyreduce: yyMinutes = (yyvsp[-2].Number); yySeconds = (yyvsp[0].Number); } + break; case 41: + { yyYear = (yyvsp[-1].Number) / 10000; yyMonth = ((yyvsp[-1].Number) % 10000)/100; @@ -1849,9 +1917,11 @@ yyreduce: yyMinutes = ((yyvsp[0].Number) % 10000)/100; yySeconds = (yyvsp[0].Number) % 100; } + break; case 42: + { /* * Offset computed year by -377 so that the returned years will be @@ -1864,80 +1934,104 @@ yyreduce: yyRelDay += (((yyvsp[-2].Number)%1000)*(365 + IsLeapYear(yyYear)))/1000; yyRelSeconds += (yyvsp[0].Number) * 144 * 60; } + break; case 43: + { yyRelSeconds *= -1; yyRelMonth *= -1; yyRelDay *= -1; } + break; case 45: + { *yyRelPointer += (yyvsp[-2].Number) * (yyvsp[-1].Number) * (yyvsp[0].Number); } + break; case 46: + { *yyRelPointer += (yyvsp[-1].Number) * (yyvsp[0].Number); } + break; case 47: + { *yyRelPointer += (yyvsp[0].Number); } + break; case 48: + { *yyRelPointer += (yyvsp[-1].Number) * (yyvsp[0].Number); } + break; case 49: + { *yyRelPointer += (yyvsp[0].Number); } + break; case 50: + { (yyval.Number) = -1; } + break; case 51: + { (yyval.Number) = 1; } + break; case 52: + { (yyval.Number) = (yyvsp[0].Number); yyRelPointer = &yyRelSeconds; } + break; case 53: + { (yyval.Number) = (yyvsp[0].Number); yyRelPointer = &yyRelDay; } + break; case 54: + { (yyval.Number) = (yyvsp[0].Number); yyRelPointer = &yyRelMonth; } + break; case 55: + { if (yyHaveTime && yyHaveDate && !yyHaveRel) { yyYear = (yyvsp[0].Number); @@ -1954,18 +2048,23 @@ yyreduce: yyMeridian = MER24; } } + break; case 56: + { (yyval.Meridian) = MER24; } + break; case 57: + { (yyval.Meridian) = (yyvsp[0].Meridian); } + break; @@ -1995,13 +2094,14 @@ yyreduce: /* Now 'shift' the result of the reduction. Determine what state that goes to, based on the state we popped back to and the rule number reduced by. */ - { - const int yylhs = yyr1[yyn] - YYNTOKENS; - const int yyi = yypgoto[yylhs] + *yyssp; - yystate = (0 <= yyi && yyi <= YYLAST && yycheck[yyi] == *yyssp - ? yytable[yyi] - : yydefgoto[yylhs]); - } + + yyn = yyr1[yyn]; + + yystate = yypgoto[yyn - YYNTOKENS] + *yyssp; + if (0 <= yystate && yystate <= YYLAST && yycheck[yystate] == *yyssp) + yystate = yytable[yystate]; + else + yystate = yydefgoto[yyn - YYNTOKENS]; goto yynewstate; @@ -2084,10 +2184,12 @@ yyerrlab: | yyerrorlab -- error raised explicitly by YYERROR. | `---------------------------------------------------*/ yyerrorlab: - /* Pacify compilers when the user code never invokes YYERROR and the - label yyerrorlab therefore never appears in user code. */ - if (0) - YYERROR; + + /* Pacify compilers like GCC when the user code never invokes + YYERROR and the label yyerrorlab therefore never appears in user + code. */ + if (/*CONSTCOND*/ 0) + goto yyerrorlab; /* Do not reclaim the symbols of the rule whose action triggered this YYERROR. */ @@ -2154,7 +2256,6 @@ yyacceptlab: yyresult = 0; goto yyreturn; - /*-----------------------------------. | yyabortlab -- YYABORT comes here. | `-----------------------------------*/ @@ -2162,7 +2263,6 @@ yyabortlab: yyresult = 1; goto yyreturn; - #if !defined yyoverflow || YYERROR_VERBOSE /*-------------------------------------------------. | yyexhaustedlab -- memory exhaustion comes here. | @@ -2173,10 +2273,6 @@ yyexhaustedlab: /* Fall through. */ #endif - -/*-----------------------------------------------------. -| yyreturn -- parsing is finished, return the result. | -`-----------------------------------------------------*/ yyreturn: if (yychar != YYEMPTY) { @@ -2207,6 +2303,7 @@ yyreturn: return yyresult; } + /* * Month and day table. */ -- cgit v0.12 From 97499f5ed8cc4ea3177e6fb8544c5cd7aba6e029 Mon Sep 17 00:00:00 2001 From: kjnash Date: Tue, 23 Jun 2020 18:10:33 +0000 Subject: Fix for ticket 41c9857bdd --- library/init.tcl | 45 +++++++++++++++++++++++++-------------------- 1 file changed, 25 insertions(+), 20 deletions(-) diff --git a/library/init.tcl b/library/init.tcl index 5cc0fee..e6964e0 100644 --- a/library/init.tcl +++ b/library/init.tcl @@ -37,41 +37,46 @@ package require -exact Tcl 8.6.10 # tcl_pkgPath, which is set by the platform-specific initialization routines # On UNIX it is compiled in # On Windows, it is not used +# +# (Ticket 41c9857bdd) In a safe interpreter, this file does not set +# ::auto_path (other than to {} if it is undefined). The caller, typically +# a Safe Base command, is responsible for setting ::auto_path. if {![info exists auto_path]} { - if {[info exists env(TCLLIBPATH)]} { + if {[info exists env(TCLLIBPATH)] && (![interp issafe])} { set auto_path $env(TCLLIBPATH) } else { set auto_path "" } } namespace eval tcl { - variable Dir - foreach Dir [list $::tcl_library [file dirname $::tcl_library]] { - if {$Dir ni $::auto_path} { - lappend ::auto_path $Dir - } - } - set Dir [file join [file dirname [file dirname \ - [info nameofexecutable]]] lib] - if {$Dir ni $::auto_path} { - lappend ::auto_path $Dir - } - if {[info exists ::tcl_pkgPath]} { catch { - foreach Dir $::tcl_pkgPath { + if {![interp issafe]} { + variable Dir + foreach Dir [list $::tcl_library [file dirname $::tcl_library]] { if {$Dir ni $::auto_path} { lappend ::auto_path $Dir } } - }} + set Dir [file join [file dirname [file dirname \ + [info nameofexecutable]]] lib] + if {$Dir ni $::auto_path} { + lappend ::auto_path $Dir + } + if {[info exists ::tcl_pkgPath]} { catch { + foreach Dir $::tcl_pkgPath { + if {$Dir ni $::auto_path} { + lappend ::auto_path $Dir + } + } + }} - if {![interp issafe]} { - variable Path [encoding dirs] - set Dir [file join $::tcl_library encoding] - if {$Dir ni $Path} { + variable Path [encoding dirs] + set Dir [file join $::tcl_library encoding] + if {$Dir ni $Path} { lappend Path $Dir encoding dirs $Path - } + } + unset Dir Path } # TIP #255 min and max functions -- cgit v0.12 From 094567e57a4212ad576fa972a418938423e8db0d Mon Sep 17 00:00:00 2001 From: sebres Date: Tue, 23 Jun 2020 20:40:49 +0000 Subject: zlib.test: replaces tests/assets/zlib.bin with inlined version (creating test file on demand), use temp files (instead of current directory) for interim files --- tests/zlib.test | 44 ++++++++++++++++++++++++++++++++++---------- 1 file changed, 34 insertions(+), 10 deletions(-) diff --git a/tests/zlib.test b/tests/zlib.test index e7ffcfe..d3a6dff 100644 --- a/tests/zlib.test +++ b/tests/zlib.test @@ -1006,10 +1006,26 @@ test zlib-12.2 {Patrick Dunnigan's issue} -constraints zlib -setup { removeFile $filedst } -result 56 -test zlib-13.1 {Ticket 8af92dfb66 - zlib stream mis-expansion} -constraints zlib -setup { - set pathin [file join $::tcltest::testsDirectory assets zlib.bin] +set zlibbinf "" +proc _zlibbinf {} { + # inlined zlib.bin file creator: + variable zlibbinf + if {$zlibbinf eq ""} { + set zlibbinf [makeFile {} test-zlib-13.bin] + set f [open $zlibbinf wb] + puts -nonewline $f [zlib decompress [binary decode base64 { + eJx7e+6s1+EAgYaLjK3ratptGmOck0vT/y/ZujHAd0qJelDBXfUPJ3tfrtLbpX+wOOFHmtn03/tizm + /+tXROXU3d203b79p5X6/0cvUyFzTsqOj4sa9r8SrZI5zT7265e2Xzq595Fb9LbpgffVy7cZaJ/d15 + 4U9L7LLM2vdqut8+aSU/r6q9Ltv6+T9mBhTgIK97bH33m/O1C1eBwf9FDKNgaIDaj9wA+5hToA== + }]] + close $f + } + return $zlibbinf +} +test zlib-13.1 {Ticket [8af92dfb66] - zlib stream mis-expansion} -constraints zlib -setup { + set pathin [_zlibbinf] set chanin [open $pathin rb] - set pathout [file join [pwd] zlib.deflated] + set pathout [makeFile {} test-zlib-13.deflated] set chanout [open $pathout wb] zlib push inflate $chanin fcopy $chanin $chanout @@ -1018,16 +1034,16 @@ test zlib-13.1 {Ticket 8af92dfb66 - zlib stream mis-expansion} -constraints zlib } -body { file size $pathout } -cleanup { - file delete $pathout + removeFile $pathout unset chanin pathin chanout pathout } -result 458752 -test zlib-13.2 {Ticket f70ce1fead - zlib multi-stream expansion} -constraints zlib -setup { +test zlib-13.2 {Ticket [f70ce1fead] - zlib multi-stream expansion} -constraints zlib -setup { # Start from the basic asset - set pathin [file join $::tcltest::testsDirectory assets zlib.bin] + set pathin [_zlibbinf] set chanin [open $pathin rb] # Create a multi-stream by copying the asset twice into it. - set pathout [file join [pwd] zlib.multi] + set pathout [makeFile {} test-zlib-13.multi] set chanout [open $pathout wb] fcopy $chanin $chanout seek $chanin 0 start @@ -1038,8 +1054,8 @@ test zlib-13.2 {Ticket f70ce1fead - zlib multi-stream expansion} -constraints zl set pathin $pathout set chanin [open $pathin rb] # And our destinations - set pathout1 [file join [pwd] zlib.1] - set pathout2 [file join [pwd] zlib.2] + set pathout1 [makeFile {} test-zlib-13.multi-1] + set pathout2 [makeFile {} test-zlib-13.multi-2] } -body { # Decode first stream set chanout [open $pathout1 wb] @@ -1057,10 +1073,18 @@ test zlib-13.2 {Ticket f70ce1fead - zlib multi-stream expansion} -constraints zl list [file size $pathout1] [file size $pathout2] } -cleanup { close $chanin - file delete $pathout $pathout1 $pathout2 + removeFile $pathout + removeFile $pathout1 + removeFile $pathout2 unset chanin pathin chanout pathout pathout1 pathout2 } -result {458752 458752} +if {$zlibbinf ne ""} { + removeFile $zlibbinf +} +unset zlibbinf +rename _zlibbinf {} + ::tcltest::cleanupTests return -- cgit v0.12 From ea3e48843d5f42ebaa1c962a705cc4b1ac8a6c80 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 24 Jun 2020 12:24:28 +0000 Subject: Add "manifest.uuid" to the distribution, so we can see exactly where "make dist" came from. In case of "git", we can see that too --- .fossil-settings/manifest | 1 + .gitignore | 19 +++++++++++-------- unix/Makefile.in | 7 ++++++- unix/tclConfig.h.in | 40 +++++++++++++++++++++++++++++++--------- 4 files changed, 49 insertions(+), 18 deletions(-) create mode 100644 .fossil-settings/manifest diff --git a/.fossil-settings/manifest b/.fossil-settings/manifest new file mode 100644 index 0000000..4ae8ef0 --- /dev/null +++ b/.fossil-settings/manifest @@ -0,0 +1 @@ +u diff --git a/.gitignore b/.gitignore index acaff0f..3f6ce0c 100644 --- a/.gitignore +++ b/.gitignore @@ -1,4 +1,5 @@ *.a +*.bundle *.dll *.dylib *.exe @@ -10,11 +11,16 @@ *.res *.sl *.so -*/Makefile -*/config.cache -*/config.log -*/config.status -*/config.status.lineno +.fslckout +Makefile +Tcl-Info.plist +config.cache +config.log +config.status +config.status.lineno +html +manifest.uuid +_FOSSIL_ */tclConfig.sh */tclsh* */tcltest* @@ -22,9 +28,6 @@ */version.vc */libtcl.vfs */libtcl_*.zip -.fslckout -_FOSSIL_ -html libtommath/bn.ilg libtommath/bn.ind libtommath/pretty.build diff --git a/unix/Makefile.in b/unix/Makefile.in index f314862..c20ba57 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -1663,9 +1663,14 @@ $(MAC_OSX_DIR)/configure: $(MAC_OSX_DIR)/configure.ac $(UNIX_DIR)/configure $(UNIX_DIR)/tclConfig.h.in: $(MAC_OSX_DIR)/configure cd $(MAC_OSX_DIR); autoheader; touch $@ -dist: $(UNIX_DIR)/configure $(UNIX_DIR)/tclConfig.h.in $(UNIX_DIR)/tcl.pc.in $(MAC_OSX_DIR)/configure genstubs +$(TOP_DIR)/manifest.uuid: + printf "git." >$(TOP_DIR)/manifest.uuid + git rev-parse HEAD >>$(TOP_DIR)/manifest.uuid + +dist: $(UNIX_DIR)/configure $(UNIX_DIR)/tclConfig.h.in $(UNIX_DIR)/tcl.pc.in $(MAC_OSX_DIR)/configure $(TOP_DIR)/manifest.uuid genstubs rm -rf $(DISTDIR) mkdir -p $(DISTDIR)/unix + cp -p $(TOP_DIR)/manifest.uuid $(DISTDIR) cp -p $(UNIX_DIR)/*.[ch] $(DISTDIR)/unix cp $(UNIX_DIR)/Makefile.in $(DISTDIR)/unix chmod 664 $(DISTDIR)/unix/Makefile.in diff --git a/unix/tclConfig.h.in b/unix/tclConfig.h.in index 0879c7a..c02adc5 100644 --- a/unix/tclConfig.h.in +++ b/unix/tclConfig.h.in @@ -4,6 +4,9 @@ #ifndef _TCLCONFIG #define _TCLCONFIG +/* Define if building universal (internal helper macro) */ +#undef AC_APPLE_UNIVERSAL_BUILD + /* Is pthread_attr_get_np() declared in ? */ #undef ATTRGETNP_NOT_DECLARED @@ -37,6 +40,17 @@ /* Is the cpuid instruction usable? */ #undef HAVE_CPUID +/* Define to 1 if you have the declaration of `gethostbyaddr_r', and to 0 if + you don't. */ +#undef HAVE_DECL_GETHOSTBYADDR_R + +/* Define to 1 if you have the declaration of `gethostbyname_r', and to 0 if + you don't. */ +#undef HAVE_DECL_GETHOSTBYNAME_R + +/* Is 'DIR64' in ? */ +#undef HAVE_DIR64 + /* Do we have fts functions? */ #undef HAVE_FTS @@ -193,16 +207,13 @@ /* Is 'struct dirent64' in ? */ #undef HAVE_STRUCT_DIRENT64 -/* Is 'DIR64' in ? */ -#undef HAVE_DIR64 - /* Is 'struct stat64' in ? */ #undef HAVE_STRUCT_STAT64 -/* Define to 1 if `st_blksize' is member of `struct stat'. */ +/* Define to 1 if `st_blksize' is a member of `struct stat'. */ #undef HAVE_STRUCT_STAT_ST_BLKSIZE -/* Define to 1 if `st_blocks' is member of `struct stat'. */ +/* Define to 1 if `st_blocks' is a member of `struct stat'. */ #undef HAVE_STRUCT_STAT_ST_BLOCKS /* Define to 1 if you have the header file. */ @@ -337,6 +348,9 @@ /* Define to the one symbol short name of this package. */ #undef PACKAGE_TARNAME +/* Define to the home page for this package. */ +#undef PACKAGE_URL + /* Define to the version of this package. */ #undef PACKAGE_VERSION @@ -430,9 +444,17 @@ /* Should we use vfork() instead of fork()? */ #undef USE_VFORK -/* Define to 1 if your processor stores words with the most significant byte - first (like Motorola and SPARC, unlike Intel and VAX). */ -#undef WORDS_BIGENDIAN +/* Define WORDS_BIGENDIAN to 1 if your processor stores words with the most + significant byte first (like Motorola and SPARC, unlike Intel). */ +#if defined AC_APPLE_UNIVERSAL_BUILD +# if defined __BIG_ENDIAN__ +# define WORDS_BIGENDIAN 1 +# endif +#else +# ifndef WORDS_BIGENDIAN +# undef WORDS_BIGENDIAN +# endif +#endif /* Are Darwin SUSv3 extensions available? */ #undef _DARWIN_C_SOURCE @@ -487,7 +509,7 @@ /* Define to `int' if does not define. */ #undef pid_t -/* Define to `unsigned' if does not define. */ +/* Define to `unsigned int' if does not define. */ #undef size_t /* Define as int if socklen_t is not available */ -- cgit v0.12 From 034bd13a3cd5781c916ced37c764a6634e458499 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 24 Jun 2020 13:05:47 +0000 Subject: Fix [9080d6a871]: Build fix for tcl on macOS on Apple Silicon --- .fossil-settings/ignore-glob | 10 ++++++++++ .gitignore | 2 ++ unix/configure | 3 +++ unix/configure.in | 2 ++ unix/tcl.m4 | 6 +++++- unix/tclConfig.h.in | 40 +++++++++------------------------------- 6 files changed, 31 insertions(+), 32 deletions(-) diff --git a/.fossil-settings/ignore-glob b/.fossil-settings/ignore-glob index 62a7a5a..eca9bcd 100644 --- a/.fossil-settings/ignore-glob +++ b/.fossil-settings/ignore-glob @@ -11,6 +11,7 @@ *.sl *.so */Makefile +*/autom4te.cache */config.cache */config.log */config.status @@ -40,10 +41,19 @@ libtommath/etc/* libtommath/demo/* libtommath/*.out libtommath/*.tex +macosx/configure unix/autoMkindex.tcl unix/dltest.marker +unix/dltest/*.bundle +unix/dltest/*.dll +unix/dltest/*.dylib +unix/dltest/*.o +unix/dltest/*.sl +unix/dltest/*.so unix/tcl.pc unix/tclIndex +unix/Tcl-Info.plist +unix/Tclsh-Info.plist unix/pkgs/* win/Debug* win/Release* diff --git a/.gitignore b/.gitignore index 3f6ce0c..701419b 100644 --- a/.gitignore +++ b/.gitignore @@ -14,6 +14,7 @@ .fslckout Makefile Tcl-Info.plist +autom4te.cache config.cache config.log config.status @@ -46,6 +47,7 @@ libtommath/etc/* libtommath/demo/* libtommath/*.out libtommath/*.tex +macosx/configure unix/autoMkindex.tcl unix/dltest.marker unix/tcl.pc diff --git a/unix/configure b/unix/configure index b02525b..a900a70 100755 --- a/unix/configure +++ b/unix/configure @@ -15050,6 +15050,7 @@ cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ int main() { + #include extern double strtod(); char *term, *string = " +69"; exit(strtod(string,&term) != 69 || term != string+4); @@ -15220,6 +15221,7 @@ cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ + #include extern double strtod(); int main() { char *infString="Inf", *nanString="NaN", *spaceString=" "; @@ -16607,6 +16609,7 @@ cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include + #include #define OURVAR "havecopy=yes" int main (int argc, char *argv[]) { diff --git a/unix/configure.in b/unix/configure.in index c110c21..a4ec925 100644 --- a/unix/configure.in +++ b/unix/configure.in @@ -298,6 +298,7 @@ SC_TCL_CHECK_BROKEN_FUNC(strtoul, [ #-------------------------------------------------------------------- SC_TCL_CHECK_BROKEN_FUNC(strtod, [ + #include extern double strtod(); char *term, *string = " +69"; exit(strtod(string,&term) != 69 || term != string+4); @@ -453,6 +454,7 @@ fi AC_CACHE_CHECK([for a putenv() that copies the buffer], tcl_cv_putenv_copy, [ AC_TRY_RUN([ #include + #include #define OURVAR "havecopy=yes" int main (int argc, char *argv[]) { diff --git a/unix/tcl.m4 b/unix/tcl.m4 index 0dd4d77..4c96316 100644 --- a/unix/tcl.m4 +++ b/unix/tcl.m4 @@ -2596,6 +2596,7 @@ AC_DEFUN([SC_BUGGY_STRTOD], [ if test "$tcl_strtod" = 1; then AC_CACHE_CHECK([for Solaris2.4/Tru64 strtod bugs], tcl_cv_strtod_buggy,[ AC_TRY_RUN([ + #include extern double strtod(); int main() { char *infString="Inf", *nanString="NaN", *spaceString=" "; @@ -2882,7 +2883,10 @@ AC_DEFUN([SC_TCL_CHECK_BROKEN_FUNC],[ AC_CHECK_FUNC($1, tcl_ok=1, tcl_ok=0) if test ["$tcl_ok"] = 1; then AC_CACHE_CHECK([proper ]$1[ implementation], [tcl_cv_]$1[_unbroken], - AC_TRY_RUN([[int main() {]$2[}]],[tcl_cv_]$1[_unbroken]=ok, + AC_TRY_RUN([[ +#include +#include +int main() {]$2[}]],[tcl_cv_]$1[_unbroken]=ok, [tcl_cv_]$1[_unbroken]=broken,[tcl_cv_]$1[_unbroken]=unknown)) if test ["$tcl_cv_]$1[_unbroken"] = "ok"; then tcl_ok=1 diff --git a/unix/tclConfig.h.in b/unix/tclConfig.h.in index c02adc5..0879c7a 100644 --- a/unix/tclConfig.h.in +++ b/unix/tclConfig.h.in @@ -4,9 +4,6 @@ #ifndef _TCLCONFIG #define _TCLCONFIG -/* Define if building universal (internal helper macro) */ -#undef AC_APPLE_UNIVERSAL_BUILD - /* Is pthread_attr_get_np() declared in ? */ #undef ATTRGETNP_NOT_DECLARED @@ -40,17 +37,6 @@ /* Is the cpuid instruction usable? */ #undef HAVE_CPUID -/* Define to 1 if you have the declaration of `gethostbyaddr_r', and to 0 if - you don't. */ -#undef HAVE_DECL_GETHOSTBYADDR_R - -/* Define to 1 if you have the declaration of `gethostbyname_r', and to 0 if - you don't. */ -#undef HAVE_DECL_GETHOSTBYNAME_R - -/* Is 'DIR64' in ? */ -#undef HAVE_DIR64 - /* Do we have fts functions? */ #undef HAVE_FTS @@ -207,13 +193,16 @@ /* Is 'struct dirent64' in ? */ #undef HAVE_STRUCT_DIRENT64 +/* Is 'DIR64' in ? */ +#undef HAVE_DIR64 + /* Is 'struct stat64' in ? */ #undef HAVE_STRUCT_STAT64 -/* Define to 1 if `st_blksize' is a member of `struct stat'. */ +/* Define to 1 if `st_blksize' is member of `struct stat'. */ #undef HAVE_STRUCT_STAT_ST_BLKSIZE -/* Define to 1 if `st_blocks' is a member of `struct stat'. */ +/* Define to 1 if `st_blocks' is member of `struct stat'. */ #undef HAVE_STRUCT_STAT_ST_BLOCKS /* Define to 1 if you have the header file. */ @@ -348,9 +337,6 @@ /* Define to the one symbol short name of this package. */ #undef PACKAGE_TARNAME -/* Define to the home page for this package. */ -#undef PACKAGE_URL - /* Define to the version of this package. */ #undef PACKAGE_VERSION @@ -444,17 +430,9 @@ /* Should we use vfork() instead of fork()? */ #undef USE_VFORK -/* Define WORDS_BIGENDIAN to 1 if your processor stores words with the most - significant byte first (like Motorola and SPARC, unlike Intel). */ -#if defined AC_APPLE_UNIVERSAL_BUILD -# if defined __BIG_ENDIAN__ -# define WORDS_BIGENDIAN 1 -# endif -#else -# ifndef WORDS_BIGENDIAN -# undef WORDS_BIGENDIAN -# endif -#endif +/* Define to 1 if your processor stores words with the most significant byte + first (like Motorola and SPARC, unlike Intel and VAX). */ +#undef WORDS_BIGENDIAN /* Are Darwin SUSv3 extensions available? */ #undef _DARWIN_C_SOURCE @@ -509,7 +487,7 @@ /* Define to `int' if does not define. */ #undef pid_t -/* Define to `unsigned int' if does not define. */ +/* Define to `unsigned' if does not define. */ #undef size_t /* Define as int if socklen_t is not available */ -- cgit v0.12 From efc338be246089be082ed7117f418735a2acecdd Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 24 Jun 2020 14:40:17 +0000 Subject: re-generate unix/configure --- unix/configure | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/unix/configure b/unix/configure index a900a70..1562f6c 100755 --- a/unix/configure +++ b/unix/configure @@ -14715,6 +14715,9 @@ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ + +#include +#include int main() { extern int strstr(); exit(strstr("\0test", "test") ? 1 : 0); @@ -14882,6 +14885,9 @@ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ + +#include +#include int main() { extern int strtoul(); char *term, *string = "0"; @@ -15049,6 +15055,9 @@ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ + +#include +#include int main() { #include extern double strtod(); -- cgit v0.12 From 56d2c7e23c1acd887d31a182324a9861cb6e68dd Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 24 Jun 2020 14:56:12 +0000 Subject: One include too much --- unix/configure | 1 - unix/configure.in | 1 - 2 files changed, 2 deletions(-) diff --git a/unix/configure b/unix/configure index 1562f6c..1c0c2be 100755 --- a/unix/configure +++ b/unix/configure @@ -15059,7 +15059,6 @@ cat >>conftest.$ac_ext <<_ACEOF #include #include int main() { - #include extern double strtod(); char *term, *string = " +69"; exit(strtod(string,&term) != 69 || term != string+4); diff --git a/unix/configure.in b/unix/configure.in index a4ec925..2556430 100644 --- a/unix/configure.in +++ b/unix/configure.in @@ -298,7 +298,6 @@ SC_TCL_CHECK_BROKEN_FUNC(strtoul, [ #-------------------------------------------------------------------- SC_TCL_CHECK_BROKEN_FUNC(strtod, [ - #include extern double strtod(); char *term, *string = " +69"; exit(strtod(string,&term) != 69 || term != string+4); -- cgit v0.12 From 97d82cb4b15f18701d239609308aa41c3b89d75c Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 25 Jun 2020 12:11:56 +0000 Subject: Clean-up compat functions, not using "register" any more, and fix some signatures (constify) matching nowadays standards. All backported from core-8-branch with modifications. --- compat/fixstrtod.c | 2 +- compat/gettod.c | 5 +++-- compat/memcmp.c | 10 +++++----- compat/opendir.c | 22 +++++++++++----------- compat/strncasecmp.c | 16 ++++++++-------- compat/strstr.c | 12 ++++++------ compat/strtod.c | 14 +++++++------- compat/strtol.c | 7 +++---- compat/strtoul.c | 16 ++++++++-------- compat/waitpid.c | 4 ++-- 10 files changed, 54 insertions(+), 54 deletions(-) diff --git a/compat/fixstrtod.c b/compat/fixstrtod.c index 91f309e..63fb8ef 100644 --- a/compat/fixstrtod.c +++ b/compat/fixstrtod.c @@ -1,4 +1,4 @@ -/* +/* * fixstrtod.c -- * * Source code for the "fixstrtod" procedure. This procedure is diff --git a/compat/gettod.c b/compat/gettod.c index 28e1432..f6651d4 100644 --- a/compat/gettod.c +++ b/compat/gettod.c @@ -1,4 +1,4 @@ -/* +/* * gettod.c -- * * This file provides the gettimeofday function on systems @@ -21,10 +21,11 @@ gettimeofday( struct timezone *tz) { struct timeb t; + (void)tz; ftime(&t); tp->tv_sec = t.time; - tp->tv_usec = t. millitm * 1000; + tp->tv_usec = t.millitm * 1000; return 0; } diff --git a/compat/memcmp.c b/compat/memcmp.c index 5fce528..c4e25a8 100644 --- a/compat/memcmp.c +++ b/compat/memcmp.c @@ -15,7 +15,7 @@ * Here is the prototype just in case it is not included in tclPort.h. */ -int memcmp(CONST VOID *s1, CONST VOID *s2, size_t n); +int memcmp(const void *s1, const void *s2, size_t n); /* *---------------------------------------------------------------------- @@ -38,12 +38,12 @@ int memcmp(CONST VOID *s1, CONST VOID *s2, size_t n); int memcmp( - CONST VOID *s1, /* First string. */ - CONST VOID *s2, /* Second string. */ + const void *s1, /* First string. */ + const void *s2, /* Second string. */ size_t n) /* Length to compare. */ { - CONST unsigned char *ptr1 = (CONST unsigned char *) s1; - CONST unsigned char *ptr2 = (CONST unsigned char *) s2; + const unsigned char *ptr1 = (const unsigned char *) s1; + const unsigned char *ptr2 = (const unsigned char *) s2; for ( ; n-- ; ptr1++, ptr2++) { unsigned char u1 = *ptr1, u2 = *ptr2; diff --git a/compat/opendir.c b/compat/opendir.c index 3fe70c1..25a7ada 100644 --- a/compat/opendir.c +++ b/compat/opendir.c @@ -1,4 +1,4 @@ -/* +/* * opendir.c -- * * This file provides dirent-style directory-reading procedures for V7 @@ -10,7 +10,7 @@ #undef DIRSIZ #define DIRSIZ(dp) \ - ((sizeof (struct dirent) - (MAXNAMLEN+1)) + (((dp)->d_namlen+1 + 3) &~ 3)) + ((sizeof(struct dirent) - (MAXNAMLEN+1)) + (((dp)->d_namlen+1 + 3) &~ 3)) /* * open a directory. @@ -20,9 +20,9 @@ DIR * opendir( char *name) { - register DIR *dirp; - register int fd; - char *myname; + DIR *dirp; + int fd; + const char *myname; myname = ((*name == '\0') ? "." : name); if ((fd = open(myname, 0, 0)) == -1) { @@ -45,14 +45,14 @@ opendir( #ifndef pyr #define ODIRSIZ 14 -struct olddirect { +struct olddirect { ino_t od_ino; char od_name[ODIRSIZ]; }; #else /* a Pyramid in the ATT universe */ #define ODIRSIZ 248 -struct olddirect { +struct olddirect { long od_ino; short od_fill1, od_fill2; char od_name[ODIRSIZ]; @@ -65,9 +65,9 @@ struct olddirect { struct dirent * readdir( - register DIR *dirp) + DIR *dirp) { - register struct olddirect *dp; + struct olddirect *dp; static struct dirent dir; for (;;) { @@ -101,10 +101,10 @@ readdir( void closedir( - register DIR *dirp) + DIR *dirp) { close(dirp->dd_fd); dirp->dd_fd = -1; dirp->dd_loc = 0; - ckfree((char *) dirp); + ckfree(dirp); } diff --git a/compat/strncasecmp.c b/compat/strncasecmp.c index 76cf549..0a69f35 100644 --- a/compat/strncasecmp.c +++ b/compat/strncasecmp.c @@ -1,4 +1,4 @@ -/* +/* * strncasecmp.c -- * * Source code for the "strncasecmp" library routine. @@ -18,7 +18,7 @@ * sequences. */ -static unsigned char charmap[] = { +static const unsigned char charmap[] = { 0x00, 0x01, 0x02, 0x03, 0x04, 0x05, 0x06, 0x07, 0x08, 0x09, 0x0a, 0x0b, 0x0c, 0x0d, 0x0e, 0x0f, 0x10, 0x11, 0x12, 0x13, 0x14, 0x15, 0x16, 0x17, @@ -57,8 +57,8 @@ static unsigned char charmap[] = { * Here are the prototypes just in case they are not included in tclPort.h. */ -int strncasecmp(CONST char *s1, CONST char *s2, size_t n); -int strcasecmp(CONST char *s1, CONST char *s2); +int strncasecmp(const char *s1, const char *s2, size_t n); +int strcasecmp(const char *s1, const char *s2); /* *---------------------------------------------------------------------- @@ -79,8 +79,8 @@ int strcasecmp(CONST char *s1, CONST char *s2); int strcasecmp( - CONST char *s1, /* First string. */ - CONST char *s2) /* Second string. */ + const char *s1, /* First string. */ + const char *s2) /* Second string. */ { unsigned char u1, u2; @@ -114,8 +114,8 @@ strcasecmp( int strncasecmp( - CONST char *s1, /* First string. */ - CONST char *s2, /* Second string. */ + const char *s1, /* First string. */ + const char *s2, /* Second string. */ size_t length) /* Maximum number of characters to compare * (stop earlier if the end of either string * is reached). */ diff --git a/compat/strstr.c b/compat/strstr.c index 6698c9f..35386d0 100644 --- a/compat/strstr.c +++ b/compat/strstr.c @@ -1,4 +1,4 @@ -/* +/* * strstr.c -- * * Source code for the "strstr" library routine. @@ -36,10 +36,10 @@ char * strstr( - register char *string, /* String to search. */ - char *substring) /* Substring to try to find in string. */ + const char *string, /* String to search. */ + const char *substring) /* Substring to try to find in string. */ { - register char *a, *b; + const char *a, *b; /* * First scan quickly through the two strings looking for a @@ -49,7 +49,7 @@ strstr( b = substring; if (*b == 0) { - return string; + return (char *)string; } for ( ; *string != 0; string += 1) { if (*string != *b) { @@ -58,7 +58,7 @@ strstr( a = string; while (1) { if (*b == 0) { - return string; + return (char *)string; } if (*a++ != *b++) { break; diff --git a/compat/strtod.c b/compat/strtod.c index 1147825..b3b02d9 100644 --- a/compat/strtod.c +++ b/compat/strtod.c @@ -1,4 +1,4 @@ -/* +/* * strtod.c -- * * Source code for the "strtod" library procedure. @@ -61,7 +61,7 @@ static double powersOf10[] = { /* Table giving binary powers of 10. Entry */ double strtod( - CONST char *string, /* A decimal ASCII floating-point number, + const char *string, /* A decimal ASCII floating-point number, * optionally preceded by white space. Must * have form "-I.FE-X", where I is the integer * part of the mantissa, F is the fractional @@ -77,8 +77,8 @@ strtod( { int sign, expSign = FALSE; double fraction, dblExp, *d; - register CONST char *p; - register int c; + const char *p; + int c; int exp = 0; /* Exponent read from "EX" field. */ int fracExp = 0; /* Exponent that derives from the fractional * part. Under normal circumstatnces, it is @@ -92,7 +92,7 @@ strtod( int mantSize; /* Number of digits in mantissa. */ int decPt; /* Number of mantissa digits BEFORE decimal * point. */ - CONST char *pExp; /* Temporarily holds location of exponent in + const char *pExp; /* Temporarily holds location of exponent in * string. */ /* @@ -137,7 +137,7 @@ strtod( * has more than 18 digits, ignore the extras, since they can't affect the * value anyway. */ - + pExp = p; p -= mantSize; if (decPt < 0) { @@ -217,7 +217,7 @@ strtod( * by processing the exponent one bit at a time to combine many powers of * 2 of 10. Then combine the exponent with the fraction. */ - + if (exp < 0) { expSign = TRUE; exp = -exp; diff --git a/compat/strtol.c b/compat/strtol.c index 793f094..a9866f4 100644 --- a/compat/strtol.c +++ b/compat/strtol.c @@ -1,4 +1,4 @@ -/* +/* * strtol.c -- * * Source code for the "strtol" library procedure. @@ -10,7 +10,6 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ -#include #include "tclInt.h" /* @@ -34,7 +33,7 @@ long int strtol( - CONST char *string, /* String of ASCII digits, possibly preceded + const char *string, /* String of ASCII digits, possibly preceded * by white space. For bases greater than 10, * either lower- or upper-case digits may be * used. */ @@ -46,7 +45,7 @@ strtol( * hex, "0" means octal, anything else means * decimal. */ { - register CONST char *p; + const char *p; long result; /* diff --git a/compat/strtoul.c b/compat/strtoul.c index 9d3f372..af63036 100644 --- a/compat/strtoul.c +++ b/compat/strtoul.c @@ -1,4 +1,4 @@ -/* +/* * strtoul.c -- * * Source code for the "strtoul" library procedure. @@ -18,7 +18,7 @@ * characters). */ -static char cvtIn[] = { +static const char cvtIn[] = { 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, /* '0' - '9' */ 100, 100, 100, 100, 100, 100, 100, /* punctuation */ 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, /* 'A' - 'Z' */ @@ -50,7 +50,7 @@ static char cvtIn[] = { unsigned long int strtoul( - CONST char *string, /* String of ASCII digits, possibly preceded + const char *string, /* String of ASCII digits, possibly preceded * by white space. For bases greater than 10, * either lower- or upper-case digits may be * used. */ @@ -62,9 +62,9 @@ strtoul( * hex, "0" means octal, anything else means * decimal. */ { - register CONST char *p; - register unsigned long int result = 0; - register unsigned digit; + const char *p; + unsigned long int result = 0; + unsigned digit; int anyDigits = 0; int negative=0; int overflow=0; @@ -90,7 +90,7 @@ strtoul( * If no base was provided, pick one from the leading characters of the * string. */ - + if (base == 0) { if (*p == '0') { p += 1; @@ -206,7 +206,7 @@ strtoul( if (overflow) { errno = ERANGE; return ULONG_MAX; - } + } if (negative) { return -result; } diff --git a/compat/waitpid.c b/compat/waitpid.c index 8f65799..6f43934 100644 --- a/compat/waitpid.c +++ b/compat/waitpid.c @@ -1,4 +1,4 @@ -/* +/* * waitpid.c -- * * This procedure emulates the POSIX waitpid kernel call on BSD systems @@ -70,7 +70,7 @@ waitpid( int options) /* OR'ed combination of WNOHANG and * WUNTRACED. */ { - register WaitInfo *waitPtr, *prevPtr; + WaitInfo *waitPtr, *prevPtr; pid_t result; WAIT_STATUS_TYPE status; -- cgit v0.12 From e758e349344fca7d9511356a69b89eb7177194e1 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 26 Jun 2020 13:29:41 +0000 Subject: Add "make dist" target to Travis build, as regression test. This should continue to work. --- .travis.yml | 1 + unix/installManPage | 2 +- 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/.travis.yml b/.travis.yml index 77e52ea..2f93f24 100644 --- a/.travis.yml +++ b/.travis.yml @@ -372,3 +372,4 @@ script: - make all tcltest - make test - make install + - make dist diff --git a/unix/installManPage b/unix/installManPage index 1af3f6d..00c6cc5 100755 --- a/unix/installManPage +++ b/unix/installManPage @@ -99,7 +99,7 @@ SrcDir=`dirname $ManPage` ### Process Page to Create Target Pages ### -Specials="DString Thread Notifier RegExp library packagens pkgMkIndex safesock" +Specials="DString Thread Notifier RegExp library packagens pkgMkIndex safesock FindPhoto FontId MeasureChar" for n in $Specials; do if [ "$Name" = "$n" ] ; then Names="$n $Names" -- cgit v0.12 From 2c7d6403e8bf45a9d610dd24471c79ffc0efb10f Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 28 Jun 2020 15:13:31 +0000 Subject: MacOSX: add some type-casts, improving C++ compatibility. Make sure that strstr and strtoul() are not configured as invalid: Mac is more strict in exact function signatures. Backported from 8.7 --- macosx/tclMacOSXBundle.c | 2 +- macosx/tclMacOSXFCmd.c | 8 ++++---- macosx/tclMacOSXNotify.c | 28 +++++++++++++++++++--------- unix/configure | 2 -- unix/configure.in | 2 -- 5 files changed, 24 insertions(+), 18 deletions(-) diff --git a/macosx/tclMacOSXBundle.c b/macosx/tclMacOSXBundle.c index 9fadb7b..beef2ed 100644 --- a/macosx/tclMacOSXBundle.c +++ b/macosx/tclMacOSXBundle.c @@ -106,7 +106,7 @@ OpenResourceMap( if (tclMacOSXDarwinRelease >= 8) #endif { - openresourcemap = dlsym(RTLD_NEXT, + openresourcemap = (short (*)(CFBundleRef))dlsym(RTLD_NEXT, "CFBundleOpenBundleResourceMap"); #ifdef TCL_DEBUG_LOAD if (!openresourcemap) { diff --git a/macosx/tclMacOSXFCmd.c b/macosx/tclMacOSXFCmd.c index f34b280..e462e5e 100644 --- a/macosx/tclMacOSXFCmd.c +++ b/macosx/tclMacOSXFCmd.c @@ -106,7 +106,7 @@ typedef struct finderinfo { u_int32_t extendedFileInfo[4]; } __attribute__ ((__packed__)) finderinfo; -typedef struct fileinfobuf { +typedef struct { u_int32_t info_length; u_int32_t data[8]; } fileinfobuf; @@ -172,7 +172,7 @@ TclMacOSXGetFileAttribute( } else { alist.commonattr = ATTR_CMN_FNDRINFO; } - native = Tcl_FSGetNativePath(fileName); + native = (const char *)Tcl_FSGetNativePath(fileName); result = getattrlist(native, &alist, &finfo, sizeof(fileinfobuf), 0); if (result != 0) { @@ -268,7 +268,7 @@ TclMacOSXSetFileAttribute( } else { alist.commonattr = ATTR_CMN_FNDRINFO; } - native = Tcl_FSGetNativePath(fileName); + native = (const char *)Tcl_FSGetNativePath(fileName); result = getattrlist(native, &alist, &finfo, sizeof(fileinfobuf), 0); if (result != 0) { @@ -347,7 +347,7 @@ TclMacOSXSetFileAttribute( Tcl_DStringAppend(&ds, native, -1); Tcl_DStringAppend(&ds, _PATH_RSRCFORKSPEC, -1); - result = truncate(Tcl_DStringValue(&ds), (off_t)0); + result = truncate(Tcl_DStringValue(&ds), 0); if (result != 0) { /* * truncate() on a valid resource fork path may fail with a diff --git a/macosx/tclMacOSXNotify.c b/macosx/tclMacOSXNotify.c index 9b7bd1a..01581cf 100644 --- a/macosx/tclMacOSXNotify.c +++ b/macosx/tclMacOSXNotify.c @@ -31,6 +31,9 @@ */ #if defined(HAVE_LIBKERN_OSATOMIC_H) && defined(HAVE_OSSPINLOCKLOCK) +#pragma GCC diagnostic push +#pragma GCC diagnostic ignored "-Wdeprecated-declarations" +#pragma GCC diagnostic ignored "-Wunused-function" /* * Use OSSpinLock API where available (Tiger or later). */ @@ -42,14 +45,17 @@ * Support for weakly importing spinlock API. */ #define WEAK_IMPORT_SPINLOCKLOCK + #if MAC_OS_X_VERSION_MAX_ALLOWED >= 1050 #define VOLATILE volatile #else #define VOLATILE #endif /* MAC_OS_X_VERSION_MAX_ALLOWED >= 1050 */ + #ifndef bool #define bool int #endif + extern void OSSpinLockLock(VOLATILE OSSpinLock *lock) WEAK_IMPORT_ATTRIBUTE; extern void OSSpinLockUnlock(VOLATILE OSSpinLock *lock) @@ -101,6 +107,7 @@ extern int _spin_lock_try(OSSpinLock *lock); #define SpinLockTry(p) _spin_lock_try(p) #define SPINLOCK_INIT 0 +#pragma GCC diagnostic pop #endif /* HAVE_LIBKERN_OSATOMIC_H && HAVE_OSSPINLOCKLOCK */ /* @@ -217,7 +224,7 @@ typedef struct FileHandler { * handlers are ready to fire. */ -typedef struct FileHandlerEvent { +typedef struct { Tcl_Event header; /* Information that is standard for all * events. */ int fd; /* File descriptor that is ready. Used to find @@ -232,7 +239,7 @@ typedef struct FileHandlerEvent { * writable, and exceptional conditions. */ -typedef struct SelectMasks { +typedef struct { fd_set readable; fd_set writable; fd_set exceptional; @@ -686,7 +693,7 @@ StartNotifierThread(void) void Tcl_FinalizeNotifier( - ClientData clientData) /* Not used. */ + ClientData clientData) { ThreadSpecificData *tsdPtr; @@ -789,7 +796,7 @@ void Tcl_AlertNotifier( ClientData clientData) { - ThreadSpecificData *tsdPtr = clientData; + ThreadSpecificData *tsdPtr = (ThreadSpecificData *)clientData; if (tclNotifierHooks.alertNotifierProc) { tclNotifierHooks.alertNotifierProc(clientData); @@ -967,7 +974,7 @@ Tcl_CreateFileHandler( } } if (filePtr == NULL) { - filePtr = ckalloc(sizeof(FileHandler)); + filePtr = (FileHandler *)ckalloc(sizeof(FileHandler)); filePtr->fd = fd; filePtr->readyMask = 0; filePtr->nextPtr = tsdPtr->firstFileHandlerPtr; @@ -1311,7 +1318,7 @@ QueueFileEvents( { SelectMasks readyMasks; FileHandler *filePtr; - ThreadSpecificData *tsdPtr = info; + ThreadSpecificData *tsdPtr = (ThreadSpecificData *)info; /* * Queue all detected file events. @@ -1350,7 +1357,7 @@ QueueFileEvents( */ if (filePtr->readyMask == 0) { - FileHandlerEvent *fileEvPtr = ckalloc(sizeof(FileHandlerEvent)); + FileHandlerEvent *fileEvPtr = (FileHandlerEvent *)ckalloc(sizeof(FileHandlerEvent)); fileEvPtr->header.proc = FileHandlerEventProc; fileEvPtr->fd = filePtr->fd; @@ -1383,7 +1390,7 @@ UpdateWaitingListAndServiceEvents( CFRunLoopActivity activity, void *info) { - ThreadSpecificData *tsdPtr = info; + ThreadSpecificData *tsdPtr = (ThreadSpecificData *)info; if (tsdPtr->sleeping) { return; @@ -1412,7 +1419,10 @@ UpdateWaitingListAndServiceEvents( (tsdPtr->runLoopNestingLevel > 1 || !tsdPtr->runLoopRunning)) { tsdPtr->runLoopServicingEvents = 1; - /* This call seems to simply force event processing through and prevents hangups that have long been observed with Tk-Cocoa. */ + /* + * This call seems to simply force event processing through and + * prevents hangups that have long been observed with Tk-Cocoa. + */ Tcl_ServiceAll(); tsdPtr->runLoopServicingEvents = 0; } diff --git a/unix/configure b/unix/configure index 73a8eac..7d40237 100755 --- a/unix/configure +++ b/unix/configure @@ -14926,7 +14926,6 @@ cat >>conftest.$ac_ext <<_ACEOF #include #include int main() { - extern int strstr(); exit(strstr("\0test", "test") ? 1 : 0); } _ACEOF @@ -15096,7 +15095,6 @@ cat >>conftest.$ac_ext <<_ACEOF #include #include int main() { - extern int strtoul(); char *term, *string = "0"; exit(strtoul(string,&term,0) != 0 || term != string+1); } diff --git a/unix/configure.in b/unix/configure.in index 9dd9b7f..2a66cb1 100644 --- a/unix/configure.in +++ b/unix/configure.in @@ -342,7 +342,6 @@ AC_CHECK_FUNC(memmove, , [ #-------------------------------------------------------------------- SC_TCL_CHECK_BROKEN_FUNC(strstr, [ - extern int strstr(); exit(strstr("\0test", "test") ? 1 : 0); ]) @@ -353,7 +352,6 @@ SC_TCL_CHECK_BROKEN_FUNC(strstr, [ #-------------------------------------------------------------------- SC_TCL_CHECK_BROKEN_FUNC(strtoul, [ - extern int strtoul(); char *term, *string = "0"; exit(strtoul(string,&term,0) != 0 || term != string+1); ]) -- cgit v0.12 From 1aeadf38fa5a0c61196589e1b2f4192200b41d49 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 29 Jun 2020 10:21:58 +0000 Subject: Re-generate unix/tclConfig.h.in --- unix/tclConfig.h.in | 26 ++++++++++++++++++++------ 1 file changed, 20 insertions(+), 6 deletions(-) diff --git a/unix/tclConfig.h.in b/unix/tclConfig.h.in index ce9c8d0..2aa3bb8 100644 --- a/unix/tclConfig.h.in +++ b/unix/tclConfig.h.in @@ -4,6 +4,9 @@ #ifndef _TCLCONFIG #define _TCLCONFIG +/* Define if building universal (internal helper macro) */ +#undef AC_APPLE_UNIVERSAL_BUILD + /* Is gettimeofday() actually declared in ? */ #undef GETTOD_NOT_DECLARED @@ -219,10 +222,10 @@ /* Is 'struct stat64' in ? */ #undef HAVE_STRUCT_STAT64 -/* Define to 1 if `st_blksize' is member of `struct stat'. */ +/* Define to 1 if `st_blksize' is a member of `struct stat'. */ #undef HAVE_STRUCT_STAT_ST_BLKSIZE -/* Define to 1 if `st_blocks' is member of `struct stat'. */ +/* Define to 1 if `st_blocks' is a member of `struct stat'. */ #undef HAVE_STRUCT_STAT_ST_BLOCKS /* Define to 1 if you have the header file. */ @@ -363,6 +366,9 @@ /* Define to the one symbol short name of this package. */ #undef PACKAGE_TARNAME +/* Define to the home page for this package. */ +#undef PACKAGE_URL + /* Define to the version of this package. */ #undef PACKAGE_VERSION @@ -441,9 +447,17 @@ /* Should we use vfork() instead of fork()? */ #undef USE_VFORK -/* Define to 1 if your processor stores words with the most significant byte - first (like Motorola and SPARC, unlike Intel and VAX). */ -#undef WORDS_BIGENDIAN +/* Define WORDS_BIGENDIAN to 1 if your processor stores words with the most + significant byte first (like Motorola and SPARC, unlike Intel). */ +#if defined AC_APPLE_UNIVERSAL_BUILD +# if defined __BIG_ENDIAN__ +# define WORDS_BIGENDIAN 1 +# endif +#else +# ifndef WORDS_BIGENDIAN +# undef WORDS_BIGENDIAN +# endif +#endif /* Are Darwin SUSv3 extensions available? */ #undef _DARWIN_C_SOURCE @@ -498,7 +512,7 @@ /* Define to `int' if does not define. */ #undef pid_t -/* Define to `unsigned' if does not define. */ +/* Define to `unsigned int' if does not define. */ #undef size_t /* Define as int if socklen_t is not available */ -- cgit v0.12 From 22d9a275de6676c097e323284da1e19ae11a45f5 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 29 Jun 2020 12:41:08 +0000 Subject: A few missing entries in .fossil-settings/ignore-glob and .gitignore --- .fossil-settings/ignore-glob | 1 + .gitignore | 3 +++ 2 files changed, 4 insertions(+) diff --git a/.fossil-settings/ignore-glob b/.fossil-settings/ignore-glob index 51c422e..a58aef5 100644 --- a/.fossil-settings/ignore-glob +++ b/.fossil-settings/ignore-glob @@ -1,6 +1,7 @@ *.a *.dll *.dylib +*.dylib.E *.exe *.exp *.la diff --git a/.gitignore b/.gitignore index 701419b..33579cf 100644 --- a/.gitignore +++ b/.gitignore @@ -2,6 +2,7 @@ *.bundle *.dll *.dylib +*.dylib.E *.exe *.exp *.lib @@ -14,6 +15,7 @@ .fslckout Makefile Tcl-Info.plist +Tclsh-Info.plist autom4te.cache config.cache config.log @@ -59,4 +61,5 @@ win/*.manifest win/pkgs/* win/coffbase.txt win/tcl.hpj +win/nmakehlp.out win/nmhlp-out.txt -- cgit v0.12 From 932835c1ebe010e7c12090fc2a09d00170c641ba Mon Sep 17 00:00:00 2001 From: sebres Date: Tue, 30 Jun 2020 11:59:48 +0000 Subject: doc/clock.n: clearer form explaininng format groups on output --- doc/clock.n | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/doc/clock.n b/doc/clock.n index 0460a54..b2d53ed 100644 --- a/doc/clock.n +++ b/doc/clock.n @@ -448,36 +448,36 @@ The following format groups are recognized by the \fBclock scan\fR and \fBclock format\fR commands. .TP \fB%a\fR -On output, receives an abbreviation (\fIe.g.,\fR \fBMon\fR) for the day +On output, produces an abbreviation (\fIe.g.,\fR \fBMon\fR) for the day of the week in the given locale. On input, matches the name of the day of the week in the given locale (in either abbreviated or full form, or any unique prefix of either form). .TP \fB%A\fR -On output, receives the full name (\fIe.g.,\fR \fBMonday\fR) of the day +On output, produces the full name (\fIe.g.,\fR \fBMonday\fR) of the day of the week in the given locale. On input, matches the name of the day of the week in the given locale (in either abbreviated or full form, or any unique prefix of either form). .TP \fB%b\fR -On output, receives an abbreviation (\fIe.g.,\fR \fBJan\fR) for the name +On output, produces an abbreviation (\fIe.g.,\fR \fBJan\fR) for the name of the month in the given locale. On input, matches the name of the month in the given locale (in either abbreviated or full form, or any unique prefix of either form). .TP \fB%B\fR -On output, receives the full name (\fIe.g.,\fR \fBJanuary\fR) +On output, produces the full name (\fIe.g.,\fR \fBJanuary\fR) of the month in the given locale. On input, matches the name of the month in the given locale (in either abbreviated or full form, or any unique prefix of either form). .TP \fB%c\fR -On output, receives a localized representation of date and time of day; +On output, produces a localized representation of date and time of day; the localized representation is expected to use the Gregorian calendar. On input, matches whatever \fB%c\fR produces. .TP \fB%C\fR -On output, receives the number of the century in Indo-Arabic numerals. +On output, produces the number of the century in Indo-Arabic numerals. On input, matches one or two digits, possibly with leading whitespace, that are expected to be the number of the century. .TP -- cgit v0.12 From 870670e4d40ffddec9c1fda18e8dabfeaa3d9afe Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 3 Jul 2020 08:39:53 +0000 Subject: In tcl_startOfPreviousWord, don't bother doing a regexp when $start <= 0. --- library/word.tcl | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/library/word.tcl b/library/word.tcl index 3e4bc3a..4e57479 100644 --- a/library/word.tcl +++ b/library/word.tcl @@ -146,7 +146,9 @@ proc tcl_startOfNextWord {str start} { proc tcl_startOfPreviousWord {str start} { variable ::tcl::WordBreakRE set word {-1 -1} - regexp -indices -- $WordBreakRE(previous) [string range $str 0 $start-1] \ - result word + if {$start > 0} { + regexp -indices -- $WordBreakRE(previous) [string range $str 0 $start-1] \ + result word + } return [lindex $word 0] } -- cgit v0.12 From 131eb6c30bec526285cbc4dc33869718c17de7f4 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 7 Jul 2020 12:52:24 +0000 Subject: Make sure that in tclConfig.sh for Windows ${DBGX} is expanded before exporting TCL_(SHARED|UNSHARED|EXPORT)_LIB_SUFFIX there. Otherwise extensions removing ${DBGX} from their implementation (see TIP #578) will break on Windows. tclConfig.sh should never contain the macro ${DBGX} any more. (On UNIX this was already correct, on Windows it was forgotten) --- win/configure | 9 ++++----- win/configure.in | 9 ++++----- 2 files changed, 8 insertions(+), 10 deletions(-) diff --git a/win/configure b/win/configure index cc5a3fc..2cfd3a9 100755 --- a/win/configure +++ b/win/configure @@ -5064,10 +5064,6 @@ TCL_SHARED_BUILD=${SHARED_BUILD} # Perform final evaluations of variables with possible substitutions. #-------------------------------------------------------------------- -TCL_SHARED_LIB_SUFFIX="\${NODOT_VERSION}${DLLSUFFIX}" -TCL_UNSHARED_LIB_SUFFIX="\${NODOT_VERSION}${LIBSUFFIX}" -TCL_EXPORT_FILE_SUFFIX="\${NODOT_VERSION}${LIBSUFFIX}" - eval "TCL_SRC_DIR=\"`cd $srcdir/..; $CYGPATH $(pwd)`\"" eval "TCL_DLL_FILE=tcl${VER}${DLLSUFFIX}" @@ -5086,12 +5082,15 @@ eval "TCL_LIB_SPEC=\"-L${libdir} -ltcl${VER}${FLAGSUFFIX}\"" # Install time header dir can be set via --includedir eval "TCL_INCLUDE_SPEC=\"-I${includedir}\"" - eval "DLLSUFFIX=${DLLSUFFIX}" eval "LIBPREFIX=${LIBPREFIX}" eval "LIBSUFFIX=${LIBSUFFIX}" eval "EXESUFFIX=${EXESUFFIX}" +TCL_SHARED_LIB_SUFFIX="\${NODOT_VERSION}${DLLSUFFIX}" +TCL_UNSHARED_LIB_SUFFIX="\${NODOT_VERSION}${LIBSUFFIX}" +TCL_EXPORT_FILE_SUFFIX="\${NODOT_VERSION}${LIBSUFFIX}" + CFG_TCL_SHARED_LIB_SUFFIX=${TCL_SHARED_LIB_SUFFIX} CFG_TCL_UNSHARED_LIB_SUFFIX=${TCL_UNSHARED_LIB_SUFFIX} CFG_TCL_EXPORT_FILE_SUFFIX=${TCL_EXPORT_FILE_SUFFIX} diff --git a/win/configure.in b/win/configure.in index d1b2b20..70553b8 100644 --- a/win/configure.in +++ b/win/configure.in @@ -300,10 +300,6 @@ TCL_SHARED_BUILD=${SHARED_BUILD} # Perform final evaluations of variables with possible substitutions. #-------------------------------------------------------------------- -TCL_SHARED_LIB_SUFFIX="\${NODOT_VERSION}${DLLSUFFIX}" -TCL_UNSHARED_LIB_SUFFIX="\${NODOT_VERSION}${LIBSUFFIX}" -TCL_EXPORT_FILE_SUFFIX="\${NODOT_VERSION}${LIBSUFFIX}" - eval "TCL_SRC_DIR=\"`cd $srcdir/..; $CYGPATH $(pwd)`\"" eval "TCL_DLL_FILE=tcl${VER}${DLLSUFFIX}" @@ -322,12 +318,15 @@ eval "TCL_LIB_SPEC=\"-L${libdir} -ltcl${VER}${FLAGSUFFIX}\"" # Install time header dir can be set via --includedir eval "TCL_INCLUDE_SPEC=\"-I${includedir}\"" - eval "DLLSUFFIX=${DLLSUFFIX}" eval "LIBPREFIX=${LIBPREFIX}" eval "LIBSUFFIX=${LIBSUFFIX}" eval "EXESUFFIX=${EXESUFFIX}" +TCL_SHARED_LIB_SUFFIX="\${NODOT_VERSION}${DLLSUFFIX}" +TCL_UNSHARED_LIB_SUFFIX="\${NODOT_VERSION}${LIBSUFFIX}" +TCL_EXPORT_FILE_SUFFIX="\${NODOT_VERSION}${LIBSUFFIX}" + CFG_TCL_SHARED_LIB_SUFFIX=${TCL_SHARED_LIB_SUFFIX} CFG_TCL_UNSHARED_LIB_SUFFIX=${TCL_UNSHARED_LIB_SUFFIX} CFG_TCL_EXPORT_FILE_SUFFIX=${TCL_EXPORT_FILE_SUFFIX} -- cgit v0.12 From f77d355196ec60d248464b6b78b6b4f227ee82ae Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 9 Jul 2020 07:57:32 +0000 Subject: Proposed fix for [5019748c73]: FreeScan resp. Oldscan does not recognize positive time zone offset like "31 Jan 14 23:59:59 +0100" --- generic/tclDate.c | 250 ++++++++++++++++++++++++--------------------------- generic/tclGetDate.y | 21 +---- tests/clock.test | 101 +++++++++++++-------- 3 files changed, 184 insertions(+), 188 deletions(-) diff --git a/generic/tclDate.c b/generic/tclDate.c index dcb85e9..5410046 100644 --- a/generic/tclDate.c +++ b/generic/tclDate.c @@ -560,16 +560,16 @@ union yyalloc /* YYFINAL -- State number of the termination state. */ #define YYFINAL 2 /* YYLAST -- Last index in YYTABLE. */ -#define YYLAST 86 +#define YYLAST 81 /* YYNTOKENS -- Number of terminals. */ #define YYNTOKENS 26 /* YYNNTS -- Number of nonterminals. */ #define YYNNTS 16 /* YYNRULES -- Number of rules. */ -#define YYNRULES 57 +#define YYNRULES 56 /* YYNSTATES -- Number of states. */ -#define YYNSTATES 89 +#define YYNSTATES 85 /* YYTRANSLATE[YYX] -- Symbol number corresponding to YYX as returned by yylex, with out-of-bounds checking. */ @@ -587,7 +587,7 @@ static const yytype_uint8 yytranslate[] = 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, - 2, 2, 2, 25, 22, 21, 24, 23, 2, 2, + 2, 2, 2, 25, 21, 23, 24, 22, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 20, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, @@ -618,11 +618,11 @@ static const yytype_uint8 yytranslate[] = static const yytype_uint16 yyrline[] = { 0, 223, 223, 224, 227, 230, 233, 236, 239, 242, - 245, 249, 254, 257, 263, 269, 277, 283, 294, 299, - 304, 310, 314, 318, 322, 326, 332, 336, 341, 346, - 351, 356, 360, 365, 369, 374, 381, 385, 391, 401, - 410, 419, 429, 443, 448, 451, 454, 457, 460, 463, - 468, 471, 476, 480, 484, 490, 508, 511 + 245, 249, 254, 257, 263, 269, 277, 282, 287, 291, + 297, 301, 305, 309, 313, 319, 323, 328, 333, 338, + 343, 347, 352, 356, 361, 368, 372, 378, 388, 397, + 406, 416, 430, 435, 438, 441, 444, 447, 450, 455, + 458, 463, 467, 471, 477, 495, 498 }; #endif @@ -634,7 +634,7 @@ static const char *const yytname[] = "$end", "error", "$undefined", "tAGO", "tDAY", "tDAYZONE", "tID", "tMERIDIAN", "tMONTH", "tMONTH_UNIT", "tSTARDATE", "tSEC_UNIT", "tSNUMBER", "tUNUMBER", "tZONE", "tEPOCH", "tDST", "tISOBASE", - "tDAY_UNIT", "tNEXT", "':'", "'-'", "','", "'/'", "'.'", "'+'", + "tDAY_UNIT", "tNEXT", "':'", "','", "'/'", "'-'", "'.'", "'+'", "$accept", "spec", "item", "time", "zone", "day", "date", "ordMonth", "iso", "trek", "relspec", "relunits", "sign", "unit", "number", "o_merid", YY_NULLPTR @@ -648,14 +648,14 @@ static const yytype_uint16 yytoknum[] = { 0, 256, 257, 258, 259, 260, 261, 262, 263, 264, 265, 266, 267, 268, 269, 270, 271, 272, 273, 274, - 58, 45, 44, 47, 46, 43 + 58, 44, 47, 45, 46, 43 }; # endif -#define YYPACT_NINF -22 +#define YYPACT_NINF -18 #define yypact_value_is_default(Yystate) \ - (!!((Yystate) == (-22))) + (!!((Yystate) == (-18))) #define YYTABLE_NINF -1 @@ -666,15 +666,15 @@ static const yytype_uint16 yytoknum[] = STATE-NUM. */ static const yytype_int8 yypact[] = { - -22, 2, -22, -21, -22, -4, -22, 1, -22, 22, - 18, -22, 8, -22, 40, -22, -22, -22, -22, -22, - -22, -22, -22, -22, -22, -22, 32, 28, -22, -22, - -22, 24, 26, -22, -22, 42, 47, -5, 49, -22, - -22, 15, -22, -22, -22, 48, -22, -22, 43, 50, - 51, -22, 17, 44, 46, 45, 52, -22, -22, -22, - -22, -22, -22, -22, -22, 56, 57, -22, 58, 60, - 61, 62, -3, -22, -22, 63, -22, 59, 65, -22, - 67, 68, -22, 64, -22, 69, 66, 70, -22 + -18, 2, -18, -17, -18, -4, -18, 10, -18, 22, + 8, -18, 18, -18, 39, -18, -18, -18, -18, -18, + -18, -18, -18, -18, -18, -18, 25, 21, -18, -18, + -18, 16, 14, -18, -18, 28, 36, 41, -5, -18, + -18, 5, -18, -18, -18, 47, -18, -18, 42, 46, + 48, -18, -6, 40, 43, 44, 49, -18, -18, -18, + -18, -18, -18, -18, -18, 50, -18, 51, 55, 57, + 58, 65, -18, -18, 59, 54, -18, 62, 63, 60, + -18, 64, 61, 66, -18 }; /* YYDEFACT[STATE-NUM] -- Default reduction number in state STATE-NUM. @@ -682,29 +682,29 @@ static const yytype_int8 yypact[] = means the default is an error. */ static const yytype_uint8 yydefact[] = { - 2, 0, 1, 21, 20, 0, 54, 0, 52, 55, - 19, 34, 28, 53, 0, 50, 51, 3, 4, 5, - 8, 6, 7, 10, 11, 9, 44, 0, 49, 12, - 22, 31, 0, 23, 13, 33, 0, 0, 0, 46, - 18, 0, 41, 25, 36, 0, 47, 43, 0, 0, - 0, 35, 56, 0, 0, 26, 0, 39, 37, 48, - 24, 45, 32, 42, 57, 0, 0, 14, 0, 0, - 0, 0, 56, 15, 29, 30, 27, 0, 0, 16, - 0, 0, 17, 0, 40, 0, 0, 0, 38 + 2, 0, 1, 20, 18, 0, 53, 0, 51, 54, + 17, 33, 27, 52, 0, 49, 50, 3, 4, 5, + 8, 6, 7, 10, 11, 9, 43, 0, 48, 12, + 21, 30, 0, 22, 13, 32, 0, 0, 0, 45, + 16, 0, 40, 24, 35, 0, 46, 42, 19, 0, + 0, 34, 55, 25, 0, 0, 0, 38, 36, 47, + 23, 44, 31, 41, 56, 0, 14, 0, 0, 0, + 0, 55, 26, 28, 29, 0, 15, 0, 0, 0, + 39, 0, 0, 0, 37 }; /* YYPGOTO[NTERM-NUM]. */ static const yytype_int8 yypgoto[] = { - -22, -22, -22, -22, -22, -22, -22, -22, -22, -22, - -22, -22, -22, -9, -22, 4 + -18, -18, -18, -18, -18, -18, -18, -18, -18, -18, + -18, -18, -18, -9, -18, 7 }; /* YYDEFGOTO[NTERM-NUM]. */ static const yytype_int8 yydefgoto[] = { -1, 1, 17, 18, 19, 20, 21, 22, 23, 24, - 25, 26, 27, 28, 29, 67 + 25, 26, 27, 28, 29, 66 }; /* YYTABLE[YYPACT[STATE-NUM]] -- What to do in state STATE-NUM. If @@ -712,28 +712,28 @@ static const yytype_int8 yydefgoto[] = number is the opposite. If YYTABLE_NINF, syntax error. */ static const yytype_uint8 yytable[] = { - 39, 30, 2, 53, 64, 46, 3, 4, 54, 31, - 5, 6, 7, 8, 32, 9, 10, 11, 78, 12, - 13, 14, 41, 15, 64, 42, 33, 16, 56, 34, - 35, 6, 57, 8, 40, 47, 59, 65, 66, 61, - 13, 48, 36, 37, 43, 38, 49, 60, 44, 6, - 50, 8, 6, 45, 8, 51, 58, 6, 13, 8, - 52, 13, 55, 62, 63, 68, 13, 69, 70, 72, - 73, 74, 71, 75, 76, 77, 79, 80, 82, 81, - 83, 84, 86, 88, 85, 0, 87 + 39, 64, 2, 54, 30, 46, 3, 4, 55, 31, + 5, 6, 7, 8, 65, 9, 10, 11, 56, 12, + 13, 14, 57, 32, 40, 15, 33, 16, 47, 34, + 35, 6, 41, 8, 48, 42, 59, 49, 50, 61, + 13, 51, 36, 43, 37, 38, 60, 44, 6, 52, + 8, 6, 45, 8, 53, 58, 6, 13, 8, 62, + 13, 63, 67, 71, 72, 13, 68, 69, 73, 70, + 74, 75, 64, 77, 78, 79, 80, 82, 76, 84, + 81, 83 }; -static const yytype_int8 yycheck[] = +static const yytype_uint8 yycheck[] = { - 9, 22, 0, 8, 7, 14, 4, 5, 13, 13, - 8, 9, 10, 11, 13, 13, 14, 15, 21, 17, - 18, 19, 14, 21, 7, 17, 4, 25, 13, 7, - 8, 9, 17, 11, 16, 3, 45, 20, 21, 48, - 18, 13, 20, 21, 4, 23, 22, 4, 8, 9, - 24, 11, 9, 13, 11, 13, 8, 9, 18, 11, - 13, 18, 13, 13, 13, 21, 18, 21, 23, 13, - 13, 13, 20, 13, 13, 13, 72, 14, 13, 20, - 13, 13, 13, 13, 20, -1, 20 + 9, 7, 0, 8, 21, 14, 4, 5, 13, 13, + 8, 9, 10, 11, 20, 13, 14, 15, 13, 17, + 18, 19, 17, 13, 16, 23, 4, 25, 3, 7, + 8, 9, 14, 11, 13, 17, 45, 21, 24, 48, + 18, 13, 20, 4, 22, 23, 4, 8, 9, 13, + 11, 9, 13, 11, 13, 8, 9, 18, 11, 13, + 18, 13, 22, 13, 13, 18, 23, 23, 13, 20, + 13, 13, 7, 14, 20, 13, 13, 13, 71, 13, + 20, 20 }; /* YYSTOS[STATE-NUM] -- The (internal number of the) accessing @@ -741,36 +741,36 @@ static const yytype_int8 yycheck[] = static const yytype_uint8 yystos[] = { 0, 27, 0, 4, 5, 8, 9, 10, 11, 13, - 14, 15, 17, 18, 19, 21, 25, 28, 29, 30, + 14, 15, 17, 18, 19, 23, 25, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, - 22, 13, 13, 4, 7, 8, 20, 21, 23, 39, - 16, 14, 17, 4, 8, 13, 39, 3, 13, 22, - 24, 13, 13, 8, 13, 13, 13, 17, 8, 39, - 4, 39, 13, 13, 7, 20, 21, 41, 21, 21, - 23, 20, 13, 13, 13, 13, 13, 13, 21, 41, - 14, 20, 13, 13, 13, 20, 13, 20, 13 + 21, 13, 13, 4, 7, 8, 20, 22, 23, 39, + 16, 14, 17, 4, 8, 13, 39, 3, 13, 21, + 24, 13, 13, 13, 8, 13, 13, 17, 8, 39, + 4, 39, 13, 13, 7, 20, 41, 22, 23, 23, + 20, 13, 13, 13, 13, 13, 41, 14, 20, 13, + 13, 20, 13, 20, 13 }; /* YYR1[YYN] -- Symbol number of symbol that rule YYN derives. */ static const yytype_uint8 yyr1[] = { 0, 26, 27, 27, 28, 28, 28, 28, 28, 28, - 28, 28, 28, 29, 29, 29, 29, 29, 30, 30, - 30, 31, 31, 31, 31, 31, 32, 32, 32, 32, - 32, 32, 32, 32, 32, 32, 33, 33, 34, 34, - 34, 34, 35, 36, 36, 37, 37, 37, 37, 37, - 38, 38, 39, 39, 39, 40, 41, 41 + 28, 28, 28, 29, 29, 29, 30, 30, 30, 30, + 31, 31, 31, 31, 31, 32, 32, 32, 32, 32, + 32, 32, 32, 32, 32, 33, 33, 34, 34, 34, + 34, 35, 36, 36, 37, 37, 37, 37, 37, 38, + 38, 39, 39, 39, 40, 41, 41 }; /* YYR2[YYN] -- Number of symbols on the right hand side of rule YYN. */ static const yytype_uint8 yyr2[] = { 0, 2, 0, 2, 1, 1, 1, 1, 1, 1, - 1, 1, 1, 2, 4, 5, 6, 7, 2, 1, - 1, 1, 2, 2, 3, 2, 3, 5, 1, 5, - 5, 2, 4, 2, 1, 3, 2, 3, 11, 3, - 7, 2, 4, 2, 1, 3, 2, 2, 3, 1, - 1, 1, 1, 1, 1, 1, 0, 1 + 1, 1, 1, 2, 4, 6, 2, 1, 1, 2, + 1, 2, 2, 3, 2, 3, 5, 1, 5, 5, + 2, 4, 2, 1, 3, 2, 3, 11, 3, 7, + 2, 4, 2, 1, 3, 2, 2, 3, 1, 1, + 1, 1, 1, 1, 1, 0, 1 }; @@ -1641,12 +1641,10 @@ yyreduce: case 15: { - yyHour = (yyvsp[-4].Number); - yyMinutes = (yyvsp[-2].Number); - yyMeridian = MER24; - yyDSTmode = DSToff; - yyTimezone = ((yyvsp[0].Number) % 100 + ((yyvsp[0].Number) / 100) * 60); - ++yyHaveZone; + yyHour = (yyvsp[-5].Number); + yyMinutes = (yyvsp[-3].Number); + yySeconds = (yyvsp[-1].Number); + yyMeridian = (yyvsp[0].Meridian); } break; @@ -1654,10 +1652,9 @@ yyreduce: case 16: { - yyHour = (yyvsp[-5].Number); - yyMinutes = (yyvsp[-3].Number); - yySeconds = (yyvsp[-1].Number); - yyMeridian = (yyvsp[0].Meridian); + yyTimezone = (yyvsp[-1].Number); + if (yyTimezone > HOUR( 12)) yyTimezone -= HOUR(100); + yyDSTmode = DSTon; } break; @@ -1665,13 +1662,9 @@ yyreduce: case 17: { - yyHour = (yyvsp[-6].Number); - yyMinutes = (yyvsp[-4].Number); - yySeconds = (yyvsp[-2].Number); - yyMeridian = MER24; + yyTimezone = (yyvsp[0].Number); + if (yyTimezone > HOUR( 12)) yyTimezone -= HOUR(100); yyDSTmode = DSToff; - yyTimezone = ((yyvsp[0].Number) % 100 + ((yyvsp[0].Number) / 100) * 60); - ++yyHaveZone; } break; @@ -1679,8 +1672,7 @@ yyreduce: case 18: { - yyTimezone = (yyvsp[-1].Number); - if (yyTimezone > HOUR( 12)) yyTimezone -= HOUR(100); + yyTimezone = (yyvsp[0].Number); yyDSTmode = DSTon; } @@ -1689,8 +1681,7 @@ yyreduce: case 19: { - yyTimezone = (yyvsp[0].Number); - if (yyTimezone > HOUR( 12)) yyTimezone -= HOUR(100); + yyTimezone = -(yyvsp[-1].Number)*((yyvsp[0].Number) % 100 + ((yyvsp[0].Number) / 100) * 60); yyDSTmode = DSToff; } @@ -1699,22 +1690,13 @@ yyreduce: case 20: { - yyTimezone = (yyvsp[0].Number); - yyDSTmode = DSTon; - } - - break; - - case 21: - - { yyDayOrdinal = 1; yyDayNumber = (yyvsp[0].Number); } break; - case 22: + case 21: { yyDayOrdinal = 1; @@ -1723,7 +1705,7 @@ yyreduce: break; - case 23: + case 22: { yyDayOrdinal = (yyvsp[-1].Number); @@ -1732,7 +1714,7 @@ yyreduce: break; - case 24: + case 23: { yyDayOrdinal = (yyvsp[-2].Number) * (yyvsp[-1].Number); @@ -1741,7 +1723,7 @@ yyreduce: break; - case 25: + case 24: { yyDayOrdinal = 2; @@ -1750,7 +1732,7 @@ yyreduce: break; - case 26: + case 25: { yyMonth = (yyvsp[-2].Number); @@ -1759,7 +1741,7 @@ yyreduce: break; - case 27: + case 26: { yyMonth = (yyvsp[-4].Number); @@ -1769,7 +1751,7 @@ yyreduce: break; - case 28: + case 27: { yyYear = (yyvsp[0].Number) / 10000; @@ -1779,7 +1761,7 @@ yyreduce: break; - case 29: + case 28: { yyDay = (yyvsp[-4].Number); @@ -1789,7 +1771,7 @@ yyreduce: break; - case 30: + case 29: { yyMonth = (yyvsp[-2].Number); @@ -1799,7 +1781,7 @@ yyreduce: break; - case 31: + case 30: { yyMonth = (yyvsp[-1].Number); @@ -1808,7 +1790,7 @@ yyreduce: break; - case 32: + case 31: { yyMonth = (yyvsp[-3].Number); @@ -1818,7 +1800,7 @@ yyreduce: break; - case 33: + case 32: { yyMonth = (yyvsp[0].Number); @@ -1827,7 +1809,7 @@ yyreduce: break; - case 34: + case 33: { yyMonth = 1; @@ -1837,7 +1819,7 @@ yyreduce: break; - case 35: + case 34: { yyMonth = (yyvsp[-1].Number); @@ -1847,7 +1829,7 @@ yyreduce: break; - case 36: + case 35: { yyMonthOrdinal = 1; @@ -1856,7 +1838,7 @@ yyreduce: break; - case 37: + case 36: { yyMonthOrdinal = (yyvsp[-1].Number); @@ -1865,7 +1847,7 @@ yyreduce: break; - case 38: + case 37: { if ((yyvsp[-5].Number) != HOUR( 7) + HOUR(100)) YYABORT; @@ -1879,7 +1861,7 @@ yyreduce: break; - case 39: + case 38: { if ((yyvsp[-1].Number) != HOUR( 7) + HOUR(100)) YYABORT; @@ -1893,7 +1875,7 @@ yyreduce: break; - case 40: + case 39: { if ((yyvsp[-5].Number) != HOUR( 7) + HOUR(100)) YYABORT; @@ -1907,7 +1889,7 @@ yyreduce: break; - case 41: + case 40: { yyYear = (yyvsp[-1].Number) / 10000; @@ -1920,7 +1902,7 @@ yyreduce: break; - case 42: + case 41: { /* @@ -1937,7 +1919,7 @@ yyreduce: break; - case 43: + case 42: { yyRelSeconds *= -1; @@ -1947,7 +1929,7 @@ yyreduce: break; - case 45: + case 44: { *yyRelPointer += (yyvsp[-2].Number) * (yyvsp[-1].Number) * (yyvsp[0].Number); @@ -1955,7 +1937,7 @@ yyreduce: break; - case 46: + case 45: { *yyRelPointer += (yyvsp[-1].Number) * (yyvsp[0].Number); @@ -1963,7 +1945,7 @@ yyreduce: break; - case 47: + case 46: { *yyRelPointer += (yyvsp[0].Number); @@ -1971,7 +1953,7 @@ yyreduce: break; - case 48: + case 47: { *yyRelPointer += (yyvsp[-1].Number) * (yyvsp[0].Number); @@ -1979,7 +1961,7 @@ yyreduce: break; - case 49: + case 48: { *yyRelPointer += (yyvsp[0].Number); @@ -1987,7 +1969,7 @@ yyreduce: break; - case 50: + case 49: { (yyval.Number) = -1; @@ -1995,7 +1977,7 @@ yyreduce: break; - case 51: + case 50: { (yyval.Number) = 1; @@ -2003,7 +1985,7 @@ yyreduce: break; - case 52: + case 51: { (yyval.Number) = (yyvsp[0].Number); @@ -2012,7 +1994,7 @@ yyreduce: break; - case 53: + case 52: { (yyval.Number) = (yyvsp[0].Number); @@ -2021,7 +2003,7 @@ yyreduce: break; - case 54: + case 53: { (yyval.Number) = (yyvsp[0].Number); @@ -2030,7 +2012,7 @@ yyreduce: break; - case 55: + case 54: { if (yyHaveTime && yyHaveDate && !yyHaveRel) { @@ -2051,7 +2033,7 @@ yyreduce: break; - case 56: + case 55: { (yyval.Meridian) = MER24; @@ -2059,7 +2041,7 @@ yyreduce: break; - case 57: + case 56: { (yyval.Meridian) = (yyvsp[0].Meridian); diff --git a/generic/tclGetDate.y b/generic/tclGetDate.y index 578f179..86037d6 100644 --- a/generic/tclGetDate.y +++ b/generic/tclGetDate.y @@ -266,29 +266,12 @@ time : tUNUMBER tMERIDIAN { yySeconds = 0; yyMeridian = $4; } - | tUNUMBER ':' tUNUMBER '-' tUNUMBER { - yyHour = $1; - yyMinutes = $3; - yyMeridian = MER24; - yyDSTmode = DSToff; - yyTimezone = ($5 % 100 + ($5 / 100) * 60); - ++yyHaveZone; - } | tUNUMBER ':' tUNUMBER ':' tUNUMBER o_merid { yyHour = $1; yyMinutes = $3; yySeconds = $5; yyMeridian = $6; } - | tUNUMBER ':' tUNUMBER ':' tUNUMBER '-' tUNUMBER { - yyHour = $1; - yyMinutes = $3; - yySeconds = $5; - yyMeridian = MER24; - yyDSTmode = DSToff; - yyTimezone = ($7 % 100 + ($7 / 100) * 60); - ++yyHaveZone; - } ; zone : tZONE tDST { @@ -305,6 +288,10 @@ zone : tZONE tDST { yyTimezone = $1; yyDSTmode = DSTon; } + | sign tUNUMBER { + yyTimezone = -$1*($2 % 100 + ($2 / 100) * 60); + yyDSTmode = DSToff; + } ; day : tDAY { diff --git a/tests/clock.test b/tests/clock.test index f7da08f..a3498e8 100644 --- a/tests/clock.test +++ b/tests/clock.test @@ -254,7 +254,6 @@ proc ::testClock::registry { cmd path key } { return [dict get $reg $path $key] } - # Test some of the basics of [clock format] test clock-1.0 "clock format - wrong # args" { @@ -35635,7 +35634,6 @@ test clock-34.11 {clock scan tests} { set time [clock scan "1/1/37" -gmt true] clock format $time -format {%b %d,%Y %H:%M GMT} -gmt true } {Jan 01,2037 00:00 GMT} - test clock-34.12 {clock scan, relative times} { set time [clock scan "Oct 23, 1992 -1 day"] clock format $time -format {%b %d, %Y} @@ -35664,30 +35662,6 @@ test clock-34.18 {clock scan, ISO 8601 point in time format} { set time [clock scan "19921023T000000"] clock format $time -format {%b %d, %Y %H:%M:%S} } "Oct 23, 1992 00:00:00" -test clock-34.19 {clock scan, ISO 8601 point in time format} { - set time [clock scan "19921023T00:00:00"] - clock format $time -format {%b %d, %Y %H:%M:%S} -} "Oct 23, 1992 00:00:00" -test clock-34.20 {clock scan, ISO 8601 point in time format} { - set time [clock scan "1992-10-23T00:00:00"] - clock format $time -format {%b %d, %Y %H:%M:%S} -} "Oct 23, 1992 00:00:00" -test clock-34.21 {clock scan, ISO 8601 invalid TZ} -body { - set time [clock scan "19921023MST000000"] - clock format $time -format {%b %d, %Y %H:%M:%S} -} -returnCodes error -match glob -result {unable to convert date-time string*} -test clock-34.22 {clock scan, ISO 8601 invalid TZ} -body { - set time [clock scan "19921023M000000"] - clock format $time -format {%b %d, %Y %H:%M:%S} -} -returnCodes error -match glob -result {unable to convert date-time string*} -test clock-34.23 {clock scan, ISO 8601 invalid TZ} -body { - set time [clock scan "1992-10-23M00:00:00"] - clock format $time -format {%b %d, %Y %H:%M:%S} -} -returnCodes error -match glob -result {unable to convert date-time string*} -test clock-34.24 {clock scan, ISO 8601 invalid TZ} -body { - set time [clock scan "1992-10-23MST00:00:00"] - clock format $time -format {%b %d, %Y %H:%M:%S} -} -returnCodes error -match glob -result {unable to convert date-time string*} # CLOCK SCAN REAL TESTS # We use 5am PST, 31-12-1999 as the base for these scans because irrespective @@ -35811,7 +35785,6 @@ test clock-34.43 {last monday in november} { } set res } {1991-11-25 1992-11-30 1993-11-29 1994-11-28 1995-11-27 1996-11-25} - test clock-34.44 {2nd monday in november} { set res {} foreach i {91 92 93 94 95 96} { @@ -35844,38 +35817,95 @@ test clock-34.47 {ago with multiple relative units} { set res [clock scan "2 days 2 hours ago" -base $base] expr {$base - $res} } 180000 - test clock-34.48 {more than one ToD} {*}{ -body {clock scan {10:00 11:00}} -returnCodes error -result {unable to convert date-time string "10:00 11:00": more than one time of day in string} } - test clock-34.49 {more than one date} {*}{ -body {clock scan {1/1/2001 2/2/2002}} -returnCodes error -result {unable to convert date-time string "1/1/2001 2/2/2002": more than one date in string} } - test clock-34.50 {more than one time zone} {*}{ -body {clock scan {10:00 EST CST}} -returnCodes error -result {unable to convert date-time string "10:00 EST CST": more than one time zone in string} } - test clock-34.51 {more than one weekday} {*}{ -body {clock scan {Monday Tuesday}} -returnCodes error -result {unable to convert date-time string "Monday Tuesday": more than one weekday in string} } - test clock-34.52 {more than one ordinal month} {*}{ -body {clock scan {next January next March}} -returnCodes error -result {unable to convert date-time string "next January next March": more than one ordinal month in string} } - - +test clock-34.53 {clock scan, ISO 8601 point in time format} { + set time [clock scan "19921023T00:00:00"] + clock format $time -format {%b %d, %Y %H:%M:%S} +} "Oct 23, 1992 00:00:00" +test clock-34.54 {clock scan, ISO 8601 point in time format} { + set time [clock scan "1992-10-23T00:00:00"] + clock format $time -format {%b %d, %Y %H:%M:%S} +} "Oct 23, 1992 00:00:00" +test clock-34.55 {clock scan, ISO 8601 invalid TZ} -body { + set time [clock scan "19921023MST000000"] + clock format $time -format {%b %d, %Y %H:%M:%S} +} -returnCodes error -match glob -result {unable to convert date-time string*} +test clock-34.56 {clock scan, ISO 8601 invalid TZ} -body { + set time [clock scan "19921023M000000"] + clock format $time -format {%b %d, %Y %H:%M:%S} +} -returnCodes error -match glob -result {unable to convert date-time string*} +test clock-34.57 {clock scan, ISO 8601 invalid TZ} -body { + set time [clock scan "1992-10-23M00:00:00"] + clock format $time -format {%b %d, %Y %H:%M:%S} +} -returnCodes error -match glob -result {unable to convert date-time string*} +test clock-34.58 {clock scan, ISO 8601 invalid TZ} -body { + set time [clock scan "1992-10-23MST00:00:00"] + clock format $time -format {%b %d, %Y %H:%M:%S} +} -returnCodes error -match glob -result {unable to convert date-time string*} +test clock-34.59 {clock scan tests (-TZ)} { + set time [clock scan "31 Jan 14 23:59:59 -0100"] + clock format $time -format {%b %d,%Y %H:%M:%S %Z} -gmt true +} {Feb 01,2014 00:59:59 GMT} +test clock-34.60 {clock scan tests (+TZ)} { + set time [clock scan "31 Jan 14 23:59:59 +0100"] + clock format $time -format {%b %d,%Y %H:%M:%S %Z} -gmt true +} {Jan 31,2014 22:59:59 GMT} +test clock-34.61 {clock scan tests (-TZ)} { + set time [clock scan "23:59:59 -0100" -base 0] + clock format $time -format {%b %d,%Y %H:%M:%S %Z} -gmt true +} {Jan 02,1970 00:59:59 GMT} +test clock-34.62 {clock scan tests (+TZ)} { + set time [clock scan "23:59:59 +0100" -base 0] + clock format $time -format {%b %d,%Y %H:%M:%S %Z} -gmt true +} {Jan 01,1970 22:59:59 GMT} +test clock-34.63 {clock scan tests (TZ)} { + set time [clock scan "Mon, 30 Jun 2014 23:59:59 CEST"] + clock format $time -format {%b %d,%Y %H:%M:%S %Z} -gmt true +} {Jun 30,2014 21:59:59 GMT} +test clock-34.64 {clock scan tests (TZ)} { + set time [clock scan "Fri, 31 Jan 2014 23:59:59 CET"] + clock format $time -format {%b %d,%Y %H:%M:%S %Z} -gmt true +} {Jan 31,2014 22:59:59 GMT} +test clock-34.65 {clock scan tests (relspec, day unit not TZ)} { + set time [clock scan "23:59:59 +15 day" -base 2000000] + clock format $time -format {%b %d,%Y %H:%M:%S %Z} -gmt true +} {Feb 08,1970 22:59:59 GMT} +test clock-34.66 {clock scan tests (relspec, day unit not TZ)} { + set time [clock scan "23:59:59 -15 day" -base 2000000] + clock format $time -format {%b %d,%Y %H:%M:%S %Z} -gmt true +} {Jan 09,1970 22:59:59 GMT} +test clock-34.67 {clock scan tests (merid and TZ)} { + set time [clock scan "10:59 pm CET" -base 2000000] + clock format $time -format {%b %d,%Y %H:%M:%S %Z} -gmt true +} {Jan 24,1970 21:59:00 GMT} +test clock-34.68 {clock scan tests (merid and TZ)} { + set time [clock scan "10:59 pm +0100" -base 2000000] + clock format $time -format {%b %d,%Y %H:%M:%S %Z} -gmt true +} {Jan 24,1970 21:59:00 GMT} # clock seconds test clock-35.1 {clock seconds tests} { @@ -36975,12 +37005,10 @@ test clock-67.2 {Bug d19a30db57} -body { # error, not segfault tcl::clock::GetJulianDayFromEraYearMonthDay {} 2361222 } -returnCodes error -match glob -result * - test clock-67.3 {Bug d19a30db57} -body { # error, not segfault tcl::clock::GetJulianDayFromEraYearWeekDay {} 2361222 } -returnCodes error -match glob -result * - test clock-67.4 {Change format %x output on global locale change [Bug 4a0c163d24]} -setup { package require msgcat set current [msgcat::mclocale] @@ -36992,7 +37020,6 @@ test clock-67.4 {Change format %x output on global locale change [Bug 4a0c163d24 } -cleanup { msgcat::mclocale $current } -result {1 1} - test clock-67.5 {Change scan %x output on global locale change [Bug 4a0c163d24]} -setup { package require msgcat set current [msgcat::mclocale] -- cgit v0.12 From 0fab7463a3318c4fb204e1d463c34ca2616bf201 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 10 Jul 2020 07:26:55 +0000 Subject: Addendum to [60fab362ce]: "Also don't allow surrogates in \U??????". This change was only meant for builds with TCL_UTF_MAX > 3. --- generic/tclParse.c | 2 ++ tests/utf.test | 4 ++-- 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/generic/tclParse.c b/generic/tclParse.c index 78f3a9e..7a51dae 100644 --- a/generic/tclParse.c +++ b/generic/tclParse.c @@ -942,9 +942,11 @@ TclParseBackslash( * No hexdigits -> This is just "U". */ result = 'U'; +#if TCL_UTF_MAX > 3 } else if ((result & ~0x7FF) == 0xD800) { /* Upper or lower surrogate, not allowed in this syntax. */ result = 0xFFFD; +#endif } break; case '\n': diff --git a/tests/utf.test b/tests/utf.test index 14b2198..2f5f7f3 100644 --- a/tests/utf.test +++ b/tests/utf.test @@ -78,8 +78,8 @@ test utf-1.11 {Tcl_UniCharToUtf: 3 byte sequence, low surrogate} testbytestring test utf-1.12 {Tcl_UniCharToUtf: 4 byte sequence, high/low surrogate} {pairsTo4bytes testbytestring} { expr {"\uD842\uDC42" eq [testbytestring \xF0\xA0\xA1\x82]} } 1 -test utf-1.13 {Tcl_UniCharToUtf: Invalid surrogate} {Uesc testbytestring} { - expr {"\UD842" eq [testbytestring \xEF\xBF\xBD]} +test utf-1.13 {Tcl_UniCharToUtf: Invalid surrogate} Uesc { + expr {"\UD842" eq "\uD842"} } 1 test utf-2.1 {Tcl_UtfToUniChar: low ascii} { -- cgit v0.12 From a25f4ac082e9ece00bc80d9471f178ea2832a40a Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 10 Jul 2020 08:52:13 +0000 Subject: Fix utf-1.13 testcase for TCL_UTF_MAX>3 --- tests/utf.test | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/utf.test b/tests/utf.test index 2f5f7f3..b1fafb6 100644 --- a/tests/utf.test +++ b/tests/utf.test @@ -78,7 +78,7 @@ test utf-1.11 {Tcl_UniCharToUtf: 3 byte sequence, low surrogate} testbytestring test utf-1.12 {Tcl_UniCharToUtf: 4 byte sequence, high/low surrogate} {pairsTo4bytes testbytestring} { expr {"\uD842\uDC42" eq [testbytestring \xF0\xA0\xA1\x82]} } 1 -test utf-1.13 {Tcl_UniCharToUtf: Invalid surrogate} Uesc { +test utf-1.13 {Tcl_UniCharToUtf: Invalid surrogate} {Uesc ucs2} { expr {"\UD842" eq "\uD842"} } 1 -- cgit v0.12 From ae39d915c8de190f44a3b6989665dd1e92b07727 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 10 Jul 2020 10:32:00 +0000 Subject: Fix test-cases clock-34.65 and clock-34.66, they seem to be affected by summertime --- tests/clock.test | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/tests/clock.test b/tests/clock.test index a3498e8..d69dd6c 100644 --- a/tests/clock.test +++ b/tests/clock.test @@ -35891,13 +35891,13 @@ test clock-34.64 {clock scan tests (TZ)} { clock format $time -format {%b %d,%Y %H:%M:%S %Z} -gmt true } {Jan 31,2014 22:59:59 GMT} test clock-34.65 {clock scan tests (relspec, day unit not TZ)} { - set time [clock scan "23:59:59 +15 day" -base 2000000] + set time [clock scan "23:59:59 +15 day" -base 2000000 -gmt true] clock format $time -format {%b %d,%Y %H:%M:%S %Z} -gmt true -} {Feb 08,1970 22:59:59 GMT} +} {Feb 08,1970 23:59:59 GMT} test clock-34.66 {clock scan tests (relspec, day unit not TZ)} { - set time [clock scan "23:59:59 -15 day" -base 2000000] + set time [clock scan "23:59:59 -15 day" -base 2000000 -gmt true] clock format $time -format {%b %d,%Y %H:%M:%S %Z} -gmt true -} {Jan 09,1970 22:59:59 GMT} +} {Jan 09,1970 23:59:59 GMT} test clock-34.67 {clock scan tests (merid and TZ)} { set time [clock scan "10:59 pm CET" -base 2000000] clock format $time -format {%b %d,%Y %H:%M:%S %Z} -gmt true -- cgit v0.12 From 2ead5632823207539bb83b296fb903b63ec595ff Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sat, 11 Jul 2020 16:01:28 +0000 Subject: Fix 4 test-cases, which fail when running from the western hemisphere --- tests/clock.test | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/tests/clock.test b/tests/clock.test index d69dd6c..0dc5caf 100644 --- a/tests/clock.test +++ b/tests/clock.test @@ -35875,11 +35875,11 @@ test clock-34.60 {clock scan tests (+TZ)} { clock format $time -format {%b %d,%Y %H:%M:%S %Z} -gmt true } {Jan 31,2014 22:59:59 GMT} test clock-34.61 {clock scan tests (-TZ)} { - set time [clock scan "23:59:59 -0100" -base 0] + set time [clock scan "23:59:59 -0100" -base 0 -gmt true] clock format $time -format {%b %d,%Y %H:%M:%S %Z} -gmt true } {Jan 02,1970 00:59:59 GMT} test clock-34.62 {clock scan tests (+TZ)} { - set time [clock scan "23:59:59 +0100" -base 0] + set time [clock scan "23:59:59 +0100" -base 0 -gmt true] clock format $time -format {%b %d,%Y %H:%M:%S %Z} -gmt true } {Jan 01,1970 22:59:59 GMT} test clock-34.63 {clock scan tests (TZ)} { @@ -35899,11 +35899,11 @@ test clock-34.66 {clock scan tests (relspec, day unit not TZ)} { clock format $time -format {%b %d,%Y %H:%M:%S %Z} -gmt true } {Jan 09,1970 23:59:59 GMT} test clock-34.67 {clock scan tests (merid and TZ)} { - set time [clock scan "10:59 pm CET" -base 2000000] + set time [clock scan "10:59 pm CET" -base 2000000 -gmt true] clock format $time -format {%b %d,%Y %H:%M:%S %Z} -gmt true } {Jan 24,1970 21:59:00 GMT} test clock-34.68 {clock scan tests (merid and TZ)} { - set time [clock scan "10:59 pm +0100" -base 2000000] + set time [clock scan "10:59 pm +0100" -base 2000000 -gmt true] clock format $time -format {%b %d,%Y %H:%M:%S %Z} -gmt true } {Jan 24,1970 21:59:00 GMT} -- cgit v0.12 -- cgit v0.12 From 0d59960edfba62674a912819c0328b91a02beb29 Mon Sep 17 00:00:00 2001 From: kjnash Date: Mon, 13 Jul 2020 11:22:37 +0000 Subject: Add example files for use in tests/safe.test; add tests of the files themselves. --- tests/auto0/auto1/file1.tcl | 3 + tests/auto0/auto1/package1.tcl | 5 ++ tests/auto0/auto1/pkgIndex.tcl | 11 +++ tests/auto0/auto1/tclIndex | 9 +++ tests/auto0/auto2/file2.tcl | 3 + tests/auto0/auto2/package2.tcl | 5 ++ tests/auto0/auto2/pkgIndex.tcl | 11 +++ tests/auto0/auto2/tclIndex | 9 +++ tests/auto0/modules/mod1/test1-1.0.tm | 5 ++ tests/auto0/modules/mod2/test2-2.0.tm | 5 ++ tests/auto0/modules/test0-0.5.tm | 5 ++ tests/safe.test | 123 ++++++++++++++++++++++++++++++++++ 12 files changed, 194 insertions(+) create mode 100644 tests/auto0/auto1/file1.tcl create mode 100644 tests/auto0/auto1/package1.tcl create mode 100644 tests/auto0/auto1/pkgIndex.tcl create mode 100644 tests/auto0/auto1/tclIndex create mode 100644 tests/auto0/auto2/file2.tcl create mode 100644 tests/auto0/auto2/package2.tcl create mode 100644 tests/auto0/auto2/pkgIndex.tcl create mode 100644 tests/auto0/auto2/tclIndex create mode 100644 tests/auto0/modules/mod1/test1-1.0.tm create mode 100644 tests/auto0/modules/mod2/test2-2.0.tm create mode 100644 tests/auto0/modules/test0-0.5.tm diff --git a/tests/auto0/auto1/file1.tcl b/tests/auto0/auto1/file1.tcl new file mode 100644 index 0000000..bd8b92b --- /dev/null +++ b/tests/auto0/auto1/file1.tcl @@ -0,0 +1,3 @@ +proc report1 {args} { + return ok1 +} diff --git a/tests/auto0/auto1/package1.tcl b/tests/auto0/auto1/package1.tcl new file mode 100644 index 0000000..32d7c56 --- /dev/null +++ b/tests/auto0/auto1/package1.tcl @@ -0,0 +1,5 @@ +proc HeresPackage1 {args} { + return OK1 +} + +package provide SafeTestPackage1 1.2.3 diff --git a/tests/auto0/auto1/pkgIndex.tcl b/tests/auto0/auto1/pkgIndex.tcl new file mode 100644 index 0000000..babb6d5 --- /dev/null +++ b/tests/auto0/auto1/pkgIndex.tcl @@ -0,0 +1,11 @@ +# Tcl package index file, version 1.1 +# This file is generated by the "pkg_mkIndex" command +# and sourced either when an application starts up or +# by a "package unknown" script. It invokes the +# "package ifneeded" command to set up package-related +# information so that packages will be loaded automatically +# in response to "package require" commands. When this +# script is sourced, the variable $dir must contain the +# full path name of this file's directory. + +package ifneeded SafeTestPackage1 1.2.3 [list source [file join $dir package1.tcl]] diff --git a/tests/auto0/auto1/tclIndex b/tests/auto0/auto1/tclIndex new file mode 100644 index 0000000..bbfa6d4 --- /dev/null +++ b/tests/auto0/auto1/tclIndex @@ -0,0 +1,9 @@ +# Tcl autoload index file, version 2.0 +# This file is generated by the "auto_mkindex" command +# and sourced to set up indexing information for one or +# more commands. Typically each line is a command that +# sets an element in the auto_index array, where the +# element name is the name of a command and the value is +# a script that loads the command. + +set auto_index(report1) [list source [file join $dir file1.tcl]] diff --git a/tests/auto0/auto2/file2.tcl b/tests/auto0/auto2/file2.tcl new file mode 100644 index 0000000..5bc622f --- /dev/null +++ b/tests/auto0/auto2/file2.tcl @@ -0,0 +1,3 @@ +proc report2 {args} { + return ok2 +} diff --git a/tests/auto0/auto2/package2.tcl b/tests/auto0/auto2/package2.tcl new file mode 100644 index 0000000..61774df --- /dev/null +++ b/tests/auto0/auto2/package2.tcl @@ -0,0 +1,5 @@ +proc HeresPackage2 {args} { + return OK2 +} + +package provide SafeTestPackage2 2.3.4 diff --git a/tests/auto0/auto2/pkgIndex.tcl b/tests/auto0/auto2/pkgIndex.tcl new file mode 100644 index 0000000..1022691 --- /dev/null +++ b/tests/auto0/auto2/pkgIndex.tcl @@ -0,0 +1,11 @@ +# Tcl package index file, version 1.1 +# This file is generated by the "pkg_mkIndex" command +# and sourced either when an application starts up or +# by a "package unknown" script. It invokes the +# "package ifneeded" command to set up package-related +# information so that packages will be loaded automatically +# in response to "package require" commands. When this +# script is sourced, the variable $dir must contain the +# full path name of this file's directory. + +package ifneeded SafeTestPackage2 2.3.4 [list source [file join $dir package2.tcl]] diff --git a/tests/auto0/auto2/tclIndex b/tests/auto0/auto2/tclIndex new file mode 100644 index 0000000..9cd2a74 --- /dev/null +++ b/tests/auto0/auto2/tclIndex @@ -0,0 +1,9 @@ +# Tcl autoload index file, version 2.0 +# This file is generated by the "auto_mkindex" command +# and sourced to set up indexing information for one or +# more commands. Typically each line is a command that +# sets an element in the auto_index array, where the +# element name is the name of a command and the value is +# a script that loads the command. + +set auto_index(report2) [list source [file join $dir file2.tcl]] diff --git a/tests/auto0/modules/mod1/test1-1.0.tm b/tests/auto0/modules/mod1/test1-1.0.tm new file mode 100644 index 0000000..927fa6f --- /dev/null +++ b/tests/auto0/modules/mod1/test1-1.0.tm @@ -0,0 +1,5 @@ +namespace eval mod1::test1 {} + +proc mod1::test1::try1 args { + return res1 +} diff --git a/tests/auto0/modules/mod2/test2-2.0.tm b/tests/auto0/modules/mod2/test2-2.0.tm new file mode 100644 index 0000000..b5cd45b --- /dev/null +++ b/tests/auto0/modules/mod2/test2-2.0.tm @@ -0,0 +1,5 @@ +namespace eval mod2::test2 {} + +proc mod2::test2::try2 args { + return res2 +} diff --git a/tests/auto0/modules/test0-0.5.tm b/tests/auto0/modules/test0-0.5.tm new file mode 100644 index 0000000..19f3613 --- /dev/null +++ b/tests/auto0/modules/test0-0.5.tm @@ -0,0 +1,5 @@ +namespace eval test0 {} + +proc test0::try0 args { + return res0 +} diff --git a/tests/safe.test b/tests/safe.test index 11ad2a9..71fe0fb 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -24,6 +24,8 @@ foreach i [interp slaves] { set saveAutoPath $::auto_path set ::auto_path [info library] +set TestsDir [file normalize [file dirname [info script]]] + # Force actual loading of the safe package because we use un exported (and # thus un-autoindexed) APIs in this test result arguments: catch {safe::interpConfigure} @@ -179,6 +181,126 @@ test safe-6.3 {test safe interpreters knowledge of the world} { # More test should be added to check that hostname, nameofexecutable, aren't # leaking infos, but they still do... +# Tests 7.0* test the example files before using them to test safe interpreters. + +test safe-7.0a {example tclIndex commands, test in master interpreter} -setup { + set tmpAutoPath $::auto_path + lappend ::auto_path [file join $TestsDir auto0 auto1] [file join $TestsDir auto0 auto2] +} -body { + # Try to load the commands. + set code3 [catch report1 msg3] + set code4 [catch report2 msg4] + list $code3 $msg3 $code4 $msg4 +} -cleanup { + catch {rename report1 {}} + catch {rename report2 {}} + set ::auto_path $tmpAutoPath + auto_reset +} -match glob -result {0 ok1 0 ok2} + +test safe-7.0b {example tclIndex commands, negative test in master interpreter} -setup { + set tmpAutoPath $::auto_path + lappend ::auto_path [file join $TestsDir auto0] +} -body { + # Try to load the commands. + set code3 [catch report1 msg3] + set code4 [catch report2 msg4] + list $code3 $msg3 $code4 $msg4 +} -cleanup { + catch {rename report1 {}} + catch {rename report2 {}} + set ::auto_path $tmpAutoPath + auto_reset +} -match glob -result {1 {invalid command name "report1"} 1 {invalid command name "report2"}} + +test safe-7.0c {example pkgIndex.tcl packages, test in master interpreter, child directories} -setup { + set tmpAutoPath $::auto_path + lappend ::auto_path [file join $TestsDir auto0] +} -body { + # Try to load the packages and run a command from each one. + set code3 [catch {package require SafeTestPackage1} msg3] + set code4 [catch {package require SafeTestPackage2} msg4] + set code5 [catch HeresPackage1 msg5] + set code6 [catch HeresPackage2 msg6] + + list $code3 $msg3 $code4 $msg4 $code5 $msg5 $code6 $msg6 +} -cleanup { + set ::auto_path $tmpAutoPath + catch {package forget SafeTestPackage1} + catch {package forget SafeTestPackage2} + catch {rename HeresPackage1 {}} + catch {rename HeresPackage2 {}} +} -match glob -result {0 1.2.3 0 2.3.4 0 OK1 0 OK2} + +test safe-7.0d {example pkgIndex.tcl packages, test in master interpreter, main directories} -setup { + set tmpAutoPath $::auto_path + lappend ::auto_path [file join $TestsDir auto0 auto1] \ + [file join $TestsDir auto0 auto2] +} -body { + # Try to load the packages and run a command from each one. + set code3 [catch {package require SafeTestPackage1} msg3] + set code4 [catch {package require SafeTestPackage2} msg4] + set code5 [catch HeresPackage1 msg5] + set code6 [catch HeresPackage2 msg6] + + list $code3 $msg3 $code4 $msg4 $code5 $msg5 $code6 $msg6 +} -cleanup { + set ::auto_path $tmpAutoPath + catch {package forget SafeTestPackage1} + catch {package forget SafeTestPackage2} + catch {rename HeresPackage1 {}} + catch {rename HeresPackage2 {}} +} -match glob -result {0 1.2.3 0 2.3.4 0 OK1 0 OK2} + +test safe-7.0e {example modules packages, test in master interpreter, replace path} -setup { + set oldTm [tcl::tm::path list] + foreach path $oldTm { + tcl::tm::path remove $path + } + tcl::tm::path add [file join $TestsDir auto0 modules] +} -body { + # Try to load the modules and run a command from each one. + set code0 [catch {package require test0} msg0] + set code1 [catch {package require mod1::test1} msg1] + set code2 [catch {package require mod2::test2} msg2] + set out0 [test0::try0] + set out1 [mod1::test1::try1] + set out2 [mod2::test2::try2] + + list $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $out0 $out1 $out2 +} -cleanup { + tcl::tm::path remove [file join $TestsDir auto0 modules] + foreach path [lreverse $oldTm] { + tcl::tm::path add $path + } + catch {package forget test0} + catch {package forget mod1::test1} + catch {package forget mod2::test2} + catch {namespace delete ::test0} + catch {namespace delete ::mod1} +} -match glob -result {0 0.5 0 1.0 0 2.0 -- res0 res1 res2} + +test safe-7.0f {example modules packages, test in master interpreter, append to path} -setup { + tcl::tm::path add [file join $TestsDir auto0 modules] +} -body { + # Try to load the modules and run a command from each one. + set code0 [catch {package require test0} msg0] + set code1 [catch {package require mod1::test1} msg1] + set code2 [catch {package require mod2::test2} msg2] + set out0 [test0::try0] + set out1 [mod1::test1::try1] + set out2 [mod2::test2::try2] + + list $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $out0 $out1 $out2 +} -cleanup { + tcl::tm::path remove [file join $TestsDir auto0 modules] + catch {package forget test0} + catch {package forget mod1::test1} + catch {package forget mod2::test2} + catch {namespace delete ::test0} + catch {namespace delete ::mod1} +} -match glob -result {0 0.5 0 1.0 0 2.0 -- res0 res1 res2} + # high level general test test safe-7.1 {tests that everything works at high level} -body { set i [safe::interpCreate] @@ -833,6 +955,7 @@ test safe-16.4 {Bug 3529949: defang ~user in globs} -setup { } -result {} set ::auto_path $saveAutoPath +unset saveAutoPath TestsDir # cleanup ::tcltest::cleanupTests return -- cgit v0.12 From 2c1750c78f0c5c36008d4043f099ef2485d96de4 Mon Sep 17 00:00:00 2001 From: kjnash Date: Mon, 13 Jul 2020 11:43:52 +0000 Subject: Add new tests to tests/safe.test. --- tests/safe.test | 544 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 544 insertions(+) diff --git a/tests/safe.test b/tests/safe.test index 71fe0fb..3ff9e62 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -527,6 +527,550 @@ test safe-9.6 {interpConfigure widget like behaviour} -body { safe::interpConfigure $i] } -match glob -result {{-accessPath * -statics 0 -nested 1 -deleteHook {foo bar}} {-accessPath *} {-nested 1} {-statics 0} {-deleteHook {foo bar}} {-accessPath * -statics 1 -nested 1 -deleteHook {foo bar}} {-accessPath * -statics 0 -nested 0 -deleteHook toto}} +test safe-9.7 {interpConfigure widget like behaviour (demystified)} -body { + # this test shall work, believed equivalent to 9.6 + set i [safe::interpCreate \ + -noStatics \ + -nestedLoadOk \ + -deleteHook {foo bar} \ + ] + + safe::interpConfigure $i -accessPath /foo/bar + set a [safe::interpConfigure $i] + set b [safe::interpConfigure $i -aCCess] + set c [safe::interpConfigure $i -nested] + set d [safe::interpConfigure $i -statics] + set e [safe::interpConfigure $i -DEL] + safe::interpConfigure $i -accessPath /blah -statics 1 + set f [safe::interpConfigure $i] + safe::interpConfigure $i -deleteHook toto -nosta -nested 0 + set g [safe::interpConfigure $i] + + list $a $b $c $d $e $f $g +} -cleanup { + safe::interpDelete $i +} -match glob -result {{-accessPath * -statics 0 -nested 1 -deleteHook {foo bar}} {-accessPath *} {-nested 1} {-statics 0} {-deleteHook {foo bar}} {-accessPath * -statics 1 -nested 1 -deleteHook {foo bar}} {-accessPath * -statics 0 -nested 0 -deleteHook toto}} + +test safe-9.8 {interpConfigure change the access path; tclIndex commands unaffected by token rearrangement (dummy test of doreset)} -setup { +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library \ + [file join $TestsDir auto0 auto1] \ + [file join $TestsDir auto0 auto2]]] + + # Inspect. + set confA [safe::interpConfigure $i] + set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]] + set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]] + + # Load auto_load data. + interp eval $i {catch nonExistentCommand} + + # Load and run the commands. + # This guarantees the test will pass even if the tokens are swapped. + set code1 [catch {interp eval $i {report1}} msg1] + set code2 [catch {interp eval $i {report2}} msg2] + + # Rearrange access path. Swap tokens {$p(:1:)} and {$p(:2:)}. + safe::interpConfigure $i -accessPath [list $tcl_library \ + [file join $TestsDir auto0 auto2] \ + [file join $TestsDir auto0 auto1]] + + # Inspect. + set confB [safe::interpConfigure $i] + set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]] + set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]] + + # Run the commands. + set code3 [catch {interp eval $i {report1}} msg3] + set code4 [catch {interp eval $i {report2}} msg4] + + list $path1 $path2 $path3 $path4 $code3 $msg3 $code4 $msg4 $confA $confB +} -cleanup { + safe::interpDelete $i +} -match glob -result "{\$p(:1:)} {\$p(:2:)} {\$p(:2:)} {\$p(:1:)} 0 ok1 0 ok2\ + {-accessPath {[list $tcl_library $TestsDir/auto0/auto1 $TestsDir/auto0/auto2]*}\ + -statics 1 -nested 0 -deleteHook {}}\ + {-accessPath {[list $tcl_library $TestsDir/auto0/auto2 $TestsDir/auto0/auto1]*}\ + -statics 1 -nested 0 -deleteHook {}}" + +test safe-9.9 {interpConfigure change the access path; tclIndex commands unaffected by token rearrangement (actual test of doreset)} -setup { +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library \ + [file join $TestsDir auto0 auto1] \ + [file join $TestsDir auto0 auto2]]] + + # Inspect. + set confA [safe::interpConfigure $i] + set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]] + set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]] + + # Load auto_load data. + interp eval $i {catch nonExistentCommand} + + # Do not load the commands. With the tokens swapped, the test + # will pass only if the Safe Base has called auto_reset. + + # Rearrange access path. Swap tokens {$p(:1:)} and {$p(:2:)}. + safe::interpConfigure $i -accessPath [list $tcl_library \ + [file join $TestsDir auto0 auto2] \ + [file join $TestsDir auto0 auto1]] + + # Inspect. + set confB [safe::interpConfigure $i] + set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]] + set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]] + + # Load and run the commands. + set code3 [catch {interp eval $i {report1}} msg3] + set code4 [catch {interp eval $i {report2}} msg4] + + list $path1 $path2 $path3 $path4 $code3 $msg3 $code4 $msg4 $confA $confB +} -cleanup { + safe::interpDelete $i +} -match glob -result "{\$p(:1:)} {\$p(:2:)} {\$p(:2:)} {\$p(:1:)} 0 ok1 0 ok2\ + {-accessPath {[list $tcl_library $TestsDir/auto0/auto1 $TestsDir/auto0/auto2]*}\ + -statics 1 -nested 0 -deleteHook {}}\ + {-accessPath {[list $tcl_library $TestsDir/auto0/auto2 $TestsDir/auto0/auto1]*}\ + -statics 1 -nested 0 -deleteHook {}}" + +test safe-9.10 {interpConfigure change the access path; pkgIndex.tcl packages unaffected by token rearrangement} -setup { +} -body { + # For complete correspondence to safe-9.10opt, include auto0 in access path. + set i [safe::interpCreate -accessPath [list $tcl_library \ + [file join $TestsDir auto0] \ + [file join $TestsDir auto0 auto1] \ + [file join $TestsDir auto0 auto2]]] + + # Inspect. + set confA [safe::interpConfigure $i] + set path0 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0]] + set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]] + set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]] + + # Load pkgIndex.tcl data. + catch {interp eval $i {package require NOEXIST}} + + # Rearrange access path. Swap tokens {$p(:2:)} and {$p(:3:)}. + # This would have no effect because the records in Pkg of these directories + # were from access as children of {$p(:1:)}. + safe::interpConfigure $i -accessPath [list $tcl_library \ + [file join $TestsDir auto0] \ + [file join $TestsDir auto0 auto2] \ + [file join $TestsDir auto0 auto1]] + + # Inspect. + set confB [safe::interpConfigure $i] + set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]] + set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]] + + # Try to load the packages and run a command from each one. + set code3 [catch {interp eval $i {package require SafeTestPackage1}} msg3 opts3] + set code4 [catch {interp eval $i {package require SafeTestPackage2}} msg4 opts4] + set code5 [catch {interp eval $i {HeresPackage1}} msg5 opts5] + set code6 [catch {interp eval $i {HeresPackage2}} msg6 opts6] + + list $path1 $path2 $path3 $path4 $code3 $msg3 $code4 $msg4 $confA $confB \ + $code5 $msg5 $code6 $msg6 + +} -cleanup { + safe::interpDelete $i +} -match glob -result "{\$p(:2:)} {\$p(:3:)} {\$p(:3:)} {\$p(:2:)} 0 1.2.3 0 2.3.4\ + {-accessPath {[list $tcl_library $TestsDir/auto0 $TestsDir/auto0/auto1 $TestsDir/auto0/auto2]*}\ + -statics 1 -nested 0 -deleteHook {}}\ + {-accessPath {[list $tcl_library $TestsDir/auto0 $TestsDir/auto0/auto2 $TestsDir/auto0/auto1]*}\ + -statics 1 -nested 0 -deleteHook {}}\ + 0 OK1 0 OK2" + +test safe-9.11 {interpConfigure change the access path; pkgIndex.tcl packages unaffected by token rearrangement, 9.10 without path auto0} -setup { +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library \ + [file join $TestsDir auto0 auto1] \ + [file join $TestsDir auto0 auto2]]] + + # Inspect. + set confA [safe::interpConfigure $i] + set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]] + set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]] + + # Load pkgIndex.tcl data. + catch {interp eval $i {package require NOEXIST}} + + # Rearrange access path. Swap tokens {$p(:1:)} and {$p(:2:)}. + safe::interpConfigure $i -accessPath [list $tcl_library \ + [file join $TestsDir auto0 auto2] \ + [file join $TestsDir auto0 auto1]] + + # Inspect. + set confB [safe::interpConfigure $i] + set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]] + set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]] + + # Try to load the packages and run a command from each one. + set code3 [catch {interp eval $i {package require SafeTestPackage1}} msg3 opts3] + set code4 [catch {interp eval $i {package require SafeTestPackage2}} msg4 opts4] + set code5 [catch {interp eval $i {HeresPackage1}} msg5 opts5] + set code6 [catch {interp eval $i {HeresPackage2}} msg6 opts6] + + list $path1 $path2 $path3 $path4 $code3 $msg3 $code4 $msg4 $confA $confB \ + $code5 $msg5 $code6 $msg6 +} -cleanup { + safe::interpDelete $i +} -match glob -result "{\$p(:1:)} {\$p(:2:)} {\$p(:2:)} {\$p(:1:)} 0 1.2.3 0 2.3.4\ + {-accessPath {[list $tcl_library $TestsDir/auto0/auto1 $TestsDir/auto0/auto2]*}\ + -statics 1 -nested 0 -deleteHook {}}\ + {-accessPath {[list $tcl_library $TestsDir/auto0/auto2 $TestsDir/auto0/auto1]*}\ + -statics 1 -nested 0 -deleteHook {}}\ + 0 OK1 0 OK2" + +test safe-9.12 {interpConfigure change the access path; pkgIndex.tcl packages fail if directory de-listed} -setup { +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library \ + [file join $TestsDir auto0 auto1] \ + [file join $TestsDir auto0 auto2]]] + + # Inspect. + set confA [safe::interpConfigure $i] + set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]] + set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]] + + # Load pkgIndex.tcl data. + catch {interp eval $i {package require NOEXIST}} + + # Limit access path. Remove tokens {$p(:1:)} and {$p(:2:)}. + safe::interpConfigure $i -accessPath [list $tcl_library] + + # Inspect. + set confB [safe::interpConfigure $i] + set code4 [catch {::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]} path4] + set code5 [catch {::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]} path5] + + # Try to load the packages. + set code3 [catch {interp eval $i {package require SafeTestPackage1}} msg3] + set code6 [catch {interp eval $i {package require SafeTestPackage2}} msg6] + + list $path1 $path2 $code4 $path4 $code5 $path5 $code3 $msg3 $code6 $msg6 $confA $confB +} -cleanup { + safe::interpDelete $i +} -match glob -result "{\$p(:1:)} {\$p(:2:)} 1 {* not found in access path}\ + 1 {* not found in access path} 1 {*} 1 {*}\ + {-accessPath {[list $tcl_library $TestsDir/auto0/auto1 $TestsDir/auto0/auto2]*}\ + -statics 1 -nested 0 -deleteHook {}}\ + {-accessPath {[list $tcl_library]*} -statics 1 -nested 0 -deleteHook {}}" + +test safe-9.20 {check module loading} -setup { + set oldTm [tcl::tm::path list] + foreach path $oldTm { + tcl::tm::path remove $path + } + tcl::tm::path add [file join $TestsDir auto0 modules] +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library]] + + # Inspect. + set confA [safe::interpConfigure $i] + set modsA [interp eval $i {tcl::tm::path list}] + set path0 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]] + set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]] + set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]] + + # Try to load the packages and run a command from each one. + set code0 [catch {interp eval $i {package require test0}} msg0] + set code1 [catch {interp eval $i {package require mod1::test1}} msg1] + set code2 [catch {interp eval $i {package require mod2::test2}} msg2] + set out0 [interp eval $i {test0::try0}] + set out1 [interp eval $i {mod1::test1::try1}] + set out2 [interp eval $i {mod2::test2::try2}] + + list $path0 $path1 $path2 -- $modsA -- \ + $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $confA -- $out0 $out1 $out2 +} -cleanup { + tcl::tm::path remove [file join $TestsDir auto0 modules] + foreach path [lreverse $oldTm] { + tcl::tm::path add $path + } + safe::interpDelete $i +} -match glob -result "{\$p(:1:)} {\$p(:2:)} {\$p(:3:)} -- {{\$p(:1:)}} --\ + 0 0.5 0 1.0 0 2.0 --\ + {-accessPath {[list $tcl_library $TestsDir/auto0/modules \ + $TestsDir/auto0/modules/mod1 \ + $TestsDir/auto0/modules/mod2]*}\ + -statics 1 -nested 0 -deleteHook {}} --\ + res0 res1 res2" + +test safe-9.21 {interpConfigure change the access path; check module loading; stale data case 1} -setup { + set oldTm [tcl::tm::path list] + foreach path $oldTm { + tcl::tm::path remove $path + } + tcl::tm::path add [file join $TestsDir auto0 modules] +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library]] + + # Inspect. + set confA [safe::interpConfigure $i] + set modsA [interp eval $i {tcl::tm::path list}] + set path0 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]] + set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]] + set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]] + + # Add to access path. + # This injects more tokens, pushing modules to higher token numbers. + safe::interpConfigure $i -accessPath [list $tcl_library \ + [file join $TestsDir auto0 auto1] \ + [file join $TestsDir auto0 auto2]] + + # Inspect. + set confB [safe::interpConfigure $i] + set modsB [interp eval $i {tcl::tm::path list}] + set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]] + set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]] + set path5 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]] + + # Load pkg data. + catch {interp eval $i {package require NOEXIST}} + catch {interp eval $i {package require mod1::NOEXIST}} + catch {interp eval $i {package require mod2::NOEXIST}} + + # Try to load the packages and run a command from each one. + set code0 [catch {interp eval $i {package require test0}} msg0] + set code1 [catch {interp eval $i {package require mod1::test1}} msg1] + set code2 [catch {interp eval $i {package require mod2::test2}} msg2] + set out0 [interp eval $i {test0::try0}] + set out1 [interp eval $i {mod1::test1::try1}] + set out2 [interp eval $i {mod2::test2::try2}] + + list $path0 $path1 $path2 -- $modsA -- $path3 $path4 $path5 -- $modsB -- \ + $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $confA -- $confB -- \ + $out0 $out1 $out2 +} -cleanup { + tcl::tm::path remove [file join $TestsDir auto0 modules] + foreach path [lreverse $oldTm] { + tcl::tm::path add $path + } + safe::interpDelete $i +} -match glob -result "{\$p(:1:)} {\$p(:2:)} {\$p(:3:)} -- {{\$p(:1:)}} --\ + {\$p(:3:)} {\$p(:4:)} {\$p(:5:)} -- {{\$p(:3:)}} --\ + 0 0.5 0 1.0 0 2.0 --\ + {-accessPath {[list $tcl_library \ + $TestsDir/auto0/modules \ + $TestsDir/auto0/modules/mod1 \ + $TestsDir/auto0/modules/mod2]}\ + -statics 1 -nested 0 -deleteHook {}} --\ + {-accessPath {[list $tcl_library \ + $TestsDir/auto0/auto1 \ + $TestsDir/auto0/auto2 \ + $TestsDir/auto0/modules \ + $TestsDir/auto0/modules/mod1 \ + $TestsDir/auto0/modules/mod2]}\ + -statics 1 -nested 0 -deleteHook {}} --\ + res0 res1 res2" + +test safe-9.22 {interpConfigure change the access path; check module loading; stale data case 0} -setup { + set oldTm [tcl::tm::path list] + foreach path $oldTm { + tcl::tm::path remove $path + } + tcl::tm::path add [file join $TestsDir auto0 modules] +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library]] + + # Inspect. + set confA [safe::interpConfigure $i] + set modsA [interp eval $i {tcl::tm::path list}] + set path0 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]] + set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]] + set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]] + + # Add to access path. + # This injects more tokens, pushing modules to higher token numbers. + safe::interpConfigure $i -accessPath [list $tcl_library \ + [file join $TestsDir auto0 auto1] \ + [file join $TestsDir auto0 auto2]] + + # Inspect. + set confB [safe::interpConfigure $i] + set modsB [interp eval $i {tcl::tm::path list}] + set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]] + set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]] + set path5 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]] + + # Try to load the packages and run a command from each one. + set code0 [catch {interp eval $i {package require test0}} msg0] + set code1 [catch {interp eval $i {package require mod1::test1}} msg1] + set code2 [catch {interp eval $i {package require mod2::test2}} msg2] + set out0 [interp eval $i {test0::try0}] + set out1 [interp eval $i {mod1::test1::try1}] + set out2 [interp eval $i {mod2::test2::try2}] + + list $path0 $path1 $path2 -- $modsA -- $path3 $path4 $path5 -- $modsB -- \ + $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $confA -- $confB -- \ + $out0 $out1 $out2 +} -cleanup { + tcl::tm::path remove [file join $TestsDir auto0 modules] + foreach path [lreverse $oldTm] { + tcl::tm::path add $path + } + safe::interpDelete $i +} -match glob -result "{\$p(:1:)} {\$p(:2:)} {\$p(:3:)} -- {{\$p(:1:)}} --\ + {\$p(:3:)} {\$p(:4:)} {\$p(:5:)} -- {{\$p(:3:)}} --\ + 0 0.5 0 1.0 0 2.0 --\ + {-accessPath {[list $tcl_library \ + $TestsDir/auto0/modules \ + $TestsDir/auto0/modules/mod1 \ + $TestsDir/auto0/modules/mod2]}\ + -statics 1 -nested 0 -deleteHook {}} --\ + {-accessPath {[list $tcl_library \ + $TestsDir/auto0/auto1 \ + $TestsDir/auto0/auto2 \ + $TestsDir/auto0/modules \ + $TestsDir/auto0/modules/mod1 \ + $TestsDir/auto0/modules/mod2]}\ + -statics 1 -nested 0 -deleteHook {}} --\ + res0 res1 res2" + +test safe-9.23 {interpConfigure change the access path; check module loading; stale data case 3} -setup { + set oldTm [tcl::tm::path list] + foreach path $oldTm { + tcl::tm::path remove $path + } + tcl::tm::path add [file join $TestsDir auto0 modules] +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library]] + + # Inspect. + set confA [safe::interpConfigure $i] + set modsA [interp eval $i {tcl::tm::path list}] + set path0 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]] + set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]] + set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]] + + # Force the interpreter to acquire pkg data which will soon become stale. + catch {interp eval $i {package require NOEXIST}} + catch {interp eval $i {package require mod1::NOEXIST}} + catch {interp eval $i {package require mod2::NOEXIST}} + + # Add to access path. + # This injects more tokens, pushing modules to higher token numbers. + safe::interpConfigure $i -accessPath [list $tcl_library \ + [file join $TestsDir auto0 auto1] \ + [file join $TestsDir auto0 auto2]] + + # Inspect. + set confB [safe::interpConfigure $i] + set modsB [interp eval $i {tcl::tm::path list}] + set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]] + set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]] + set path5 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]] + + # Refresh stale pkg data. + catch {interp eval $i {package require NOEXIST}} + catch {interp eval $i {package require mod1::NOEXIST}} + catch {interp eval $i {package require mod2::NOEXIST}} + + # Try to load the packages and run a command from each one. + set code0 [catch {interp eval $i {package require test0}} msg0] + set code1 [catch {interp eval $i {package require mod1::test1}} msg1] + set code2 [catch {interp eval $i {package require mod2::test2}} msg2] + set out0 [interp eval $i {test0::try0}] + set out1 [interp eval $i {mod1::test1::try1}] + set out2 [interp eval $i {mod2::test2::try2}] + + list $path0 $path1 $path2 -- $modsA -- $path3 $path4 $path5 -- $modsB -- \ + $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $confA -- $confB -- \ + $out0 $out1 $out2 + +} -cleanup { + tcl::tm::path remove [file join $TestsDir auto0 modules] + foreach path [lreverse $oldTm] { + tcl::tm::path add $path + } + safe::interpDelete $i +} -match glob -result "{\$p(:1:)} {\$p(:2:)} {\$p(:3:)} -- {{\$p(:1:)}} --\ + {\$p(:3:)} {\$p(:4:)} {\$p(:5:)} -- {{\$p(:3:)}} --\ + 0 0.5 0 1.0 0 2.0 --\ + {-accessPath {[list $tcl_library \ + $TestsDir/auto0/modules \ + $TestsDir/auto0/modules/mod1 \ + $TestsDir/auto0/modules/mod2]}\ + -statics 1 -nested 0 -deleteHook {}} --\ + {-accessPath {[list $tcl_library \ + $TestsDir/auto0/auto1 \ + $TestsDir/auto0/auto2 \ + $TestsDir/auto0/modules \ + $TestsDir/auto0/modules/mod1 \ + $TestsDir/auto0/modules/mod2]}\ + -statics 1 -nested 0 -deleteHook {}} --\ + res0 res1 res2" + +test safe-9.24 {interpConfigure change the access path; check module loading; stale data case 2 (worst case)} -setup { + set oldTm [tcl::tm::path list] + foreach path $oldTm { + tcl::tm::path remove $path + } + tcl::tm::path add [file join $TestsDir auto0 modules] +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library]] + + # Inspect. + set confA [safe::interpConfigure $i] + set modsA [interp eval $i {tcl::tm::path list}] + set path0 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]] + set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]] + set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]] + + # Force the interpreter to acquire pkg data which will soon become stale. + catch {interp eval $i {package require NOEXIST}} + catch {interp eval $i {package require mod1::NOEXIST}} + catch {interp eval $i {package require mod2::NOEXIST}} + + # Add to access path. + # This injects more tokens, pushing modules to higher token numbers. + safe::interpConfigure $i -accessPath [list $tcl_library \ + [file join $TestsDir auto0 auto1] \ + [file join $TestsDir auto0 auto2]] + + # Inspect. + set confB [safe::interpConfigure $i] + set modsB [interp eval $i {tcl::tm::path list}] + set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]] + set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]] + set path5 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]] + + # Try to load the packages and run a command from each one. + set code0 [catch {interp eval $i {package require test0}} msg0] + set code1 [catch {interp eval $i {package require mod1::test1}} msg1] + set code2 [catch {interp eval $i {package require mod2::test2}} msg2] + set out0 [interp eval $i {test0::try0}] + set out1 [interp eval $i {mod1::test1::try1}] + set out2 [interp eval $i {mod2::test2::try2}] + + list $path0 $path1 $path2 -- $modsA -- $path3 $path4 $path5 -- $modsB -- \ + $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $confA -- $confB -- \ + $out0 $out1 $out2 +} -cleanup { + tcl::tm::path remove [file join $TestsDir auto0 modules] + foreach path [lreverse $oldTm] { + tcl::tm::path add $path + } + safe::interpDelete $i +} -match glob -result "{\$p(:1:)} {\$p(:2:)} {\$p(:3:)} -- {{\$p(:1:)}} --\ + {\$p(:3:)} {\$p(:4:)} {\$p(:5:)} -- {{\$p(:3:)}} --\ + 0 0.5 0 1.0 0 2.0 --\ + {-accessPath {[list $tcl_library \ + $TestsDir/auto0/modules \ + $TestsDir/auto0/modules/mod1 \ + $TestsDir/auto0/modules/mod2]}\ + -statics 1 -nested 0 -deleteHook {}} --\ + {-accessPath {[list $tcl_library \ + $TestsDir/auto0/auto1 \ + $TestsDir/auto0/auto2 \ + $TestsDir/auto0/modules \ + $TestsDir/auto0/modules/mod1 \ + $TestsDir/auto0/modules/mod2]}\ + -statics 1 -nested 0 -deleteHook {}} --\ + res0 res1 res2" + + catch {teststaticpkg Safepkg1 0 0} test safe-10.1 {testing statics loading} -constraints TcltestPackage -setup { set i [safe::interpCreate] -- cgit v0.12 From c256107a5c50a4ffa13d226f245f25cf4ccc311f Mon Sep 17 00:00:00 2001 From: kjnash Date: Mon, 13 Jul 2020 11:49:46 +0000 Subject: Bugfix in library/safe.tcl for doreset (auto_reset); pass test safe-9.9 --- library/safe.tcl | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/library/safe.tcl b/library/safe.tcl index 3429b9e..7ed6b94 100644 --- a/library/safe.tcl +++ b/library/safe.tcl @@ -192,10 +192,10 @@ proc ::safe::interpConfigure {args} { # Get the current (and not the default) values of whatever has # not been given: if {![::tcl::OptProcArgGiven -accessPath]} { - set doreset 1 + set doreset 0 set accessPath $state(access_path) } else { - set doreset 0 + set doreset 1 } if { ![::tcl::OptProcArgGiven -statics] -- cgit v0.12 From 9c9af976ae17ba173df40300467589554956e8f2 Mon Sep 17 00:00:00 2001 From: kjnash Date: Mon, 13 Jul 2020 12:09:47 +0000 Subject: Bugfix in library/safe.tcl - when auto_reset, also reload pkgIndex.tcl data; pass tests safe-9.10, safe-9.11 --- library/safe.tcl | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/library/safe.tcl b/library/safe.tcl index 7ed6b94..deefa33 100644 --- a/library/safe.tcl +++ b/library/safe.tcl @@ -225,6 +225,14 @@ proc ::safe::interpConfigure {args} { } else { Log $slave "successful auto_reset" NOTICE } + # Wherever possible, refresh package data. + # - Ideally [package ifneeded $pkg $ver {}] would clear the + # stale data from the interpreter, but instead it sets a + # nonsense empty script. + # - We cannot purge stale package data, but we can overwrite + # it where we have fresh data. Any remaining stale data will + # do no harm but the error messages may be cryptic. + ::interp eval $slave [list catch {package require NOEXIST}] } } } -- cgit v0.12 From af4b36c13d6d8cbcdf5798b5b12dd996b484d8a8 Mon Sep 17 00:00:00 2001 From: kjnash Date: Mon, 13 Jul 2020 12:13:07 +0000 Subject: Bugfix in library/safe.tcl - remove impossible error message in safe::interpFindInAccessPath; pass test safe-9.12 --- library/safe.tcl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/library/safe.tcl b/library/safe.tcl index deefa33..838f65f 100644 --- a/library/safe.tcl +++ b/library/safe.tcl @@ -404,7 +404,7 @@ proc ::safe::interpFindInAccessPath {slave path} { namespace upvar ::safe S$slave state if {![dict exists $state(access_path,remap) $path]} { - return -code error "$path not found in access path $access_path" + return -code error "$path not found in access path" } return [dict get $state(access_path,remap) $path] -- cgit v0.12 From cca23e5286ec6f14dd7c62275cc409419f2a6d3c Mon Sep 17 00:00:00 2001 From: kjnash Date: Mon, 13 Jul 2020 12:25:10 +0000 Subject: Bugfix in library/safe.tcl - only add tm roots to tcl::tm::list; pass test safe-9.20 --- library/safe.tcl | 15 ++++++++++++++- 1 file changed, 14 insertions(+), 1 deletion(-) diff --git a/library/safe.tcl b/library/safe.tcl index 838f65f..d31ca63 100644 --- a/library/safe.tcl +++ b/library/safe.tcl @@ -352,6 +352,7 @@ proc ::safe::InterpSetConfig {slave access_path staticsok nestedok deletehook} { } set morepaths [::tcl::tm::list] + set firstpass 1 while {[llength $morepaths]} { set addpaths $morepaths set morepaths {} @@ -360,6 +361,12 @@ proc ::safe::InterpSetConfig {slave access_path staticsok nestedok deletehook} { # Prevent the addition of dirs on the tm list to the # result if they are already known. if {[dict exists $remap_access_path $dir]} { + if {$firstpass} { + # $dir is in [::tcl::tm::list] and belongs in the slave_tm_path. + # Later passes handle subdirectories, which belong in the + # access path but not in the module path. + lappend slave_tm_path [dict get $remap_access_path $dir] + } continue } @@ -369,7 +376,12 @@ proc ::safe::InterpSetConfig {slave access_path staticsok nestedok deletehook} { lappend map_access_path $token $dir lappend remap_access_path $dir $token lappend norm_access_path [file normalize $dir] - lappend slave_tm_path $token + if {$firstpass} { + # $dir is in [::tcl::tm::list] and belongs in the slave_tm_path. + # Later passes handle subdirectories, which belong in the + # access path but not in the module path. + lappend slave_tm_path $token + } incr i # [Bug 2854929] @@ -380,6 +392,7 @@ proc ::safe::InterpSetConfig {slave access_path staticsok nestedok deletehook} { # subdirectories. lappend morepaths {*}[glob -nocomplain -directory $dir -type d *] } + set firstpass 0 } set state(access_path) $access_path -- cgit v0.12 From f0a97b5c716346e60173644010e1d201bea8e690 Mon Sep 17 00:00:00 2001 From: kjnash Date: Mon, 13 Jul 2020 12:32:08 +0000 Subject: Bugfix in library/safe.tcl - interpConfigure use revised value of tcl::tm::list; pass tests safe-9.21, safe-9.22 --- library/safe.tcl | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/library/safe.tcl b/library/safe.tcl index d31ca63..4d22cbe 100644 --- a/library/safe.tcl +++ b/library/safe.tcl @@ -225,6 +225,14 @@ proc ::safe::interpConfigure {args} { } else { Log $slave "successful auto_reset" NOTICE } + + # Sync the paths used to search for Tcl modules. + ::interp eval $slave {tcl::tm::path remove {*}[tcl::tm::list]} + if {[llength $state(tm_path_slave)] > 0} { + ::interp eval $slave [list \ + ::tcl::tm::add {*}[lreverse $state(tm_path_slave)]] + } + # Wherever possible, refresh package data. # - Ideally [package ifneeded $pkg $ver {}] would clear the # stale data from the interpreter, but instead it sets a -- cgit v0.12 From 12ba446acbcd70856603aeeffb90fc425be58e02 Mon Sep 17 00:00:00 2001 From: kjnash Date: Mon, 13 Jul 2020 12:37:16 +0000 Subject: Bugfix in library/tm.tcl - in a safe interp ::tcl::tm::UnknownHandler should always use the freshest "package ifneeded"; pass test safe-9.23 --- library/tm.tcl | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/library/tm.tcl b/library/tm.tcl index 1802bb9..3861532 100644 --- a/library/tm.tcl +++ b/library/tm.tcl @@ -238,12 +238,16 @@ proc ::tcl::tm::UnknownHandler {original name args} { continue } - if {[package ifneeded $pkgname $pkgversion] ne {}} { + if { ([package ifneeded $pkgname $pkgversion] ne {}) + && (![interp issafe]) + } { # There's already a provide script registered for # this version of this package. Since all units of # code claiming to be the same version of the same # package ought to be identical, just stick with # the one we already have. + # This does not apply to Safe Base interpreters because + # the token-to-directory mapping may have changed. continue } -- cgit v0.12 From 4c326aa381e14ad6cdef2060e7f0a6328b970699 Mon Sep 17 00:00:00 2001 From: kjnash Date: Mon, 13 Jul 2020 12:52:53 +0000 Subject: Bugfix in library/safe.tcl - when auto_reset, also reload module data; pass test safe-9.24 --- library/safe.tcl | 21 +++++++++++++++++++-- 1 file changed, 19 insertions(+), 2 deletions(-) diff --git a/library/safe.tcl b/library/safe.tcl index 4d22cbe..30b045e 100644 --- a/library/safe.tcl +++ b/library/safe.tcl @@ -217,7 +217,7 @@ proc ::safe::interpConfigure {args} { set deleteHook $state(cleanupHook) } # we can now reconfigure : - InterpSetConfig $slave $accessPath $statics $nested $deleteHook + set slave_tm_rel [InterpSetConfig $slave $accessPath $statics $nested $deleteHook] # auto_reset the slave (to completly synch the new access_path) if {$doreset} { if {[catch {::interp eval $slave {auto_reset}} msg]} { @@ -233,7 +233,7 @@ proc ::safe::interpConfigure {args} { ::tcl::tm::add {*}[lreverse $state(tm_path_slave)]] } - # Wherever possible, refresh package data. + # Wherever possible, refresh package/module data. # - Ideally [package ifneeded $pkg $ver {}] would clear the # stale data from the interpreter, but instead it sets a # nonsense empty script. @@ -241,6 +241,10 @@ proc ::safe::interpConfigure {args} { # it where we have fresh data. Any remaining stale data will # do no harm but the error messages may be cryptic. ::interp eval $slave [list catch {package require NOEXIST}] + foreach rel $slave_tm_rel { + set cmd [list package require [string map {/ ::} $rel]::NOEXIST] + ::interp eval $slave [list catch $cmd] + } } } } @@ -348,6 +352,8 @@ proc ::safe::InterpSetConfig {slave access_path staticsok nestedok deletehook} { set map_access_path {} set remap_access_path {} set slave_tm_path {} + set slave_tm_roots {} + set slave_tm_rel {} set i 0 foreach dir $access_path { @@ -374,6 +380,7 @@ proc ::safe::InterpSetConfig {slave access_path staticsok nestedok deletehook} { # Later passes handle subdirectories, which belong in the # access path but not in the module path. lappend slave_tm_path [dict get $remap_access_path $dir] + lappend slave_tm_roots [file normalize $dir] [file normalize $dir] } continue } @@ -389,6 +396,7 @@ proc ::safe::InterpSetConfig {slave access_path staticsok nestedok deletehook} { # Later passes handle subdirectories, which belong in the # access path but not in the module path. lappend slave_tm_path $token + lappend slave_tm_roots [file normalize $dir] [file normalize $dir] } incr i @@ -399,6 +407,14 @@ proc ::safe::InterpSetConfig {slave access_path staticsok nestedok deletehook} { # 'platform/shell-X.tm', i.e arbitrarily deep # subdirectories. lappend morepaths {*}[glob -nocomplain -directory $dir -type d *] + foreach sub [glob -nocomplain -directory $dir -type d *] { + lappend slave_tm_roots [file normalize $sub] [dict get $slave_tm_roots $dir] + set lenny [string length [dict get $slave_tm_roots $dir]] + set relpath [string range [file normalize $sub] $lenny+1 end] + if {$relpath ni $slave_tm_rel} { + lappend slave_tm_rel $relpath + } + } } set firstpass 0 } @@ -414,6 +430,7 @@ proc ::safe::InterpSetConfig {slave access_path staticsok nestedok deletehook} { set state(cleanupHook) $deletehook SyncAccessPath $slave + return $slave_tm_rel } # -- cgit v0.12 From 7169e0abe0053715354bdb1f7e2ecec9199e9691 Mon Sep 17 00:00:00 2001 From: kjnash Date: Mon, 13 Jul 2020 14:55:28 +0000 Subject: Add tests to tests/safe.test --- tests/safe.test | 73 +++++++++++++++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 71 insertions(+), 2 deletions(-) diff --git a/tests/safe.test b/tests/safe.test index 3ff9e62..c70d9b1 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -9,6 +9,7 @@ # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. +# PURGE SyncExists AutoPathSync package require Tcl 8.5- @@ -302,7 +303,25 @@ test safe-7.0f {example modules packages, test in master interpreter, append to } -match glob -result {0 0.5 0 1.0 0 2.0 -- res0 res1 res2} # high level general test -test safe-7.1 {tests that everything works at high level} -body { +# Use example packages not http1.0 +test safe-7.1 {tests that everything works at high level} -setup { + set tmpAutoPath $::auto_path + lappend ::auto_path [file join $TestsDir auto0] + set i [safe::interpCreate] + set ::auto_path $tmpAutoPath +} -body { + # no error shall occur: + # (because the default access_path shall include 1st level sub dirs so + # package require in a slave works like in the master) + set v [interp eval $i {package require SafeTestPackage1}] + # no error shall occur: + interp eval $i {HeresPackage1} + set v +} -cleanup { + safe::interpDelete $i +} -match glob -result 1.2.3 +# high level general test +test safe-7.1http {tests that everything works at high level, uses http 2} -body { set i [safe::interpCreate] # no error shall occur: # (because the default access_path shall include 1st level sub dirs so @@ -313,7 +332,27 @@ test safe-7.1 {tests that everything works at high level} -body { safe::interpDelete $i set v } -match glob -result 2.* -test safe-7.2 {tests specific path and interpFind/AddToAccessPath} -body { +test safe-7.2 {tests specific path and interpFind/AddToAccessPath} -setup { +} -body { + set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]] + # should not add anything (p0) + set token1 [safe::interpAddToAccessPath $i [info library]] + # should add as p* (not p1 if master has a module path) + set token2 [safe::interpAddToAccessPath $i "/dummy/unixlike/test/path"] + # should add as p* (not p2 if master has a module path) + set token3 [safe::interpAddToAccessPath $i [file join $TestsDir auto0]] + # an error shall occur (SafeTestPackage1 is not anymore in the secure 0-level + # provided deep path) + list $token1 $token2 $token3 \ + [catch {interp eval $i {package require SafeTestPackage1}} msg] $msg \ + [safe::interpConfigure $i]\ + [safe::interpDelete $i] +} -cleanup { +} -match glob -result "{\$p(:0:)} {\$p(:*:)} {\$p(:*:)} 1\ + {can't find package SafeTestPackage1}\ + {-accessPath {[list $tcl_library */dummy/unixlike/test/path $TestsDir/auto0]}\ + -statics 0 -nested 1 -deleteHook {}} {}" +test safe-7.2http {tests specific path and interpFind/AddToAccessPath, uses http1.0} -body { set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]] # should not add anything (p0) set token1 [safe::interpAddToAccessPath $i [info library]] @@ -331,6 +370,36 @@ test safe-7.3 {check that safe subinterpreters work} { set j [safe::interpCreate [list $i x]] list [interp eval $j {join {o k} ""}] [safe::interpDelete $i] [interp exists $j] } {ok {} 0} +test safe-7.4 {tests specific path and positive search} -setup { +} -body { + set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]] + # should not add anything (p0) + set token1 [safe::interpAddToAccessPath $i [info library]] + # should add as p* (not p1 if master has a module path) + set token2 [safe::interpAddToAccessPath $i [file join $TestsDir auto0 auto1]] + # this time, unlike test safe-7.2, SafeTestPackage1 should be found + list $token1 $token2 \ + [catch {interp eval $i {package require SafeTestPackage1}} msg] $msg \ + [safe::interpConfigure $i]\ + [safe::interpDelete $i] + # Note that the glob match elides directories (those from the module path) + # other than the first and last in the access path. +} -cleanup { +} -match glob -result "{\$p(:0:)} {\$p(:*:)} 0 1.2.3\ + {-accessPath {[list $tcl_library * $TestsDir/auto0/auto1]}\ + -statics 0 -nested 1 -deleteHook {}} {}" +test safe-7.4http {tests specific path and positive search, uses http1.0} -body { + set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]] + # should not add anything (p0) + set token1 [safe::interpAddToAccessPath $i [info library]] + # should add as p1 + set token2 [safe::interpAddToAccessPath $i [file join [info library] http1.0]] + # this time, unlike test safe-7.2, http should be found + list $token1 $token2 \ + [catch {interp eval $i {package require http 1}} msg] $msg \ + [safe::interpConfigure $i]\ + [safe::interpDelete $i] +} -match glob -result "{\$p(:0:)} {\$p(:*:)} 0 1.0 {-accessPath {[list $tcl_library *$tcl_library/http1.0]} -statics 0 -nested 1 -deleteHook {}} {}" # test source control on file name set i "a" -- cgit v0.12 From 26cf086c2c3bbb88a608e5c24767c065f5763d8a Mon Sep 17 00:00:00 2001 From: kjnash Date: Mon, 13 Jul 2020 14:57:44 +0000 Subject: Comments only. --- tests/safe.test | 1 - 1 file changed, 1 deletion(-) diff --git a/tests/safe.test b/tests/safe.test index c70d9b1..0f40c36 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -9,7 +9,6 @@ # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -# PURGE SyncExists AutoPathSync package require Tcl 8.5- -- cgit v0.12 From 2ef9dcb65faae43f66ba1ed0dedeac2496d2b3ba Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 14 Jul 2020 10:16:05 +0000 Subject: (cherry-pick): Bugfix in library/tm.tcl - in a safe interp ::tcl::tm::UnknownHandler should always use the freshest "package ifneeded" --- library/tm.tcl | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/library/tm.tcl b/library/tm.tcl index 1802bb9..0ed3f1a 100644 --- a/library/tm.tcl +++ b/library/tm.tcl @@ -238,12 +238,16 @@ proc ::tcl::tm::UnknownHandler {original name args} { continue } - if {[package ifneeded $pkgname $pkgversion] ne {}} { + if {([package ifneeded $pkgname $pkgversion] ne {}) + && (![interp issafe]) + } { # There's already a provide script registered for # this version of this package. Since all units of # code claiming to be the same version of the same # package ought to be identical, just stick with # the one we already have. + # This does not apply to Safe Base interpreters because + # the token-to-directory mapping may have changed. continue } -- cgit v0.12 From 1e3b6b37d1734027a4d8cb19ba379a0b676eaffe Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 15 Jul 2020 09:07:00 +0000 Subject: Rename doc/CrtSlave.3 to doc/CrtAlias.3. Some more doc tweaks. --- doc/CrtAlias.3 | 236 +++++++++++++++++++++++++++++++++++ doc/CrtSlave.3 | 236 ----------------------------------- generic/tcl.decls | 2 +- generic/tclDecls.h | 4 +- macosx/Tcl.xcode/project.pbxproj | 4 +- macosx/Tcl.xcodeproj/project.pbxproj | 4 +- win/tcl.dsp | 2 +- 7 files changed, 244 insertions(+), 244 deletions(-) create mode 100644 doc/CrtAlias.3 delete mode 100644 doc/CrtSlave.3 diff --git a/doc/CrtAlias.3 b/doc/CrtAlias.3 new file mode 100644 index 0000000..72912bc --- /dev/null +++ b/doc/CrtAlias.3 @@ -0,0 +1,236 @@ +'\" +'\" Copyright (c) 1995-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +.TH Tcl_CreateAlias 3 7.6 Tcl "Tcl Library Procedures" +.so man.macros +.BS +.SH NAME +Tcl_IsSafe, Tcl_MakeSafe, Tcl_CreateSlave, Tcl_GetSlave, Tcl_GetMaster, Tcl_GetInterpPath, Tcl_CreateAlias, Tcl_CreateAliasObj, Tcl_GetAlias, Tcl_GetAliasObj, Tcl_ExposeCommand, Tcl_HideCommand \- manage multiple Tcl interpreters, aliases and hidden commands +.SH SYNOPSIS +.nf +\fB#include \fR +.sp +int +\fBTcl_IsSafe\fR(\fIinterp\fR) +.sp +int +\fBTcl_MakeSafe\fR(\fIinterp\fR) +.sp +Tcl_Interp * +\fBTcl_CreateSlave\fR(\fIinterp, name, isSafe\fR) +.sp +Tcl_Interp * +\fBTcl_GetSlave\fR(\fIinterp, name\fR) +.sp +Tcl_Interp * +\fBTcl_GetMaster\fR(\fIinterp\fR) +.sp +int +\fBTcl_GetInterpPath\fR(\finterp, slaveInterp\fR) +.sp +int +\fBTcl_CreateAlias\fR(\fIslaveInterp, slaveCmd, targetInterp, targetCmd, + argc, argv\fR) +.sp +int +\fBTcl_CreateAliasObj\fR(\fIslaveInterp, slaveCmd, targetInterp, targetCmd, + objc, objv\fR) +.sp +int +\fBTcl_GetAlias\fR(\fIinterp, slaveCmd, targetInterpPtr, targetCmdPtr, + argcPtr, argvPtr\fR) +.sp +int +\fBTcl_GetAliasObj\fR(\fIinterp, slaveCmd, targetInterpPtr, targetCmdPtr, + objcPtr, objvPtr\fR) +.sp +int +\fBTcl_ExposeCommand\fR(\fIinterp, hiddenCmdName, cmdName\fR) +.sp +int +\fBTcl_HideCommand\fR(\fIinterp, cmdName, hiddenCmdName\fR) +.SH ARGUMENTS +.AS "const char *const" **targetInterpPtr out +.AP Tcl_Interp *interp in +Interpreter in which to execute the specified command. +.AP "const char" *name in +Name of slave interpreter to create or manipulate. +.AP int isSafe in +If non-zero, a +.QW safe +slave that is suitable for running untrusted code +is created, otherwise a trusted slave is created. +.AP Tcl_Interp *slaveInterp in +Interpreter to use for creating the source command for an alias (see +below). +.AP "const char" *slaveCmd in +Name of source command for alias. +.AP Tcl_Interp *targetInterp in +Interpreter that contains the target command for an alias. +.AP "const char" *targetCmd in +Name of target command for alias in \fItargetInterp\fR. +.AP int argc in +Count of additional arguments to pass to the alias command. +.AP "const char *const" *argv in +Vector of strings, the additional arguments to pass to the alias command. +This storage is owned by the caller. +.AP int objc in +Count of additional value arguments to pass to the aliased command. +.AP Tcl_Obj **objv in +Vector of Tcl_Obj structures, the additional value arguments to pass to +the aliased command. +This storage is owned by the caller. +.AP Tcl_Interp **targetInterpPtr in +Pointer to location to store the address of the interpreter where a target +command is defined for an alias. +.AP "const char" **targetCmdPtr out +Pointer to location to store the address of the name of the target command +for an alias. +.AP int *argcPtr out +Pointer to location to store count of additional arguments to be passed to +the alias. The location is in storage owned by the caller. +.AP "const char" ***argvPtr out +Pointer to location to store a vector of strings, the additional arguments +to pass to an alias. The location is in storage owned by the caller, the +vector of strings is owned by the called function. +.AP int *objcPtr out +Pointer to location to store count of additional value arguments to be +passed to the alias. The location is in storage owned by the caller. +.AP Tcl_Obj ***objvPtr out +Pointer to location to store a vector of Tcl_Obj structures, the additional +arguments to pass to an alias command. The location is in storage +owned by the caller, the vector of Tcl_Obj structures is owned by the +called function. +.AP "const char" *cmdName in +Name of an exposed command to hide or create. +.AP "const char" *hiddenCmdName in +Name under which a hidden command is stored and with which it can be +exposed or invoked. +.BE + +.SH DESCRIPTION +.PP +These procedures are intended for access to the multiple interpreter +facility from inside C programs. They enable managing multiple interpreters +in a hierarchical relationship, and the management of aliases, commands +that when invoked in one interpreter execute a command in another +interpreter. The return value for those procedures that return an \fBint\fR +is either \fBTCL_OK\fR or \fBTCL_ERROR\fR. If \fBTCL_ERROR\fR is returned +then the interpreter's result contains an error message. +.PP +\fBTcl_CreateSlave\fR creates a new interpreter as a slave of \fIinterp\fR. +It also creates a slave command named \fIslaveName\fR in \fIinterp\fR which +allows \fIinterp\fR to manipulate the new slave. +If \fIisSafe\fR is zero, the command creates a trusted slave in which Tcl +code has access to all the Tcl commands. +If it is \fB1\fR, the command creates a +.QW safe +slave in which Tcl code has access only to set of Tcl commands defined as +.QW "Safe Tcl" ; +see the manual entry for the Tcl \fBinterp\fR command for details. +If the creation of the new slave interpreter failed, \fBNULL\fR is returned. +.PP +\fBTcl_IsSafe\fR returns \fB1\fR if \fIinterp\fR is +.QW safe +(was created with the \fBTCL_SAFE_INTERPRETER\fR flag specified), +\fB0\fR otherwise. +.PP +\fBTcl_MakeSafe\fR marks \fIinterp\fR as +.QW safe , +so that future +calls to \fBTcl_IsSafe\fR will return 1. It also removes all known +potentially-unsafe core functionality (both commands and variables) +from \fIinterp\fR. However, it cannot know what parts of an extension +or application are safe and does not make any attempt to remove those +parts, so safety is not guaranteed after calling \fBTcl_MakeSafe\fR. +Callers will want to take care with their use of \fBTcl_MakeSafe\fR +to avoid false claims of safety. For many situations, \fBTcl_CreateSlave\fR +may be a better choice, since it creates interpreters in a known-safe state. +.PP +\fBTcl_GetSlave\fR returns a pointer to a slave interpreter of +\fIinterp\fR. The slave interpreter is identified by \fIslaveName\fR. +If no such slave interpreter exists, \fBNULL\fR is returned. +.PP +\fBTcl_GetMaster\fR returns a pointer to the master interpreter of +\fIinterp\fR. If \fIinterp\fR has no master (it is a +top-level interpreter) then \fBNULL\fR is returned. +.PP +\fBTcl_GetInterpPath\fR stores in the result of \fIaskingInterp\fR +the relative path between \fIaskingInterp\fR and \fIslaveInterp\fR; +\fIslaveInterp\fR must be a slave of \fIaskingInterp\fR. If the computation +of the relative path succeeds, \fBTCL_OK\fR is returned, else +\fBTCL_ERROR\fR is returned and an error message is stored as the +result of \fIaskingInterp\fR. +.PP +\fBTcl_CreateAlias\fR creates a command named \fIslaveCmd\fR in +\fIslaveInterp\fR that when invoked, will cause the command \fItargetCmd\fR +to be invoked in \fItargetInterp\fR. The arguments specified by the strings +contained in \fIargv\fR are always prepended to any arguments supplied in the +invocation of \fIslaveCmd\fR and passed to \fItargetCmd\fR. +This operation returns \fBTCL_OK\fR if it succeeds, or \fBTCL_ERROR\fR if +it fails; in that case, an error message is left in the value result +of \fIslaveInterp\fR. +Note that there are no restrictions on the ancestry relationship (as +created by \fBTcl_CreateSlave\fR) between \fIslaveInterp\fR and +\fItargetInterp\fR. Any two interpreters can be used, without any +restrictions on how they are related. +.PP +\fBTcl_CreateAliasObj\fR is similar to \fBTcl_CreateAlias\fR except +that it takes a vector of values to pass as additional arguments instead +of a vector of strings. +.PP +\fBTcl_GetAlias\fR returns information about an alias \fIaliasName\fR +in \fIinterp\fR. Any of the result fields can be \fBNULL\fR, in +which case the corresponding datum is not returned. If a result field is +non\-\fBNULL\fR, the address indicated is set to the corresponding datum. +For example, if \fItargetNamePtr\fR is non\-\fBNULL\fR it is set to a +pointer to the string containing the name of the target command. +.PP +\fBTcl_GetAliasObj\fR is similar to \fBTcl_GetAlias\fR except that it +returns a pointer to a vector of Tcl_Obj structures instead of a vector of +strings. +.PP +\fBTcl_ExposeCommand\fR moves the command named \fIhiddenCmdName\fR from +the set of hidden commands to the set of exposed commands, putting +it under the name +\fIcmdName\fR. +\fIHiddenCmdName\fR must be the name of an existing hidden +command, or the operation will return \fBTCL_ERROR\fR and +leave an error message as the result of \fIinterp\fR. +If an exposed command named \fIcmdName\fR already exists, +the operation returns \fBTCL_ERROR\fR and leaves an error message as +the result of \fIinterp\fR. +If the operation succeeds, it returns \fBTCL_OK\fR. +After executing this command, attempts to use \fIcmdName\fR in any +script evaluation mechanism will again succeed. +.PP +\fBTcl_HideCommand\fR moves the command named \fIcmdName\fR from the set of +exposed commands to the set of hidden commands, under the name +\fIhiddenCmdName\fR. +\fICmdName\fR must be the name of an existing exposed +command, or the operation will return \fBTCL_ERROR\fR and leave an error +message as the result of \fIinterp\fR. +Currently both \fIcmdName\fR and \fIhiddenCmdName\fR must not contain +namespace qualifiers, or the operation will return \fBTCL_ERROR\fR and +leave an error message as the result of \fIinterp\fR. +The \fICmdName\fR will be looked up in the global namespace, and not +relative to the current namespace, even if the current namespace is not the +global one. +If a hidden command whose name is \fIhiddenCmdName\fR already +exists, the operation also returns \fBTCL_ERROR\fR and an error +message is left as the result of \fIinterp\fR. +If the operation succeeds, it returns \fBTCL_OK\fR. +After executing this command, attempts to use \fIcmdName\fR in +any script evaluation mechanism will fail. +.PP +For a description of the Tcl interface to multiple interpreters, see +\fIinterp(n)\fR. +.SH "SEE ALSO" +interp + +.SH KEYWORDS +alias, command, exposed commands, hidden commands, interpreter, invoke, +master, slave diff --git a/doc/CrtSlave.3 b/doc/CrtSlave.3 deleted file mode 100644 index b8ac421..0000000 --- a/doc/CrtSlave.3 +++ /dev/null @@ -1,236 +0,0 @@ -'\" -'\" Copyright (c) 1995-1996 Sun Microsystems, Inc. -'\" -'\" See the file "license.terms" for information on usage and redistribution -'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" -.TH Tcl_CreateSlave 3 7.6 Tcl "Tcl Library Procedures" -.so man.macros -.BS -.SH NAME -Tcl_IsSafe, Tcl_MakeSafe, Tcl_CreateSlave, Tcl_GetSlave, Tcl_GetMaster, Tcl_GetInterpPath, Tcl_CreateAlias, Tcl_CreateAliasObj, Tcl_GetAlias, Tcl_GetAliasObj, Tcl_ExposeCommand, Tcl_HideCommand \- manage multiple Tcl interpreters, aliases and hidden commands -.SH SYNOPSIS -.nf -\fB#include \fR -.sp -int -\fBTcl_IsSafe\fR(\fIinterp\fR) -.sp -int -\fBTcl_MakeSafe\fR(\fIinterp\fR) -.sp -Tcl_Interp * -\fBTcl_CreateSlave\fR(\fIinterp, slaveName, isSafe\fR) -.sp -Tcl_Interp * -\fBTcl_GetSlave\fR(\fIinterp, slaveName\fR) -.sp -Tcl_Interp * -\fBTcl_GetMaster\fR(\fIinterp\fR) -.sp -int -\fBTcl_GetInterpPath\fR(\fIaskingInterp, slaveInterp\fR) -.sp -int -\fBTcl_CreateAlias\fR(\fIslaveInterp, slaveCmd, targetInterp, targetCmd, - argc, argv\fR) -.sp -int -\fBTcl_CreateAliasObj\fR(\fIslaveInterp, slaveCmd, targetInterp, targetCmd, - objc, objv\fR) -.sp -int -\fBTcl_GetAlias\fR(\fIinterp, slaveCmd, targetInterpPtr, targetCmdPtr, - argcPtr, argvPtr\fR) -.sp -int -\fBTcl_GetAliasObj\fR(\fIinterp, slaveCmd, targetInterpPtr, targetCmdPtr, - objcPtr, objvPtr\fR) -.sp -int -\fBTcl_ExposeCommand\fR(\fIinterp, hiddenCmdName, cmdName\fR) -.sp -int -\fBTcl_HideCommand\fR(\fIinterp, cmdName, hiddenCmdName\fR) -.SH ARGUMENTS -.AS "const char *const" **targetInterpPtr out -.AP Tcl_Interp *interp in -Interpreter in which to execute the specified command. -.AP "const char" *slaveName in -Name of slave interpreter to create or manipulate. -.AP int isSafe in -If non-zero, a -.QW safe -slave that is suitable for running untrusted code -is created, otherwise a trusted slave is created. -.AP Tcl_Interp *slaveInterp in -Interpreter to use for creating the source command for an alias (see -below). -.AP "const char" *slaveCmd in -Name of source command for alias. -.AP Tcl_Interp *targetInterp in -Interpreter that contains the target command for an alias. -.AP "const char" *targetCmd in -Name of target command for alias in \fItargetInterp\fR. -.AP int argc in -Count of additional arguments to pass to the alias command. -.AP "const char *const" *argv in -Vector of strings, the additional arguments to pass to the alias command. -This storage is owned by the caller. -.AP int objc in -Count of additional value arguments to pass to the aliased command. -.AP Tcl_Obj **objv in -Vector of Tcl_Obj structures, the additional value arguments to pass to -the aliased command. -This storage is owned by the caller. -.AP Tcl_Interp **targetInterpPtr in -Pointer to location to store the address of the interpreter where a target -command is defined for an alias. -.AP "const char" **targetCmdPtr out -Pointer to location to store the address of the name of the target command -for an alias. -.AP int *argcPtr out -Pointer to location to store count of additional arguments to be passed to -the alias. The location is in storage owned by the caller. -.AP "const char" ***argvPtr out -Pointer to location to store a vector of strings, the additional arguments -to pass to an alias. The location is in storage owned by the caller, the -vector of strings is owned by the called function. -.AP int *objcPtr out -Pointer to location to store count of additional value arguments to be -passed to the alias. The location is in storage owned by the caller. -.AP Tcl_Obj ***objvPtr out -Pointer to location to store a vector of Tcl_Obj structures, the additional -arguments to pass to an alias command. The location is in storage -owned by the caller, the vector of Tcl_Obj structures is owned by the -called function. -.AP "const char" *cmdName in -Name of an exposed command to hide or create. -.AP "const char" *hiddenCmdName in -Name under which a hidden command is stored and with which it can be -exposed or invoked. -.BE - -.SH DESCRIPTION -.PP -These procedures are intended for access to the multiple interpreter -facility from inside C programs. They enable managing multiple interpreters -in a hierarchical relationship, and the management of aliases, commands -that when invoked in one interpreter execute a command in another -interpreter. The return value for those procedures that return an \fBint\fR -is either \fBTCL_OK\fR or \fBTCL_ERROR\fR. If \fBTCL_ERROR\fR is returned -then the interpreter's result contains an error message. -.PP -\fBTcl_CreateSlave\fR creates a new interpreter as a slave of \fIinterp\fR. -It also creates a slave command named \fIslaveName\fR in \fIinterp\fR which -allows \fIinterp\fR to manipulate the new slave. -If \fIisSafe\fR is zero, the command creates a trusted slave in which Tcl -code has access to all the Tcl commands. -If it is \fB1\fR, the command creates a -.QW safe -slave in which Tcl code has access only to set of Tcl commands defined as -.QW "Safe Tcl" ; -see the manual entry for the Tcl \fBinterp\fR command for details. -If the creation of the new slave interpreter failed, \fBNULL\fR is returned. -.PP -\fBTcl_IsSafe\fR returns \fB1\fR if \fIinterp\fR is -.QW safe -(was created with the \fBTCL_SAFE_INTERPRETER\fR flag specified), -\fB0\fR otherwise. -.PP -\fBTcl_MakeSafe\fR marks \fIinterp\fR as -.QW safe , -so that future -calls to \fBTcl_IsSafe\fR will return 1. It also removes all known -potentially-unsafe core functionality (both commands and variables) -from \fIinterp\fR. However, it cannot know what parts of an extension -or application are safe and does not make any attempt to remove those -parts, so safety is not guaranteed after calling \fBTcl_MakeSafe\fR. -Callers will want to take care with their use of \fBTcl_MakeSafe\fR -to avoid false claims of safety. For many situations, \fBTcl_CreateSlave\fR -may be a better choice, since it creates interpreters in a known-safe state. -.PP -\fBTcl_GetSlave\fR returns a pointer to a slave interpreter of -\fIinterp\fR. The slave interpreter is identified by \fIslaveName\fR. -If no such slave interpreter exists, \fBNULL\fR is returned. -.PP -\fBTcl_GetMaster\fR returns a pointer to the master interpreter of -\fIinterp\fR. If \fIinterp\fR has no master (it is a -top-level interpreter) then \fBNULL\fR is returned. -.PP -\fBTcl_GetInterpPath\fR stores in the result of \fIaskingInterp\fR -the relative path between \fIaskingInterp\fR and \fIslaveInterp\fR; -\fIslaveInterp\fR must be a slave of \fIaskingInterp\fR. If the computation -of the relative path succeeds, \fBTCL_OK\fR is returned, else -\fBTCL_ERROR\fR is returned and an error message is stored as the -result of \fIaskingInterp\fR. -.PP -\fBTcl_CreateAlias\fR creates a command named \fIslaveCmd\fR in -\fIslaveInterp\fR that when invoked, will cause the command \fItargetCmd\fR -to be invoked in \fItargetInterp\fR. The arguments specified by the strings -contained in \fIargv\fR are always prepended to any arguments supplied in the -invocation of \fIslaveCmd\fR and passed to \fItargetCmd\fR. -This operation returns \fBTCL_OK\fR if it succeeds, or \fBTCL_ERROR\fR if -it fails; in that case, an error message is left in the value result -of \fIslaveInterp\fR. -Note that there are no restrictions on the ancestry relationship (as -created by \fBTcl_CreateSlave\fR) between \fIslaveInterp\fR and -\fItargetInterp\fR. Any two interpreters can be used, without any -restrictions on how they are related. -.PP -\fBTcl_CreateAliasObj\fR is similar to \fBTcl_CreateAlias\fR except -that it takes a vector of values to pass as additional arguments instead -of a vector of strings. -.PP -\fBTcl_GetAlias\fR returns information about an alias \fIaliasName\fR -in \fIinterp\fR. Any of the result fields can be \fBNULL\fR, in -which case the corresponding datum is not returned. If a result field is -non\-\fBNULL\fR, the address indicated is set to the corresponding datum. -For example, if \fItargetNamePtr\fR is non\-\fBNULL\fR it is set to a -pointer to the string containing the name of the target command. -.PP -\fBTcl_GetAliasObj\fR is similar to \fBTcl_GetAlias\fR except that it -returns a pointer to a vector of Tcl_Obj structures instead of a vector of -strings. -.PP -\fBTcl_ExposeCommand\fR moves the command named \fIhiddenCmdName\fR from -the set of hidden commands to the set of exposed commands, putting -it under the name -\fIcmdName\fR. -\fIHiddenCmdName\fR must be the name of an existing hidden -command, or the operation will return \fBTCL_ERROR\fR and -leave an error message as the result of \fIinterp\fR. -If an exposed command named \fIcmdName\fR already exists, -the operation returns \fBTCL_ERROR\fR and leaves an error message as -the result of \fIinterp\fR. -If the operation succeeds, it returns \fBTCL_OK\fR. -After executing this command, attempts to use \fIcmdName\fR in any -script evaluation mechanism will again succeed. -.PP -\fBTcl_HideCommand\fR moves the command named \fIcmdName\fR from the set of -exposed commands to the set of hidden commands, under the name -\fIhiddenCmdName\fR. -\fICmdName\fR must be the name of an existing exposed -command, or the operation will return \fBTCL_ERROR\fR and leave an error -message as the result of \fIinterp\fR. -Currently both \fIcmdName\fR and \fIhiddenCmdName\fR must not contain -namespace qualifiers, or the operation will return \fBTCL_ERROR\fR and -leave an error message as the result of \fIinterp\fR. -The \fICmdName\fR will be looked up in the global namespace, and not -relative to the current namespace, even if the current namespace is not the -global one. -If a hidden command whose name is \fIhiddenCmdName\fR already -exists, the operation also returns \fBTCL_ERROR\fR and an error -message is left as the result of \fIinterp\fR. -If the operation succeeds, it returns \fBTCL_OK\fR. -After executing this command, attempts to use \fIcmdName\fR in -any script evaluation mechanism will fail. -.PP -For a description of the Tcl interface to multiple interpreters, see -\fIinterp(n)\fR. -.SH "SEE ALSO" -interp - -.SH KEYWORDS -alias, command, exposed commands, hidden commands, interpreter, invoke, -master, slave diff --git a/generic/tcl.decls b/generic/tcl.decls index 7cd3fd2..6f35631 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -582,7 +582,7 @@ declare 162 { CONST84_RETURN char *Tcl_GetHostName(void) } declare 163 { - int Tcl_GetInterpPath(Tcl_Interp *askInterp, Tcl_Interp *slaveInterp) + int Tcl_GetInterpPath(Tcl_Interp *interp, Tcl_Interp *slaveInterp) } declare 164 { Tcl_Interp *Tcl_GetMaster(Tcl_Interp *interp) diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 037b6e5..e341731 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -503,7 +503,7 @@ EXTERN int Tcl_GetErrno(void); /* 162 */ EXTERN CONST84_RETURN char * Tcl_GetHostName(void); /* 163 */ -EXTERN int Tcl_GetInterpPath(Tcl_Interp *askInterp, +EXTERN int Tcl_GetInterpPath(Tcl_Interp *interp, Tcl_Interp *slaveInterp); /* 164 */ EXTERN Tcl_Interp * Tcl_GetMaster(Tcl_Interp *interp); @@ -2026,7 +2026,7 @@ typedef struct TclStubs { CONST84_RETURN char * (*tcl_GetCommandName) (Tcl_Interp *interp, Tcl_Command command); /* 160 */ int (*tcl_GetErrno) (void); /* 161 */ CONST84_RETURN char * (*tcl_GetHostName) (void); /* 162 */ - int (*tcl_GetInterpPath) (Tcl_Interp *askInterp, Tcl_Interp *slaveInterp); /* 163 */ + int (*tcl_GetInterpPath) (Tcl_Interp *interp, Tcl_Interp *slaveInterp); /* 163 */ Tcl_Interp * (*tcl_GetMaster) (Tcl_Interp *interp); /* 164 */ const char * (*tcl_GetNameOfExecutable) (void); /* 165 */ Tcl_Obj * (*tcl_GetObjResult) (Tcl_Interp *interp); /* 166 */ diff --git a/macosx/Tcl.xcode/project.pbxproj b/macosx/Tcl.xcode/project.pbxproj index 788aa8d..06c7fa0 100644 --- a/macosx/Tcl.xcode/project.pbxproj +++ b/macosx/Tcl.xcode/project.pbxproj @@ -263,7 +263,7 @@ F96D3E1F08F272A5004A47F5 /* CrtInterp.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CrtInterp.3; sourceTree = ""; }; F96D3E2008F272A5004A47F5 /* CrtMathFnc.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CrtMathFnc.3; sourceTree = ""; }; F96D3E2108F272A5004A47F5 /* CrtObjCmd.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CrtObjCmd.3; sourceTree = ""; }; - F96D3E2208F272A5004A47F5 /* CrtSlave.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CrtSlave.3; sourceTree = ""; }; + F96D3E2208F272A5004A47F5 /* CrtAlias.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CrtAlias.3; sourceTree = ""; }; F96D3E2308F272A5004A47F5 /* CrtTimerHdlr.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CrtTimerHdlr.3; sourceTree = ""; }; F96D3E2408F272A5004A47F5 /* CrtTrace.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CrtTrace.3; sourceTree = ""; }; F96D3E2508F272A5004A47F5 /* dde.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = dde.n; sourceTree = ""; }; @@ -1013,7 +1013,7 @@ F96D3E1F08F272A5004A47F5 /* CrtInterp.3 */, F96D3E2008F272A5004A47F5 /* CrtMathFnc.3 */, F96D3E2108F272A5004A47F5 /* CrtObjCmd.3 */, - F96D3E2208F272A5004A47F5 /* CrtSlave.3 */, + F96D3E2208F272A5004A47F5 /* CrtAlias.3 */, F96D3E2308F272A5004A47F5 /* CrtTimerHdlr.3 */, F96D3E2408F272A5004A47F5 /* CrtTrace.3 */, F96D3E2508F272A5004A47F5 /* dde.n */, diff --git a/macosx/Tcl.xcodeproj/project.pbxproj b/macosx/Tcl.xcodeproj/project.pbxproj index 4362739..a0d4f2a 100644 --- a/macosx/Tcl.xcodeproj/project.pbxproj +++ b/macosx/Tcl.xcodeproj/project.pbxproj @@ -263,7 +263,7 @@ F96D3E1F08F272A5004A47F5 /* CrtInterp.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CrtInterp.3; sourceTree = ""; }; F96D3E2008F272A5004A47F5 /* CrtMathFnc.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CrtMathFnc.3; sourceTree = ""; }; F96D3E2108F272A5004A47F5 /* CrtObjCmd.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CrtObjCmd.3; sourceTree = ""; }; - F96D3E2208F272A5004A47F5 /* CrtSlave.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CrtSlave.3; sourceTree = ""; }; + F96D3E2208F272A5004A47F5 /* CrtAlias.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CrtAlias.3; sourceTree = ""; }; F96D3E2308F272A5004A47F5 /* CrtTimerHdlr.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CrtTimerHdlr.3; sourceTree = ""; }; F96D3E2408F272A5004A47F5 /* CrtTrace.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CrtTrace.3; sourceTree = ""; }; F96D3E2508F272A5004A47F5 /* dde.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = dde.n; sourceTree = ""; }; @@ -1013,7 +1013,7 @@ F96D3E1F08F272A5004A47F5 /* CrtInterp.3 */, F96D3E2008F272A5004A47F5 /* CrtMathFnc.3 */, F96D3E2108F272A5004A47F5 /* CrtObjCmd.3 */, - F96D3E2208F272A5004A47F5 /* CrtSlave.3 */, + F96D3E2208F272A5004A47F5 /* CrtAlias.3 */, F96D3E2308F272A5004A47F5 /* CrtTimerHdlr.3 */, F96D3E2408F272A5004A47F5 /* CrtTrace.3 */, F96D3E2508F272A5004A47F5 /* dde.n */, diff --git a/win/tcl.dsp b/win/tcl.dsp index e8b1a33..4f35cb3 100644 --- a/win/tcl.dsp +++ b/win/tcl.dsp @@ -364,7 +364,7 @@ SOURCE=..\doc\CrtObjCmd.3 # End Source File # Begin Source File -SOURCE=..\doc\CrtSlave.3 +SOURCE=..\doc\CrtAlias.3 # End Source File # Begin Source File -- cgit v0.12 From c14dbae8ad115c63cccc32ca0fee7a5c355edbe5 Mon Sep 17 00:00:00 2001 From: kjnash Date: Wed, 15 Jul 2020 13:22:54 +0000 Subject: Bugfix in library/safe.tcl - when deleting a safe interpreter, delete its sub-interpreters cleanly; pass revised test safe-7.3 --- library/safe.tcl | 11 +++++++++++ tests/safe.test | 12 ++++++++++-- 2 files changed, 21 insertions(+), 2 deletions(-) diff --git a/library/safe.tcl b/library/safe.tcl index 30b045e..68d4b21 100644 --- a/library/safe.tcl +++ b/library/safe.tcl @@ -593,6 +593,17 @@ proc ::safe::interpDelete {slave} { namespace upvar ::safe S$slave state + # When an interpreter is deleted with [interp delete], any sub-interpreters + # are deleted automatically, but this leaves behind their data in the Safe + # Base. To clean up properly, we call safe::interpDelete recursively on each + # Safe Base sub-interpreter, so each one is deleted cleanly and not by + # the automatic mechanism built into [interp delete]. + foreach sub [interp slaves $slave] { + if {[info exists ::safe::S[list $slave $sub]]} { + ::safe::interpDelete [list $slave $sub] + } + } + # If the slave has a cleanup hook registered, call it. Check the # existance because we might be called to delete an interp which has # not been registered with us at all diff --git a/tests/safe.test b/tests/safe.test index 0f40c36..6b55ef1 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -365,10 +365,18 @@ test safe-7.2http {tests specific path and interpFind/AddToAccessPath, uses http [safe::interpDelete $i] } -match glob -result "{\$p(:0:)} {\$p(:*:)} 1 {can't find package http 1} {-accessPath {[list $tcl_library */dummy/unixlike/test/path]} -statics 0 -nested 1 -deleteHook {}} {}" test safe-7.3 {check that safe subinterpreters work} { + set g [interp slaves] + if {$g ne {}} { + append g { -- residue of an earlier test} + } + set h [info vars ::safe::S*] + if {$h ne {}} { + append h { -- residue of an earlier test} + } set i [safe::interpCreate] set j [safe::interpCreate [list $i x]] - list [interp eval $j {join {o k} ""}] [safe::interpDelete $i] [interp exists $j] -} {ok {} 0} + list $g $h [interp eval $j {join {o k} ""}] [safe::interpDelete $i] [interp exists $j] [info vars ::safe::S*] +} {{} {} ok {} 0 {}} test safe-7.4 {tests specific path and positive search} -setup { } -body { set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]] -- cgit v0.12 From 69fdd85b744c7f463d6731dff11db373df7e33f6 Mon Sep 17 00:00:00 2001 From: kjnash Date: Wed, 15 Jul 2020 17:03:47 +0000 Subject: Bugfix in library/safe.tcl - AliasGlob passes -join to glob inappropriately; pass new test safe-13.7a --- library/safe.tcl | 6 +++++- tests/safe.test | 34 ++++++++++++++++++++++++++++++---- 2 files changed, 35 insertions(+), 5 deletions(-) diff --git a/library/safe.tcl b/library/safe.tcl index 68d4b21..82a2780 100644 --- a/library/safe.tcl +++ b/library/safe.tcl @@ -769,11 +769,15 @@ proc ::safe::AliasGlob {slave args} { while {$at < [llength $args]} { switch -glob -- [set opt [lindex $args $at]] { - -nocomplain - -- - -join - -tails { + -nocomplain - -- - -tails { lappend cmd $opt set got($opt) 1 incr at } + -join { + set got($opt) 1 + incr at + } -types - -type { lappend cmd -types [lindex $args [incr at]] incr at diff --git a/tests/safe.test b/tests/safe.test index 6b55ef1..c250400 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -1354,6 +1354,15 @@ proc buildEnvironment {filename} { set testdir2 [makeDirectory deletemetoo $testdir] set testfile [makeFile {} $filename $testdir2] } +proc buildEnvironment2 {filename} { + upvar 1 testdir testdir testdir2 testdir2 testfile testfile + upvar 1 testdir3 testdir3 testfile2 testfile2 + set testdir [makeDirectory deletethisdir] + set testdir2 [makeDirectory deletemetoo $testdir] + set testfile [makeFile {} $filename $testdir2] + set testdir3 [makeDirectory deleteme $testdir] + set testfile2 [makeFile {} $filename $testdir3] +} #### New tests for Safe base glob, with patches @ Bug 2964715 test safe-13.1 {glob is restricted [Bug 2964715]} -setup { set i [safe::interpCreate] @@ -1425,7 +1434,7 @@ test safe-13.6 {as 13.4 but test silent failure when result is outside access_pa safe::interpDelete $i removeDirectory $testdir } -result {} -test safe-13.7 {mimic the glob call by tclPkgUnknown which gives a deliberate error in a safe interpreter [Bug 2964715]} -setup { +test safe-13.7 {mimic the glob call by tclPkgUnknown in a safe interpreter [Bug 2964715]} -setup { set i [safe::interpCreate] buildEnvironment pkgIndex.tcl } -body { @@ -1437,9 +1446,25 @@ test safe-13.7 {mimic the glob call by tclPkgUnknown which gives a deliberate er safe::interpDelete $i removeDirectory $testdir } -result {{EXPECTED/deletemetoo/pkgIndex.tcl}} -# Note the extra {} around the result above; that's *expected* because of the -# format of virtual path roots. -test safe-13.8 {mimic the glob call by tclPkgUnknown without the deliberate error that is specific to pkgIndex.tcl [Bug 2964715]} -setup { +# Note the extra {} around the result above; that's *expected* because the +# tokenized paths require delimitation in the list returned by glob; the +# braces remain after the token is replaced by EXPECTED. +test safe-13.7a {mimic the glob call by tclPkgUnknown in a safe interpreter with multiple subdirectories} -setup { + set i [safe::interpCreate] + buildEnvironment2 pkgIndex.tcl +} -body { + set safeTD [::safe::interpAddToAccessPath $i $testdir] + ::safe::interpAddToAccessPath $i $testdir2 + ::safe::interpAddToAccessPath $i $testdir3 + lsort [string map [list $safeTD EXPECTED] [$i eval [list \ + glob -directory $safeTD -join * pkgIndex.tcl]]] +} -cleanup { + safe::interpDelete $i + removeDirectory $testdir +} -result {EXPECTED/deleteme/pkgIndex.tcl EXPECTED/deletemetoo/pkgIndex.tcl} +# Cf safe-13.7 - this time there's no extra {} around the result; the list +# operation lsort removed it. +test safe-13.8 {mimic the glob call by tclPkgUnknown without the special treatment that is specific to pkgIndex.tcl [Bug 2964715]} -setup { set i [safe::interpCreate] buildEnvironment notIndex.tcl } -body { @@ -1477,6 +1502,7 @@ test safe-13.10 {as 13.8 but test silent failure when result is outside access_p removeDirectory $testdir } -result {} rename buildEnvironment {} +rename buildEnvironment2 {} #### Test for the module path test safe-14.1 {Check that module path is the same as in the master interpreter [Bug 2964715]} -setup { -- cgit v0.12 From 439f72dad506c9f5143db634365aab3375b8c532 Mon Sep 17 00:00:00 2001 From: sebres Date: Wed, 15 Jul 2020 20:06:07 +0000 Subject: closes [3c6e47363e]: missing de-duplication mechanism for nested TEBC starting from scratch (e. g. nested compiled blocks enclosed in parent cycle), so reset interp's result to avoid possible duplications of large objects by first commands like lappend, append, etc --- generic/tclExecute.c | 18 +++++++++++++++++- 1 file changed, 17 insertions(+), 1 deletion(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 76feb79..dd82f95 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -2214,6 +2214,22 @@ TEBCresume( if (!pc) { /* bytecode is starting from scratch */ pc = codePtr->codeStart; + + /* + * Reset the interp's result to avoid possible duplications of large + * objects [3c6e47363e], [781585], [804681], This can happen by start + * also in nested compiled blocks (enclosed in parent cycle). + * See else branch below for opposite handling by continuation/resume. + */ + + objPtr = iPtr->objResultPtr; + if (objPtr->refCount > 1) { + TclDecrRefCount(objPtr); + TclNewObj(objPtr); + Tcl_IncrRefCount(objPtr); + iPtr->objResultPtr = objPtr; + } + goto cleanup0; } else { /* resume from invocation */ @@ -2253,7 +2269,7 @@ TEBCresume( objc, cmdNameBuf), Tcl_GetObjResult(interp)); /* - * Reset the interp's result to avoid possible duplications of large + * Obtain and reset interp's result to avoid possible duplications of * objects [Bug 781585]. We do not call Tcl_ResetResult to avoid any * side effects caused by the resetting of errorInfo and errorCode * [Bug 804681], which are not needed here. We chose instead to -- cgit v0.12 From 79214905a2153e60fdf993173f37afcc2b2e80d8 Mon Sep 17 00:00:00 2001 From: kjnash Date: Wed, 15 Jul 2020 23:11:46 +0000 Subject: Bugfix tests/safe.test. Harden tests safe-9.20 to safe-9.24 against indeterminate order of glob matches. Audit use of glob and tcl::tm in modified tests for cases with multiple matches. Simplify test comparison patterns. --- library/safe.tcl | 5 +- tests/safe.test | 307 +++++++++++++++++++++++++++---------------------------- 2 files changed, 154 insertions(+), 158 deletions(-) diff --git a/library/safe.tcl b/library/safe.tcl index 82a2780..74aee87 100644 --- a/library/safe.tcl +++ b/library/safe.tcl @@ -406,8 +406,9 @@ proc ::safe::InterpSetConfig {slave access_path staticsok nestedok deletehook} { # 'platform::shell', which translate into # 'platform/shell-X.tm', i.e arbitrarily deep # subdirectories. - lappend morepaths {*}[glob -nocomplain -directory $dir -type d *] - foreach sub [glob -nocomplain -directory $dir -type d *] { + set next [glob -nocomplain -directory $dir -type d *] + lappend morepaths {*}$next + foreach sub $next { lappend slave_tm_roots [file normalize $sub] [dict get $slave_tm_roots $dir] set lenny [string length [dict get $slave_tm_roots $dir]] set relpath [string range [file normalize $sub] $lenny+1 end] diff --git a/tests/safe.test b/tests/safe.test index c250400..69da9d2 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -25,8 +25,24 @@ set saveAutoPath $::auto_path set ::auto_path [info library] set TestsDir [file normalize [file dirname [info script]]] +set PathMapp [list $tcl_library TCLLIB $TestsDir TESTSDIR] -# Force actual loading of the safe package because we use un exported (and +proc mapList {map listIn} { + set listOut {} + foreach element $listIn { + lappend listOut [string map $map $element] + } + return $listOut +} +proc mapAndSortList {map listIn} { + set listOut {} + foreach element $listIn { + lappend listOut [string map $map $element] + } + lsort $listOut +} + +# Force actual loading of the safe package because we use un-exported (and # thus un-autoindexed) APIs in this test result arguments: catch {safe::interpConfigure} @@ -340,30 +356,32 @@ test safe-7.2 {tests specific path and interpFind/AddToAccessPath} -setup { set token2 [safe::interpAddToAccessPath $i "/dummy/unixlike/test/path"] # should add as p* (not p2 if master has a module path) set token3 [safe::interpAddToAccessPath $i [file join $TestsDir auto0]] + set confA [safe::interpConfigure $i] + set mappA [mapList $PathMapp [dict get $confA -accessPath]] # an error shall occur (SafeTestPackage1 is not anymore in the secure 0-level # provided deep path) - list $token1 $token2 $token3 \ - [catch {interp eval $i {package require SafeTestPackage1}} msg] $msg \ - [safe::interpConfigure $i]\ - [safe::interpDelete $i] + list $token1 $token2 $token3 -- \ + [catch {interp eval $i {package require SafeTestPackage1}} msg] $msg -- \ + $mappA -- [safe::interpDelete $i] } -cleanup { -} -match glob -result "{\$p(:0:)} {\$p(:*:)} {\$p(:*:)} 1\ - {can't find package SafeTestPackage1}\ - {-accessPath {[list $tcl_library */dummy/unixlike/test/path $TestsDir/auto0]}\ - -statics 0 -nested 1 -deleteHook {}} {}" +} -match glob -result {{$p(:0:)} {$p(:*:)} {$p(:*:)} --\ + 1 {can't find package SafeTestPackage1} --\ + {TCLLIB */dummy/unixlike/test/path TESTSDIR/auto0} -- {}} test safe-7.2http {tests specific path and interpFind/AddToAccessPath, uses http1.0} -body { set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]] # should not add anything (p0) set token1 [safe::interpAddToAccessPath $i [info library]] # should add as p1 set token2 [safe::interpAddToAccessPath $i "/dummy/unixlike/test/path"] + set confA [safe::interpConfigure $i] + set mappA [mapList $PathMapp [dict get $confA -accessPath]] # an error shall occur (http is not anymore in the secure 0-level # provided deep path) - list $token1 $token2 \ - [catch {interp eval $i {package require http 1}} msg] $msg \ - [safe::interpConfigure $i]\ - [safe::interpDelete $i] -} -match glob -result "{\$p(:0:)} {\$p(:*:)} 1 {can't find package http 1} {-accessPath {[list $tcl_library */dummy/unixlike/test/path]} -statics 0 -nested 1 -deleteHook {}} {}" + list $token1 $token2 -- \ + [catch {interp eval $i {package require http 1}} msg] $msg -- \ + $mappA -- [safe::interpDelete $i] +} -match glob -result {{$p(:0:)} {$p(:*:)} -- 1 {can't find package http 1} --\ + {TCLLIB */dummy/unixlike/test/path} -- {}} test safe-7.3 {check that safe subinterpreters work} { set g [interp slaves] if {$g ne {}} { @@ -384,29 +402,30 @@ test safe-7.4 {tests specific path and positive search} -setup { set token1 [safe::interpAddToAccessPath $i [info library]] # should add as p* (not p1 if master has a module path) set token2 [safe::interpAddToAccessPath $i [file join $TestsDir auto0 auto1]] + set confA [safe::interpConfigure $i] + set mappA [mapList $PathMapp [dict get $confA -accessPath]] # this time, unlike test safe-7.2, SafeTestPackage1 should be found - list $token1 $token2 \ - [catch {interp eval $i {package require SafeTestPackage1}} msg] $msg \ - [safe::interpConfigure $i]\ - [safe::interpDelete $i] + list $token1 $token2 -- \ + [catch {interp eval $i {package require SafeTestPackage1}} msg] $msg -- \ + $mappA -- [safe::interpDelete $i] # Note that the glob match elides directories (those from the module path) # other than the first and last in the access path. } -cleanup { -} -match glob -result "{\$p(:0:)} {\$p(:*:)} 0 1.2.3\ - {-accessPath {[list $tcl_library * $TestsDir/auto0/auto1]}\ - -statics 0 -nested 1 -deleteHook {}} {}" +} -match glob -result {{$p(:0:)} {$p(:*:)} -- 0 1.2.3 --\ + {TCLLIB * TESTSDIR/auto0/auto1} -- {}} test safe-7.4http {tests specific path and positive search, uses http1.0} -body { set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]] # should not add anything (p0) set token1 [safe::interpAddToAccessPath $i [info library]] # should add as p1 set token2 [safe::interpAddToAccessPath $i [file join [info library] http1.0]] + set confA [safe::interpConfigure $i] + set mappA [mapList $PathMapp [dict get $confA -accessPath]] # this time, unlike test safe-7.2, http should be found - list $token1 $token2 \ - [catch {interp eval $i {package require http 1}} msg] $msg \ - [safe::interpConfigure $i]\ - [safe::interpDelete $i] -} -match glob -result "{\$p(:0:)} {\$p(:*:)} 0 1.0 {-accessPath {[list $tcl_library *$tcl_library/http1.0]} -statics 0 -nested 1 -deleteHook {}} {}" + list $token1 $token2 -- \ + [catch {interp eval $i {package require http 1}} msg] $msg -- \ + $mappA -- [safe::interpDelete $i] +} -match glob -result {{$p(:0:)} {$p(:*:)} -- 0 1.0 -- {TCLLIB *TCLLIB/http1.0} -- {}} # test source control on file name set i "a" @@ -632,9 +651,9 @@ test safe-9.8 {interpConfigure change the access path; tclIndex commands unaffec set i [safe::interpCreate -accessPath [list $tcl_library \ [file join $TestsDir auto0 auto1] \ [file join $TestsDir auto0 auto2]]] - # Inspect. set confA [safe::interpConfigure $i] + set mappA [mapList $PathMapp [dict get $confA -accessPath]] set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]] set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]] @@ -653,6 +672,7 @@ test safe-9.8 {interpConfigure change the access path; tclIndex commands unaffec # Inspect. set confB [safe::interpConfigure $i] + set mappB [mapList $PathMapp [dict get $confB -accessPath]] set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]] set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]] @@ -660,23 +680,21 @@ test safe-9.8 {interpConfigure change the access path; tclIndex commands unaffec set code3 [catch {interp eval $i {report1}} msg3] set code4 [catch {interp eval $i {report2}} msg4] - list $path1 $path2 $path3 $path4 $code3 $msg3 $code4 $msg4 $confA $confB + list $path1 $path2 -- $path3 $path4 -- $code3 $msg3 $code4 $msg4 -- $mappA -- $mappB } -cleanup { safe::interpDelete $i -} -match glob -result "{\$p(:1:)} {\$p(:2:)} {\$p(:2:)} {\$p(:1:)} 0 ok1 0 ok2\ - {-accessPath {[list $tcl_library $TestsDir/auto0/auto1 $TestsDir/auto0/auto2]*}\ - -statics 1 -nested 0 -deleteHook {}}\ - {-accessPath {[list $tcl_library $TestsDir/auto0/auto2 $TestsDir/auto0/auto1]*}\ - -statics 1 -nested 0 -deleteHook {}}" +} -match glob -result {{$p(:1:)} {$p(:2:)} -- {$p(:2:)} {$p(:1:)} -- 0 ok1 0 ok2 --\ + {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} --\ + {TCLLIB TESTSDIR/auto0/auto2 TESTSDIR/auto0/auto1*}} test safe-9.9 {interpConfigure change the access path; tclIndex commands unaffected by token rearrangement (actual test of doreset)} -setup { } -body { set i [safe::interpCreate -accessPath [list $tcl_library \ [file join $TestsDir auto0 auto1] \ [file join $TestsDir auto0 auto2]]] - # Inspect. set confA [safe::interpConfigure $i] + set mappA [mapList $PathMapp [dict get $confA -accessPath]] set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]] set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]] @@ -693,6 +711,7 @@ test safe-9.9 {interpConfigure change the access path; tclIndex commands unaffec # Inspect. set confB [safe::interpConfigure $i] + set mappB [mapList $PathMapp [dict get $confB -accessPath]] set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]] set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]] @@ -700,14 +719,13 @@ test safe-9.9 {interpConfigure change the access path; tclIndex commands unaffec set code3 [catch {interp eval $i {report1}} msg3] set code4 [catch {interp eval $i {report2}} msg4] - list $path1 $path2 $path3 $path4 $code3 $msg3 $code4 $msg4 $confA $confB + list $path1 $path2 -- $path3 $path4 -- $code3 $msg3 $code4 $msg4 -- $mappA -- $mappB } -cleanup { safe::interpDelete $i -} -match glob -result "{\$p(:1:)} {\$p(:2:)} {\$p(:2:)} {\$p(:1:)} 0 ok1 0 ok2\ - {-accessPath {[list $tcl_library $TestsDir/auto0/auto1 $TestsDir/auto0/auto2]*}\ - -statics 1 -nested 0 -deleteHook {}}\ - {-accessPath {[list $tcl_library $TestsDir/auto0/auto2 $TestsDir/auto0/auto1]*}\ - -statics 1 -nested 0 -deleteHook {}}" +} -match glob -result {{$p(:1:)} {$p(:2:)} -- {$p(:2:)} {$p(:1:)} --\ + 0 ok1 0 ok2 --\ + {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} --\ + {TCLLIB TESTSDIR/auto0/auto2 TESTSDIR/auto0/auto1*}} test safe-9.10 {interpConfigure change the access path; pkgIndex.tcl packages unaffected by token rearrangement} -setup { } -body { @@ -719,6 +737,7 @@ test safe-9.10 {interpConfigure change the access path; pkgIndex.tcl packages un # Inspect. set confA [safe::interpConfigure $i] + set mappA [mapList $PathMapp [dict get $confA -accessPath]] set path0 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0]] set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]] set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]] @@ -736,6 +755,7 @@ test safe-9.10 {interpConfigure change the access path; pkgIndex.tcl packages un # Inspect. set confB [safe::interpConfigure $i] + set mappB [mapList $PathMapp [dict get $confB -accessPath]] set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]] set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]] @@ -745,17 +765,14 @@ test safe-9.10 {interpConfigure change the access path; pkgIndex.tcl packages un set code5 [catch {interp eval $i {HeresPackage1}} msg5 opts5] set code6 [catch {interp eval $i {HeresPackage2}} msg6 opts6] - list $path1 $path2 $path3 $path4 $code3 $msg3 $code4 $msg4 $confA $confB \ - $code5 $msg5 $code6 $msg6 - + list $path1 $path2 -- $path3 $path4 -- $code3 $msg3 $code4 $msg4 -- \ + $mappA -- $mappB -- $code5 $msg5 $code6 $msg6 } -cleanup { safe::interpDelete $i -} -match glob -result "{\$p(:2:)} {\$p(:3:)} {\$p(:3:)} {\$p(:2:)} 0 1.2.3 0 2.3.4\ - {-accessPath {[list $tcl_library $TestsDir/auto0 $TestsDir/auto0/auto1 $TestsDir/auto0/auto2]*}\ - -statics 1 -nested 0 -deleteHook {}}\ - {-accessPath {[list $tcl_library $TestsDir/auto0 $TestsDir/auto0/auto2 $TestsDir/auto0/auto1]*}\ - -statics 1 -nested 0 -deleteHook {}}\ - 0 OK1 0 OK2" +} -match glob -result {{$p(:2:)} {$p(:3:)} -- {$p(:3:)} {$p(:2:)} -- 0 1.2.3 0 2.3.4 --\ + {TCLLIB TESTSDIR/auto0 TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} --\ + {TCLLIB TESTSDIR/auto0 TESTSDIR/auto0/auto2 TESTSDIR/auto0/auto1*} --\ + 0 OK1 0 OK2} test safe-9.11 {interpConfigure change the access path; pkgIndex.tcl packages unaffected by token rearrangement, 9.10 without path auto0} -setup { } -body { @@ -765,6 +782,7 @@ test safe-9.11 {interpConfigure change the access path; pkgIndex.tcl packages un # Inspect. set confA [safe::interpConfigure $i] + set mappA [mapList $PathMapp [dict get $confA -accessPath]] set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]] set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]] @@ -778,6 +796,7 @@ test safe-9.11 {interpConfigure change the access path; pkgIndex.tcl packages un # Inspect. set confB [safe::interpConfigure $i] + set mappB [mapList $PathMapp [dict get $confB -accessPath]] set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]] set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]] @@ -787,25 +806,23 @@ test safe-9.11 {interpConfigure change the access path; pkgIndex.tcl packages un set code5 [catch {interp eval $i {HeresPackage1}} msg5 opts5] set code6 [catch {interp eval $i {HeresPackage2}} msg6 opts6] - list $path1 $path2 $path3 $path4 $code3 $msg3 $code4 $msg4 $confA $confB \ + list $path1 $path2 -- $path3 $path4 -- $code3 $msg3 $code4 $msg4 -- $mappA -- $mappB -- \ $code5 $msg5 $code6 $msg6 } -cleanup { safe::interpDelete $i -} -match glob -result "{\$p(:1:)} {\$p(:2:)} {\$p(:2:)} {\$p(:1:)} 0 1.2.3 0 2.3.4\ - {-accessPath {[list $tcl_library $TestsDir/auto0/auto1 $TestsDir/auto0/auto2]*}\ - -statics 1 -nested 0 -deleteHook {}}\ - {-accessPath {[list $tcl_library $TestsDir/auto0/auto2 $TestsDir/auto0/auto1]*}\ - -statics 1 -nested 0 -deleteHook {}}\ - 0 OK1 0 OK2" - +} -match glob -result {{$p(:1:)} {$p(:2:)} -- {$p(:2:)} {$p(:1:)} --\ + 0 1.2.3 0 2.3.4 --\ + {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} --\ + {TCLLIB TESTSDIR/auto0/auto2 TESTSDIR/auto0/auto1*} --\ + 0 OK1 0 OK2} test safe-9.12 {interpConfigure change the access path; pkgIndex.tcl packages fail if directory de-listed} -setup { } -body { set i [safe::interpCreate -accessPath [list $tcl_library \ [file join $TestsDir auto0 auto1] \ [file join $TestsDir auto0 auto2]]] - # Inspect. set confA [safe::interpConfigure $i] + set mappA [mapList $PathMapp [dict get $confA -accessPath]] set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]] set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]] @@ -817,6 +834,7 @@ test safe-9.12 {interpConfigure change the access path; pkgIndex.tcl packages fa # Inspect. set confB [safe::interpConfigure $i] + set mappB [mapList $PathMapp [dict get $confB -accessPath]] set code4 [catch {::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]} path4] set code5 [catch {::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]} path5] @@ -824,15 +842,12 @@ test safe-9.12 {interpConfigure change the access path; pkgIndex.tcl packages fa set code3 [catch {interp eval $i {package require SafeTestPackage1}} msg3] set code6 [catch {interp eval $i {package require SafeTestPackage2}} msg6] - list $path1 $path2 $code4 $path4 $code5 $path5 $code3 $msg3 $code6 $msg6 $confA $confB + list $path1 $path2 -- $code4 $path4 -- $code5 $path5 -- $code3 $code6 -- $mappA -- $mappB } -cleanup { safe::interpDelete $i -} -match glob -result "{\$p(:1:)} {\$p(:2:)} 1 {* not found in access path}\ - 1 {* not found in access path} 1 {*} 1 {*}\ - {-accessPath {[list $tcl_library $TestsDir/auto0/auto1 $TestsDir/auto0/auto2]*}\ - -statics 1 -nested 0 -deleteHook {}}\ - {-accessPath {[list $tcl_library]*} -statics 1 -nested 0 -deleteHook {}}" - +} -match glob -result {{$p(:1:)} {$p(:2:)} -- 1 {* not found in access path} --\ + 1 {* not found in access path} -- 1 1 --\ + {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} -- {TCLLIB*}} test safe-9.20 {check module loading} -setup { set oldTm [tcl::tm::path list] foreach path $oldTm { @@ -844,6 +859,7 @@ test safe-9.20 {check module loading} -setup { # Inspect. set confA [safe::interpConfigure $i] + set sortA [mapAndSortList $PathMapp [dict get $confA -accessPath]] set modsA [interp eval $i {tcl::tm::path list}] set path0 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]] set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]] @@ -857,22 +873,27 @@ test safe-9.20 {check module loading} -setup { set out1 [interp eval $i {mod1::test1::try1}] set out2 [interp eval $i {mod2::test2::try2}] - list $path0 $path1 $path2 -- $modsA -- \ - $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $confA -- $out0 $out1 $out2 + list [lsort [list $path0 $path1 $path2]] -- $modsA -- \ + $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $sortA -- $out0 $out1 $out2 } -cleanup { tcl::tm::path remove [file join $TestsDir auto0 modules] foreach path [lreverse $oldTm] { tcl::tm::path add $path } safe::interpDelete $i -} -match glob -result "{\$p(:1:)} {\$p(:2:)} {\$p(:3:)} -- {{\$p(:1:)}} --\ +} -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} --\ 0 0.5 0 1.0 0 2.0 --\ - {-accessPath {[list $tcl_library $TestsDir/auto0/modules \ - $TestsDir/auto0/modules/mod1 \ - $TestsDir/auto0/modules/mod2]*}\ - -statics 1 -nested 0 -deleteHook {}} --\ - res0 res1 res2" - + {TCLLIB TESTSDIR/auto0/modules TESTSDIR/auto0/modules/mod1\ + TESTSDIR/auto0/modules/mod2} -- res0 res1 res2} +# - The command safe::InterpSetConfig adds the master's [tcl::tm::list] in +# tokenized form to the slave's access path, and then adds all the +# descendants, discovered recursively by using glob. +# - The order of the directories in the list returned by glob is system-dependent, +# and therefore this is true also for (a) the order of token assignment to +# descendants of the [tcl::tm::list] roots; and (b) the order of those same +# directories in the access path. Both those things must be sorted before +# comparing with expected results. The test is therefore not totally strict, +# but will notice missing or surplus directories. test safe-9.21 {interpConfigure change the access path; check module loading; stale data case 1} -setup { set oldTm [tcl::tm::path list] foreach path $oldTm { @@ -884,6 +905,7 @@ test safe-9.21 {interpConfigure change the access path; check module loading; st # Inspect. set confA [safe::interpConfigure $i] + set sortA [mapAndSortList $PathMapp [dict get $confA -accessPath]] set modsA [interp eval $i {tcl::tm::path list}] set path0 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]] set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]] @@ -897,6 +919,7 @@ test safe-9.21 {interpConfigure change the access path; check module loading; st # Inspect. set confB [safe::interpConfigure $i] + set sortB [mapAndSortList $PathMapp [dict get $confB -accessPath]] set modsB [interp eval $i {tcl::tm::path list}] set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]] set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]] @@ -915,8 +938,8 @@ test safe-9.21 {interpConfigure change the access path; check module loading; st set out1 [interp eval $i {mod1::test1::try1}] set out2 [interp eval $i {mod2::test2::try2}] - list $path0 $path1 $path2 -- $modsA -- $path3 $path4 $path5 -- $modsB -- \ - $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $confA -- $confB -- \ + list [lsort [list $path0 $path1 $path2]] -- $modsA -- [lsort [list $path3 $path4 $path5]] -- $modsB -- \ + $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $sortA -- $sortB -- \ $out0 $out1 $out2 } -cleanup { tcl::tm::path remove [file join $TestsDir auto0 modules] @@ -924,23 +947,15 @@ test safe-9.21 {interpConfigure change the access path; check module loading; st tcl::tm::path add $path } safe::interpDelete $i -} -match glob -result "{\$p(:1:)} {\$p(:2:)} {\$p(:3:)} -- {{\$p(:1:)}} --\ - {\$p(:3:)} {\$p(:4:)} {\$p(:5:)} -- {{\$p(:3:)}} --\ +} -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} --\ + {{$p(:3:)} {$p(:4:)} {$p(:5:)}} -- {{$p(:3:)}} --\ 0 0.5 0 1.0 0 2.0 --\ - {-accessPath {[list $tcl_library \ - $TestsDir/auto0/modules \ - $TestsDir/auto0/modules/mod1 \ - $TestsDir/auto0/modules/mod2]}\ - -statics 1 -nested 0 -deleteHook {}} --\ - {-accessPath {[list $tcl_library \ - $TestsDir/auto0/auto1 \ - $TestsDir/auto0/auto2 \ - $TestsDir/auto0/modules \ - $TestsDir/auto0/modules/mod1 \ - $TestsDir/auto0/modules/mod2]}\ - -statics 1 -nested 0 -deleteHook {}} --\ - res0 res1 res2" - + {TCLLIB TESTSDIR/auto0/modules TESTSDIR/auto0/modules/mod1\ + TESTSDIR/auto0/modules/mod2} --\ + {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2 TESTSDIR/auto0/modules\ + TESTSDIR/auto0/modules/mod1 TESTSDIR/auto0/modules/mod2} --\ + res0 res1 res2} +# See comments on lsort after test safe-9.20. test safe-9.22 {interpConfigure change the access path; check module loading; stale data case 0} -setup { set oldTm [tcl::tm::path list] foreach path $oldTm { @@ -952,6 +967,7 @@ test safe-9.22 {interpConfigure change the access path; check module loading; st # Inspect. set confA [safe::interpConfigure $i] + set sortA [mapAndSortList $PathMapp [dict get $confA -accessPath]] set modsA [interp eval $i {tcl::tm::path list}] set path0 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]] set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]] @@ -965,6 +981,7 @@ test safe-9.22 {interpConfigure change the access path; check module loading; st # Inspect. set confB [safe::interpConfigure $i] + set sortB [mapAndSortList $PathMapp [dict get $confB -accessPath]] set modsB [interp eval $i {tcl::tm::path list}] set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]] set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]] @@ -978,8 +995,8 @@ test safe-9.22 {interpConfigure change the access path; check module loading; st set out1 [interp eval $i {mod1::test1::try1}] set out2 [interp eval $i {mod2::test2::try2}] - list $path0 $path1 $path2 -- $modsA -- $path3 $path4 $path5 -- $modsB -- \ - $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $confA -- $confB -- \ + list [lsort [list $path0 $path1 $path2]] -- $modsA -- [lsort [list $path3 $path4 $path5]] -- $modsB -- \ + $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $sortA -- $sortB -- \ $out0 $out1 $out2 } -cleanup { tcl::tm::path remove [file join $TestsDir auto0 modules] @@ -987,23 +1004,15 @@ test safe-9.22 {interpConfigure change the access path; check module loading; st tcl::tm::path add $path } safe::interpDelete $i -} -match glob -result "{\$p(:1:)} {\$p(:2:)} {\$p(:3:)} -- {{\$p(:1:)}} --\ - {\$p(:3:)} {\$p(:4:)} {\$p(:5:)} -- {{\$p(:3:)}} --\ +} -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} --\ + {{$p(:3:)} {$p(:4:)} {$p(:5:)}} -- {{$p(:3:)}} --\ 0 0.5 0 1.0 0 2.0 --\ - {-accessPath {[list $tcl_library \ - $TestsDir/auto0/modules \ - $TestsDir/auto0/modules/mod1 \ - $TestsDir/auto0/modules/mod2]}\ - -statics 1 -nested 0 -deleteHook {}} --\ - {-accessPath {[list $tcl_library \ - $TestsDir/auto0/auto1 \ - $TestsDir/auto0/auto2 \ - $TestsDir/auto0/modules \ - $TestsDir/auto0/modules/mod1 \ - $TestsDir/auto0/modules/mod2]}\ - -statics 1 -nested 0 -deleteHook {}} --\ - res0 res1 res2" - + {TCLLIB TESTSDIR/auto0/modules TESTSDIR/auto0/modules/mod1\ + TESTSDIR/auto0/modules/mod2} --\ + {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2 TESTSDIR/auto0/modules\ + TESTSDIR/auto0/modules/mod1 TESTSDIR/auto0/modules/mod2} --\ + res0 res1 res2} +# See comments on lsort after test safe-9.20. test safe-9.23 {interpConfigure change the access path; check module loading; stale data case 3} -setup { set oldTm [tcl::tm::path list] foreach path $oldTm { @@ -1015,6 +1024,7 @@ test safe-9.23 {interpConfigure change the access path; check module loading; st # Inspect. set confA [safe::interpConfigure $i] + set sortA [mapAndSortList $PathMapp [dict get $confA -accessPath]] set modsA [interp eval $i {tcl::tm::path list}] set path0 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]] set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]] @@ -1033,6 +1043,7 @@ test safe-9.23 {interpConfigure change the access path; check module loading; st # Inspect. set confB [safe::interpConfigure $i] + set sortB [mapAndSortList $PathMapp [dict get $confB -accessPath]] set modsB [interp eval $i {tcl::tm::path list}] set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]] set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]] @@ -1051,8 +1062,8 @@ test safe-9.23 {interpConfigure change the access path; check module loading; st set out1 [interp eval $i {mod1::test1::try1}] set out2 [interp eval $i {mod2::test2::try2}] - list $path0 $path1 $path2 -- $modsA -- $path3 $path4 $path5 -- $modsB -- \ - $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $confA -- $confB -- \ + list [lsort [list $path0 $path1 $path2]] -- $modsA -- [lsort [list $path3 $path4 $path5]] -- $modsB -- \ + $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $sortA -- $sortB -- \ $out0 $out1 $out2 } -cleanup { @@ -1061,23 +1072,15 @@ test safe-9.23 {interpConfigure change the access path; check module loading; st tcl::tm::path add $path } safe::interpDelete $i -} -match glob -result "{\$p(:1:)} {\$p(:2:)} {\$p(:3:)} -- {{\$p(:1:)}} --\ - {\$p(:3:)} {\$p(:4:)} {\$p(:5:)} -- {{\$p(:3:)}} --\ +} -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} --\ + {{$p(:3:)} {$p(:4:)} {$p(:5:)}} -- {{$p(:3:)}} --\ 0 0.5 0 1.0 0 2.0 --\ - {-accessPath {[list $tcl_library \ - $TestsDir/auto0/modules \ - $TestsDir/auto0/modules/mod1 \ - $TestsDir/auto0/modules/mod2]}\ - -statics 1 -nested 0 -deleteHook {}} --\ - {-accessPath {[list $tcl_library \ - $TestsDir/auto0/auto1 \ - $TestsDir/auto0/auto2 \ - $TestsDir/auto0/modules \ - $TestsDir/auto0/modules/mod1 \ - $TestsDir/auto0/modules/mod2]}\ - -statics 1 -nested 0 -deleteHook {}} --\ - res0 res1 res2" - + {TCLLIB TESTSDIR/auto0/modules TESTSDIR/auto0/modules/mod1\ + TESTSDIR/auto0/modules/mod2} --\ + {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2 TESTSDIR/auto0/modules\ + TESTSDIR/auto0/modules/mod1 TESTSDIR/auto0/modules/mod2} --\ + res0 res1 res2} +# See comments on lsort after test safe-9.20. test safe-9.24 {interpConfigure change the access path; check module loading; stale data case 2 (worst case)} -setup { set oldTm [tcl::tm::path list] foreach path $oldTm { @@ -1089,6 +1092,7 @@ test safe-9.24 {interpConfigure change the access path; check module loading; st # Inspect. set confA [safe::interpConfigure $i] + set sortA [mapAndSortList $PathMapp [dict get $confA -accessPath]] set modsA [interp eval $i {tcl::tm::path list}] set path0 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]] set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]] @@ -1107,6 +1111,7 @@ test safe-9.24 {interpConfigure change the access path; check module loading; st # Inspect. set confB [safe::interpConfigure $i] + set sortB [mapAndSortList $PathMapp [dict get $confB -accessPath]] set modsB [interp eval $i {tcl::tm::path list}] set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]] set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]] @@ -1120,8 +1125,8 @@ test safe-9.24 {interpConfigure change the access path; check module loading; st set out1 [interp eval $i {mod1::test1::try1}] set out2 [interp eval $i {mod2::test2::try2}] - list $path0 $path1 $path2 -- $modsA -- $path3 $path4 $path5 -- $modsB -- \ - $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $confA -- $confB -- \ + list [lsort [list $path0 $path1 $path2]] -- $modsA -- [lsort [list $path3 $path4 $path5]] -- $modsB -- \ + $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $sortA -- $sortB -- \ $out0 $out1 $out2 } -cleanup { tcl::tm::path remove [file join $TestsDir auto0 modules] @@ -1129,23 +1134,15 @@ test safe-9.24 {interpConfigure change the access path; check module loading; st tcl::tm::path add $path } safe::interpDelete $i -} -match glob -result "{\$p(:1:)} {\$p(:2:)} {\$p(:3:)} -- {{\$p(:1:)}} --\ - {\$p(:3:)} {\$p(:4:)} {\$p(:5:)} -- {{\$p(:3:)}} --\ +} -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} --\ + {{$p(:3:)} {$p(:4:)} {$p(:5:)}} -- {{$p(:3:)}} --\ 0 0.5 0 1.0 0 2.0 --\ - {-accessPath {[list $tcl_library \ - $TestsDir/auto0/modules \ - $TestsDir/auto0/modules/mod1 \ - $TestsDir/auto0/modules/mod2]}\ - -statics 1 -nested 0 -deleteHook {}} --\ - {-accessPath {[list $tcl_library \ - $TestsDir/auto0/auto1 \ - $TestsDir/auto0/auto2 \ - $TestsDir/auto0/modules \ - $TestsDir/auto0/modules/mod1 \ - $TestsDir/auto0/modules/mod2]}\ - -statics 1 -nested 0 -deleteHook {}} --\ - res0 res1 res2" - + {TCLLIB TESTSDIR/auto0/modules TESTSDIR/auto0/modules/mod1\ + TESTSDIR/auto0/modules/mod2} --\ + {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2 TESTSDIR/auto0/modules\ + TESTSDIR/auto0/modules/mod1 TESTSDIR/auto0/modules/mod2} --\ + res0 res1 res2} +# See comments on lsort after test safe-9.20. catch {teststaticpkg Safepkg1 0 0} test safe-10.1 {testing statics loading} -constraints TcltestPackage -setup { @@ -1440,15 +1437,12 @@ test safe-13.7 {mimic the glob call by tclPkgUnknown in a safe interpreter [Bug } -body { set safeTD [::safe::interpAddToAccessPath $i $testdir] ::safe::interpAddToAccessPath $i $testdir2 - string map [list $safeTD EXPECTED] [$i eval [list \ + mapList [list $safeTD EXPECTED] [$i eval [list \ glob -directory $safeTD -join * pkgIndex.tcl]] } -cleanup { safe::interpDelete $i removeDirectory $testdir -} -result {{EXPECTED/deletemetoo/pkgIndex.tcl}} -# Note the extra {} around the result above; that's *expected* because the -# tokenized paths require delimitation in the list returned by glob; the -# braces remain after the token is replaced by EXPECTED. +} -result {EXPECTED/deletemetoo/pkgIndex.tcl} test safe-13.7a {mimic the glob call by tclPkgUnknown in a safe interpreter with multiple subdirectories} -setup { set i [safe::interpCreate] buildEnvironment2 pkgIndex.tcl @@ -1456,14 +1450,12 @@ test safe-13.7a {mimic the glob call by tclPkgUnknown in a safe interpreter with set safeTD [::safe::interpAddToAccessPath $i $testdir] ::safe::interpAddToAccessPath $i $testdir2 ::safe::interpAddToAccessPath $i $testdir3 - lsort [string map [list $safeTD EXPECTED] [$i eval [list \ - glob -directory $safeTD -join * pkgIndex.tcl]]] + mapAndSortList [list $safeTD EXPECTED] [$i eval [list \ + glob -directory $safeTD -join * pkgIndex.tcl]] } -cleanup { safe::interpDelete $i removeDirectory $testdir } -result {EXPECTED/deleteme/pkgIndex.tcl EXPECTED/deletemetoo/pkgIndex.tcl} -# Cf safe-13.7 - this time there's no extra {} around the result; the list -# operation lsort removed it. test safe-13.8 {mimic the glob call by tclPkgUnknown without the special treatment that is specific to pkgIndex.tcl [Bug 2964715]} -setup { set i [safe::interpCreate] buildEnvironment notIndex.tcl @@ -1601,7 +1593,10 @@ test safe-16.4 {Bug 3529949: defang ~user in globs} -setup { } -result {} set ::auto_path $saveAutoPath -unset saveAutoPath TestsDir +unset saveAutoPath TestsDir PathMapp +rename mapList {} +rename mapAndSortList {} + # cleanup ::tcltest::cleanupTests return -- cgit v0.12 From 8bd505ac8349a223aa3abad60887b222c52eb0ec Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 16 Jul 2020 13:42:57 +0000 Subject: Fix [5bbd044812]: Fix index underflow. --- generic/tclFileName.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/generic/tclFileName.c b/generic/tclFileName.c index 8fb9f4d..f7de10c 100644 --- a/generic/tclFileName.c +++ b/generic/tclFileName.c @@ -2448,7 +2448,7 @@ DoGlob( int len; const char *joined = Tcl_GetStringFromObj(joinedPtr,&len); - if (strchr(separators, joined[len-1]) == NULL) { + if ((len > 0) && (strchr(separators, joined[len-1]) == NULL)) { Tcl_AppendToObj(joinedPtr, "/", 1); } } @@ -2485,7 +2485,7 @@ DoGlob( int len; const char *joined = Tcl_GetStringFromObj(joinedPtr,&len); - if (strchr(separators, joined[len-1]) == NULL) { + if ((len > 0) && (strchr(separators, joined[len-1]) == NULL)) { if (Tcl_FSGetPathType(pathPtr) != TCL_PATH_VOLUME_RELATIVE) { Tcl_AppendToObj(joinedPtr, "/", 1); } -- cgit v0.12 From 565b9dca95a5103374909c089697e655748cc932 Mon Sep 17 00:00:00 2001 From: sebres Date: Thu, 16 Jul 2020 15:34:57 +0000 Subject: cherry pick [df5f1e8652]: Fix [5bbd044812]: Fix index underflow. --- generic/tclFileName.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/generic/tclFileName.c b/generic/tclFileName.c index a8360fc..be1fdfa 100644 --- a/generic/tclFileName.c +++ b/generic/tclFileName.c @@ -2432,7 +2432,7 @@ DoGlob( int len; const char *joined = Tcl_GetStringFromObj(joinedPtr,&len); - if (strchr(separators, joined[len-1]) == NULL) { + if ((len > 0) && (strchr(separators, joined[len-1]) == NULL)) { Tcl_AppendToObj(joinedPtr, "/", 1); } } @@ -2469,7 +2469,7 @@ DoGlob( int len; const char *joined = Tcl_GetStringFromObj(joinedPtr,&len); - if (strchr(separators, joined[len-1]) == NULL) { + if ((len > 0) && (strchr(separators, joined[len-1]) == NULL)) { if (Tcl_FSGetPathType(pathPtr) != TCL_PATH_VOLUME_RELATIVE) { Tcl_AppendToObj(joinedPtr, "/", 1); } -- cgit v0.12 From 9598926f42bd5ffbd6c7e9b7022f39382e8d29b8 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 17 Jul 2020 10:42:29 +0000 Subject: New TIP #581 implementation --- doc/CrtAlias.3 | 29 ++++++++++++++++++++++++++++- doc/interp.n | 6 ++++++ generic/tclDecls.h | 3 +++ generic/tclIntDecls.h | 2 ++ generic/tclInterp.c | 5 +++-- tests/interp.test | 8 ++++---- 6 files changed, 46 insertions(+), 7 deletions(-) diff --git a/doc/CrtAlias.3 b/doc/CrtAlias.3 index 72912bc..f9c912d 100644 --- a/doc/CrtAlias.3 +++ b/doc/CrtAlias.3 @@ -8,7 +8,7 @@ .so man.macros .BS .SH NAME -Tcl_IsSafe, Tcl_MakeSafe, Tcl_CreateSlave, Tcl_GetSlave, Tcl_GetMaster, Tcl_GetInterpPath, Tcl_CreateAlias, Tcl_CreateAliasObj, Tcl_GetAlias, Tcl_GetAliasObj, Tcl_ExposeCommand, Tcl_HideCommand \- manage multiple Tcl interpreters, aliases and hidden commands +Tcl_IsSafe, Tcl_MakeSafe, Tcl_CreateChild, Tcl_CreateSlave, Tcl_GetChild, Tcl_GetSlave, Tcl_GetParent, Tcl_GetMaster, Tcl_GetInterpPath, Tcl_CreateAlias, Tcl_CreateAliasObj, Tcl_GetAlias, Tcl_GetAliasObj, Tcl_ExposeCommand, Tcl_HideCommand \- manage multiple Tcl interpreters, aliases and hidden commands .SH SYNOPSIS .nf \fB#include \fR @@ -19,12 +19,27 @@ int int \fBTcl_MakeSafe\fR(\fIinterp\fR) .sp +.VS "TIP 581" +Tcl_Interp * +\fBTcl_CreateChild\fR(\fIinterp, name, isSafe\fR) +.VE "TIP 581" +.sp Tcl_Interp * \fBTcl_CreateSlave\fR(\fIinterp, name, isSafe\fR) .sp +.VS "TIP 581" +Tcl_Interp * +\fBTcl_GetChild\fR(\fIinterp, name\fR) +.VE "TIP 581" +.sp Tcl_Interp * \fBTcl_GetSlave\fR(\fIinterp, name\fR) .sp +.VS "TIP 581" +Tcl_Interp * +\fBTcl_GetParent\fR(\fIinterp\fR) +.VE "TIP 581" +.sp Tcl_Interp * \fBTcl_GetMaster\fR(\fIinterp\fR) .sp @@ -133,6 +148,10 @@ slave in which Tcl code has access only to set of Tcl commands defined as see the manual entry for the Tcl \fBinterp\fR command for details. If the creation of the new slave interpreter failed, \fBNULL\fR is returned. .PP +.VS "TIP 581" +\fBTcl_CreateChild\fR is a synonym for \fBTcl_CreateSlave\fR. +.VE "TIP 581" +.PP \fBTcl_IsSafe\fR returns \fB1\fR if \fIinterp\fR is .QW safe (was created with the \fBTCL_SAFE_INTERPRETER\fR flag specified), @@ -154,10 +173,18 @@ may be a better choice, since it creates interpreters in a known-safe state. \fIinterp\fR. The slave interpreter is identified by \fIslaveName\fR. If no such slave interpreter exists, \fBNULL\fR is returned. .PP +.VS "TIP 581" +\fBTcl_GetChild\fR is a synonym for \fBTcl_GetSlave\fR. +.VE "TIP 581" +.PP \fBTcl_GetMaster\fR returns a pointer to the master interpreter of \fIinterp\fR. If \fIinterp\fR has no master (it is a top-level interpreter) then \fBNULL\fR is returned. .PP +.VS "TIP 581" +\fBTcl_GetParent\fR is a synonym for \fBTcl_GetMaster\fR. +.VE "TIP 581" +.PP \fBTcl_GetInterpPath\fR stores in the result of \fIaskingInterp\fR the relative path between \fIaskingInterp\fR and \fIslaveInterp\fR; \fIslaveInterp\fR must be a slave of \fIaskingInterp\fR. If the computation diff --git a/doc/interp.n b/doc/interp.n index 9fcd055..9f975d0 100644 --- a/doc/interp.n +++ b/doc/interp.n @@ -377,6 +377,12 @@ Returns a Tcl list of the names of all the slave interpreters associated with the interpreter identified by \fIpath\fR. If \fIpath\fR is omitted, the invoking interpreter is used. .TP +.VS "TIP 581" +\fBinterp\fR \fBchildren\fR ?\fIpath\fR? +. +Synonym for . \fBinterp\fR \fBslaves\fR ?\fIpath\fR? +.VE "TIP 581" +.TP \fBinterp\fR \fBtarget\fR \fIpath alias\fR . Returns a Tcl list describing the target interpreter for an alias. The diff --git a/generic/tclDecls.h b/generic/tclDecls.h index e341731..e0854d6 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -3974,5 +3974,8 @@ extern const TclStubs *tclStubsPtr; #undef Tcl_GlobalEvalObj #define Tcl_GlobalEvalObj(interp,objPtr) \ Tcl_EvalObjEx((interp),(objPtr),TCL_EVAL_GLOBAL) +#define Tcl_CreateChild Tcl_CreateSlave +#define Tcl_GetChild Tcl_GetSlave +#define Tcl_GetParent Tcl_GetMaster #endif /* _TCLDECLS */ diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index 7560d11..ffe0e17 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -1422,4 +1422,6 @@ extern const TclIntStubs *tclIntStubsPtr; #undef TclCopyChannelOld #undef TclSockMinimumBuffersOld +#define TclSetChildCancelFlags TclSetSlaveCancelFlags + #endif /* _TCLINTDECLS */ diff --git a/generic/tclInterp.c b/generic/tclInterp.c index ac66324..6e99913 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -611,7 +611,7 @@ NRInterpCmd( int index; static const char *const options[] = { "alias", "aliases", "bgerror", "cancel", - "create", "debug", "delete", + "children", "create", "debug", "delete", "eval", "exists", "expose", "hide", "hidden", "issafe", "invokehidden", "limit", "marktrusted", "recursionlimit", @@ -620,7 +620,7 @@ NRInterpCmd( }; enum option { OPT_ALIAS, OPT_ALIASES, OPT_BGERROR, OPT_CANCEL, - OPT_CREATE, OPT_DEBUG, OPT_DELETE, + OPT_CHILDREN, OPT_CREATE, OPT_DEBUG, OPT_DELETE, OPT_EVAL, OPT_EXISTS, OPT_EXPOSE, OPT_HIDE, OPT_HIDDEN, OPT_ISSAFE, OPT_INVOKEHID, OPT_LIMIT, OPT_MARKTRUSTED,OPT_RECLIMIT, @@ -1008,6 +1008,7 @@ NRInterpCmd( return TCL_ERROR; } return SlaveRecursionLimit(interp, slaveInterp, objc - 3, objv + 3); + case OPT_CHILDREN: case OPT_SLAVES: { InterpInfo *iiPtr; Tcl_Obj *resultPtr; diff --git a/tests/interp.test b/tests/interp.test index 5b7b157..df94678 100644 --- a/tests/interp.test +++ b/tests/interp.test @@ -32,7 +32,7 @@ test interp-1.1 {options for interp command} -returnCodes error -body { } -result {wrong # args: should be "interp cmd ?arg ...?"} test interp-1.2 {options for interp command} -returnCodes error -body { interp frobox -} -result {bad option "frobox": must be alias, aliases, bgerror, cancel, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer} +} -result {bad option "frobox": must be alias, aliases, bgerror, cancel, children, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer} test interp-1.3 {options for interp command} { interp delete } "" @@ -50,13 +50,13 @@ test interp-1.6 {options for interp command} -returnCodes error -body { } -result {wrong # args: should be "interp slaves ?path?"} test interp-1.7 {options for interp command} -returnCodes error -body { interp hello -} -result {bad option "hello": must be alias, aliases, bgerror, cancel, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer} +} -result {bad option "hello": must be alias, aliases, bgerror, cancel, children, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer} test interp-1.8 {options for interp command} -returnCodes error -body { interp -froboz -} -result {bad option "-froboz": must be alias, aliases, bgerror, cancel, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer} +} -result {bad option "-froboz": must be alias, aliases, bgerror, cancel, children, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer} test interp-1.9 {options for interp command} -returnCodes error -body { interp -froboz -safe -} -result {bad option "-froboz": must be alias, aliases, bgerror, cancel, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer} +} -result {bad option "-froboz": must be alias, aliases, bgerror, cancel, children, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer} test interp-1.10 {options for interp command} -returnCodes error -body { interp target } -result {wrong # args: should be "interp target path alias"} -- cgit v0.12 From 56e784cb1b7a6e78689cfa75df0e0dbaf51657d0 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 17 Jul 2020 11:11:47 +0000 Subject: Doc/internal variable tweaks --- doc/CrtAlias.3 | 8 ++++---- generic/tclInterp.c | 10 +++++----- 2 files changed, 9 insertions(+), 9 deletions(-) diff --git a/doc/CrtAlias.3 b/doc/CrtAlias.3 index 72912bc..82ef122 100644 --- a/doc/CrtAlias.3 +++ b/doc/CrtAlias.3 @@ -158,12 +158,12 @@ If no such slave interpreter exists, \fBNULL\fR is returned. \fIinterp\fR. If \fIinterp\fR has no master (it is a top-level interpreter) then \fBNULL\fR is returned. .PP -\fBTcl_GetInterpPath\fR stores in the result of \fIaskingInterp\fR -the relative path between \fIaskingInterp\fR and \fIslaveInterp\fR; -\fIslaveInterp\fR must be a slave of \fIaskingInterp\fR. If the computation +\fBTcl_GetInterpPath\fR stores in the result of \fIinterp\fR +the relative path between \fIinterp\fR and \fIslaveInterp\fR; +\fIslaveInterp\fR must be a slave of \fIinterp\fR. If the computation of the relative path succeeds, \fBTCL_OK\fR is returned, else \fBTCL_ERROR\fR is returned and an error message is stored as the -result of \fIaskingInterp\fR. +result of \fIinterp\fR. .PP \fBTcl_CreateAlias\fR creates a command named \fIslaveCmd\fR in \fIslaveInterp\fR that when invoked, will cause the command \fItargetCmd\fR diff --git a/generic/tclInterp.c b/generic/tclInterp.c index ac66324..95c68ee 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -2169,23 +2169,23 @@ TclSetSlaveCancelFlags( int Tcl_GetInterpPath( - Tcl_Interp *askingInterp, /* Interpreter to start search from. */ + Tcl_Interp *interp, /* Interpreter to start search from. */ Tcl_Interp *targetInterp) /* Interpreter to find. */ { InterpInfo *iiPtr; - if (targetInterp == askingInterp) { - Tcl_SetObjResult(askingInterp, Tcl_NewObj()); + if (targetInterp == interp) { + Tcl_SetObjResult(interp, Tcl_NewObj()); return TCL_OK; } if (targetInterp == NULL) { return TCL_ERROR; } iiPtr = (InterpInfo *) ((Interp *) targetInterp)->interpInfo; - if (Tcl_GetInterpPath(askingInterp, iiPtr->slave.masterInterp) != TCL_OK){ + if (Tcl_GetInterpPath(interp, iiPtr->slave.masterInterp) != TCL_OK){ return TCL_ERROR; } - Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(askingInterp), + Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), Tcl_NewStringObj(Tcl_GetHashKey(&iiPtr->master.slaveTable, iiPtr->slave.slaveEntryPtr), -1)); return TCL_OK; -- cgit v0.12 From 651f71edfd77b66fd1e585154b7f4390e6df2b6f Mon Sep 17 00:00:00 2001 From: kjnash Date: Sat, 18 Jul 2020 04:12:08 +0000 Subject: Tidying tests/safe.test --- tests/safe.test | 128 +++++++++++++++++++++++++++++++------------------------- 1 file changed, 70 insertions(+), 58 deletions(-) diff --git a/tests/safe.test b/tests/safe.test index dbcd2cc..2683b9c 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -21,9 +21,8 @@ foreach i [interp slaves] { interp delete $i } -set saveAutoPath $::auto_path +set SaveAutoPath $::auto_path set ::auto_path [info library] - set TestsDir [file normalize [file dirname [info script]]] set PathMapp [list $tcl_library TCLLIB $TestsDir TESTSDIR] @@ -194,6 +193,7 @@ test safe-6.3 {test safe interpreters knowledge of the world} { lsort $r } {byteOrder engine pathSeparator platform pointerSize wordSize} +rename SafeEval {} # More test should be added to check that hostname, nameofexecutable, aren't # leaking infos, but they still do... @@ -213,7 +213,6 @@ test safe-7.0a {example tclIndex commands, test in master interpreter} -setup { set ::auto_path $tmpAutoPath auto_reset } -match glob -result {0 ok1 0 ok2} - test safe-7.0b {example tclIndex commands, negative test in master interpreter} -setup { set tmpAutoPath $::auto_path lappend ::auto_path [file join $TestsDir auto0] @@ -228,7 +227,6 @@ test safe-7.0b {example tclIndex commands, negative test in master interpreter} set ::auto_path $tmpAutoPath auto_reset } -match glob -result {1 {invalid command name "report1"} 1 {invalid command name "report2"}} - test safe-7.0c {example pkgIndex.tcl packages, test in master interpreter, child directories} -setup { set tmpAutoPath $::auto_path lappend ::auto_path [file join $TestsDir auto0] @@ -238,7 +236,6 @@ test safe-7.0c {example pkgIndex.tcl packages, test in master interpreter, child set code4 [catch {package require SafeTestPackage2} msg4] set code5 [catch HeresPackage1 msg5] set code6 [catch HeresPackage2 msg6] - list $code3 $msg3 $code4 $msg4 $code5 $msg5 $code6 $msg6 } -cleanup { set ::auto_path $tmpAutoPath @@ -247,7 +244,6 @@ test safe-7.0c {example pkgIndex.tcl packages, test in master interpreter, child catch {rename HeresPackage1 {}} catch {rename HeresPackage2 {}} } -match glob -result {0 1.2.3 0 2.3.4 0 OK1 0 OK2} - test safe-7.0d {example pkgIndex.tcl packages, test in master interpreter, main directories} -setup { set tmpAutoPath $::auto_path lappend ::auto_path [file join $TestsDir auto0 auto1] \ @@ -258,7 +254,6 @@ test safe-7.0d {example pkgIndex.tcl packages, test in master interpreter, main set code4 [catch {package require SafeTestPackage2} msg4] set code5 [catch HeresPackage1 msg5] set code6 [catch HeresPackage2 msg6] - list $code3 $msg3 $code4 $msg4 $code5 $msg5 $code6 $msg6 } -cleanup { set ::auto_path $tmpAutoPath @@ -267,7 +262,6 @@ test safe-7.0d {example pkgIndex.tcl packages, test in master interpreter, main catch {rename HeresPackage1 {}} catch {rename HeresPackage2 {}} } -match glob -result {0 1.2.3 0 2.3.4 0 OK1 0 OK2} - test safe-7.0e {example modules packages, test in master interpreter, replace path} -setup { set oldTm [tcl::tm::path list] foreach path $oldTm { @@ -282,7 +276,6 @@ test safe-7.0e {example modules packages, test in master interpreter, replace pa set out0 [test0::try0] set out1 [mod1::test1::try1] set out2 [mod2::test2::try2] - list $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $out0 $out1 $out2 } -cleanup { tcl::tm::path remove [file join $TestsDir auto0 modules] @@ -295,7 +288,6 @@ test safe-7.0e {example modules packages, test in master interpreter, replace pa catch {namespace delete ::test0} catch {namespace delete ::mod1} } -match glob -result {0 0.5 0 1.0 0 2.0 -- res0 res1 res2} - test safe-7.0f {example modules packages, test in master interpreter, append to path} -setup { tcl::tm::path add [file join $TestsDir auto0 modules] } -body { @@ -306,7 +298,6 @@ test safe-7.0f {example modules packages, test in master interpreter, append to set out0 [test0::try0] set out1 [mod1::test1::try1] set out2 [mod2::test2::try2] - list $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $out0 $out1 $out2 } -cleanup { tcl::tm::path remove [file join $TestsDir auto0 modules] @@ -393,7 +384,8 @@ test safe-7.3 {check that safe subinterpreters work} { } set i [safe::interpCreate] set j [safe::interpCreate [list $i x]] - list $g $h [interp eval $j {join {o k} ""}] [safe::interpDelete $i] [interp exists $j] [info vars ::safe::S*] + list $g $h [interp eval $j {join {o k} ""}] [safe::interpDelete $i] \ + [interp exists $j] [info vars ::safe::S*] } {{} {} ok {} 0 {}} test safe-7.4 {tests specific path and positive search} -setup { } -body { @@ -428,24 +420,28 @@ test safe-7.4http {tests specific path and positive search, uses http1.0} -body } -match glob -result {{$p(:0:)} {$p(:*:)} -- 0 1.0 -- {TCLLIB *TCLLIB/http1.0} -- {}} # test source control on file name -set i "a" test safe-8.1 {safe source control on file} -setup { + set i "a" catch {safe::interpDelete $i} } -body { safe::interpCreate $i $i eval {source} } -returnCodes error -cleanup { safe::interpDelete $i + unset i } -result {wrong # args: should be "source ?-encoding E? fileName"} test safe-8.2 {safe source control on file} -setup { + set i "a" catch {safe::interpDelete $i} } -body { safe::interpCreate $i $i eval {source a b c d e} } -returnCodes error -cleanup { safe::interpDelete $i + unset i } -result {wrong # args: should be "source ?-encoding E? fileName"} test safe-8.3 {safe source control on file} -setup { + set i "a" catch {safe::interpDelete $i} set log {} proc safe-test-log {str} {lappend ::log $str} @@ -456,10 +452,12 @@ test safe-8.3 {safe source control on file} -setup { list [catch {$i eval {source .}} msg] $msg $log } -cleanup { safe::setLogCmd $prevlog - unset log safe::interpDelete $i + rename safe-test-log {} + unset i log } -result {1 {permission denied} {{ERROR for slave a : ".": is a directory}}} test safe-8.4 {safe source control on file} -setup { + set i "a" catch {safe::interpDelete $i} set log {} proc safe-test-log {str} {global log; lappend log $str} @@ -470,10 +468,12 @@ test safe-8.4 {safe source control on file} -setup { list [catch {$i eval {source /abc/def}} msg] $msg $log } -cleanup { safe::setLogCmd $prevlog - unset log safe::interpDelete $i + rename safe-test-log {} + unset i log } -result {1 {permission denied} {{ERROR for slave a : "/abc/def": not in access_path}}} test safe-8.5 {safe source control on file} -setup { + set i "a" catch {safe::interpDelete $i} set log {} proc safe-test-log {str} {global log; lappend log $str} @@ -488,10 +488,12 @@ test safe-8.5 {safe source control on file} -setup { } msg] $msg $log } -cleanup { safe::setLogCmd $prevlog - unset log safe::interpDelete $i + rename safe-test-log {} + unset i log } -result [list 1 {no such file or directory} [list "ERROR for slave a : [file join [info library] blah]:no such file or directory"]] test safe-8.6 {safe source control on file} -setup { + set i "a" catch {safe::interpDelete $i} set log {} proc safe-test-log {str} {global log; lappend log $str} @@ -504,10 +506,12 @@ test safe-8.6 {safe source control on file} -setup { } msg] $msg $log } -cleanup { safe::setLogCmd $prevlog - unset log safe::interpDelete $i + rename safe-test-log {} + unset i log } -result [list 1 {no such file or directory} [list "ERROR for slave a : [file join [info library] blah.tcl]:no such file or directory"]] test safe-8.7 {safe source control on file} -setup { + set i "a" catch {safe::interpDelete $i} set log {} proc safe-test-log {str} {global log; lappend log $str} @@ -522,14 +526,16 @@ test safe-8.7 {safe source control on file} -setup { } msg] $msg $log } -cleanup { safe::setLogCmd $prevlog - unset log safe::interpDelete $i + rename safe-test-log {} + unset i log } -result [list 1 {no such file or directory} [list "ERROR for slave a : [file join [info library] xxxxxxxxxxx.tcl]:no such file or directory"]] test safe-8.8 {safe source forbids -rsrc} emptyTest { # Disabled this test. It was only useful for long unsupported # Mac OS 9 systems. [Bug 860a9f1945] } {} test safe-8.9 {safe source and return} -setup { + set i "a" set returnScript [makeFile {return "ok"} return.tcl] catch {safe::interpDelete $i} } -body { @@ -539,8 +545,10 @@ test safe-8.9 {safe source and return} -setup { } -cleanup { catch {safe::interpDelete $i} removeFile $returnScript + unset i } -result ok test safe-8.10 {safe source and return} -setup { + set i "a" set returnScript [makeFile {return -level 2 "ok"} return.tcl] catch {safe::interpDelete $i} } -body { @@ -553,10 +561,11 @@ test safe-8.10 {safe source and return} -setup { } -cleanup { catch {safe::interpDelete $i} removeFile $returnScript + unset i } -result ok -set i "a" test safe-9.1 {safe interps' deleteHook} -setup { + set i "a" catch {safe::interpDelete $i} set res {} } -body { @@ -569,8 +578,12 @@ test safe-9.1 {safe interps' deleteHook} -setup { } safe::interpCreate $i -deleteHook "testDelHook arg1 arg2" list [interp eval $i exit] $res +} -cleanup { + catch {rename testDelHook {}} + unset i res } -result {{} {arg1 arg2 a}} test safe-9.2 {safe interps' error in deleteHook} -setup { + set i "a" catch {safe::interpDelete $i} set res {} set log {} @@ -591,7 +604,9 @@ test safe-9.2 {safe interps' error in deleteHook} -setup { list [safe::interpDelete $i] $res $log } -cleanup { safe::setLogCmd $prevlog - unset log + catch {rename testDelHook {}} + rename safe-test-log {} + unset i log res } -result {{} {arg1 arg2 a} {{NOTICE for slave a : About to delete} {ERROR for slave a : Delete hook error (being catched)} {NOTICE for slave a : Deleted}}} test safe-9.3 {dual specification of statics} -returnCodes error -body { safe::interpCreate -stat true -nostat @@ -620,16 +635,18 @@ test safe-9.6 {interpConfigure widget like behaviour} -body { safe::interpConfigure $i]\ [safe::interpConfigure $i -deleteHook toto -nosta -nested 0 safe::interpConfigure $i] -} -match glob -result {{-accessPath * -statics 0 -nested 1 -deleteHook {foo bar}} {-accessPath *} {-nested 1} {-statics 0} {-deleteHook {foo bar}} {-accessPath * -statics 1 -nested 1 -deleteHook {foo bar}} {-accessPath * -statics 0 -nested 0 -deleteHook toto}} - +} -cleanup { + safe::interpDelete $i +} -match glob -result {{-accessPath * -statics 0 -nested 1 -deleteHook {foo bar}}\ + {-accessPath *} {-nested 1} {-statics 0} {-deleteHook {foo bar}}\ + {-accessPath * -statics 1 -nested 1 -deleteHook {foo bar}}\ + {-accessPath * -statics 0 -nested 0 -deleteHook toto}} test safe-9.7 {interpConfigure widget like behaviour (demystified)} -body { # this test shall work, believed equivalent to 9.6 set i [safe::interpCreate \ -noStatics \ -nestedLoadOk \ - -deleteHook {foo bar} \ - ] - + -deleteHook {foo bar}] safe::interpConfigure $i -accessPath /foo/bar set a [safe::interpConfigure $i] set b [safe::interpConfigure $i -aCCess] @@ -644,8 +661,11 @@ test safe-9.7 {interpConfigure widget like behaviour (demystified)} -body { list $a $b $c $d $e $f $g } -cleanup { safe::interpDelete $i -} -match glob -result {{-accessPath * -statics 0 -nested 1 -deleteHook {foo bar}} {-accessPath *} {-nested 1} {-statics 0} {-deleteHook {foo bar}} {-accessPath * -statics 1 -nested 1 -deleteHook {foo bar}} {-accessPath * -statics 0 -nested 0 -deleteHook toto}} - + unset -nocomplain a b c d e f g i +} -match glob -result {{-accessPath * -statics 0 -nested 1 -deleteHook {foo bar}}\ + {-accessPath *} {-nested 1} {-statics 0} {-deleteHook {foo bar}}\ + {-accessPath * -statics 1 -nested 1 -deleteHook {foo bar}}\ + {-accessPath * -statics 0 -nested 0 -deleteHook toto}} test safe-9.8 {interpConfigure change the access path; tclIndex commands unaffected by token rearrangement (dummy test of doreset)} -setup { } -body { set i [safe::interpCreate -accessPath [list $tcl_library \ @@ -669,7 +689,6 @@ test safe-9.8 {interpConfigure change the access path; tclIndex commands unaffec safe::interpConfigure $i -accessPath [list $tcl_library \ [file join $TestsDir auto0 auto2] \ [file join $TestsDir auto0 auto1]] - # Inspect. set confB [safe::interpConfigure $i] set mappB [mapList $PathMapp [dict get $confB -accessPath]] @@ -686,7 +705,6 @@ test safe-9.8 {interpConfigure change the access path; tclIndex commands unaffec } -match glob -result {{$p(:1:)} {$p(:2:)} -- {$p(:2:)} {$p(:1:)} -- 0 ok1 0 ok2 --\ {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} --\ {TCLLIB TESTSDIR/auto0/auto2 TESTSDIR/auto0/auto1*}} - test safe-9.9 {interpConfigure change the access path; tclIndex commands unaffected by token rearrangement (actual test of doreset)} -setup { } -body { set i [safe::interpCreate -accessPath [list $tcl_library \ @@ -708,7 +726,6 @@ test safe-9.9 {interpConfigure change the access path; tclIndex commands unaffec safe::interpConfigure $i -accessPath [list $tcl_library \ [file join $TestsDir auto0 auto2] \ [file join $TestsDir auto0 auto1]] - # Inspect. set confB [safe::interpConfigure $i] set mappB [mapList $PathMapp [dict get $confB -accessPath]] @@ -726,7 +743,6 @@ test safe-9.9 {interpConfigure change the access path; tclIndex commands unaffec 0 ok1 0 ok2 --\ {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} --\ {TCLLIB TESTSDIR/auto0/auto2 TESTSDIR/auto0/auto1*}} - test safe-9.10 {interpConfigure change the access path; pkgIndex.tcl packages unaffected by token rearrangement} -setup { } -body { # For complete correspondence to safe-9.10opt, include auto0 in access path. @@ -734,7 +750,6 @@ test safe-9.10 {interpConfigure change the access path; pkgIndex.tcl packages un [file join $TestsDir auto0] \ [file join $TestsDir auto0 auto1] \ [file join $TestsDir auto0 auto2]]] - # Inspect. set confA [safe::interpConfigure $i] set mappA [mapList $PathMapp [dict get $confA -accessPath]] @@ -752,7 +767,6 @@ test safe-9.10 {interpConfigure change the access path; pkgIndex.tcl packages un [file join $TestsDir auto0] \ [file join $TestsDir auto0 auto2] \ [file join $TestsDir auto0 auto1]] - # Inspect. set confB [safe::interpConfigure $i] set mappB [mapList $PathMapp [dict get $confB -accessPath]] @@ -773,13 +787,11 @@ test safe-9.10 {interpConfigure change the access path; pkgIndex.tcl packages un {TCLLIB TESTSDIR/auto0 TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} --\ {TCLLIB TESTSDIR/auto0 TESTSDIR/auto0/auto2 TESTSDIR/auto0/auto1*} --\ 0 OK1 0 OK2} - test safe-9.11 {interpConfigure change the access path; pkgIndex.tcl packages unaffected by token rearrangement, 9.10 without path auto0} -setup { } -body { set i [safe::interpCreate -accessPath [list $tcl_library \ [file join $TestsDir auto0 auto1] \ [file join $TestsDir auto0 auto2]]] - # Inspect. set confA [safe::interpConfigure $i] set mappA [mapList $PathMapp [dict get $confA -accessPath]] @@ -793,7 +805,6 @@ test safe-9.11 {interpConfigure change the access path; pkgIndex.tcl packages un safe::interpConfigure $i -accessPath [list $tcl_library \ [file join $TestsDir auto0 auto2] \ [file join $TestsDir auto0 auto1]] - # Inspect. set confB [safe::interpConfigure $i] set mappB [mapList $PathMapp [dict get $confB -accessPath]] @@ -806,8 +817,9 @@ test safe-9.11 {interpConfigure change the access path; pkgIndex.tcl packages un set code5 [catch {interp eval $i {HeresPackage1}} msg5 opts5] set code6 [catch {interp eval $i {HeresPackage2}} msg6 opts6] - list $path1 $path2 -- $path3 $path4 -- $code3 $msg3 $code4 $msg4 -- $mappA -- $mappB -- \ - $code5 $msg5 $code6 $msg6 + list $path1 $path2 -- $path3 $path4 -- $code3 $msg3 $code4 $msg4 -- \ + $mappA -- $mappB -- \ + $code5 $msg5 $code6 $msg6 } -cleanup { safe::interpDelete $i } -match glob -result {{$p(:1:)} {$p(:2:)} -- {$p(:2:)} {$p(:1:)} --\ @@ -842,7 +854,8 @@ test safe-9.12 {interpConfigure change the access path; pkgIndex.tcl packages fa set code3 [catch {interp eval $i {package require SafeTestPackage1}} msg3] set code6 [catch {interp eval $i {package require SafeTestPackage2}} msg6] - list $path1 $path2 -- $code4 $path4 -- $code5 $path5 -- $code3 $code6 -- $mappA -- $mappB + list $path1 $path2 -- $code4 $path4 -- $code5 $path5 -- $code3 $code6 -- \ + $mappA -- $mappB } -cleanup { safe::interpDelete $i } -match glob -result {{$p(:1:)} {$p(:2:)} -- 1 {* not found in access path} --\ @@ -916,7 +929,6 @@ test safe-9.21 {interpConfigure change the access path; check module loading; st safe::interpConfigure $i -accessPath [list $tcl_library \ [file join $TestsDir auto0 auto1] \ [file join $TestsDir auto0 auto2]] - # Inspect. set confB [safe::interpConfigure $i] set sortB [mapAndSortList $PathMapp [dict get $confB -accessPath]] @@ -938,9 +950,10 @@ test safe-9.21 {interpConfigure change the access path; check module loading; st set out1 [interp eval $i {mod1::test1::try1}] set out2 [interp eval $i {mod2::test2::try2}] - list [lsort [list $path0 $path1 $path2]] -- $modsA -- [lsort [list $path3 $path4 $path5]] -- $modsB -- \ - $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $sortA -- $sortB -- \ - $out0 $out1 $out2 + list [lsort [list $path0 $path1 $path2]] -- $modsA -- \ + [lsort [list $path3 $path4 $path5]] -- $modsB -- \ + $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $sortA -- $sortB -- \ + $out0 $out1 $out2 } -cleanup { tcl::tm::path remove [file join $TestsDir auto0 modules] foreach path [lreverse $oldTm] { @@ -978,7 +991,6 @@ test safe-9.22 {interpConfigure change the access path; check module loading; st safe::interpConfigure $i -accessPath [list $tcl_library \ [file join $TestsDir auto0 auto1] \ [file join $TestsDir auto0 auto2]] - # Inspect. set confB [safe::interpConfigure $i] set sortB [mapAndSortList $PathMapp [dict get $confB -accessPath]] @@ -995,9 +1007,10 @@ test safe-9.22 {interpConfigure change the access path; check module loading; st set out1 [interp eval $i {mod1::test1::try1}] set out2 [interp eval $i {mod2::test2::try2}] - list [lsort [list $path0 $path1 $path2]] -- $modsA -- [lsort [list $path3 $path4 $path5]] -- $modsB -- \ - $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $sortA -- $sortB -- \ - $out0 $out1 $out2 + list [lsort [list $path0 $path1 $path2]] -- $modsA --\ + [lsort [list $path3 $path4 $path5]] -- $modsB -- \ + $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $sortA -- $sortB -- \ + $out0 $out1 $out2 } -cleanup { tcl::tm::path remove [file join $TestsDir auto0 modules] foreach path [lreverse $oldTm] { @@ -1040,7 +1053,6 @@ test safe-9.23 {interpConfigure change the access path; check module loading; st safe::interpConfigure $i -accessPath [list $tcl_library \ [file join $TestsDir auto0 auto1] \ [file join $TestsDir auto0 auto2]] - # Inspect. set confB [safe::interpConfigure $i] set sortB [mapAndSortList $PathMapp [dict get $confB -accessPath]] @@ -1062,10 +1074,10 @@ test safe-9.23 {interpConfigure change the access path; check module loading; st set out1 [interp eval $i {mod1::test1::try1}] set out2 [interp eval $i {mod2::test2::try2}] - list [lsort [list $path0 $path1 $path2]] -- $modsA -- [lsort [list $path3 $path4 $path5]] -- $modsB -- \ - $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $sortA -- $sortB -- \ - $out0 $out1 $out2 - + list [lsort [list $path0 $path1 $path2]] -- $modsA --\ + [lsort [list $path3 $path4 $path5]] -- $modsB -- \ + $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $sortA -- $sortB -- \ + $out0 $out1 $out2 } -cleanup { tcl::tm::path remove [file join $TestsDir auto0 modules] foreach path [lreverse $oldTm] { @@ -1108,7 +1120,6 @@ test safe-9.24 {interpConfigure change the access path; check module loading; st safe::interpConfigure $i -accessPath [list $tcl_library \ [file join $TestsDir auto0 auto1] \ [file join $TestsDir auto0 auto2]] - # Inspect. set confB [safe::interpConfigure $i] set sortB [mapAndSortList $PathMapp [dict get $confB -accessPath]] @@ -1125,9 +1136,10 @@ test safe-9.24 {interpConfigure change the access path; check module loading; st set out1 [interp eval $i {mod1::test1::try1}] set out2 [interp eval $i {mod2::test2::try2}] - list [lsort [list $path0 $path1 $path2]] -- $modsA -- [lsort [list $path3 $path4 $path5]] -- $modsB -- \ - $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $sortA -- $sortB -- \ - $out0 $out1 $out2 + list [lsort [list $path0 $path1 $path2]] -- $modsA -- \ + [lsort [list $path3 $path4 $path5]] -- $modsB -- \ + $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $sortA -- $sortB -- \ + $out0 $out1 $out2 } -cleanup { tcl::tm::path remove [file join $TestsDir auto0 modules] foreach path [lreverse $oldTm] { @@ -1593,8 +1605,8 @@ test safe-16.4 {Bug 3529949: defang ~user in globs} -setup { safe::interpDelete $i } -result {} -set ::auto_path $saveAutoPath -unset saveAutoPath TestsDir PathMapp +set ::auto_path $SaveAutoPath +unset SaveAutoPath TestsDir PathMapp rename mapList {} rename mapAndSortList {} -- cgit v0.12 From 2a52ff28dd5deb1dc6fde4f0fdbbb85aa6b4efe3 Mon Sep 17 00:00:00 2001 From: kjnash Date: Sat, 18 Jul 2020 12:53:53 +0000 Subject: Remove code block in ::safe::AliasGlob that no longer serves a useful purpose. --- library/safe.tcl | 7 ------- 1 file changed, 7 deletions(-) diff --git a/library/safe.tcl b/library/safe.tcl index 74aee87..e645085 100644 --- a/library/safe.tcl +++ b/library/safe.tcl @@ -792,13 +792,6 @@ proc ::safe::AliasGlob {slave args} { set virtualdir [lindex $args [incr at]] incr at } - pkgIndex.tcl { - # Oops, this is globbing a subdirectory in regular package - # search. That is not wanted. Abort, handler does catch - # already (because glob was not defined before). See - # package.tcl, lines 484ff in tclPkgUnknown. - return -code error "unknown command glob" - } -* { Log $slave "Safe base rejecting glob option '$opt'" return -code error "Safe base rejecting glob option '$opt'" -- cgit v0.12 From a300508fee9c27bc2ea2bf95a19d7007dcd26424 Mon Sep 17 00:00:00 2001 From: kjnash Date: Sat, 18 Jul 2020 13:09:25 +0000 Subject: Remove unused code for *.tm from ::safe::AliasGlob. --- library/safe.tcl | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/library/safe.tcl b/library/safe.tcl index e645085..843255a 100644 --- a/library/safe.tcl +++ b/library/safe.tcl @@ -831,8 +831,7 @@ proc ::safe::AliasGlob {slave args} { } elseif {[string match ~* $thedir]} { set thedir ./$thedir } - if {$thedir eq "*" && - ($thefile eq "pkgIndex.tcl" || $thefile eq "*.tm")} { + if {($thedir eq "*") && ($thefile eq "pkgIndex.tcl")} { set mapped 0 foreach d [glob -directory [TranslatePath $slave $virtualdir] \ -types d -tails *] { -- cgit v0.12 From 690f2c283978a046e78664a1070c5c0bf5ddf67f Mon Sep 17 00:00:00 2001 From: kjnash Date: Sat, 18 Jul 2020 13:18:48 +0000 Subject: Bugfix argument combination -- and -directory in ::safe::AliasGlob. --- library/safe.tcl | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/library/safe.tcl b/library/safe.tcl index 843255a..410a5c1 100644 --- a/library/safe.tcl +++ b/library/safe.tcl @@ -815,7 +815,11 @@ proc ::safe::AliasGlob {slave args} { if {$got(-nocomplain)} return return -code error "permission denied" } - lappend cmd -directory $dir + if {$got(--)} { + set cmd [linsert $cmd end-1 -directory $dir] + } else { + lappend cmd -directory $dir + } } # Apply the -join semantics ourselves -- cgit v0.12 From 6310c709d39e30dcefc165aa242973e919d86134 Mon Sep 17 00:00:00 2001 From: kjnash Date: Sat, 18 Jul 2020 13:22:31 +0000 Subject: Update comments about safe interpreters in library/tm.tcl and library/package.tcl so they agree with code --- library/package.tcl | 10 +++++++--- library/tm.tcl | 11 ++++++----- 2 files changed, 13 insertions(+), 8 deletions(-) diff --git a/library/package.tcl b/library/package.tcl index 44e3b28..d6280ae 100644 --- a/library/package.tcl +++ b/library/package.tcl @@ -479,9 +479,12 @@ proc tclPkgUnknown {name args} { } set tclSeenPath($dir) 1 - # we can't use glob in safe interps, so enclose the following in a - # catch statement, where we get the pkgIndex files out of the - # subdirectories + # Get the pkgIndex.tcl files in subdirectories of auto_path directories. + # - Safe Base interpreters have a restricted "glob" command that + # works in this case. + # - The "catch" was essential when there was no safe glob and every + # call in a safe interp failed; it is retained only for corner + # cases in which the eventual call to glob returns an error. catch { foreach file [glob -directory $dir -join -nocomplain \ * pkgIndex.tcl] { @@ -585,6 +588,7 @@ proc tcl::MacOSXPkgUnknown {original name args} { set tclSeenPath($dir) 1 # get the pkgIndex files out of the subdirectories + # Safe interpreters do not use tcl::MacOSXPkgUnknown - see init.tcl. foreach file [glob -directory $dir -join -nocomplain \ * Resources Scripts pkgIndex.tcl] { set dir [file dirname $file] diff --git a/library/tm.tcl b/library/tm.tcl index 0ed3f1a..c60084c 100644 --- a/library/tm.tcl +++ b/library/tm.tcl @@ -212,11 +212,12 @@ proc ::tcl::tm::UnknownHandler {original name args} { } set strip [llength [file split $path]] - # We can't use glob in safe interps, so enclose the following in a - # catch statement, where we get the module files out of the - # subdirectories. In other words, Tcl Modules are not-functional - # in such an interpreter. This is the same as for the command - # "tclPkgUnknown", i.e. the search for regular packages. + # Get the module files out of the subdirectories. + # - Safe Base interpreters have a restricted "glob" command that + # works in this case. + # - The "catch" was essential when there was no safe glob and every + # call in a safe interp failed; it is retained only for corner + # cases in which the eventual call to glob returns an error. catch { # We always look for _all_ possible modules in the current -- cgit v0.12 From 201d01f9da1f2fb006cc4c0fc265e552cf9c2703 Mon Sep 17 00:00:00 2001 From: kjnash Date: Sat, 18 Jul 2020 17:51:27 +0000 Subject: Add explanatory comments to safe::AliasGlob --- library/safe.tcl | 33 +++++++++++++++++++++++++++++++-- tests/safe.test | 49 +++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 80 insertions(+), 2 deletions(-) diff --git a/library/safe.tcl b/library/safe.tcl index 410a5c1..da6523c 100644 --- a/library/safe.tcl +++ b/library/safe.tcl @@ -822,19 +822,27 @@ proc ::safe::AliasGlob {slave args} { } } - # Apply the -join semantics ourselves + # Apply the -join semantics ourselves. if {$got(-join)} { set args [lreplace $args $at end [join [lrange $args $at end] "/"]] } - # Process remaining pattern arguments + # Process the pattern arguments. If we've done a join there is only one + # pattern argument. + set firstPattern [llength $cmd] foreach opt [lrange $args $at end] { if {![regexp $dirPartRE $opt -> thedir thefile]} { set thedir . + # The *.tm search comes here. } elseif {[string match ~* $thedir]} { set thedir ./$thedir } + # "Special" treatment for (joined) argument {*/pkgIndex.tcl}. + # Do the expansion of "*" here, and filter out any directories that are + # not in the access path. The outcome is to lappend to cmd a path of + # the form $virtualdir/subdir/pkgIndex.tcl for each subdirectory subdir, + # after removing any subdir that are not in the access path. if {($thedir eq "*") && ($thefile eq "pkgIndex.tcl")} { set mapped 0 foreach d [glob -directory [TranslatePath $slave $virtualdir] \ @@ -847,7 +855,19 @@ proc ::safe::AliasGlob {slave args} { } } if {$mapped} continue + # Don't [continue] if */pkgIndex.tcl has no matches in the access + # path. The pattern will now receive the same treatment as a + # "non-special" pattern (and will fail because it includes a "*" in + # the directory name). } + # Any directory pattern that is not an exact (i.e. non-glob) match to a + # directory in the access path will be rejected here. + # - Rejections include any directory pattern that has glob matching + # patterns "*", "?", backslashes, braces or square brackets, (UNLESS + # it corresponds to a genuine directory name AND that directory is in + # the access path). + # - The only "special matching characters" that remain in patterns for + # processing by glob are in the filename tail. try { DirInAccessPath $slave [TranslatePath $slave \ [file join $virtualdir $thedir]] @@ -865,8 +885,17 @@ proc ::safe::AliasGlob {slave args} { return } try { + # >>>>>>>>>> HERE'S THE CALL TO SAFE INTERP GLOB <<<<<<<<<< + # - Pattern arguments added to cmd have NOT been translated from tokens. + # Only the virtualdir is translated (to dir). + # - In the pkgIndex.tcl case, there is no "*" in the pattern arguments, + # which are a list of names each with tail pkgIndex.tcl. The purpose + # of the call to glob is to remove the names for which the file does + # not exist. set entries [::interp invokehidden $slave glob {*}$cmd] } on error msg { + # This is the only place that a call with -nocomplain and no invalid + # "dash-options" can return an error. Log $slave $msg return -code error "script error" } diff --git a/tests/safe.test b/tests/safe.test index 2683b9c..9e90236 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -1572,6 +1572,7 @@ test safe-16.1 {Bug 3529949: defang ~ in paths} -setup { } -cleanup { safe::interpDelete $i set env(HOME) $savedHOME + unset savedHOME } -result {./~} test safe-16.2 {Bug 3529949: defang ~user in paths} -setup { set i [safe::interpCreate] @@ -1581,6 +1582,7 @@ test safe-16.2 {Bug 3529949: defang ~user in paths} -setup { "file join \[file dirname ~$user\] \[file tail ~$user\]"] } -cleanup { safe::interpDelete $i + unset user } -result {./~USER} test safe-16.3 {Bug 3529949: defang ~ in globs} -setup { set syntheticHOME [makeDirectory foo] @@ -1595,6 +1597,7 @@ test safe-16.3 {Bug 3529949: defang ~ in globs} -setup { safe::interpDelete $i set env(HOME) $savedHOME removeDirectory $syntheticHOME + unset savedHOME syntheticHOME } -result {} test safe-16.4 {Bug 3529949: defang ~user in globs} -setup { set i [safe::interpCreate] @@ -1604,6 +1607,52 @@ test safe-16.4 {Bug 3529949: defang ~user in globs} -setup { } -cleanup { safe::interpDelete $i } -result {} +test safe-16.5 {Bug 3529949: defang ~ in paths used by AliasGlob (1)} -setup { + set savedHOME $env(HOME) + set env(HOME) /foo/bar + set i [safe::interpCreate] +} -body { + $i eval { + set d [format %c 126] + file join {$p(:0:)} $d + } +} -cleanup { + safe::interpDelete $i + set env(HOME) $savedHOME + unset savedHOME +} -result {~} +test safe-16.6 {Bug 3529949: defang ~ in paths used by AliasGlob (2)} -setup { + set savedHOME $env(HOME) + set env(HOME) /foo/bar + set i [safe::interpCreate] +} -body { + $i eval { + set d [format %c 126] + file join {$p(:0:)/foo/bar} $d + } +} -cleanup { + safe::interpDelete $i + set env(HOME) $savedHOME + unset savedHOME +} -result {~} +test safe-16.7 {Bug 3529949: defang ~user in paths used by AliasGlob (1)} -setup { + set i [safe::interpCreate] + set user $tcl_platform(user) +} -body { + string map [list $user USER] [$i eval [list file join {$p(:0:)} ~$user]] +} -cleanup { + safe::interpDelete $i + unset user +} -result {~USER} +test safe-16.8 {Bug 3529949: defang ~user in paths used by AliasGlob (2)} -setup { + set i [safe::interpCreate] + set user $tcl_platform(user) +} -body { + string map [list $user USER] [$i eval [list file join {$p(:0:)/foo/bar} ~$user]] +} -cleanup { + safe::interpDelete $i + unset user +} -result {~USER} set ::auto_path $SaveAutoPath unset SaveAutoPath TestsDir PathMapp -- cgit v0.12 From d12eb85c8fe92ca27b4f03950a447068c2418cb8 Mon Sep 17 00:00:00 2001 From: kjnash Date: Sat, 18 Jul 2020 18:06:30 +0000 Subject: Simplify case analysis in safe::AliasGlob --- library/safe.tcl | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/library/safe.tcl b/library/safe.tcl index da6523c..f0a14a3 100644 --- a/library/safe.tcl +++ b/library/safe.tcl @@ -820,6 +820,13 @@ proc ::safe::AliasGlob {slave args} { } else { lappend cmd -directory $dir } + } else { + # The code after this "if ... else" block would conspire to return with + # no results in this case, if it were allowed to proceed. Instead, + # return now and reduce the number of cases to be considered later. + Log $slave {option -directory must be supplied} + if {$got(-nocomplain)} return + return -code error "permission denied" } # Apply the -join semantics ourselves. -- cgit v0.12 From a541a7be4cbbd4b2e5cca7ff65b98010dc224929 Mon Sep 17 00:00:00 2001 From: kjnash Date: Sat, 18 Jul 2020 18:51:53 +0000 Subject: Remove an old fix for ~ expansion in safe::AliasGlob that is now fixed by other means --- library/safe.tcl | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/library/safe.tcl b/library/safe.tcl index f0a14a3..4540be3 100644 --- a/library/safe.tcl +++ b/library/safe.tcl @@ -842,8 +842,6 @@ proc ::safe::AliasGlob {slave args} { if {![regexp $dirPartRE $opt -> thedir thefile]} { set thedir . # The *.tm search comes here. - } elseif {[string match ~* $thedir]} { - set thedir ./$thedir } # "Special" treatment for (joined) argument {*/pkgIndex.tcl}. # Do the expansion of "*" here, and filter out any directories that are @@ -875,6 +873,12 @@ proc ::safe::AliasGlob {slave args} { # the access path). # - The only "special matching characters" that remain in patterns for # processing by glob are in the filename tail. + # - [file join $anything ~${foo}] is ~${foo}, which is not an exact + # match to any directory in the access path. Hence directory patterns + # that begin with "~" are rejected here. Tests safe-16.[5-8] check + # that "file join" remains as required and does not expand ~${foo}. + # - Bug [3529949] relates to unwanted expansion of ~${foo} and this is + # how the present code avoids the bug. All tests safe-16.* relate. try { DirInAccessPath $slave [TranslatePath $slave \ [file join $virtualdir $thedir]] -- cgit v0.12 From a15ea81906fdac4ed3868e9866d07a8ca4c2354c Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 20 Jul 2020 07:33:42 +0000 Subject: Backport changes in tcltest package from higher Tcl versions. Rename (internal, undocumented) tcltest::loadIntoSlaveInterpreter into tcltest::loadIntoChildInterpreter tcltest 2.5.1 -> 2.5.3 --- library/tcltest/pkgIndex.tcl | 2 +- library/tcltest/tcltest.tcl | 35 +++++++++++++++++++++++------------ tests/init.test | 10 +++++----- tests/pkg.test | 4 ++-- unix/Makefile.in | 4 ++-- win/Makefile.in | 4 ++-- 6 files changed, 35 insertions(+), 24 deletions(-) diff --git a/library/tcltest/pkgIndex.tcl b/library/tcltest/pkgIndex.tcl index ca93725..a56a0d6 100644 --- a/library/tcltest/pkgIndex.tcl +++ b/library/tcltest/pkgIndex.tcl @@ -9,4 +9,4 @@ # full path name of this file's directory. if {![package vsatisfies [package provide Tcl] 8.5-]} {return} -package ifneeded tcltest 2.5.1 [list source [file join $dir tcltest.tcl]] +package ifneeded tcltest 2.5.3 [list source [file join $dir tcltest.tcl]] diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl index 1394949..c894ff1 100644 --- a/library/tcltest/tcltest.tcl +++ b/library/tcltest/tcltest.tcl @@ -22,7 +22,7 @@ namespace eval tcltest { # When the version number changes, be sure to update the pkgIndex.tcl file, # and the install directory in the Makefiles. When the minor version # changes (new feature) be sure to update the man page as well. - variable Version 2.5.1 + variable Version 2.5.3 # Compatibility support for dumb variables defined in tcltest 1 # Do not use these. Call [package provide Tcl] and [info patchlevel] @@ -811,14 +811,14 @@ namespace eval tcltest { trace add variable Option(-errfile) write \ [namespace code {errorChannel $Option(-errfile) ;#}] - proc loadIntoSlaveInterpreter {slave args} { + proc loadIntoChildInterpreter {child args} { variable Version - interp eval $slave [package ifneeded tcltest $Version] - interp eval $slave "tcltest::configure {*}{$args}" - interp alias $slave ::tcltest::ReportToMaster \ - {} ::tcltest::ReportedFromSlave + interp eval $child [package ifneeded tcltest $Version] + interp eval $child "tcltest::configure {*}{$args}" + interp alias $child ::tcltest::ReportToParent \ + {} ::tcltest::ReportedFromChild } - proc ReportedFromSlave {total passed skipped failed because newfiles} { + proc ReportedFromChild {total passed skipped failed because newfiles} { variable numTests variable skippedBecause variable createdNewFiles @@ -1982,7 +1982,10 @@ proc tcltest::test {name description args} { } } - # First, run the setup script + # First, run the setup script (or a hook if it presents): + if {[set cmd [namespace which -command [namespace current]::SetupTest]] ne ""} { + set setup [list $cmd $setup] + } set processTest 1 set code [catch {uplevel 1 $setup} setupMsg] if {$code == 1} { @@ -2077,7 +2080,10 @@ proc tcltest::test {name description args} { set scriptFailure 1 } - # Always run the cleanup script + # Always run the cleanup script (or a hook if it presents): + if {[set cmd [namespace which -command [namespace current]::CleanupTest]] ne ""} { + set cleanup [list $cmd $cleanup] + } set code [catch {uplevel 1 $cleanup} cleanupMsg] if {$code == 1} { set errorInfo(cleanup) $::errorInfo @@ -2390,6 +2396,10 @@ proc tcltest::RunTest {name script} { memory tag $name } + # run the test script (or a hook if it presents): + if {[set cmd [namespace which -command [namespace current]::EvalTest]] ne ""} { + set script [list $cmd $script] + } set code [catch {uplevel 1 $script} actualAnswer] return [list $actualAnswer $code] @@ -2452,8 +2462,8 @@ proc tcltest::cleanupTests {{calledFromAllFile 0}} { set testFileName [file tail [info script]] # Hook to handle reporting to a parent interpreter - if {[llength [info commands [namespace current]::ReportToMaster]]} { - ReportToMaster $numTests(Total) $numTests(Passed) $numTests(Skipped) \ + if {[llength [info commands [namespace current]::ReportToParent]]} { + ReportToParent $numTests(Total) $numTests(Passed) $numTests(Skipped) \ $numTests(Failed) [array get skippedBecause] \ [array get createdNewFiles] set testSingleFile false @@ -3097,11 +3107,12 @@ proc tcltest::removeFile {name {directory ""}} { set fullName [file join $directory $name] DebugPuts 3 "[lindex [info level 0] 0]: removing $fullName" set idx [lsearch -exact $filesMade $fullName] - set filesMade [lreplace $filesMade $idx $idx] if {$idx == -1} { DebugDo 1 { Warn "removeFile removing \"$fullName\":\n not created by makeFile" } + } else { + set filesMade [lreplace $filesMade $idx $idx] } if {![file isfile $fullName]} { DebugDo 1 { diff --git a/tests/init.test b/tests/init.test index d56c72d..9c81694 100644 --- a/tests/init.test +++ b/tests/init.test @@ -19,16 +19,16 @@ if {[lsearch [namespace children] ::tcltest] == -1} { catch {namespace delete {*}[namespace children :: test_ns_*]} test init-0.1 {no error on initialization phase (init.tcl)} -setup { - interp create slave + interp create child } -body { - slave eval { + child eval { list [set v [info exists ::errorInfo]] \ [if {$v} {set ::errorInfo}] \ [set v [info exists ::errorCode]] \ [if {$v} {set ::errorCode}] } } -cleanup { - interp delete slave + interp delete child } -result {0 {} 0 {}} # Six cases - white box testing @@ -68,11 +68,11 @@ test init-1.8 {auto_qualify - multiple colons 2} { } foo -# we use a sub interp and auto_reset and double the tests because there is 2 +# we use a child interp and auto_reset and double the tests because there is 2 # places where auto_loading occur (before loading the indexes files and after) set testInterp [interp create] -tcltest::loadIntoSlaveInterpreter $testInterp {*}$argv +tcltest::loadIntoChildInterpreter $testInterp {*}$argv interp eval $testInterp { namespace import -force ::tcltest::* auto_reset diff --git a/tests/pkg.test b/tests/pkg.test index 10b4732..21f898c 100644 --- a/tests/pkg.test +++ b/tests/pkg.test @@ -16,10 +16,10 @@ if {[lsearch [namespace children] ::tcltest] == -1} { namespace import -force ::tcltest::* } -# Do all this in a slave interp to avoid garbaging the +# Do all this in a child interp to avoid garbaging the # package list set i [interp create] -tcltest::loadIntoSlaveInterpreter $i {*}$argv +tcltest::loadIntoChildInterpreter $i {*}$argv interp eval $i { namespace import -force ::tcltest::* diff --git a/unix/Makefile.in b/unix/Makefile.in index c20ba57..fd44f4e 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -788,8 +788,8 @@ install-libraries: libraries $(INSTALL_TZDATA) install-msgs done; @echo "Installing package msgcat 1.5.2 as a Tcl Module"; @$(INSTALL_DATA) $(TOP_DIR)/library/msgcat/msgcat.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/msgcat-1.5.2.tm; - @echo "Installing package tcltest 2.5.1 as a Tcl Module"; - @$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/tcltest-2.5.1.tm; + @echo "Installing package tcltest 2.5.3 as a Tcl Module"; + @$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/tcltest-2.5.3.tm; @echo "Installing package platform 1.0.14 as a Tcl Module"; @$(INSTALL_DATA) $(TOP_DIR)/library/platform/platform.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.4/platform-1.0.14.tm; diff --git a/win/Makefile.in b/win/Makefile.in index 63f4c15..25a919a 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -671,8 +671,8 @@ install-libraries: libraries install-tzdata install-msgs done; @echo "Installing package msgcat 1.5.2 as a Tcl Module"; @$(COPY) $(ROOT_DIR)/library/msgcat/msgcat.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/msgcat-1.5.2.tm; - @echo "Installing package tcltest 2.5.1 as a Tcl Module"; - @$(COPY) $(ROOT_DIR)/library/tcltest/tcltest.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/tcltest-2.5.1.tm; + @echo "Installing package tcltest 2.5.3 as a Tcl Module"; + @$(COPY) $(ROOT_DIR)/library/tcltest/tcltest.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/tcltest-2.5.3.tm; @echo "Installing package platform 1.0.14 as a Tcl Module"; @$(COPY) $(ROOT_DIR)/library/platform/platform.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.4/platform-1.0.14.tm; @echo "Installing package platform::shell 1.1.4 as a Tcl Module"; -- cgit v0.12 From 99d517e3cba02eeef2d49f6447db7dce60c611f6 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 20 Jul 2020 14:25:11 +0000 Subject: Use "Global" in stead of "Master" internally, where "Master" is not used in the Master-Slave paradigm and where this makes sense. --- generic/tclInt.h | 28 ++++++++++---------- generic/tclThread.c | 22 ++++++++-------- generic/tclThreadStorage.c | 32 +++++++++++------------ generic/tclUtil.c | 4 +-- unix/tclUnixThrd.c | 52 ++++++++++++++++++------------------- win/tclWinThrd.c | 64 +++++++++++++++++++++++----------------------- 6 files changed, 101 insertions(+), 101 deletions(-) diff --git a/generic/tclInt.h b/generic/tclInt.h index dfb3dfe..31108c7 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -1804,7 +1804,7 @@ typedef struct Interp { * of hidden commands on a per-interp * basis. */ ClientData interpInfo; /* Information used by tclInterp.c to keep - * track of master/slave interps on a + * track of parent/child interps on a * per-interp basis. */ union { void (*optimizer)(void *envPtr); @@ -2082,7 +2082,7 @@ typedef struct Interp { * (c) are accessed very often (e.g., at each command call) * * Note that these are the same for all interps in the same thread. They - * just have to be initialised for the thread's master interp, slaves + * just have to be initialised for the thread's parent interp, children * inherit the value. * * They are used by the macros defined below. @@ -2600,20 +2600,20 @@ typedef void (TclInitProcessGlobalValueProc)(char **valuePtr, int *lengthPtr, /* * A ProcessGlobalValue struct exists for each internal value in Tcl that is * to be shared among several threads. Each thread sees a (Tcl_Obj) copy of - * the value, and the master is kept as a counted string, with epoch and mutex - * control. Each ProcessGlobalValue struct should be a static variable in some - * file. + * the value, and the gobal value is kept as a counted string, with epoch and + * mutex control. Each ProcessGlobalValue struct should be a static variable in + * some file. */ typedef struct ProcessGlobalValue { int epoch; /* Epoch counter to detect changes in the - * master value. */ - int numBytes; /* Length of the master string. */ - char *value; /* The master string value. */ - Tcl_Encoding encoding; /* system encoding when master string was + * global value. */ + int numBytes; /* Length of the global string. */ + char *value; /* The global string value. */ + Tcl_Encoding encoding; /* system encoding when global string was * initialized. */ TclInitProcessGlobalValueProc *proc; - /* A procedure to initialize the master string + /* A procedure to initialize the global string * copy when a "get" request comes in before * any "set" request has been received. */ Tcl_Mutex mutex; /* Enforce orderly access from multiple @@ -3097,8 +3097,8 @@ MODULE_SCOPE void TclpInitLock(void); MODULE_SCOPE void TclpInitPlatform(void); MODULE_SCOPE void TclpInitUnlock(void); MODULE_SCOPE Tcl_Obj * TclpObjListVolumes(void); -MODULE_SCOPE void TclpMasterLock(void); -MODULE_SCOPE void TclpMasterUnlock(void); +MODULE_SCOPE void TclpGlobalLock(void); +MODULE_SCOPE void TclpGlobalUnlock(void); MODULE_SCOPE int TclpMatchFiles(Tcl_Interp *interp, char *separators, Tcl_DString *dirPtr, char *pattern, char *tail); MODULE_SCOPE int TclpObjNormalizePath(Tcl_Interp *interp, @@ -3242,8 +3242,8 @@ MODULE_SCOPE Tcl_WideInt TclpGetMicroseconds(void); MODULE_SCOPE int TclZlibInit(Tcl_Interp *interp); MODULE_SCOPE void * TclpThreadCreateKey(void); MODULE_SCOPE void TclpThreadDeleteKey(void *keyPtr); -MODULE_SCOPE void TclpThreadSetMasterTSD(void *tsdKeyPtr, void *ptr); -MODULE_SCOPE void * TclpThreadGetMasterTSD(void *tsdKeyPtr); +MODULE_SCOPE void TclpThreadSetGlobalTSD(void *tsdKeyPtr, void *ptr); +MODULE_SCOPE void * TclpThreadGetGlobalTSD(void *tsdKeyPtr); MODULE_SCOPE void TclErrorStackResetIf(Tcl_Interp *interp, const char *msg, int length); diff --git a/generic/tclThread.c b/generic/tclThread.c index 198fa6a..8915792 100644 --- a/generic/tclThread.c +++ b/generic/tclThread.c @@ -141,7 +141,7 @@ TclThreadDataKeyGet( * Keep a list of (mutexes/condition variable/data key) used during * finalization. * - * Assume master lock is held. + * Assume global lock is held. * * Results: * None. @@ -202,7 +202,7 @@ RememberSyncObject( * ForgetSyncObject * * Remove a single object from the list. - * Assume master lock is held. + * Assume global lock is held. * * Results: * None. @@ -234,7 +234,7 @@ ForgetSyncObject( * TclRememberMutex * * Keep a list of mutexes used during finalization. - * Assume master lock is held. + * Assume global lock is held. * * Results: * None. @@ -276,9 +276,9 @@ Tcl_MutexFinalize( #ifdef TCL_THREADS TclpFinalizeMutex(mutexPtr); #endif - TclpMasterLock(); + TclpGlobalLock(); ForgetSyncObject(mutexPtr, &mutexRecord); - TclpMasterUnlock(); + TclpGlobalUnlock(); } /* @@ -287,7 +287,7 @@ Tcl_MutexFinalize( * TclRememberCondition * * Keep a list of condition variables used during finalization. - * Assume master lock is held. + * Assume global lock is held. * * Results: * None. @@ -329,9 +329,9 @@ Tcl_ConditionFinalize( #ifdef TCL_THREADS TclpFinalizeCondition(condPtr); #endif - TclpMasterLock(); + TclpGlobalLock(); ForgetSyncObject(condPtr, &condRecord); - TclpMasterUnlock(); + TclpGlobalUnlock(); } /* @@ -393,7 +393,7 @@ TclFinalizeSynchronization(void) Tcl_Mutex *mutexPtr; Tcl_Condition *condPtr; - TclpMasterLock(); + TclpGlobalLock(); #endif /* @@ -415,7 +415,7 @@ TclFinalizeSynchronization(void) #ifdef TCL_THREADS /* - * Call thread storage master cleanup. + * Call thread storage global cleanup. */ TclFinalizeThreadStorage(); @@ -446,7 +446,7 @@ TclFinalizeSynchronization(void) condRecord.max = 0; condRecord.num = 0; - TclpMasterUnlock(); + TclpGlobalUnlock(); #endif /* TCL_THREADS */ } diff --git a/generic/tclThreadStorage.c b/generic/tclThreadStorage.c index 755a461..ad8c50f 100644 --- a/generic/tclThreadStorage.c +++ b/generic/tclThreadStorage.c @@ -27,11 +27,11 @@ */ /* - * The master collection of information about TSDs. This is shared across the + * The global collection of information about TSDs. This is shared across the * whole process, and includes the mutex used to protect it. */ -static struct TSDMaster { +static struct { void *key; /* Key into the system TSD structure. The * collection of Tcl TSD values for a * particular thread will hang off the @@ -41,13 +41,13 @@ static struct TSDMaster { * increasing value. */ Tcl_Mutex mutex; /* Protection for the rest of this structure, * which holds per-process data. */ -} tsdMaster = { NULL, 0, NULL }; +} tsdGlobal = { NULL, 0, NULL }; /* * The type of the data held per thread in a system TSD. */ -typedef struct TSDTable { +typedef struct { ClientData *tablePtr; /* The table of Tcl TSDs. */ sig_atomic_t allocated; /* The size of the table in the current * thread. */ @@ -57,7 +57,7 @@ typedef struct TSDTable { * The actual type of Tcl_ThreadDataKey. */ -typedef union TSDUnion { +typedef union { volatile sig_atomic_t offset; /* The type is really an offset into the * thread-local table of TSDs, which is this @@ -189,7 +189,7 @@ void * TclThreadStorageKeyGet( Tcl_ThreadDataKey *dataKeyPtr) { - TSDTable *tsdTablePtr = TclpThreadGetMasterTSD(tsdMaster.key); + TSDTable *tsdTablePtr = TclpThreadGetGlobalTSD(tsdGlobal.key); ClientData resultPtr = NULL; TSDUnion *keyPtr = (TSDUnion *) dataKeyPtr; sig_atomic_t offset = keyPtr->offset; @@ -223,12 +223,12 @@ TclThreadStorageKeySet( Tcl_ThreadDataKey *dataKeyPtr, void *value) { - TSDTable *tsdTablePtr = TclpThreadGetMasterTSD(tsdMaster.key); + TSDTable *tsdTablePtr = TclpThreadGetGlobalTSD(tsdGlobal.key); TSDUnion *keyPtr = (TSDUnion *) dataKeyPtr; if (tsdTablePtr == NULL) { tsdTablePtr = TSDTableCreate(); - TclpThreadSetMasterTSD(tsdMaster.key, tsdTablePtr); + TclpThreadSetGlobalTSD(tsdGlobal.key, tsdTablePtr); } /* @@ -240,15 +240,15 @@ TclThreadStorageKeySet( */ if (keyPtr->offset == 0) { - Tcl_MutexLock(&tsdMaster.mutex); + Tcl_MutexLock(&tsdGlobal.mutex); if (keyPtr->offset == 0) { /* * The Tcl_ThreadDataKey hasn't been used yet. Make a new one. */ - keyPtr->offset = ++tsdMaster.counter; + keyPtr->offset = ++tsdGlobal.counter; } - Tcl_MutexUnlock(&tsdMaster.mutex); + Tcl_MutexUnlock(&tsdGlobal.mutex); } /* @@ -288,11 +288,11 @@ TclThreadStorageKeySet( void TclFinalizeThreadDataThread(void) { - TSDTable *tsdTablePtr = TclpThreadGetMasterTSD(tsdMaster.key); + TSDTable *tsdTablePtr = TclpThreadGetGlobalTSD(tsdGlobal.key); if (tsdTablePtr != NULL) { TSDTableDelete(tsdTablePtr); - TclpThreadSetMasterTSD(tsdMaster.key, NULL); + TclpThreadSetGlobalTSD(tsdGlobal.key, NULL); } } @@ -316,7 +316,7 @@ TclFinalizeThreadDataThread(void) void TclInitThreadStorage(void) { - tsdMaster.key = TclpThreadCreateKey(); + tsdGlobal.key = TclpThreadCreateKey(); } /* @@ -339,8 +339,8 @@ TclInitThreadStorage(void) void TclFinalizeThreadStorage(void) { - TclpThreadDeleteKey(tsdMaster.key); - tsdMaster.key = NULL; + TclpThreadDeleteKey(tsdGlobal.key); + tsdGlobal.key = NULL; } #else /* !TCL_THREADS */ diff --git a/generic/tclUtil.c b/generic/tclUtil.c index a9819d5..9efdbc3 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -4263,8 +4263,8 @@ TclGetProcessGlobalValue( if (pgvPtr->encoding != current) { /* - * The system encoding has changed since the master string value - * was saved. Convert the master value to be based on the new + * The system encoding has changed since the global string value + * was saved. Convert the global value to be based on the new * system encoding. */ diff --git a/unix/tclUnixThrd.c b/unix/tclUnixThrd.c index ef8e737..68852a1 100644 --- a/unix/tclUnixThrd.c +++ b/unix/tclUnixThrd.c @@ -22,23 +22,23 @@ typedef struct ThreadSpecificData { static Tcl_ThreadDataKey dataKey; /* - * masterLock is used to serialize creation of mutexes, condition variables, + * globalLock is used to serialize creation of mutexes, condition variables, * and thread local storage. This is the only place that can count on the * ability to statically initialize the mutex. */ -static pthread_mutex_t masterLock = PTHREAD_MUTEX_INITIALIZER; +static pthread_mutex_t globalLock = PTHREAD_MUTEX_INITIALIZER; /* * initLock is used to serialize initialization and finalization of Tcl. It - * cannot use any dyamically allocated storage. + * cannot use any dynamically allocated storage. */ static pthread_mutex_t initLock = PTHREAD_MUTEX_INITIALIZER; /* * allocLock is used by Tcl's version of malloc for synchronization. For - * obvious reasons, cannot use any dyamically allocated storage. + * obvious reasons, cannot use any dynamically allocated storage. */ static pthread_mutex_t allocLock = PTHREAD_MUTEX_INITIALIZER; @@ -48,8 +48,8 @@ static pthread_mutex_t *allocLockPtr = &allocLock; * These are for the critical sections inside this file. */ -#define MASTER_LOCK pthread_mutex_lock(&masterLock) -#define MASTER_UNLOCK pthread_mutex_unlock(&masterLock) +#define GLOBAL_LOCK pthread_mutex_lock(&globalLock) +#define GLOBAL_UNLOCK pthread_mutex_unlock(&globalLock) #endif /* TCL_THREADS */ @@ -274,7 +274,7 @@ TclFinalizeLock(void) /* * You do not need to destroy mutexes that were created with the * PTHREAD_MUTEX_INITIALIZER macro. These mutexes do not need any - * destruction: masterLock, allocLock, and initLock. + * destruction: globalLock, allocLock, and initLock. */ pthread_mutex_unlock(&initLock); @@ -309,7 +309,7 @@ TclpInitUnlock(void) /* *---------------------------------------------------------------------- * - * TclpMasterLock + * TclpGlobalLock * * This procedure is used to grab a lock that serializes creation and * finalization of serialization objects. This interface is only needed @@ -322,16 +322,16 @@ TclpInitUnlock(void) * None. * * Side effects: - * Acquire the master mutex. + * Acquire the global mutex. * *---------------------------------------------------------------------- */ void -TclpMasterLock(void) +TclpGlobalLock(void) { #ifdef TCL_THREADS - pthread_mutex_lock(&masterLock); + pthread_mutex_lock(&globalLock); #endif } @@ -339,7 +339,7 @@ TclpMasterLock(void) /* *---------------------------------------------------------------------- * - * TclpMasterUnlock + * TclpGlobalUnlock * * This procedure is used to release a lock that serializes creation and * finalization of synchronization objects. @@ -348,16 +348,16 @@ TclpMasterLock(void) * None. * * Side effects: - * Release the master mutex. + * Release the global mutex. * *---------------------------------------------------------------------- */ void -TclpMasterUnlock(void) +TclpGlobalUnlock(void) { #ifdef TCL_THREADS - pthread_mutex_unlock(&masterLock); + pthread_mutex_unlock(&globalLock); #endif } @@ -367,7 +367,7 @@ TclpMasterUnlock(void) * Tcl_GetAllocMutex * * This procedure returns a pointer to a statically initialized mutex for - * use by the memory allocator. The alloctor must use this lock, because + * use by the memory allocator. The allocator must use this lock, because * all other locks are allocated... * * Results: @@ -421,10 +421,10 @@ Tcl_MutexLock( pthread_mutex_t *pmutexPtr; if (*mutexPtr == NULL) { - MASTER_LOCK; + GLOBAL_LOCK; if (*mutexPtr == NULL) { /* - * Double inside master lock check to avoid a race condition. + * Double inside global lock check to avoid a race condition. */ pmutexPtr = ckalloc(sizeof(pthread_mutex_t)); @@ -432,7 +432,7 @@ Tcl_MutexLock( *mutexPtr = (Tcl_Mutex)pmutexPtr; TclRememberMutex(mutexPtr); } - MASTER_UNLOCK; + GLOBAL_UNLOCK; } pmutexPtr = *((pthread_mutex_t **)mutexPtr); pthread_mutex_lock(pmutexPtr); @@ -472,7 +472,7 @@ Tcl_MutexUnlock( * This procedure is invoked to clean up one mutex. This is only safe to * call at the end of time. * - * This assumes the Master Lock is held. + * This assumes the Global Lock is held. * * Results: * None. @@ -529,7 +529,7 @@ Tcl_ConditionWait( struct timespec ptime; if (*condPtr == NULL) { - MASTER_LOCK; + GLOBAL_LOCK; /* * Double check inside mutex to avoid race, then initialize condition @@ -542,7 +542,7 @@ Tcl_ConditionWait( *condPtr = (Tcl_Condition) pcondPtr; TclRememberCondition(condPtr); } - MASTER_UNLOCK; + GLOBAL_UNLOCK; } pmutexPtr = *((pthread_mutex_t **)mutexPtr); pcondPtr = *((pthread_cond_t **)condPtr); @@ -605,7 +605,7 @@ Tcl_ConditionNotify( * This procedure is invoked to clean up a condition variable. This is * only safe to call at the end of time. * - * This assumes the Master Lock is held. + * This assumes the Global Lock is held. * * Results: * None. @@ -793,19 +793,19 @@ TclpThreadDeleteKey( } void -TclpThreadSetMasterTSD( +TclpThreadSetGlobalTSD( void *tsdKeyPtr, void *ptr) { pthread_key_t *ptkeyPtr = tsdKeyPtr; if (pthread_setspecific(*ptkeyPtr, ptr)) { - Tcl_Panic("unable to set master TSD value"); + Tcl_Panic("unable to set global TSD value"); } } void * -TclpThreadGetMasterTSD( +TclpThreadGetGlobalTSD( void *tsdKeyPtr) { pthread_key_t *ptkeyPtr = tsdKeyPtr; diff --git a/win/tclWinThrd.c b/win/tclWinThrd.c index 5316075..44b5f6c 100644 --- a/win/tclWinThrd.c +++ b/win/tclWinThrd.c @@ -24,18 +24,18 @@ _CRTIMP unsigned int __cdecl _controlfp (unsigned int unNew, unsigned int unMask #endif /* - * This is the master lock used to serialize access to other serialization + * This is the global lock used to serialize access to other serialization * data structures. */ -static CRITICAL_SECTION masterLock; +static CRITICAL_SECTION globalLock; static int init = 0; -#define MASTER_LOCK TclpMasterLock() -#define MASTER_UNLOCK TclpMasterUnlock() +#define GLOBAL_LOCK TclpGlobalLock() +#define GLOBAL_UNLOCK TclpGlobalUnlock() /* - * This is the master lock used to serialize initialization and finalization + * This is the global lock used to serialize initialization and finalization * of Tcl as a whole. */ @@ -43,7 +43,7 @@ static CRITICAL_SECTION initLock; /* * allocLock is used by Tcl's version of malloc for synchronization. For - * obvious reasons, cannot use any dyamically allocated storage. + * obvious reasons, cannot use any dynamically allocated storage. */ #ifdef TCL_THREADS @@ -368,7 +368,7 @@ TclpInitLock(void) init = 1; InitializeCriticalSection(&joinLock); InitializeCriticalSection(&initLock); - InitializeCriticalSection(&masterLock); + InitializeCriticalSection(&globalLock); } EnterCriticalSection(&initLock); } @@ -399,7 +399,7 @@ TclpInitUnlock(void) /* *---------------------------------------------------------------------- * - * TclpMasterLock + * TclpGlobalLock * * This procedure is used to grab a lock that serializes creation of * mutexes, condition variables, and thread local storage keys. @@ -411,13 +411,13 @@ TclpInitUnlock(void) * None. * * Side effects: - * Acquire the master mutex. + * Acquire the global mutex. * *---------------------------------------------------------------------- */ void -TclpMasterLock(void) +TclpGlobalLock(void) { if (!init) { /* @@ -430,15 +430,15 @@ TclpMasterLock(void) init = 1; InitializeCriticalSection(&joinLock); InitializeCriticalSection(&initLock); - InitializeCriticalSection(&masterLock); + InitializeCriticalSection(&globalLock); } - EnterCriticalSection(&masterLock); + EnterCriticalSection(&globalLock); } /* *---------------------------------------------------------------------- * - * TclpMasterUnlock + * TclpGlobalUnlock * * This procedure is used to release a lock that serializes creation and * deletion of synchronization objects. @@ -447,15 +447,15 @@ TclpMasterLock(void) * None. * * Side effects: - * Release the master mutex. + * Release the global mutex. * *---------------------------------------------------------------------- */ void -TclpMasterUnlock(void) +TclpGlobalUnlock(void) { - LeaveCriticalSection(&masterLock); + LeaveCriticalSection(&globalLock); } /* @@ -464,7 +464,7 @@ TclpMasterUnlock(void) * Tcl_GetAllocMutex * * This procedure returns a pointer to a statically initialized mutex for - * use by the memory allocator. The alloctor must use this lock, because + * use by the memory allocator. The allocator must use this lock, because * all other locks are allocated... * * Results: @@ -512,14 +512,14 @@ Tcl_GetAllocMutex(void) void TclFinalizeLock(void) { - MASTER_LOCK; + GLOBAL_LOCK; DeleteCriticalSection(&joinLock); /* * Destroy the critical section that we are holding! */ - DeleteCriticalSection(&masterLock); + DeleteCriticalSection(&globalLock); init = 0; #ifdef TCL_THREADS @@ -567,10 +567,10 @@ Tcl_MutexLock( CRITICAL_SECTION *csPtr; if (*mutexPtr == NULL) { - MASTER_LOCK; + GLOBAL_LOCK; /* - * Double inside master lock check to avoid a race. + * Double inside global lock check to avoid a race. */ if (*mutexPtr == NULL) { @@ -579,7 +579,7 @@ Tcl_MutexLock( *mutexPtr = (Tcl_Mutex)csPtr; TclRememberMutex(mutexPtr); } - MASTER_UNLOCK; + GLOBAL_UNLOCK; } csPtr = *((CRITICAL_SECTION **)mutexPtr); EnterCriticalSection(csPtr); @@ -681,7 +681,7 @@ Tcl_ConditionWait( */ if (tsdPtr->flags == WIN_THREAD_UNINIT) { - MASTER_LOCK; + GLOBAL_LOCK; /* * Create the per-thread event and queue pointers. @@ -695,14 +695,14 @@ Tcl_ConditionWait( tsdPtr->flags = WIN_THREAD_RUNNING; doExit = 1; } - MASTER_UNLOCK; + GLOBAL_UNLOCK; if (doExit) { /* * Create a per-thread exit handler to clean up the condEvent. We - * must be careful to do this outside the Master Lock because + * must be careful to do this outside the Global Lock because * Tcl_CreateThreadExitHandler uses its own ThreadSpecificData, - * and initializing that may drop back into the Master Lock. + * and initializing that may drop back into the Global Lock. */ Tcl_CreateThreadExitHandler(FinalizeConditionEvent, tsdPtr); @@ -710,7 +710,7 @@ Tcl_ConditionWait( } if (*condPtr == NULL) { - MASTER_LOCK; + GLOBAL_LOCK; /* * Initialize the per-condition queue pointers and Mutex. @@ -724,7 +724,7 @@ Tcl_ConditionWait( *condPtr = (Tcl_Condition) winCondPtr; TclRememberCondition(condPtr); } - MASTER_UNLOCK; + GLOBAL_UNLOCK; } csPtr = *((CRITICAL_SECTION **)mutexPtr); winCondPtr = *((WinCondition **)condPtr); @@ -902,7 +902,7 @@ FinalizeConditionEvent( * This procedure is invoked to clean up a condition variable. This is * only safe to call at the end of time. * - * This assumes the Master Lock is held. + * This assumes the Global Lock is held. * * Results: * None. @@ -1073,19 +1073,19 @@ TclpThreadDeleteKey( } void -TclpThreadSetMasterTSD( +TclpThreadSetGlobalTSD( void *tsdKeyPtr, void *ptr) { DWORD *key = tsdKeyPtr; if (!TlsSetValue(*key, ptr)) { - Tcl_Panic("unable to set master TSD value"); + Tcl_Panic("unable to set global TSD value"); } } void * -TclpThreadGetMasterTSD( +TclpThreadGetGlobalTSD( void *tsdKeyPtr) { DWORD *key = tsdKeyPtr; -- cgit v0.12 From e6a9f22409462ec90bb2009619173c4228809317 Mon Sep 17 00:00:00 2001 From: kjnash Date: Mon, 20 Jul 2020 22:32:28 +0000 Subject: File tests/safe.test - rearrange tests - move tests of command/package loading that use Tcl files to new file tests/safe-stock86.test; renumber tests 9.8+ and add test 9.8 to replace old 5.1; move tests 7.0* to 5.*. --- tests/safe-stock86.test | 116 ++++++++++++++++++++++++++++++++ tests/safe.test | 172 ++++++++++++++++++++++-------------------------- 2 files changed, 193 insertions(+), 95 deletions(-) create mode 100644 tests/safe-stock86.test diff --git a/tests/safe-stock86.test b/tests/safe-stock86.test new file mode 100644 index 0000000..2fbe108 --- /dev/null +++ b/tests/safe-stock86.test @@ -0,0 +1,116 @@ +# safe-stock86.test -- +# +# This file contains tests for safe Tcl that were previously in the file +# safe.test, and use files and packages of stock Tcl 8.6 to perform the tests. +# These files may be changed or disappear in future revisions of Tcl, for +# example package http 1.0 will be removed from Tcl 8.7. +# +# The tests are replaced in safe.tcl with tests that use files provided in the +# tests directory. Test numbering is for comparison with similar tests in +# safe.test. +# +# Sourcing this file into tcl runs the tests and generates output for errors. +# No output means no errors were found. +# +# Copyright (c) 1995-1996 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# +# See the file "license.terms" for information on usage and redistribution of +# this file, and for a DISCLAIMER OF ALL WARRANTIES. + +package require Tcl 8.5- + +if {[lsearch [namespace children] ::tcltest] == -1} { + package require tcltest 2 + namespace import -force ::tcltest::* +} + +foreach i [interp slaves] { + interp delete $i +} + +set SaveAutoPath $::auto_path +set ::auto_path [info library] +set TestsDir [file normalize [file dirname [info script]]] +set PathMapp [list $tcl_library TCLLIB $TestsDir TESTSDIR] + +proc mapList {map listIn} { + set listOut {} + foreach element $listIn { + lappend listOut [string map $map $element] + } + return $listOut +} + +# Force actual loading of the safe package because we use un-exported (and +# thus un-autoindexed) APIs in this test result arguments: +catch {safe::interpConfigure} + +# testing that nested and statics do what is advertised (we use a static +# package - Tcltest - but it might be absent if we're in standard tclsh) + +testConstraint TcltestPackage [expr {![catch {package require Tcltest}]}] + +# high level general test +test safe-stock86-7.1 {tests that everything works at high level, uses http 2} -body { + set i [safe::interpCreate] + # no error shall occur: + # (because the default access_path shall include 1st level sub dirs so + # package require in a slave works like in the master) + set v [interp eval $i {package require http 2}] + # no error shall occur: + interp eval $i {http::config} + safe::interpDelete $i + set v +} -match glob -result 2.* +test safe-stock86-7.2 {tests specific path and interpFind/AddToAccessPath, uses http1.0} -body { + set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]] + # should not add anything (p0) + set token1 [safe::interpAddToAccessPath $i [info library]] + # should add as p1 + set token2 [safe::interpAddToAccessPath $i "/dummy/unixlike/test/path"] + set confA [safe::interpConfigure $i] + set mappA [mapList $PathMapp [dict get $confA -accessPath]] + # an error shall occur (http is not anymore in the secure 0-level + # provided deep path) + list $token1 $token2 -- \ + [catch {interp eval $i {package require http 1}} msg] $msg -- \ + $mappA -- [safe::interpDelete $i] +} -match glob -result {{$p(:0:)} {$p(:*:)} -- 1 {can't find package http 1} --\ + {TCLLIB */dummy/unixlike/test/path} -- {}} +test safe-stock86-7.4 {tests specific path and positive search, uses http1.0} -body { + set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]] + # should not add anything (p0) + set token1 [safe::interpAddToAccessPath $i [info library]] + # should add as p1 + set token2 [safe::interpAddToAccessPath $i [file join [info library] http1.0]] + set confA [safe::interpConfigure $i] + set mappA [mapList $PathMapp [dict get $confA -accessPath]] + # this time, unlike test safe-stock86-7.2, http should be found + list $token1 $token2 -- \ + [catch {interp eval $i {package require http 1}} msg] $msg -- \ + $mappA -- [safe::interpDelete $i] +} -match glob -result {{$p(:0:)} {$p(:*:)} -- 0 1.0 -- {TCLLIB *TCLLIB/http1.0} -- {}} + +# The following test checks whether the definition of tcl_endOfWord can be +# obtained from auto_loading. It was previously test "safe-5.1". +test safe-stock86-9.8 {test auto-loading in safe interpreters, was test 5.1} -setup { + catch {safe::interpDelete a} + safe::interpCreate a +} -body { + interp eval a {tcl_endOfWord "" 0} +} -cleanup { + safe::interpDelete a +} -result -1 + +set ::auto_path $SaveAutoPath +unset SaveAutoPath TestsDir PathMapp +rename mapList {} + +# cleanup +::tcltest::cleanupTests +return + +# Local Variables: +# mode: tcl +# End: diff --git a/tests/safe.test b/tests/safe.test index 9e90236..3511625 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -4,6 +4,17 @@ # using safe interpreters. Sourcing this file into tcl runs the tests and # generates output for errors. No output means no errors were found. # +# The package http 1.0 is convenient for testing package loading, but will soon +# be removed. +# - Tests that use http are replaced here with tests that use example packages +# provided in subdirectory auto0 of the tests directory, which are independent +# of any changes made to the packages provided with Tcl itself. +# - These are tests 7.1 7.2 7.4 9.11 9.13 +# - Tests 5.* test the example packages themselves before they +# are used to test Safe Base interpreters. +# - Alternative tests using stock packages of Tcl 8.6 are in file +# safe-stock86.test. +# # Copyright (c) 1995-1996 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # @@ -155,51 +166,11 @@ test safe-4.6 {safe::interpDelete, indirectly} -setup { a eval exit } -result "" -# The following test checks whether the definition of tcl_endOfWord can be -# obtained from auto_loading. - -test safe-5.1 {test auto-loading in safe interpreters} -setup { - catch {safe::interpDelete a} - safe::interpCreate a -} -body { - interp eval a {tcl_endOfWord "" 0} -} -cleanup { - safe::interpDelete a -} -result -1 - -# test safe interps 'information leak' -proc SafeEval {script} { - # Helper procedure that ensures the safe interp is cleaned up even if - # there is a failure in the script. - set SafeInterp [interp create -safe] - catch {$SafeInterp eval $script} msg opts - interp delete $SafeInterp - return -options $opts $msg -} +# The old test "safe-5.1" has been moved to "safe-stock86-9.8". +# A replacement test using example files is "safe-9.8". +# Tests 5.* test the example files before using them to test safe interpreters. -test safe-6.1 {test safe interpreters knowledge of the world} { - lsort [SafeEval {info globals}] -} {tcl_interactive tcl_patchLevel tcl_platform tcl_version} -test safe-6.2 {test safe interpreters knowledge of the world} { - SafeEval {info script} -} {} -test safe-6.3 {test safe interpreters knowledge of the world} { - set r [SafeEval {array names tcl_platform}] - # If running a windows-debug shell, remove the "debug" element from r. - if {[testConstraint win]} { - set r [lsearch -all -inline -not -exact $r "debug"] - } - set r [lsearch -all -inline -not -exact $r "threaded"] - lsort $r -} {byteOrder engine pathSeparator platform pointerSize wordSize} - -rename SafeEval {} -# More test should be added to check that hostname, nameofexecutable, aren't -# leaking infos, but they still do... - -# Tests 7.0* test the example files before using them to test safe interpreters. - -test safe-7.0a {example tclIndex commands, test in master interpreter} -setup { +test safe-5.1 {example tclIndex commands, test in master interpreter} -setup { set tmpAutoPath $::auto_path lappend ::auto_path [file join $TestsDir auto0 auto1] [file join $TestsDir auto0 auto2] } -body { @@ -213,7 +184,7 @@ test safe-7.0a {example tclIndex commands, test in master interpreter} -setup { set ::auto_path $tmpAutoPath auto_reset } -match glob -result {0 ok1 0 ok2} -test safe-7.0b {example tclIndex commands, negative test in master interpreter} -setup { +test safe-5.2 {example tclIndex commands, negative test in master interpreter} -setup { set tmpAutoPath $::auto_path lappend ::auto_path [file join $TestsDir auto0] } -body { @@ -227,7 +198,7 @@ test safe-7.0b {example tclIndex commands, negative test in master interpreter} set ::auto_path $tmpAutoPath auto_reset } -match glob -result {1 {invalid command name "report1"} 1 {invalid command name "report2"}} -test safe-7.0c {example pkgIndex.tcl packages, test in master interpreter, child directories} -setup { +test safe-5.3 {example pkgIndex.tcl packages, test in master interpreter, child directories} -setup { set tmpAutoPath $::auto_path lappend ::auto_path [file join $TestsDir auto0] } -body { @@ -244,7 +215,7 @@ test safe-7.0c {example pkgIndex.tcl packages, test in master interpreter, child catch {rename HeresPackage1 {}} catch {rename HeresPackage2 {}} } -match glob -result {0 1.2.3 0 2.3.4 0 OK1 0 OK2} -test safe-7.0d {example pkgIndex.tcl packages, test in master interpreter, main directories} -setup { +test safe-5.4 {example pkgIndex.tcl packages, test in master interpreter, main directories} -setup { set tmpAutoPath $::auto_path lappend ::auto_path [file join $TestsDir auto0 auto1] \ [file join $TestsDir auto0 auto2] @@ -262,7 +233,7 @@ test safe-7.0d {example pkgIndex.tcl packages, test in master interpreter, main catch {rename HeresPackage1 {}} catch {rename HeresPackage2 {}} } -match glob -result {0 1.2.3 0 2.3.4 0 OK1 0 OK2} -test safe-7.0e {example modules packages, test in master interpreter, replace path} -setup { +test safe-5.5 {example modules packages, test in master interpreter, replace path} -setup { set oldTm [tcl::tm::path list] foreach path $oldTm { tcl::tm::path remove $path @@ -288,7 +259,7 @@ test safe-7.0e {example modules packages, test in master interpreter, replace pa catch {namespace delete ::test0} catch {namespace delete ::mod1} } -match glob -result {0 0.5 0 1.0 0 2.0 -- res0 res1 res2} -test safe-7.0f {example modules packages, test in master interpreter, append to path} -setup { +test safe-5.6 {example modules packages, test in master interpreter, append to path} -setup { tcl::tm::path add [file join $TestsDir auto0 modules] } -body { # Try to load the modules and run a command from each one. @@ -308,6 +279,37 @@ test safe-7.0f {example modules packages, test in master interpreter, append to catch {namespace delete ::mod1} } -match glob -result {0 0.5 0 1.0 0 2.0 -- res0 res1 res2} + +# test safe interps 'information leak' +proc SafeEval {script} { + # Helper procedure that ensures the safe interp is cleaned up even if + # there is a failure in the script. + set SafeInterp [interp create -safe] + catch {$SafeInterp eval $script} msg opts + interp delete $SafeInterp + return -options $opts $msg +} + +test safe-6.1 {test safe interpreters knowledge of the world} { + lsort [SafeEval {info globals}] +} {tcl_interactive tcl_patchLevel tcl_platform tcl_version} +test safe-6.2 {test safe interpreters knowledge of the world} { + SafeEval {info script} +} {} +test safe-6.3 {test safe interpreters knowledge of the world} { + set r [SafeEval {array names tcl_platform}] + # If running a windows-debug shell, remove the "debug" element from r. + if {[testConstraint win]} { + set r [lsearch -all -inline -not -exact $r "debug"] + } + set r [lsearch -all -inline -not -exact $r "threaded"] + lsort $r +} {byteOrder engine pathSeparator platform pointerSize wordSize} + +rename SafeEval {} +# More test should be added to check that hostname, nameofexecutable, aren't +# leaking infos, but they still do... + # high level general test # Use example packages not http1.0 test safe-7.1 {tests that everything works at high level} -setup { @@ -326,18 +328,6 @@ test safe-7.1 {tests that everything works at high level} -setup { } -cleanup { safe::interpDelete $i } -match glob -result 1.2.3 -# high level general test -test safe-7.1http {tests that everything works at high level, uses http 2} -body { - set i [safe::interpCreate] - # no error shall occur: - # (because the default access_path shall include 1st level sub dirs so - # package require in a slave works like in the master) - set v [interp eval $i {package require http 2}] - # no error shall occur: - interp eval $i {http::config} - safe::interpDelete $i - set v -} -match glob -result 2.* test safe-7.2 {tests specific path and interpFind/AddToAccessPath} -setup { } -body { set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]] @@ -358,21 +348,6 @@ test safe-7.2 {tests specific path and interpFind/AddToAccessPath} -setup { } -match glob -result {{$p(:0:)} {$p(:*:)} {$p(:*:)} --\ 1 {can't find package SafeTestPackage1} --\ {TCLLIB */dummy/unixlike/test/path TESTSDIR/auto0} -- {}} -test safe-7.2http {tests specific path and interpFind/AddToAccessPath, uses http1.0} -body { - set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]] - # should not add anything (p0) - set token1 [safe::interpAddToAccessPath $i [info library]] - # should add as p1 - set token2 [safe::interpAddToAccessPath $i "/dummy/unixlike/test/path"] - set confA [safe::interpConfigure $i] - set mappA [mapList $PathMapp [dict get $confA -accessPath]] - # an error shall occur (http is not anymore in the secure 0-level - # provided deep path) - list $token1 $token2 -- \ - [catch {interp eval $i {package require http 1}} msg] $msg -- \ - $mappA -- [safe::interpDelete $i] -} -match glob -result {{$p(:0:)} {$p(:*:)} -- 1 {can't find package http 1} --\ - {TCLLIB */dummy/unixlike/test/path} -- {}} test safe-7.3 {check that safe subinterpreters work} { set g [interp slaves] if {$g ne {}} { @@ -405,19 +380,6 @@ test safe-7.4 {tests specific path and positive search} -setup { } -cleanup { } -match glob -result {{$p(:0:)} {$p(:*:)} -- 0 1.2.3 --\ {TCLLIB * TESTSDIR/auto0/auto1} -- {}} -test safe-7.4http {tests specific path and positive search, uses http1.0} -body { - set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]] - # should not add anything (p0) - set token1 [safe::interpAddToAccessPath $i [info library]] - # should add as p1 - set token2 [safe::interpAddToAccessPath $i [file join [info library] http1.0]] - set confA [safe::interpConfigure $i] - set mappA [mapList $PathMapp [dict get $confA -accessPath]] - # this time, unlike test safe-7.2, http should be found - list $token1 $token2 -- \ - [catch {interp eval $i {package require http 1}} msg] $msg -- \ - $mappA -- [safe::interpDelete $i] -} -match glob -result {{$p(:0:)} {$p(:*:)} -- 0 1.0 -- {TCLLIB *TCLLIB/http1.0} -- {}} # test source control on file name test safe-8.1 {safe source control on file} -setup { @@ -666,7 +628,27 @@ test safe-9.7 {interpConfigure widget like behaviour (demystified)} -body { {-accessPath *} {-nested 1} {-statics 0} {-deleteHook {foo bar}}\ {-accessPath * -statics 1 -nested 1 -deleteHook {foo bar}}\ {-accessPath * -statics 0 -nested 0 -deleteHook toto}} -test safe-9.8 {interpConfigure change the access path; tclIndex commands unaffected by token rearrangement (dummy test of doreset)} -setup { +test safe-9.8 {test autoloading commands indexed in tclIndex files} -setup { +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library \ + [file join $TestsDir auto0 auto1] \ + [file join $TestsDir auto0 auto2]]] + # Inspect. + set confA [safe::interpConfigure $i] + set mappA [mapList $PathMapp [dict get $confA -accessPath]] + set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]] + set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]] + + # Load and run the commands. + set code1 [catch {interp eval $i {report1}} msg1] + set code2 [catch {interp eval $i {report2}} msg2] + + list $path1 $path2 -- $code1 $msg1 $code2 $msg2 -- $mappA +} -cleanup { + safe::interpDelete $i +} -match glob -result {{$p(:1:)} {$p(:2:)} -- 0 ok1 0 ok2 --\ + {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*}} +test safe-9.9 {interpConfigure change the access path; tclIndex commands unaffected by token rearrangement (dummy test of doreset)} -setup { } -body { set i [safe::interpCreate -accessPath [list $tcl_library \ [file join $TestsDir auto0 auto1] \ @@ -705,7 +687,7 @@ test safe-9.8 {interpConfigure change the access path; tclIndex commands unaffec } -match glob -result {{$p(:1:)} {$p(:2:)} -- {$p(:2:)} {$p(:1:)} -- 0 ok1 0 ok2 --\ {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} --\ {TCLLIB TESTSDIR/auto0/auto2 TESTSDIR/auto0/auto1*}} -test safe-9.9 {interpConfigure change the access path; tclIndex commands unaffected by token rearrangement (actual test of doreset)} -setup { +test safe-9.10 {interpConfigure change the access path; tclIndex commands unaffected by token rearrangement (actual test of doreset)} -setup { } -body { set i [safe::interpCreate -accessPath [list $tcl_library \ [file join $TestsDir auto0 auto1] \ @@ -743,7 +725,7 @@ test safe-9.9 {interpConfigure change the access path; tclIndex commands unaffec 0 ok1 0 ok2 --\ {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} --\ {TCLLIB TESTSDIR/auto0/auto2 TESTSDIR/auto0/auto1*}} -test safe-9.10 {interpConfigure change the access path; pkgIndex.tcl packages unaffected by token rearrangement} -setup { +test safe-9.11 {interpConfigure change the access path; pkgIndex.tcl packages unaffected by token rearrangement} -setup { } -body { # For complete correspondence to safe-9.10opt, include auto0 in access path. set i [safe::interpCreate -accessPath [list $tcl_library \ @@ -787,7 +769,7 @@ test safe-9.10 {interpConfigure change the access path; pkgIndex.tcl packages un {TCLLIB TESTSDIR/auto0 TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} --\ {TCLLIB TESTSDIR/auto0 TESTSDIR/auto0/auto2 TESTSDIR/auto0/auto1*} --\ 0 OK1 0 OK2} -test safe-9.11 {interpConfigure change the access path; pkgIndex.tcl packages unaffected by token rearrangement, 9.10 without path auto0} -setup { +test safe-9.12 {interpConfigure change the access path; pkgIndex.tcl packages unaffected by token rearrangement, 9.10 without path auto0} -setup { } -body { set i [safe::interpCreate -accessPath [list $tcl_library \ [file join $TestsDir auto0 auto1] \ @@ -827,7 +809,7 @@ test safe-9.11 {interpConfigure change the access path; pkgIndex.tcl packages un {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} --\ {TCLLIB TESTSDIR/auto0/auto2 TESTSDIR/auto0/auto1*} --\ 0 OK1 0 OK2} -test safe-9.12 {interpConfigure change the access path; pkgIndex.tcl packages fail if directory de-listed} -setup { +test safe-9.13 {interpConfigure change the access path; pkgIndex.tcl packages fail if directory de-listed} -setup { } -body { set i [safe::interpCreate -accessPath [list $tcl_library \ [file join $TestsDir auto0 auto1] \ @@ -1455,7 +1437,7 @@ test safe-13.7 {mimic the glob call by tclPkgUnknown in a safe interpreter [Bug safe::interpDelete $i removeDirectory $testdir } -result {EXPECTED/deletemetoo/pkgIndex.tcl} -test safe-13.7a {mimic the glob call by tclPkgUnknown in a safe interpreter with multiple subdirectories} -setup { +test safe-13.7.1 {mimic the glob call by tclPkgUnknown in a safe interpreter with multiple subdirectories} -setup { set i [safe::interpCreate] buildEnvironment2 pkgIndex.tcl } -body { -- cgit v0.12 From 204434e4d41bb9e07b48d28331a6a63206dc36dd Mon Sep 17 00:00:00 2001 From: kjnash Date: Tue, 21 Jul 2020 03:59:35 +0000 Subject: Use suitable -errorcode in safe::AliasSource if file does not exist or is unreadable. Fixes bug f3ba57600d. --- library/safe.tcl | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/library/safe.tcl b/library/safe.tcl index 4540be3..9b8a04f 100644 --- a/library/safe.tcl +++ b/library/safe.tcl @@ -968,12 +968,15 @@ proc ::safe::AliasSource {slave args} { return -code error "permission denied" } - # do the checks on the filename : + # Check that the filename exists and is readable. If it is not, deliver + # this -errorcode so that caller in tclPkgUnknown does not write a message + # to tclLog. Has no effect on other callers of ::source, which are in + # "package ifneeded" scripts. if {[catch { CheckFileName $slave $realfile } msg]} { Log $slave "$realfile:$msg" - return -code error $msg + return -code error -errorcode {POSIX EACCES} $msg } # Passed all the tests, lets source it. Note that we do this all manually -- cgit v0.12 From f472165a3dc7d353f90af7f8143d2780b11c93fe Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 21 Jul 2020 12:26:05 +0000 Subject: Mark chan-io-50.? and event-1.1 as nonPortable (for now): Those sometimes fail in the Travis environment, but in practice this doesn't seem to be a real problem. --- tests/chanio.test | 12 ++++++------ tests/event.test | 2 +- 2 files changed, 7 insertions(+), 7 deletions(-) diff --git a/tests/chanio.test b/tests/chanio.test index 558ec10..67e0f24 100644 --- a/tests/chanio.test +++ b/tests/chanio.test @@ -6372,7 +6372,7 @@ test chan-io-49.5 {testing crlf reading, leftover cr disgorgment} -setup { test chan-io-50.1 {testing handler deletion} -setup { file delete $path(test1) -} -constraints {testchannelevent} -body { +} -constraints {testchannelevent nonPortable} -body { set f [open $path(test1) w] chan close $f set f [open $path(test1) r] @@ -6390,7 +6390,7 @@ test chan-io-50.2 {testing handler deletion with multiple handlers} -setup { file delete $path(test1) chan close [open $path(test1) w] set z "" -} -constraints {testchannelevent} -body { +} -constraints {testchannelevent nonPortable} -body { set f [open $path(test1) r] testchannelevent $f add readable [namespace code [list delhandler $f 1]] testchannelevent $f add readable [namespace code [list delhandler $f 0]] @@ -6409,7 +6409,7 @@ test chan-io-50.3 {testing handler deletion with multiple handlers} -setup { file delete $path(test1) chan close [open $path(test1) w] set z "" -} -constraints {testchannelevent} -body { +} -constraints {testchannelevent nonPortable} -body { set f [open $path(test1) r] testchannelevent $f add readable [namespace code [list notcalled $f 1]] testchannelevent $f add readable [namespace code [list delhandler $f 0]] @@ -6435,7 +6435,7 @@ test chan-io-50.4 {testing handler deletion vs reentrant calls} -setup { file delete $path(test1) set f [open $path(test1) w] chan close $f -} -constraints {testchannelevent} -body { +} -constraints {testchannelevent nonPortable} -body { set f [open $path(test1) r] testchannelevent $f add readable [namespace code { if {$u eq "recursive"} { @@ -6458,7 +6458,7 @@ test chan-io-50.5 {testing handler deletion vs reentrant calls} -setup { file delete $path(test1) set f [open $path(test1) w] chan close $f -} -constraints {testchannelevent} -body { +} -constraints {testchannelevent nonPortable} -body { set f [open $path(test1) r] testchannelevent $f add readable [namespace code [list notcalled $f]] testchannelevent $f add readable [namespace code [list del $f]] @@ -6493,7 +6493,7 @@ test chan-io-50.6 {testing handler deletion vs reentrant calls} -setup { file delete $path(test1) set f [open $path(test1) w] chan close $f -} -constraints {testchannelevent} -body { +} -constraints {testchannelevent nonPortable} -body { set f [open $path(test1) r] testchannelevent $f add readable [namespace code [list second $f]] testchannelevent $f add readable [namespace code [list first $f]] diff --git a/tests/event.test b/tests/event.test index 67a980b..6e6d116 100644 --- a/tests/event.test +++ b/tests/event.test @@ -27,7 +27,7 @@ testConstraint exec [llength [info commands exec]] test event-1.1 {Tcl_CreateFileHandler, reading} -setup { testfilehandler close set result "" -} -constraints {testfilehandler} -body { +} -constraints {testfilehandler nonPortable} -body { testfilehandler create 0 readable off testfilehandler clear 0 testfilehandler oneevent -- cgit v0.12 From 55bf49d15f4347284e30f07c67f8043b0669704f Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 21 Jul 2020 13:22:08 +0000 Subject: Re-enable event-1.1, io-50.? and chan-io-50.? test-cases, trying to get a hand at the problem [f586089a2b] --- tests/chanio.test | 20 ++++++------ tests/event.test | 8 ++--- tests/io.test | 92 +++++++++++++++++++++++++++---------------------------- 3 files changed, 60 insertions(+), 60 deletions(-) diff --git a/tests/chanio.test b/tests/chanio.test index 67e0f24..5989bfe 100644 --- a/tests/chanio.test +++ b/tests/chanio.test @@ -6372,7 +6372,7 @@ test chan-io-49.5 {testing crlf reading, leftover cr disgorgment} -setup { test chan-io-50.1 {testing handler deletion} -setup { file delete $path(test1) -} -constraints {testchannelevent nonPortable} -body { +} -constraints testchannelevent -body { set f [open $path(test1) w] chan close $f set f [open $path(test1) r] @@ -6382,7 +6382,7 @@ test chan-io-50.1 {testing handler deletion} -setup { }] variable z not_called update - return $z + set z } -cleanup { chan close $f } -result called @@ -6390,7 +6390,7 @@ test chan-io-50.2 {testing handler deletion with multiple handlers} -setup { file delete $path(test1) chan close [open $path(test1) w] set z "" -} -constraints {testchannelevent nonPortable} -body { +} -constraints testchannelevent -body { set f [open $path(test1) r] testchannelevent $f add readable [namespace code [list delhandler $f 1]] testchannelevent $f add readable [namespace code [list delhandler $f 0]] @@ -6409,7 +6409,7 @@ test chan-io-50.3 {testing handler deletion with multiple handlers} -setup { file delete $path(test1) chan close [open $path(test1) w] set z "" -} -constraints {testchannelevent nonPortable} -body { +} -constraints testchannelevent -body { set f [open $path(test1) r] testchannelevent $f add readable [namespace code [list notcalled $f 1]] testchannelevent $f add readable [namespace code [list delhandler $f 0]] @@ -6435,7 +6435,7 @@ test chan-io-50.4 {testing handler deletion vs reentrant calls} -setup { file delete $path(test1) set f [open $path(test1) w] chan close $f -} -constraints {testchannelevent nonPortable} -body { +} -constraints testchannelevent -body { set f [open $path(test1) r] testchannelevent $f add readable [namespace code { if {$u eq "recursive"} { @@ -6450,7 +6450,7 @@ test chan-io-50.4 {testing handler deletion vs reentrant calls} -setup { variable u toplevel variable z "" update - return $z + set z } -cleanup { chan close $f } -result {{delrecursive calling recursive} {delrecursive deleting recursive}} @@ -6458,7 +6458,7 @@ test chan-io-50.5 {testing handler deletion vs reentrant calls} -setup { file delete $path(test1) set f [open $path(test1) w] chan close $f -} -constraints {testchannelevent nonPortable} -body { +} -constraints testchannelevent -body { set f [open $path(test1) r] testchannelevent $f add readable [namespace code [list notcalled $f]] testchannelevent $f add readable [namespace code [list del $f]] @@ -6484,7 +6484,7 @@ test chan-io-50.5 {testing handler deletion vs reentrant calls} -setup { set z "" set u toplevel update - return $z + set z } -cleanup { chan close $f } -result [list {del calling recursive} {del deleted notcalled} \ @@ -6493,7 +6493,7 @@ test chan-io-50.6 {testing handler deletion vs reentrant calls} -setup { file delete $path(test1) set f [open $path(test1) w] chan close $f -} -constraints {testchannelevent nonPortable} -body { +} -constraints testchannelevent -body { set f [open $path(test1) r] testchannelevent $f add readable [namespace code [list second $f]] testchannelevent $f add readable [namespace code [list first $f]] @@ -6527,7 +6527,7 @@ test chan-io-50.6 {testing handler deletion vs reentrant calls} -setup { set z "" set u toplevel update - return $z + set z } -cleanup { chan close $f } -result [list {first called} {first called not toplevel} \ diff --git a/tests/event.test b/tests/event.test index 6e6d116..336c4e4 100644 --- a/tests/event.test +++ b/tests/event.test @@ -27,7 +27,7 @@ testConstraint exec [llength [info commands exec]] test event-1.1 {Tcl_CreateFileHandler, reading} -setup { testfilehandler close set result "" -} -constraints {testfilehandler nonPortable} -body { +} -constraints testfilehandler -body { testfilehandler create 0 readable off testfilehandler clear 0 testfilehandler oneevent @@ -595,16 +595,16 @@ test event-11.7 {Bug 16828b3744} { test event-11.8 {Bug 16828b3744} -setup { oo::class create A { variable continue - + method start {} { after idle [self] destroy - + set continue 0 vwait [namespace current]::continue } destructor { set continue 1 - } + } } } -body { [A new] start diff --git a/tests/io.test b/tests/io.test index 7072b63..1a30850 100644 --- a/tests/io.test +++ b/tests/io.test @@ -123,10 +123,10 @@ test io-1.8 {Tcl_WriteChars: WriteChars} { # applied to tcl will cause tcl, more specifically WriteChars, to # go into an infinite loop. - set f [open $path(test2) w] - fconfigure $f -encoding iso2022-jp - puts -nonewline $f [format %s%c [string repeat " " 4] 12399] - close $f + set f [open $path(test2) w] + fconfigure $f -encoding iso2022-jp + puts -nonewline $f [format %s%c [string repeat " " 4] 12399] + close $f contents $path(test2) } " \x1b\$B\$O\x1b(B" @@ -192,7 +192,7 @@ test io-1.9 {Tcl_WriteChars: WriteChars} { test io-2.1 {WriteBytes} { # loop until all bytes are written - + set f [open $path(test1) w] fconfigure $f -encoding binary -buffersize 16 -translation crlf puts $f "abcdefghijklmnopqrstuvwxyz" @@ -214,7 +214,7 @@ test io-2.3 {WriteBytes: flush on line} { # Tcl "line" buffering has weird behavior: if current buffer contains # a \n, entire buffer gets flushed. Logical behavior would be to flush # only up to the \n. - + set f [open $path(test1) w] fconfigure $f -encoding binary -buffering line -translation crlf puts -nonewline $f "\n12" @@ -234,7 +234,7 @@ test io-2.4 {WriteBytes: reset sawLF after each buffer} { test io-3.1 {WriteChars: compatibility with WriteBytes} { # loop until all bytes are written - + set f [open $path(test1) w] fconfigure $f -encoding ascii -buffersize 16 -translation crlf puts $f "abcdefghijklmnopqrstuvwxyz" @@ -256,7 +256,7 @@ test io-3.3 {WriteChars: compatibility with WriteBytes: flush on line} { # Tcl "line" buffering has weird behavior: if current buffer contains # a \n, entire buffer gets flushed. Logical behavior would be to flush # only up to the \n. - + set f [open $path(test1) w] fconfigure $f -encoding ascii -buffering line -translation crlf puts -nonewline $f "\n12" @@ -268,7 +268,7 @@ test io-3.4 {WriteChars: loop over stage buffer} { # stage buffer maps to more than can be queued at once. set f [open $path(test1) w] - fconfigure $f -encoding jis0208 -buffersize 16 + fconfigure $f -encoding jis0208 -buffersize 16 puts -nonewline $f "\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\" set x [list [contents $path(test1)]] close $f @@ -280,7 +280,7 @@ test io-3.5 {WriteChars: saved != 0} { # requested buffersize. set f [open $path(test1) w] - fconfigure $f -encoding jis0208 -buffersize 17 + fconfigure $f -encoding jis0208 -buffersize 17 puts -nonewline $f "\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\" set x [list [contents $path(test1)]] close $f @@ -311,7 +311,7 @@ test io-3.7 {WriteChars: (bufPtr->nextAdded > bufPtr->length)} { # of the next channel buffer. set f [open $path(test1) w] - fconfigure $f -encoding jis0208 -buffersize 17 + fconfigure $f -encoding jis0208 -buffersize 17 puts -nonewline $f "\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\" set x [list [contents $path(test1)]] close $f @@ -381,7 +381,7 @@ test io-4.5 {TranslateOutputEOL: crlf} { test io-5.1 {CheckFlush: not full} { set f [open $path(test1) w] - fconfigure $f + fconfigure $f puts -nonewline $f "12345678901234567890" set x [list [contents $path(test1)]] close $f @@ -470,7 +470,7 @@ set a "bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb" append a $a append a $a test io-6.6 {Tcl_GetsObj: loop test} { - # if (dst >= dstEnd) + # if (dst >= dstEnd) set f [open $path(test1) w] puts $f $a @@ -769,7 +769,7 @@ test io-6.32 {Tcl_GetsObj: crlf mode: buffer exhausted, more data} {testchannel} } [list 15 "123456789012345" 17 3] test io-6.33 {Tcl_GetsObj: crlf mode: buffer exhausted, at eof} { # eol still equals dstEnd - + set f [open $path(test1) w] fconfigure $f -translation lf puts -nonewline $f "123456789012345\r" @@ -781,8 +781,8 @@ test io-6.33 {Tcl_GetsObj: crlf mode: buffer exhausted, at eof} { set x } [list 16 "123456789012345\r" 1] test io-6.34 {Tcl_GetsObj: crlf mode: buffer exhausted, not followed by \n} { - # not (*eol == '\n') - + # not (*eol == '\n') + set f [open $path(test1) w] fconfigure $f -translation lf puts -nonewline $f "123456789012345\rabcd\r\nefg" @@ -889,7 +889,7 @@ test io-6.43 {Tcl_GetsObj: input saw cr} {stdio testchannel openpipe fileevent} fconfigure $f -buffersize 16 set x [list [gets $f]] fconfigure $f -blocking 0 - lappend x [gets $f line] $line [testchannel queuedcr $f] + lappend x [gets $f line] $line [testchannel queuedcr $f] fconfigure $f -blocking 1 puts -nonewline $f "\nabcd\refg\x1a" lappend x [gets $f line] $line [testchannel queuedcr $f] @@ -898,7 +898,7 @@ test io-6.43 {Tcl_GetsObj: input saw cr} {stdio testchannel openpipe fileevent} set x } [list "bbbbbbbbbbbbbbb" 15 "123456789abcdef" 1 4 "abcd" 0 3 "efg"] test io-6.44 {Tcl_GetsObj: input saw cr, not followed by cr} {stdio testchannel openpipe fileevent} { - # not (*eol == '\n') + # not (*eol == '\n') set f [open "|[list [interpreter] $path(cat)]" w+] fconfigure $f -translation {auto lf} -buffering none @@ -906,7 +906,7 @@ test io-6.44 {Tcl_GetsObj: input saw cr, not followed by cr} {stdio testchannel fconfigure $f -buffersize 16 set x [list [gets $f]] fconfigure $f -blocking 0 - lappend x [gets $f line] $line [testchannel queuedcr $f] + lappend x [gets $f line] $line [testchannel queuedcr $f] fconfigure $f -blocking 1 puts -nonewline $f "abcd\refg\x1a" lappend x [gets $f line] $line [testchannel queuedcr $f] @@ -959,10 +959,10 @@ test io-6.47 {Tcl_GetsObj: auto mode: \r at end of buffer, peek for \n} {testcha set x [list [gets $f] [testchannel inputbuffered $f]] close $f set x -} [list "123456789012345" 15] +} [list "123456789012345" 15] test io-6.48 {Tcl_GetsObj: auto mode: \r at end of buffer, no more avail} {testchannel} { # PeekAhead() did not get any, so (eol >= dstEnd) - + set f [open $path(test1) w] fconfigure $f -translation lf puts -nonewline $f "123456789012345\r" @@ -975,7 +975,7 @@ test io-6.48 {Tcl_GetsObj: auto mode: \r at end of buffer, no more avail} {testc } [list "123456789012345" 1] test io-6.49 {Tcl_GetsObj: auto mode: \r followed by \n} {testchannel} { # if (*eol == '\n') {skip++} - + set f [open $path(test1) w] fconfigure $f -translation lf puts -nonewline $f "123456\r\n78901" @@ -986,8 +986,8 @@ test io-6.49 {Tcl_GetsObj: auto mode: \r followed by \n} {testchannel} { set x } [list "123456" 0 8 "78901"] test io-6.50 {Tcl_GetsObj: auto mode: \r not followed by \n} {testchannel} { - # not (*eol == '\n') - + # not (*eol == '\n') + set f [open $path(test1) w] fconfigure $f -translation lf puts -nonewline $f "123456\r78901" @@ -999,7 +999,7 @@ test io-6.50 {Tcl_GetsObj: auto mode: \r not followed by \n} {testchannel} { } [list "123456" 0 7 "78901"] test io-6.51 {Tcl_GetsObj: auto mode: \n} { # else if (*eol == '\n') {goto gotoeol;} - + set f [open $path(test1) w] fconfigure $f -translation lf puts -nonewline $f "123456\n78901" @@ -1092,7 +1092,7 @@ test io-7.1 {FilterInputBytes: split up character at end of buffer} { } "1234567890123\uff10\uff11\uff12\uff13\uff14" test io-7.2 {FilterInputBytes: split up character in middle of buffer} { # (bufPtr->nextAdded < bufPtr->bufLength) - + set f [open $path(test1) w] fconfigure $f -encoding binary puts -nonewline $f "1234567890\n123\x82\x4f\x82\x50\x82" @@ -1201,7 +1201,7 @@ test io-8.4 {PeekAhead: cached data available in this buffer} { set x [gets $f] close $f - set x + set x } $a unset a test io-8.5 {PeekAhead: don't peek if last read was short} {stdio testchannel openpipe fileevent} { @@ -1217,7 +1217,7 @@ test io-8.5 {PeekAhead: don't peek if last read was short} {stdio testchannel op set x } {15 abcdefghijklmno 1} test io-8.6 {PeekAhead: change to non-blocking mode} {stdio testchannel openpipe fileevent} { - # ((chanPtr->flags & CHANNEL_NONBLOCKING) == 0) + # ((chanPtr->flags & CHANNEL_NONBLOCKING) == 0) set f [open "|[list [interpreter] $path(cat)]" w+] fconfigure $f -translation {auto binary} -buffersize 16 @@ -1574,7 +1574,7 @@ test io-13.2 {TranslateInputEOL: crlf mode} { set x } "abcd\ndef\n" test io-13.3 {TranslateInputEOL: crlf mode: naked cr} { - # (src >= srcMax) + # (src >= srcMax) set f [open $path(test1) w] fconfigure $f -translation lf @@ -1587,7 +1587,7 @@ test io-13.3 {TranslateInputEOL: crlf mode: naked cr} { set x } "abcd\ndef\r" test io-13.4 {TranslateInputEOL: crlf mode: cr followed by not \n} { - # (src >= srcMax) + # (src >= srcMax) set f [open $path(test1) w] fconfigure $f -translation lf @@ -1600,7 +1600,7 @@ test io-13.4 {TranslateInputEOL: crlf mode: cr followed by not \n} { set x } "abcd\ndef\rfgh" test io-13.5 {TranslateInputEOL: crlf mode: naked lf} { - # (src >= srcMax) + # (src >= srcMax) set f [open $path(test1) w] fconfigure $f -translation lf @@ -1715,7 +1715,7 @@ test io-13.9 {TranslateInputEOL: auto mode: \r followed by not \n} { set x } "abcd\ndef" test io-13.10 {TranslateInputEOL: auto mode: \n} { - # not (*src == '\r') + # not (*src == '\r') set f [open $path(test1) w] fconfigure $f -translation lf @@ -2064,7 +2064,7 @@ test io-20.1 {Tcl_CreateChannel: initial settings} { encoding system $old close $a set x -} {ascii} +} {ascii} test io-20.2 {Tcl_CreateChannel: initial settings} {win} { set f [open $path(test1) w+] set x [list [fconfigure $f -eofchar] [fconfigure $f -translation]] @@ -2159,7 +2159,7 @@ test io-26.1 {Tcl_GetChannelInstanceData} {stdio openpipe} { set f [open "|[list [interpreter] << exit]"] expr [pid $f] close $f -} {} +} {} # Test flushing. The functions tested here are FlushChannel. @@ -3057,7 +3057,7 @@ test io-30.6 {Tcl_Write cr, Tcl_Read crlf} { fconfigure $f -translation crlf set x [read $f] close $f - set x + set x } "hello\rthere\rand\rhere\r" test io-30.7 {Tcl_Write crlf, Tcl_Read crlf} { file delete $path(test1) @@ -3985,7 +3985,7 @@ test io-31.31 {Tcl_Write crlf on block boundary, Tcl_Gets crlf} { } close $f set f [open $path(test1) r] - fconfigure $f -translation crlf + fconfigure $f -translation crlf set c "" while {[gets $f line] >= 0} { append c $line\n @@ -5474,7 +5474,7 @@ test io-39.13 {Tcl_SetChannelOption, Tcl_GetChannelOption, buffer size} { test io-39.14 {Tcl_SetChannelOption: -encoding, binary & utf-8} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -encoding {} + fconfigure $f -encoding {} puts -nonewline $f \xe7\x89\xa6 close $f set f [open $path(test1) r] @@ -6719,7 +6719,7 @@ test io-49.5 {testing crlf reading, leftover cr disgorgment} { set l } [list 7 a\rb\rc 7 {} 7 1] -test io-50.1 {testing handler deletion} {testchannelevent nonPortable} { +test io-50.1 {testing handler deletion} testchannelevent { file delete $path(test1) set f [open $path(test1) w] close $f @@ -6735,7 +6735,7 @@ test io-50.1 {testing handler deletion} {testchannelevent nonPortable} { close $f set z } called -test io-50.2 {testing handler deletion with multiple handlers} {testchannelevent nonPortable} { +test io-50.2 {testing handler deletion with multiple handlers} testchannelevent { file delete $path(test1) set f [open $path(test1) w] close $f @@ -6753,7 +6753,7 @@ test io-50.2 {testing handler deletion with multiple handlers} {testchannelevent string compare [string tolower $z] \ [list [list called delhandler $f 0] [list called delhandler $f 1]] } 0 -test io-50.3 {testing handler deletion with multiple handlers} {testchannelevent nonPortable} { +test io-50.3 {testing handler deletion with multiple handlers} testchannelevent { file delete $path(test1) set f [open $path(test1) w] close $f @@ -6779,7 +6779,7 @@ test io-50.3 {testing handler deletion with multiple handlers} {testchannelevent [list [list delhandler $f 0 called] \ [list delhandler $f 0 deleted myself]] } 0 -test io-50.4 {testing handler deletion vs reentrant calls} {testchannelevent nonPortable} { +test io-50.4 {testing handler deletion vs reentrant calls} testchannelevent { file delete $path(test1) set f [open $path(test1) w] close $f @@ -6803,7 +6803,7 @@ test io-50.4 {testing handler deletion vs reentrant calls} {testchannelevent non close $f set z } {{delrecursive calling recursive} {delrecursive deleting recursive}} -test io-50.5 {testing handler deletion vs reentrant calls} {testchannelevent nonPortable} { +test io-50.5 {testing handler deletion vs reentrant calls} testchannelevent { file delete $path(test1) set f [open $path(test1) w] close $f @@ -6833,10 +6833,10 @@ test io-50.5 {testing handler deletion vs reentrant calls} {testchannelevent non set u toplevel update close $f - set z + set z } [list {del calling recursive} {del deleted notcalled} \ {del deleted myself} {del after update}] -test io-50.6 {testing handler deletion vs reentrant calls} {testchannelevent nonPortable} { +test io-50.6 {testing handler deletion vs reentrant calls} testchannelevent { file delete $path(test1) set f [open $path(test1) w] close $f @@ -8648,11 +8648,11 @@ test io-74.1 {[104f2885bb] improper cache validity check} -setup { interp create slave } -constraints testobj -body { teststringobj set 1 [string range $rfd 0 end] - read [teststringobj get 1] + read [teststringobj get 1] testobj duplicate 1 2 interp transfer {} $rfd slave catch {read [teststringobj get 1]} - read [teststringobj get 2] + read [teststringobj get 2] } -cleanup { interp delete slave testobj freeallvars -- cgit v0.12 From 14cfbc651c24aa44c83023e8bba2781d322b230f Mon Sep 17 00:00:00 2001 From: kjnash Date: Tue, 21 Jul 2020 17:25:03 +0000 Subject: Adapt Safe Base for interpreter names with namespace separators. Add a test and revise safe(n). Fixes bug [693851]. --- doc/safe.n | 10 +++++- library/safe.tcl | 92 +++++++++++++++++++++++++++++++++++++++++++++----------- tests/safe.test | 17 +++++++++++ 3 files changed, 100 insertions(+), 19 deletions(-) diff --git a/doc/safe.n b/doc/safe.n index b39f2c2..7ddb182 100644 --- a/doc/safe.n +++ b/doc/safe.n @@ -72,11 +72,19 @@ See the \fBOPTIONS\fR section below for a description of the optional arguments. If the \fIslave\fR argument is omitted, a name will be generated. \fB::safe::interpCreate\fR always returns the interpreter name. +.sp +The interpreter name \fIslave\fR may include namespace separators, +but may not have leading or trailing namespace separators, or excess +colon characters in namespace separators. The interpreter name is +qualified relative to the global namespace ::, not the namespace in which +the \fB::safe::interpCreate\fR command is evaluated. .TP \fB::safe::interpInit\fR \fIslave\fR ?\fIoptions...\fR? This command is similar to \fBinterpCreate\fR except it that does not create the safe interpreter. \fIslave\fR must have been created by some -other means, like \fBinterp create\fR \fB\-safe\fR. +other means, like \fBinterp create\fR \fB\-safe\fR. The interpreter +name \fIslave\fR may include namespace separators, subject to the same +restrictions as for \fBinterpCreate\fR. .TP \fB::safe::interpConfigure\fR \fIslave\fR ?\fIoptions...\fR? If no \fIoptions\fR are given, returns the settings for all options for the diff --git a/library/safe.tcl b/library/safe.tcl index 9b8a04f..6b531be 100644 --- a/library/safe.tcl +++ b/library/safe.tcl @@ -79,6 +79,7 @@ proc ::safe::InterpNested {} { # Interface/entry point function and front end for "Create" proc ::safe::interpCreate {args} { set Args [::tcl::OptKeyParse ::safe::interpCreate $args] + RejectExcessColons $slave InterpCreate $slave $accessPath \ [InterpStatics] [InterpNested] $deleteHook } @@ -88,13 +89,14 @@ proc ::safe::interpInit {args} { if {![::interp exists $slave]} { return -code error "\"$slave\" is not an interpreter" } + RejectExcessColons $slave InterpInit $slave $accessPath \ [InterpStatics] [InterpNested] $deleteHook } # Check that the given slave is "one of us" proc ::safe::CheckInterp {slave} { - namespace upvar ::safe S$slave state + namespace upvar ::safe [VarName $slave] state if {![info exists state] || ![::interp exists $slave]} { return -code error \ "\"$slave\" is not an interpreter managed by ::safe::" @@ -123,7 +125,7 @@ proc ::safe::interpConfigure {args} { # checks for the "-help" option. set Args [::tcl::OptKeyParse ::safe::interpIC $args] CheckInterp $slave - namespace upvar ::safe S$slave state + namespace upvar ::safe [VarName $slave] state return [join [list \ [list -accessPath $state(access_path)] \ @@ -146,7 +148,7 @@ proc ::safe::interpConfigure {args} { return -code error [::tcl::OptFlagUsage $desc $arg] } CheckInterp $slave - namespace upvar ::safe S$slave state + namespace upvar ::safe [VarName $slave] state set item [::tcl::OptCurDesc $desc] set name [::tcl::OptName $item] @@ -187,7 +189,7 @@ proc ::safe::interpConfigure {args} { # create did set Args [::tcl::OptKeyParse ::safe::interpIC $args] CheckInterp $slave - namespace upvar ::safe S$slave state + namespace upvar ::safe [VarName $slave] state # Get the current (and not the default) values of whatever has # not been given: @@ -284,8 +286,10 @@ proc ::safe::InterpCreate { deletehook } { # Create the slave. + # If evaluated in ::safe, the interpreter command for foo is ::foo; + # but for foo::bar is safe::foo::bar. So evaluate in :: instead. if {$slave ne ""} { - ::interp create -safe $slave + namespace eval :: [list ::interp create -safe $slave] } else { # empty argument: generate slave name set slave [::interp create -safe] @@ -338,7 +342,7 @@ proc ::safe::InterpSetConfig {slave access_path staticsok nestedok deletehook} { Log $slave "Setting accessPath=($access_path) staticsok=$staticsok\ nestedok=$nestedok deletehook=($deletehook)" NOTICE - namespace upvar ::safe S$slave state + namespace upvar ::safe [VarName $slave] state # clear old autopath if it existed # build new one @@ -440,7 +444,7 @@ proc ::safe::InterpSetConfig {slave access_path staticsok nestedok deletehook} { # Search for a real directory and returns its virtual Id (including the # "$") proc ::safe::interpFindInAccessPath {slave path} { - namespace upvar ::safe S$slave state + namespace upvar ::safe [VarName $slave] state if {![dict exists $state(access_path,remap) $path]} { return -code error "$path not found in access path" @@ -456,7 +460,7 @@ proc ::safe::interpFindInAccessPath {slave path} { proc ::safe::interpAddToAccessPath {slave path} { # first check if the directory is already in there # (inlined interpFindInAccessPath). - namespace upvar ::safe S$slave state + namespace upvar ::safe [VarName $slave] state if {[dict exists $state(access_path,remap) $path]} { return [dict get $state(access_path,remap) $path] @@ -555,7 +559,7 @@ proc ::safe::InterpInit { # Sync the paths used to search for Tcl modules. This can be done only # now, after tm.tcl was loaded. - namespace upvar ::safe S$slave state + namespace upvar ::safe [VarName $slave] state if {[llength $state(tm_path_slave)] > 0} { ::interp eval $slave [list \ ::tcl::tm::add {*}[lreverse $state(tm_path_slave)]] @@ -592,7 +596,7 @@ proc ::safe::AddSubDirs {pathList} { proc ::safe::interpDelete {slave} { Log $slave "About to delete" NOTICE - namespace upvar ::safe S$slave state + namespace upvar ::safe [VarName $slave] state # When an interpreter is deleted with [interp delete], any sub-interpreters # are deleted automatically, but this leaves behind their data in the Safe @@ -600,7 +604,7 @@ proc ::safe::interpDelete {slave} { # Safe Base sub-interpreter, so each one is deleted cleanly and not by # the automatic mechanism built into [interp delete]. foreach sub [interp slaves $slave] { - if {[info exists ::safe::S[list $slave $sub]]} { + if {[info exists ::safe::[VarName [list $slave $sub]]]} { ::safe::interpDelete [list $slave $sub] } } @@ -675,7 +679,7 @@ proc ::safe::setLogCmd {args} { # tcl_library to the first token of the virtual path. # proc ::safe::SyncAccessPath {slave} { - namespace upvar ::safe S$slave state + namespace upvar ::safe [VarName $slave] state set slave_access_path $state(access_path,slave) ::interp eval $slave [list set auto_path $slave_access_path] @@ -702,7 +706,7 @@ proc ::safe::PathToken {n} { # translate virtual path into real path # proc ::safe::TranslatePath {slave path} { - namespace upvar ::safe S$slave state + namespace upvar ::safe [VarName $slave] state # somehow strip the namespaces 'functionality' out (the danger is that # we would strip valid macintosh "../" queries... : @@ -1021,7 +1025,7 @@ proc ::safe::AliasLoad {slave file args} { # package name (can be empty if file is not). set package [lindex $args 0] - namespace upvar ::safe S$slave state + namespace upvar ::safe [VarName $slave] state # Determine where to load. load use a relative interp path and {} # means self, so we can directly and safely use passed arg. @@ -1083,7 +1087,7 @@ proc ::safe::AliasLoad {slave file args} { # the security here relies on "file dirname" answering the proper # result... needs checking ? proc ::safe::FileInAccessPath {slave file} { - namespace upvar ::safe S$slave state + namespace upvar ::safe [VarName $slave] state set access_path $state(access_path) if {[file isdirectory $file]} { @@ -1095,14 +1099,14 @@ proc ::safe::FileInAccessPath {slave file} { # potential pathname anomalies. set norm_parent [file normalize $parent] - namespace upvar ::safe S$slave state + namespace upvar ::safe [VarName $slave] state if {$norm_parent ni $state(access_path,norm)} { return -code error "\"$file\": not in access_path" } } proc ::safe::DirInAccessPath {slave dir} { - namespace upvar ::safe S$slave state + namespace upvar ::safe [VarName $slave] state set access_path $state(access_path) if {[file isfile $dir]} { @@ -1113,7 +1117,7 @@ proc ::safe::DirInAccessPath {slave dir} { # potential pathname anomalies. set norm_dir [file normalize $dir] - namespace upvar ::safe S$slave state + namespace upvar ::safe [VarName $slave] state if {$norm_dir ni $state(access_path,norm)} { return -code error "\"$dir\": not in access_path" } @@ -1154,6 +1158,58 @@ proc ::safe::AliasExeName {slave} { return "" } +# ------------------------------------------------------------------------------ +# Using Interpreter Names with Namespace Qualifiers +# ------------------------------------------------------------------------------ +# (1) We wish to preserve compatibility with existing code, in which Safe Base +# interpreter names have no namespace qualifiers. +# (2) safe::interpCreate and the rest of the Safe Base previously could not +# accept namespace qualifiers in an interpreter name. +# (3) The interp command will accept namespace qualifiers in an interpreter +# name, but accepts distinct interpreters that will have the same command +# name (e.g. foo, ::foo, and :::foo) (bug 66c2e8c974). +# (4) To satisfy these constraints, Safe Base interpreter names will be fully +# qualified namespace names with no excess colons and with the leading "::" +# omitted. +# (5) Trailing "::" implies a namespace tail {}, which interp reads as {{}}. +# Reject such names. +# (6) We could: +# (a) EITHER reject usable but non-compliant names (e.g. excess colons) in +# interpCreate, interpInit; +# (b) OR accept such names and then translate to a compliant name in every +# command. +# The problem with (b) is that the user will expect to use the name with the +# interp command and will find that it is not recognised. +# E.g "interpCreate ::foo" creates interpreter "foo", and the user's name +# "::foo" works with all the Safe Base commands, but "interp eval ::foo" +# fails. +# So we choose (a). +# (7) The command +# namespace upvar ::safe S$slave state +# becomes +# namespace upvar ::safe [VarName $slave] state +# ------------------------------------------------------------------------------ + +proc ::safe::RejectExcessColons {slave} { + set stripped [regsub -all -- {:::*} $slave ::] + if {[string range $stripped end-1 end] eq {::}} { + return -code error {interpreter name must not end in "::"} + } + if {$stripped ne $slave} { + set msg {interpreter name has excess colons in namespace separators} + return -code error $msg + } + if {[string range $stripped 0 1] eq {::}} { + return -code error {interpreter name must not begin "::"} + } + return +} + +proc ::safe::VarName {slave} { + # return S$slave + return S[string map {:: @N @ @A} $slave] +} + proc ::safe::Setup {} { #### # diff --git a/tests/safe.test b/tests/safe.test index 3511625..1415b09 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -362,6 +362,23 @@ test safe-7.3 {check that safe subinterpreters work} { list $g $h [interp eval $j {join {o k} ""}] [safe::interpDelete $i] \ [interp exists $j] [info vars ::safe::S*] } {{} {} ok {} 0 {}} +test safe-7.3.1 {check that safe subinterpreters work with namespace names} -setup { +} -body { + set g [interp slaves] + if {$g ne {}} { + append g { -- residue of an earlier test} + } + set h [info vars ::safe::S*] + if {$h ne {}} { + append h { -- residue of an earlier test} + } + set i [safe::interpCreate foo::bar] + set j [safe::interpCreate [list $i hello::world]] + list $g $h [interp eval $j {join {o k} ""}] \ + [foo::bar eval {hello::world eval {join {o k} ""}}] \ + [safe::interpDelete $i] \ + [interp exists $j] [info vars ::safe::S*] +} -match glob -result {{} {} ok ok {} 0 {}} test safe-7.4 {tests specific path and positive search} -setup { } -body { set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]] -- cgit v0.12 From 720183a9af204a0db0d0211ea410609891ebd9d6 Mon Sep 17 00:00:00 2001 From: kjnash Date: Tue, 21 Jul 2020 17:34:03 +0000 Subject: In ::safe::interpFindInAccessPath, ::safe::interpAddToAccessPath, add a check that the interpreter belongs to the Safe Base. Add comments on why this is not done for ::safe::interpDelete. --- library/safe.tcl | 8 +++++++- tests/safe.test | 6 ++++++ 2 files changed, 13 insertions(+), 1 deletion(-) diff --git a/library/safe.tcl b/library/safe.tcl index 6b531be..3e8c2c6 100644 --- a/library/safe.tcl +++ b/library/safe.tcl @@ -444,6 +444,7 @@ proc ::safe::InterpSetConfig {slave access_path staticsok nestedok deletehook} { # Search for a real directory and returns its virtual Id (including the # "$") proc ::safe::interpFindInAccessPath {slave path} { + CheckInterp $slave namespace upvar ::safe [VarName $slave] state if {![dict exists $state(access_path,remap) $path]} { @@ -460,6 +461,7 @@ proc ::safe::interpFindInAccessPath {slave path} { proc ::safe::interpAddToAccessPath {slave path} { # first check if the directory is already in there # (inlined interpFindInAccessPath). + CheckInterp $slave namespace upvar ::safe [VarName $slave] state if {[dict exists $state(access_path,remap) $path]} { @@ -591,11 +593,15 @@ proc ::safe::AddSubDirs {pathList} { } # This procedure deletes a safe slave managed by Safe Tcl and cleans up -# associated state: +# associated state. +# - The command will also delete non-Safe-Base interpreters. +# - This is regrettable, but to avoid breaking existing code this should be +# amended at the next major revision by uncommenting "CheckInterp". proc ::safe::interpDelete {slave} { Log $slave "About to delete" NOTICE + # CheckInterp $slave namespace upvar ::safe [VarName $slave] state # When an interpreter is deleted with [interp delete], any sub-interpreters diff --git a/tests/safe.test b/tests/safe.test index 1415b09..f6d1826 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -94,6 +94,8 @@ test safe-2.2 {creating interpreters, should have no aliases} -setup { a aliases } -cleanup { safe::interpDelete a + # This (ab)use of safe::interpDelete to delete non-Safe-Base interpreters + # is regrettable and should be removed at the next major revision. } -result "" test safe-2.3 {creating safe interpreters, should have no unexpected aliases} -setup { catch {safe::interpDelete a} @@ -143,6 +145,8 @@ test safe-4.1 {safe::interpDelete} -setup { } -body { interp create a safe::interpDelete a + # This (ab)use of safe::interpDelete to delete non-Safe-Base interpreters + # is regrettable and should be removed at the next major revision. } -result "" test safe-4.2 {safe::interpDelete, indirectly} -setup { catch {safe::interpDelete a} @@ -150,6 +154,8 @@ test safe-4.2 {safe::interpDelete, indirectly} -setup { interp create a a alias exit safe::interpDelete a a eval exit + # This (ab)use of safe::interpDelete to delete non-Safe-Base interpreters + # is regrettable and should be removed at the next major revision. } -result "" test safe-4.5 {safe::interpDelete} -setup { catch {safe::interpDelete a} -- cgit v0.12 From 7fba80338f20600d84ce7685436e377329c4c970 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 22 Jul 2020 15:28:39 +0000 Subject: Convert test-cases to do proper setup/cleanup --- tests/io.test | 46 +++++++++++++++++++++++++++++----------------- 1 file changed, 29 insertions(+), 17 deletions(-) diff --git a/tests/io.test b/tests/io.test index 1a30850..86e426c 100644 --- a/tests/io.test +++ b/tests/io.test @@ -6719,8 +6719,9 @@ test io-49.5 {testing crlf reading, leftover cr disgorgment} { set l } [list 7 a\rb\rc 7 {} 7 1] -test io-50.1 {testing handler deletion} testchannelevent { +test io-50.1 {testing handler deletion} -constraints testchannelevent -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] close $f set f [open $path(test1) r] @@ -6732,11 +6733,13 @@ test io-50.1 {testing handler deletion} testchannelevent { } set z not_called update - close $f set z -} called -test io-50.2 {testing handler deletion with multiple handlers} testchannelevent { +} -cleanup { + close $f +} -result called +test io-50.2 {testing handler deletion with multiple handlers} -constraints testchannelevent -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] close $f set f [open $path(test1) r] @@ -6749,12 +6752,14 @@ test io-50.2 {testing handler deletion with multiple handlers} testchannelevent } set z "" update - close $f string compare [string tolower $z] \ [list [list called delhandler $f 0] [list called delhandler $f 1]] -} 0 -test io-50.3 {testing handler deletion with multiple handlers} testchannelevent { +} -cleanup { + close $f +} -result 0 +test io-50.3 {testing handler deletion with multiple handlers} -constraints testchannelevent -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] close $f set f [open $path(test1) r] @@ -6774,13 +6779,15 @@ test io-50.3 {testing handler deletion with multiple handlers} testchannelevent } set z "" update - close $f string compare [string tolower $z] \ [list [list delhandler $f 0 called] \ [list delhandler $f 0 deleted myself]] -} 0 -test io-50.4 {testing handler deletion vs reentrant calls} testchannelevent { +} -cleanup { + close $f +} -result 0 +test io-50.4 {testing handler deletion vs reentrant calls} -constraints testchannelevent -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] close $f set f [open $path(test1) r] @@ -6800,11 +6807,13 @@ test io-50.4 {testing handler deletion vs reentrant calls} testchannelevent { variable u toplevel variable z "" update - close $f set z -} {{delrecursive calling recursive} {delrecursive deleting recursive}} -test io-50.5 {testing handler deletion vs reentrant calls} testchannelevent { +} -cleanup { + close $f +} -result {{delrecursive calling recursive} {delrecursive deleting recursive}} +test io-50.5 {testing handler deletion vs reentrant calls} -constraints testchannelevent -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] close $f set f [open $path(test1) r] @@ -6834,10 +6843,12 @@ test io-50.5 {testing handler deletion vs reentrant calls} testchannelevent { update close $f set z -} [list {del calling recursive} {del deleted notcalled} \ +} -cleanup { +} -result [list {del calling recursive} {del deleted notcalled} \ {del deleted myself} {del after update}] -test io-50.6 {testing handler deletion vs reentrant calls} testchannelevent { +test io-50.6 {testing handler deletion vs reentrant calls} -constraints testchannelevent -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] close $f set f [open $path(test1) r] @@ -6873,9 +6884,10 @@ test io-50.6 {testing handler deletion vs reentrant calls} testchannelevent { set z "" set u toplevel update - close $f set z -} [list {first called} {first called not toplevel} \ +} -cleanup { + close $f +} -result [list {first called} {first called not toplevel} \ {second called, first time} {second called, second time} \ {first after update}] -- cgit v0.12 From 7f6ef9991b5e56cb237fd047aa75c1c012014a3a Mon Sep 17 00:00:00 2001 From: kjnash Date: Wed, 22 Jul 2020 19:07:30 +0000 Subject: Whitespace changes only. --- tests/safe.test | 12 +++++------- 1 file changed, 5 insertions(+), 7 deletions(-) diff --git a/tests/safe.test b/tests/safe.test index f6d1826..bcb33d7 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -285,7 +285,6 @@ test safe-5.6 {example modules packages, test in master interpreter, append to p catch {namespace delete ::mod1} } -match glob -result {0 0.5 0 1.0 0 2.0 -- res0 res1 res2} - # test safe interps 'information leak' proc SafeEval {script} { # Helper procedure that ensures the safe interp is cleaned up even if @@ -317,7 +316,7 @@ rename SafeEval {} # leaking infos, but they still do... # high level general test -# Use example packages not http1.0 +# Use example packages not http1.0 etc test safe-7.1 {tests that everything works at high level} -setup { set tmpAutoPath $::auto_path lappend ::auto_path [file join $TestsDir auto0] @@ -1012,7 +1011,7 @@ test safe-9.22 {interpConfigure change the access path; check module loading; st set out1 [interp eval $i {mod1::test1::try1}] set out2 [interp eval $i {mod2::test2::try2}] - list [lsort [list $path0 $path1 $path2]] -- $modsA --\ + list [lsort [list $path0 $path1 $path2]] -- $modsA -- \ [lsort [list $path3 $path4 $path5]] -- $modsB -- \ $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $sortA -- $sortB -- \ $out0 $out1 $out2 @@ -1079,7 +1078,7 @@ test safe-9.23 {interpConfigure change the access path; check module loading; st set out1 [interp eval $i {mod1::test1::try1}] set out2 [interp eval $i {mod2::test2::try2}] - list [lsort [list $path0 $path1 $path2]] -- $modsA --\ + list [lsort [list $path0 $path1 $path2]] -- $modsA -- \ [lsort [list $path3 $path4 $path5]] -- $modsB -- \ $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $sortA -- $sortB -- \ $out0 $out1 $out2 @@ -1543,7 +1542,7 @@ test safe-15.1 {safe file ensemble does not surprise code} -setup { unset -nocomplain msg interp delete $i } -result {1 {a b c} 1 {a b c} 1 {invalid command name "file"} 1 0 {a b c} 1 {not allowed to invoke subcommand isdirectory of file}} -test safe-15.1.1 {safe file ensemble does not surprise code} -setup { +test safe-15.2 {safe file ensemble does not surprise code} -setup { set i [interp create -safe] } -body { set result [expr {"file" in [interp hidden $i]}] @@ -1659,12 +1658,11 @@ test safe-16.8 {Bug 3529949: defang ~user in paths used by AliasGlob (2)} -setup unset user } -result {~USER} +# cleanup set ::auto_path $SaveAutoPath unset SaveAutoPath TestsDir PathMapp rename mapList {} rename mapAndSortList {} - -# cleanup ::tcltest::cleanupTests return -- cgit v0.12 From 0e59966ac59400d43816bc360c74e5b9dfb49493 Mon Sep 17 00:00:00 2001 From: kjnash Date: Thu, 23 Jul 2020 13:26:02 +0000 Subject: Improvements to removal of stale package data - bugfix for 1f63efa537 and 319e438f7f --- library/safe.tcl | 40 +++++++++++++--------------------------- 1 file changed, 13 insertions(+), 27 deletions(-) diff --git a/library/safe.tcl b/library/safe.tcl index 3e8c2c6..1c46978 100644 --- a/library/safe.tcl +++ b/library/safe.tcl @@ -219,7 +219,7 @@ proc ::safe::interpConfigure {args} { set deleteHook $state(cleanupHook) } # we can now reconfigure : - set slave_tm_rel [InterpSetConfig $slave $accessPath $statics $nested $deleteHook] + InterpSetConfig $slave $accessPath $statics $nested $deleteHook # auto_reset the slave (to completly synch the new access_path) if {$doreset} { if {[catch {::interp eval $slave {auto_reset}} msg]} { @@ -235,19 +235,18 @@ proc ::safe::interpConfigure {args} { ::tcl::tm::add {*}[lreverse $state(tm_path_slave)]] } - # Wherever possible, refresh package/module data. - # - Ideally [package ifneeded $pkg $ver {}] would clear the - # stale data from the interpreter, but instead it sets a - # nonsense empty script. - # - We cannot purge stale package data, but we can overwrite - # it where we have fresh data. Any remaining stale data will - # do no harm but the error messages may be cryptic. - ::interp eval $slave [list catch {package require NOEXIST}] - foreach rel $slave_tm_rel { - set cmd [list package require [string map {/ ::} $rel]::NOEXIST] - ::interp eval $slave [list catch $cmd] + # Remove stale "package ifneeded" data for non-loaded packages. + # - Not for loaded packages, because "package forget" erases + # data from "package provide" as well as "package ifneeded". + # - This is OK because the script cannot reload any version of + # the package unless it first does "package forget". + foreach pkg [::interp eval $slave {package names}] { + if {[::interp eval $slave [list package provide $pkg]] eq ""} { + ::interp eval $slave [list package forget $pkg] + } } } + return } } } @@ -356,8 +355,6 @@ proc ::safe::InterpSetConfig {slave access_path staticsok nestedok deletehook} { set map_access_path {} set remap_access_path {} set slave_tm_path {} - set slave_tm_roots {} - set slave_tm_rel {} set i 0 foreach dir $access_path { @@ -384,7 +381,6 @@ proc ::safe::InterpSetConfig {slave access_path staticsok nestedok deletehook} { # Later passes handle subdirectories, which belong in the # access path but not in the module path. lappend slave_tm_path [dict get $remap_access_path $dir] - lappend slave_tm_roots [file normalize $dir] [file normalize $dir] } continue } @@ -400,7 +396,6 @@ proc ::safe::InterpSetConfig {slave access_path staticsok nestedok deletehook} { # Later passes handle subdirectories, which belong in the # access path but not in the module path. lappend slave_tm_path $token - lappend slave_tm_roots [file normalize $dir] [file normalize $dir] } incr i @@ -410,16 +405,7 @@ proc ::safe::InterpSetConfig {slave access_path staticsok nestedok deletehook} { # 'platform::shell', which translate into # 'platform/shell-X.tm', i.e arbitrarily deep # subdirectories. - set next [glob -nocomplain -directory $dir -type d *] - lappend morepaths {*}$next - foreach sub $next { - lappend slave_tm_roots [file normalize $sub] [dict get $slave_tm_roots $dir] - set lenny [string length [dict get $slave_tm_roots $dir]] - set relpath [string range [file normalize $sub] $lenny+1 end] - if {$relpath ni $slave_tm_rel} { - lappend slave_tm_rel $relpath - } - } + lappend morepaths {*}[glob -nocomplain -directory $dir -type d *] } set firstpass 0 } @@ -435,7 +421,7 @@ proc ::safe::InterpSetConfig {slave access_path staticsok nestedok deletehook} { set state(cleanupHook) $deletehook SyncAccessPath $slave - return $slave_tm_rel + return } # -- cgit v0.12 From 0d231a3919435409be9374f0a792e364e804b20c Mon Sep 17 00:00:00 2001 From: culler Date: Thu, 23 Jul 2020 13:32:03 +0000 Subject: Check if reverting from os_unfair_lock to OSSpinLock has any effect. --- macosx/tclMacOSXNotify.c | 2 ++ 1 file changed, 2 insertions(+) diff --git a/macosx/tclMacOSXNotify.c b/macosx/tclMacOSXNotify.c index bbbac65..7f451c7 100644 --- a/macosx/tclMacOSXNotify.c +++ b/macosx/tclMacOSXNotify.c @@ -20,11 +20,13 @@ * OSSpinLock, and the OSSpinLock was deprecated. */ +#if 0 #if MAC_OS_X_VERSION_MIN_REQUIRED >= 101200 #define USE_OS_UNFAIR_LOCK #include #undef TCL_MAC_DEBUG_NOTIFIER #endif +#endif #ifdef HAVE_COREFOUNDATION /* Traditional unix select-based notifier is * in tclUnixNotfy.c */ -- cgit v0.12 -- cgit v0.12 From 7c4cabaaae8d1f5b351e2016d56308e2531cca9b Mon Sep 17 00:00:00 2001 From: kjnash Date: Fri, 24 Jul 2020 20:32:20 +0000 Subject: Fix for bug cb0373bb33. In HTTP/1.1 the response header "Connection", if absent, must default to "keep-alive". Add test http11-1.13 and bump version to 2.9.3. --- library/http/http.tcl | 33 ++++++++++++++++++++++++++++----- library/http/pkgIndex.tcl | 2 +- tests/http11.test | 37 +++++++++++++++++++++++++++++++++++++ tests/httpPipeline.test | 2 +- unix/Makefile.in | 4 ++-- win/Makefile.in | 4 ++-- 6 files changed, 71 insertions(+), 11 deletions(-) diff --git a/library/http/http.tcl b/library/http/http.tcl index a93e67b..6e2ac4e 100644 --- a/library/http/http.tcl +++ b/library/http/http.tcl @@ -11,7 +11,7 @@ package require Tcl 8.6- # Keep this in sync with pkgIndex.tcl and with the install directories in # Makefiles -package provide http 2.9.2 +package provide http 2.9.3 namespace eval http { # Allow resourcing to not clobber existing data @@ -721,7 +721,7 @@ proc http::geturl {url args} { body {} status "" http "" - connection close + connection keep-alive } set state(-keepalive) $defaultKeepalive set state(-strict) $strict @@ -1037,7 +1037,7 @@ proc http::geturl {url args} { } # Do not automatically close the connection socket. - set state(connection) {} + set state(connection) keep-alive } } @@ -2688,8 +2688,31 @@ proc http::Event {sock token} { } proxy-connection - connection { - set state(connection) \ - [string trim [string tolower $value]] + set tmpHeader [string trim [string tolower $value]] + # RFC 7230 Section 6.1 states that a comma-separated + # list is an acceptable value. According to + # https://developer.mozilla.org/en-US/docs/Web/HTTP/Headers/Connection + # any comma-separated list implies keep-alive, but I + # don't see this in the RFC so we'll play safe and + # scan any list for "close". + if {$tmpHeader in {close keep-alive}} { + # The common cases, continue. + } elseif {[string first , $tmpHeader] == -1} { + # Not a comma-separated list, not "close", + # therefore "keep-alive". + set tmpHeader keep-alive + } else { + set tmpHeader keep-alive + set tmpCsl [split $tmpHeader ,] + # Optional whitespace either side of separator. + foreach el $tmpCsl { + if {[string trim $el] eq {close}} { + set tmpHeader close + break + } + } + } + set state(connection) $tmpHeader } } lappend state(meta) $key [string trim $value] diff --git a/library/http/pkgIndex.tcl b/library/http/pkgIndex.tcl index 4f5eafb..43cd86b 100644 --- a/library/http/pkgIndex.tcl +++ b/library/http/pkgIndex.tcl @@ -1,2 +1,2 @@ if {![package vsatisfies [package provide Tcl] 8.6-]} {return} -package ifneeded http 2.9.2 [list tclPkgSetup $dir http 2.9.2 {{http.tcl source {::http::config ::http::formatQuery ::http::geturl ::http::reset ::http::wait ::http::register ::http::unregister ::http::mapReply}}}] +package ifneeded http 2.9.3 [list tclPkgSetup $dir http 2.9.3 {{http.tcl source {::http::config ::http::formatQuery ::http::geturl ::http::reset ::http::wait ::http::register ::http::unregister ::http::mapReply}}}] diff --git a/tests/http11.test b/tests/http11.test index 1e30802..6d93d36 100644 --- a/tests/http11.test +++ b/tests/http11.test @@ -60,6 +60,20 @@ proc meta {tok {key ""}} { return $meta } +proc state {tok {key ""}} { + upvar 1 $tok state + if {$key ne ""} { + if {[array names state -exact $key] ne {}} { + return $state($key) + } else { + return "" + } + } + set res [array get state] + dict set res body + return $res +} + proc check_crc {tok args} { set crc [meta $tok x-crc32] set data [expr {[llength $args] ? [lindex $args 0] : [http::data $tok]}] @@ -241,6 +255,29 @@ test http11-1.12 "normal,identity,chunked" -setup { halt_httpd } -result {ok {HTTP/1.1 200 OK} ok {} chunked} +test http11-1.13 "normal, 1.1 and keepalive as server default, no zip" -setup { + variable httpd [create_httpd] + set zipTmp [http::config -zip] + http::config -zip 0 +} -body { + set tok [http::geturl http://localhost:$httpd_port/testdoc.html?transfer= \ + -protocol 1.1 -keepalive 1 -timeout 10000] + http::wait $tok + set res1 [list [http::status $tok] [http::code $tok] [check_crc $tok] \ + [meta $tok connection] [meta $tok transfer-encoding] [state $tok reusing] [state $tok connection]] + set toj [http::geturl http://localhost:$httpd_port/testdoc.html?transfer= \ + -protocol 1.1 -keepalive 1 -timeout 10000] + http::wait $toj + set res2 [list [http::status $toj] [http::code $toj] [check_crc $toj] \ + [meta $toj connection] [meta $toj transfer-encoding] [state $toj reusing] [state $toj connection]] + concat $res1 -- $res2 +} -cleanup { + http::cleanup $tok + http::cleanup $toj + halt_httpd + http::config -zip $zipTmp +} -result {ok {HTTP/1.1 200 OK} ok {} {} 0 keep-alive -- ok {HTTP/1.1 200 OK} ok {} {} 1 keep-alive} + # ------------------------------------------------------------------------- test http11-2.0 "-channel" -setup { diff --git a/tests/httpPipeline.test b/tests/httpPipeline.test index 8de79b9..de1a7d8 100644 --- a/tests/httpPipeline.test +++ b/tests/httpPipeline.test @@ -11,7 +11,7 @@ package require tcltest 2 namespace import -force ::tcltest::* -package require http 2.8 +package require http 2.9 set sourcedir [file normalize [file dirname [info script]]] source [file join $sourcedir httpTest.tcl] diff --git a/unix/Makefile.in b/unix/Makefile.in index 5a023e2..3e0dd1e 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -944,8 +944,8 @@ install-libraries: libraries do \ $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)/http1.0"; \ done; - @echo "Installing package http 2.9.2 as a Tcl Module"; - @$(INSTALL_DATA) $(TOP_DIR)/library/http/http.tcl "$(MODULE_INSTALL_DIR)/8.6/http-2.9.2.tm"; + @echo "Installing package http 2.9.3 as a Tcl Module"; + @$(INSTALL_DATA) $(TOP_DIR)/library/http/http.tcl "$(MODULE_INSTALL_DIR)/8.6/http-2.9.3.tm"; @echo "Installing package opt0.4 files to $(SCRIPT_INSTALL_DIR)/opt0.4/"; @for i in $(TOP_DIR)/library/opt/*.tcl ; \ do \ diff --git a/win/Makefile.in b/win/Makefile.in index 651f6b2..7c0db47 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -719,8 +719,8 @@ install-libraries: libraries install-tzdata install-msgs do \ $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/http1.0"; \ done; - @echo "Installing package http 2.9.2 as a Tcl Module"; - @$(COPY) $(ROOT_DIR)/library/http/http.tcl "$(MODULE_INSTALL_DIR)/8.6/http-2.9.2.tm"; + @echo "Installing package http 2.9.3 as a Tcl Module"; + @$(COPY) $(ROOT_DIR)/library/http/http.tcl "$(MODULE_INSTALL_DIR)/8.6/http-2.9.3.tm"; @echo "Installing library opt0.4 directory"; @for j in $(ROOT_DIR)/library/opt/*.tcl; \ do \ -- cgit v0.12 From e14cd07627b4ca6018dc89e9333418965ef0d56b Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sat, 25 Jul 2020 15:56:10 +0000 Subject: Fix [20dccf1200]: htons-related test fails on Mac OSX Catalina (10.15) Also, let http-related tests check if really http 2.9 is present --- tests/http11.test | 2 +- tests/httpPipeline.test | 2 +- tests/socket.test | 4 ++-- 3 files changed, 4 insertions(+), 4 deletions(-) diff --git a/tests/http11.test b/tests/http11.test index 1e30802..7f59f79 100644 --- a/tests/http11.test +++ b/tests/http11.test @@ -10,7 +10,7 @@ package require tcltest 2 namespace import -force ::tcltest::* -package require http 2.8 +package require http 2.9 # start the server variable httpd_output diff --git a/tests/httpPipeline.test b/tests/httpPipeline.test index 8de79b9..de1a7d8 100644 --- a/tests/httpPipeline.test +++ b/tests/httpPipeline.test @@ -11,7 +11,7 @@ package require tcltest 2 namespace import -force ::tcltest::* -package require http 2.8 +package require http 2.9 set sourcedir [file normalize [file dirname [info script]]] source [file join $sourcedir httpTest.tcl] diff --git a/tests/socket.test b/tests/socket.test index 55b4f2f..87169ae 100644 --- a/tests/socket.test +++ b/tests/socket.test @@ -904,7 +904,7 @@ test socket_$af-5.1 {byte order problems, socket numbers, htons} -body { return {htons problem, should be disallowed, are you running as SU?} } return {couldn't open socket: not owner} -} -constraints [list socket supported_$af unix notRoot] -result {couldn't open socket: not owner} +} -constraints [list socket supported_$af unix notRoot notOSX] -result {couldn't open socket: not owner} test socket_$af-5.2 {byte order problems, socket numbers, htons} -body { if {![catch {socket -server dodo 0x10000} msg]} { close $msg @@ -918,7 +918,7 @@ test socket_$af-5.3 {byte order problems, socket numbers, htons} -body { return {htons problem, should be disallowed, are you running as SU?} } return {couldn't open socket: not owner} -} -constraints [list socket supported_$af unix notRoot] -result {couldn't open socket: not owner} +} -constraints [list socket supported_$af unix notRoot notOSX] -result {couldn't open socket: not owner} test socket_$af-6.1 {accept callback error} -constraints [list socket supported_$af stdio] -setup { proc myHandler {msg options} { -- cgit v0.12 From ca51d20173c55f80a6d14a618d3d95880fb0e4f7 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 3 Aug 2020 15:23:42 +0000 Subject: Testcase cleanup: transform *io-50.* testcases to new test syntax --- tests/chanio.test | 17 ++++--- tests/io.test | 135 ++++++++++++++++++++++++++++++------------------------ 2 files changed, 85 insertions(+), 67 deletions(-) diff --git a/tests/chanio.test b/tests/chanio.test index 67e0f24..07a0d8d 100644 --- a/tests/chanio.test +++ b/tests/chanio.test @@ -5642,7 +5642,9 @@ test chan-io-44.4 {FileEventProc procedure: eror in write event} -setup { catch {chan close $f2} catch {chan close $f3} } -result {bad-write {}} -test chan-io-44.5 {FileEventProc procedure: end of file} {stdio unixExecs openpipe fileevent} { +test chan-io-44.5 {FileEventProc procedure: end of file} -constraints { + stdio unixExecs openpipe fileevent +} -body { set f4 [openpipe r $path(cat) << foo] chan event $f4 readable [namespace code { if {[chan gets $f4 line] < 0} { @@ -5655,9 +5657,10 @@ test chan-io-44.5 {FileEventProc procedure: end of file} {stdio unixExecs openpi variable x initial vwait [namespace which -variable x] vwait [namespace which -variable x] - chan close $f4 set x -} {initial foo eof} +} -cleanup { + chan close $f4 +} -result {initial foo eof} chan close $f makeFile "foo bar" foo @@ -6382,7 +6385,7 @@ test chan-io-50.1 {testing handler deletion} -setup { }] variable z not_called update - return $z + set z } -cleanup { chan close $f } -result called @@ -6450,7 +6453,7 @@ test chan-io-50.4 {testing handler deletion vs reentrant calls} -setup { variable u toplevel variable z "" update - return $z + set z } -cleanup { chan close $f } -result {{delrecursive calling recursive} {delrecursive deleting recursive}} @@ -6484,7 +6487,7 @@ test chan-io-50.5 {testing handler deletion vs reentrant calls} -setup { set z "" set u toplevel update - return $z + set z } -cleanup { chan close $f } -result [list {del calling recursive} {del deleted notcalled} \ @@ -6527,7 +6530,7 @@ test chan-io-50.6 {testing handler deletion vs reentrant calls} -setup { set z "" set u toplevel update - return $z + set z } -cleanup { chan close $f } -result [list {first called} {first called not toplevel} \ diff --git a/tests/io.test b/tests/io.test index 7072b63..e2b1a89 100644 --- a/tests/io.test +++ b/tests/io.test @@ -123,10 +123,10 @@ test io-1.8 {Tcl_WriteChars: WriteChars} { # applied to tcl will cause tcl, more specifically WriteChars, to # go into an infinite loop. - set f [open $path(test2) w] - fconfigure $f -encoding iso2022-jp - puts -nonewline $f [format %s%c [string repeat " " 4] 12399] - close $f + set f [open $path(test2) w] + fconfigure $f -encoding iso2022-jp + puts -nonewline $f [format %s%c [string repeat " " 4] 12399] + close $f contents $path(test2) } " \x1b\$B\$O\x1b(B" @@ -192,7 +192,7 @@ test io-1.9 {Tcl_WriteChars: WriteChars} { test io-2.1 {WriteBytes} { # loop until all bytes are written - + set f [open $path(test1) w] fconfigure $f -encoding binary -buffersize 16 -translation crlf puts $f "abcdefghijklmnopqrstuvwxyz" @@ -214,7 +214,7 @@ test io-2.3 {WriteBytes: flush on line} { # Tcl "line" buffering has weird behavior: if current buffer contains # a \n, entire buffer gets flushed. Logical behavior would be to flush # only up to the \n. - + set f [open $path(test1) w] fconfigure $f -encoding binary -buffering line -translation crlf puts -nonewline $f "\n12" @@ -234,7 +234,7 @@ test io-2.4 {WriteBytes: reset sawLF after each buffer} { test io-3.1 {WriteChars: compatibility with WriteBytes} { # loop until all bytes are written - + set f [open $path(test1) w] fconfigure $f -encoding ascii -buffersize 16 -translation crlf puts $f "abcdefghijklmnopqrstuvwxyz" @@ -256,7 +256,7 @@ test io-3.3 {WriteChars: compatibility with WriteBytes: flush on line} { # Tcl "line" buffering has weird behavior: if current buffer contains # a \n, entire buffer gets flushed. Logical behavior would be to flush # only up to the \n. - + set f [open $path(test1) w] fconfigure $f -encoding ascii -buffering line -translation crlf puts -nonewline $f "\n12" @@ -268,7 +268,7 @@ test io-3.4 {WriteChars: loop over stage buffer} { # stage buffer maps to more than can be queued at once. set f [open $path(test1) w] - fconfigure $f -encoding jis0208 -buffersize 16 + fconfigure $f -encoding jis0208 -buffersize 16 puts -nonewline $f "\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\" set x [list [contents $path(test1)]] close $f @@ -280,7 +280,7 @@ test io-3.5 {WriteChars: saved != 0} { # requested buffersize. set f [open $path(test1) w] - fconfigure $f -encoding jis0208 -buffersize 17 + fconfigure $f -encoding jis0208 -buffersize 17 puts -nonewline $f "\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\" set x [list [contents $path(test1)]] close $f @@ -311,7 +311,7 @@ test io-3.7 {WriteChars: (bufPtr->nextAdded > bufPtr->length)} { # of the next channel buffer. set f [open $path(test1) w] - fconfigure $f -encoding jis0208 -buffersize 17 + fconfigure $f -encoding jis0208 -buffersize 17 puts -nonewline $f "\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\" set x [list [contents $path(test1)]] close $f @@ -381,7 +381,7 @@ test io-4.5 {TranslateOutputEOL: crlf} { test io-5.1 {CheckFlush: not full} { set f [open $path(test1) w] - fconfigure $f + fconfigure $f puts -nonewline $f "12345678901234567890" set x [list [contents $path(test1)]] close $f @@ -470,7 +470,7 @@ set a "bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb" append a $a append a $a test io-6.6 {Tcl_GetsObj: loop test} { - # if (dst >= dstEnd) + # if (dst >= dstEnd) set f [open $path(test1) w] puts $f $a @@ -769,7 +769,7 @@ test io-6.32 {Tcl_GetsObj: crlf mode: buffer exhausted, more data} {testchannel} } [list 15 "123456789012345" 17 3] test io-6.33 {Tcl_GetsObj: crlf mode: buffer exhausted, at eof} { # eol still equals dstEnd - + set f [open $path(test1) w] fconfigure $f -translation lf puts -nonewline $f "123456789012345\r" @@ -781,8 +781,8 @@ test io-6.33 {Tcl_GetsObj: crlf mode: buffer exhausted, at eof} { set x } [list 16 "123456789012345\r" 1] test io-6.34 {Tcl_GetsObj: crlf mode: buffer exhausted, not followed by \n} { - # not (*eol == '\n') - + # not (*eol == '\n') + set f [open $path(test1) w] fconfigure $f -translation lf puts -nonewline $f "123456789012345\rabcd\r\nefg" @@ -889,7 +889,7 @@ test io-6.43 {Tcl_GetsObj: input saw cr} {stdio testchannel openpipe fileevent} fconfigure $f -buffersize 16 set x [list [gets $f]] fconfigure $f -blocking 0 - lappend x [gets $f line] $line [testchannel queuedcr $f] + lappend x [gets $f line] $line [testchannel queuedcr $f] fconfigure $f -blocking 1 puts -nonewline $f "\nabcd\refg\x1a" lappend x [gets $f line] $line [testchannel queuedcr $f] @@ -898,7 +898,7 @@ test io-6.43 {Tcl_GetsObj: input saw cr} {stdio testchannel openpipe fileevent} set x } [list "bbbbbbbbbbbbbbb" 15 "123456789abcdef" 1 4 "abcd" 0 3 "efg"] test io-6.44 {Tcl_GetsObj: input saw cr, not followed by cr} {stdio testchannel openpipe fileevent} { - # not (*eol == '\n') + # not (*eol == '\n') set f [open "|[list [interpreter] $path(cat)]" w+] fconfigure $f -translation {auto lf} -buffering none @@ -906,7 +906,7 @@ test io-6.44 {Tcl_GetsObj: input saw cr, not followed by cr} {stdio testchannel fconfigure $f -buffersize 16 set x [list [gets $f]] fconfigure $f -blocking 0 - lappend x [gets $f line] $line [testchannel queuedcr $f] + lappend x [gets $f line] $line [testchannel queuedcr $f] fconfigure $f -blocking 1 puts -nonewline $f "abcd\refg\x1a" lappend x [gets $f line] $line [testchannel queuedcr $f] @@ -959,10 +959,10 @@ test io-6.47 {Tcl_GetsObj: auto mode: \r at end of buffer, peek for \n} {testcha set x [list [gets $f] [testchannel inputbuffered $f]] close $f set x -} [list "123456789012345" 15] +} [list "123456789012345" 15] test io-6.48 {Tcl_GetsObj: auto mode: \r at end of buffer, no more avail} {testchannel} { # PeekAhead() did not get any, so (eol >= dstEnd) - + set f [open $path(test1) w] fconfigure $f -translation lf puts -nonewline $f "123456789012345\r" @@ -975,7 +975,7 @@ test io-6.48 {Tcl_GetsObj: auto mode: \r at end of buffer, no more avail} {testc } [list "123456789012345" 1] test io-6.49 {Tcl_GetsObj: auto mode: \r followed by \n} {testchannel} { # if (*eol == '\n') {skip++} - + set f [open $path(test1) w] fconfigure $f -translation lf puts -nonewline $f "123456\r\n78901" @@ -986,8 +986,8 @@ test io-6.49 {Tcl_GetsObj: auto mode: \r followed by \n} {testchannel} { set x } [list "123456" 0 8 "78901"] test io-6.50 {Tcl_GetsObj: auto mode: \r not followed by \n} {testchannel} { - # not (*eol == '\n') - + # not (*eol == '\n') + set f [open $path(test1) w] fconfigure $f -translation lf puts -nonewline $f "123456\r78901" @@ -999,7 +999,7 @@ test io-6.50 {Tcl_GetsObj: auto mode: \r not followed by \n} {testchannel} { } [list "123456" 0 7 "78901"] test io-6.51 {Tcl_GetsObj: auto mode: \n} { # else if (*eol == '\n') {goto gotoeol;} - + set f [open $path(test1) w] fconfigure $f -translation lf puts -nonewline $f "123456\n78901" @@ -1092,7 +1092,7 @@ test io-7.1 {FilterInputBytes: split up character at end of buffer} { } "1234567890123\uff10\uff11\uff12\uff13\uff14" test io-7.2 {FilterInputBytes: split up character in middle of buffer} { # (bufPtr->nextAdded < bufPtr->bufLength) - + set f [open $path(test1) w] fconfigure $f -encoding binary puts -nonewline $f "1234567890\n123\x82\x4f\x82\x50\x82" @@ -1201,7 +1201,7 @@ test io-8.4 {PeekAhead: cached data available in this buffer} { set x [gets $f] close $f - set x + set x } $a unset a test io-8.5 {PeekAhead: don't peek if last read was short} {stdio testchannel openpipe fileevent} { @@ -1217,7 +1217,7 @@ test io-8.5 {PeekAhead: don't peek if last read was short} {stdio testchannel op set x } {15 abcdefghijklmno 1} test io-8.6 {PeekAhead: change to non-blocking mode} {stdio testchannel openpipe fileevent} { - # ((chanPtr->flags & CHANNEL_NONBLOCKING) == 0) + # ((chanPtr->flags & CHANNEL_NONBLOCKING) == 0) set f [open "|[list [interpreter] $path(cat)]" w+] fconfigure $f -translation {auto binary} -buffersize 16 @@ -1574,7 +1574,7 @@ test io-13.2 {TranslateInputEOL: crlf mode} { set x } "abcd\ndef\n" test io-13.3 {TranslateInputEOL: crlf mode: naked cr} { - # (src >= srcMax) + # (src >= srcMax) set f [open $path(test1) w] fconfigure $f -translation lf @@ -1587,7 +1587,7 @@ test io-13.3 {TranslateInputEOL: crlf mode: naked cr} { set x } "abcd\ndef\r" test io-13.4 {TranslateInputEOL: crlf mode: cr followed by not \n} { - # (src >= srcMax) + # (src >= srcMax) set f [open $path(test1) w] fconfigure $f -translation lf @@ -1600,7 +1600,7 @@ test io-13.4 {TranslateInputEOL: crlf mode: cr followed by not \n} { set x } "abcd\ndef\rfgh" test io-13.5 {TranslateInputEOL: crlf mode: naked lf} { - # (src >= srcMax) + # (src >= srcMax) set f [open $path(test1) w] fconfigure $f -translation lf @@ -1715,7 +1715,7 @@ test io-13.9 {TranslateInputEOL: auto mode: \r followed by not \n} { set x } "abcd\ndef" test io-13.10 {TranslateInputEOL: auto mode: \n} { - # not (*src == '\r') + # not (*src == '\r') set f [open $path(test1) w] fconfigure $f -translation lf @@ -2064,7 +2064,7 @@ test io-20.1 {Tcl_CreateChannel: initial settings} { encoding system $old close $a set x -} {ascii} +} {ascii} test io-20.2 {Tcl_CreateChannel: initial settings} {win} { set f [open $path(test1) w+] set x [list [fconfigure $f -eofchar] [fconfigure $f -translation]] @@ -2159,7 +2159,7 @@ test io-26.1 {Tcl_GetChannelInstanceData} {stdio openpipe} { set f [open "|[list [interpreter] << exit]"] expr [pid $f] close $f -} {} +} {} # Test flushing. The functions tested here are FlushChannel. @@ -3057,7 +3057,7 @@ test io-30.6 {Tcl_Write cr, Tcl_Read crlf} { fconfigure $f -translation crlf set x [read $f] close $f - set x + set x } "hello\rthere\rand\rhere\r" test io-30.7 {Tcl_Write crlf, Tcl_Read crlf} { file delete $path(test1) @@ -3985,7 +3985,7 @@ test io-31.31 {Tcl_Write crlf on block boundary, Tcl_Gets crlf} { } close $f set f [open $path(test1) r] - fconfigure $f -translation crlf + fconfigure $f -translation crlf set c "" while {[gets $f line] >= 0} { append c $line\n @@ -5474,7 +5474,7 @@ test io-39.13 {Tcl_SetChannelOption, Tcl_GetChannelOption, buffer size} { test io-39.14 {Tcl_SetChannelOption: -encoding, binary & utf-8} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -encoding {} + fconfigure $f -encoding {} puts -nonewline $f \xe7\x89\xa6 close $f set f [open $path(test1) r] @@ -5946,7 +5946,9 @@ test io-44.4 {FileEventProc procedure: eror in write event} -constraints { catch {close $f2} catch {close $f3} } -result {bad-write {}} -test io-44.5 {FileEventProc procedure: end of file} {stdio unixExecs openpipe fileevent} { +test io-44.5 {FileEventProc procedure: end of file} -constraints { + stdio unixExecs openpipe fileevent +} -body { set f4 [open "|[list [interpreter] $path(cat) << foo]" r] fileevent $f4 readable [namespace code { if {[gets $f4 line] < 0} { @@ -5959,9 +5961,10 @@ test io-44.5 {FileEventProc procedure: end of file} {stdio unixExecs openpipe fi variable x initial vwait [namespace which -variable x] vwait [namespace which -variable x] - close $f4 set x -} {initial foo eof} +} -cleanup { + close $f4 +} -result {initial foo eof} close $f makeFile "foo bar" foo @@ -6719,8 +6722,9 @@ test io-49.5 {testing crlf reading, leftover cr disgorgment} { set l } [list 7 a\rb\rc 7 {} 7 1] -test io-50.1 {testing handler deletion} {testchannelevent nonPortable} { +test io-50.1 {testing handler deletion} -constraints {testchannelevent nonPortable} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] close $f set f [open $path(test1) r] @@ -6732,11 +6736,13 @@ test io-50.1 {testing handler deletion} {testchannelevent nonPortable} { } set z not_called update - close $f set z -} called -test io-50.2 {testing handler deletion with multiple handlers} {testchannelevent nonPortable} { +} -cleanup { + close $f +} -result called +test io-50.2 {testing handler deletion with multiple handlers} -constraints {testchannelevent nonPortable} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] close $f set f [open $path(test1) r] @@ -6749,12 +6755,14 @@ test io-50.2 {testing handler deletion with multiple handlers} {testchannelevent } set z "" update - close $f string compare [string tolower $z] \ [list [list called delhandler $f 0] [list called delhandler $f 1]] -} 0 -test io-50.3 {testing handler deletion with multiple handlers} {testchannelevent nonPortable} { +} -cleanup { + close $f +} -result 0 +test io-50.3 {testing handler deletion with multiple handlers} -constraints {testchannelevent nonPortable} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] close $f set f [open $path(test1) r] @@ -6774,13 +6782,15 @@ test io-50.3 {testing handler deletion with multiple handlers} {testchannelevent } set z "" update - close $f string compare [string tolower $z] \ [list [list delhandler $f 0 called] \ [list delhandler $f 0 deleted myself]] -} 0 -test io-50.4 {testing handler deletion vs reentrant calls} {testchannelevent nonPortable} { +} -cleanup { + close $f +} -result 0 +test io-50.4 {testing handler deletion vs reentrant calls} -constraints {testchannelevent nonPortable} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] close $f set f [open $path(test1) r] @@ -6800,11 +6810,13 @@ test io-50.4 {testing handler deletion vs reentrant calls} {testchannelevent non variable u toplevel variable z "" update - close $f set z -} {{delrecursive calling recursive} {delrecursive deleting recursive}} -test io-50.5 {testing handler deletion vs reentrant calls} {testchannelevent nonPortable} { +} -cleanup { + close $f +} -result {{delrecursive calling recursive} {delrecursive deleting recursive}} +test io-50.5 {testing handler deletion vs reentrant calls} -constraints {testchannelevent nonPortable} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] close $f set f [open $path(test1) r] @@ -6832,12 +6844,14 @@ test io-50.5 {testing handler deletion vs reentrant calls} {testchannelevent non set z "" set u toplevel update + set z +} -cleanup { close $f - set z -} [list {del calling recursive} {del deleted notcalled} \ +} -result [list {del calling recursive} {del deleted notcalled} \ {del deleted myself} {del after update}] -test io-50.6 {testing handler deletion vs reentrant calls} {testchannelevent nonPortable} { +test io-50.6 {testing handler deletion vs reentrant calls} -constraints {testchannelevent nonPortable} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] close $f set f [open $path(test1) r] @@ -6873,9 +6887,10 @@ test io-50.6 {testing handler deletion vs reentrant calls} {testchannelevent non set z "" set u toplevel update - close $f set z -} [list {first called} {first called not toplevel} \ +} -cleanup { + close $f +} -result [list {first called} {first called not toplevel} \ {second called, first time} {second called, second time} \ {first after update}] @@ -8648,11 +8663,11 @@ test io-74.1 {[104f2885bb] improper cache validity check} -setup { interp create slave } -constraints testobj -body { teststringobj set 1 [string range $rfd 0 end] - read [teststringobj get 1] + read [teststringobj get 1] testobj duplicate 1 2 interp transfer {} $rfd slave catch {read [teststringobj get 1]} - read [teststringobj get 2] + read [teststringobj get 2] } -cleanup { interp delete slave testobj freeallvars -- cgit v0.12 From 35d0992797dc0bcdfae9edb823cb03c41bf37a5d Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 3 Aug 2020 22:42:50 +0000 Subject: doc fix --- doc/CrtAlias.3 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/CrtAlias.3 b/doc/CrtAlias.3 index 82ef122..10192e9 100644 --- a/doc/CrtAlias.3 +++ b/doc/CrtAlias.3 @@ -29,7 +29,7 @@ Tcl_Interp * \fBTcl_GetMaster\fR(\fIinterp\fR) .sp int -\fBTcl_GetInterpPath\fR(\finterp, slaveInterp\fR) +\fBTcl_GetInterpPath\fR(\fIinterp, slaveInterp\fR) .sp int \fBTcl_CreateAlias\fR(\fIslaveInterp, slaveCmd, targetInterp, targetCmd, -- cgit v0.12 From 9557127009db74d0f4196e17d6cf1f536ef73547 Mon Sep 17 00:00:00 2001 From: culler Date: Thu, 6 Aug 2020 13:09:22 +0000 Subject: Experiment with chan-io-50.6 on Travis --- tests/chanio.test | 15 +++++++++++---- 1 file changed, 11 insertions(+), 4 deletions(-) diff --git a/tests/chanio.test b/tests/chanio.test index cdaf183..5266d57 100644 --- a/tests/chanio.test +++ b/tests/chanio.test @@ -6497,9 +6497,6 @@ test chan-io-50.6 {testing handler deletion vs reentrant calls} -setup { set f [open $path(test1) w] chan close $f } -constraints testchannelevent -body { - set f [open $path(test1) r] - testchannelevent $f add readable [namespace code [list second $f]] - testchannelevent $f add readable [namespace code [list first $f]] proc first {f} { variable u variable z @@ -6529,11 +6526,21 @@ test chan-io-50.6 {testing handler deletion vs reentrant calls} -setup { } set z "" set u toplevel + # Testing why this test fails on Travis: + # The test appears to assume that select will not detect the + # new file until update is called. + lappend z "1" + set f [open $path(test1) r] + lappend z "2" + testchannelevent $f add readable [namespace code [list second $f]] + lappend z "3" + testchannelevent $f add readable [namespace code [list first $f]] + lappend z "update" update set z } -cleanup { chan close $f -} -result [list {first called} {first called not toplevel} \ +} -result [list 1 2 3 update {first called} {first called not toplevel} \ {second called, first time} {second called, second time} \ {first after update}] -- cgit v0.12 From f460900f9f25ca6b02f7e5de803eb63a84a2d12a Mon Sep 17 00:00:00 2001 From: culler Date: Fri, 7 Aug 2020 13:12:21 +0000 Subject: Experiment with io-50.1 on Travis --- tests/chanio.test | 11 ++++------- tests/io.test | 9 +++++---- 2 files changed, 9 insertions(+), 11 deletions(-) diff --git a/tests/chanio.test b/tests/chanio.test index 5266d57..7ffe492 100644 --- a/tests/chanio.test +++ b/tests/chanio.test @@ -6526,16 +6526,13 @@ test chan-io-50.6 {testing handler deletion vs reentrant calls} -setup { } set z "" set u toplevel - # Testing why this test fails on Travis: - # The test appears to assume that select will not detect the - # new file until update is called. - lappend z "1" + # This test assume that select will not detect the new open file + # until the update command runs. This is not guaranteed, but it + # seems to help if we make sure that the calls to testchannelevent + # immediately follow the call to open. set f [open $path(test1) r] - lappend z "2" testchannelevent $f add readable [namespace code [list second $f]] - lappend z "3" testchannelevent $f add readable [namespace code [list first $f]] - lappend z "update" update set z } -cleanup { diff --git a/tests/io.test b/tests/io.test index 912f4c5..c9019af 100644 --- a/tests/io.test +++ b/tests/io.test @@ -6725,17 +6725,18 @@ test io-49.5 {testing crlf reading, leftover cr disgorgment} { test io-50.1 {testing handler deletion} -constraints testchannelevent -setup { file delete $path(test1) } -body { - set f [open $path(test1) w] - close $f - set f [open $path(test1) r] - testchannelevent $f add readable [namespace code [list delhandler $f]] proc delhandler {f} { variable z set z called testchannelevent $f delete 0 } + set f [open $path(test1) w] + close $f set z not_called update + set f [open $path(test1) r] + testchannelevent $f add readable [namespace code [list delhandler $f]] + update set z } -cleanup { close $f -- cgit v0.12 From bb9b5e7606e6deecd6b7bfc7683be22d1c5c90b6 Mon Sep 17 00:00:00 2001 From: culler Date: Fri, 7 Aug 2020 13:15:31 +0000 Subject: Fix the expected result for chanio-50.6 --- tests/chanio.test | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/chanio.test b/tests/chanio.test index 7ffe492..4f348f8 100644 --- a/tests/chanio.test +++ b/tests/chanio.test @@ -6537,7 +6537,7 @@ test chan-io-50.6 {testing handler deletion vs reentrant calls} -setup { set z } -cleanup { chan close $f -} -result [list 1 2 3 update {first called} {first called not toplevel} \ +} -result [list {first called} {first called not toplevel} \ {second called, first time} {second called, second time} \ {first after update}] -- cgit v0.12 From 4b765a3aff40f73f918d159af41222d1ce972b24 Mon Sep 17 00:00:00 2001 From: culler Date: Sat, 8 Aug 2020 21:27:06 +0000 Subject: Add and use testservicemode command; replace update by vwait --- generic/tclTest.c | 52 ++++++++++++++++++++++++++++- tests/chanio.test | 42 +++++++++++++++-------- tests/event.test | 1 + tests/io.test | 99 ++++++++++++++++++++++++++++++++++--------------------- 4 files changed, 141 insertions(+), 53 deletions(-) diff --git a/generic/tclTest.c b/generic/tclTest.c index 37aafd2..fde7190 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -307,7 +307,7 @@ static Tcl_FSNormalizePathProc TestReportNormalizePath; static Tcl_FSPathInFilesystemProc TestReportInFilesystem; static Tcl_FSFreeInternalRepProc TestReportFreeInternalRep; static Tcl_FSDupInternalRepProc TestReportDupInternalRep; - +static Tcl_CmdProc TestServiceModeCmd; static Tcl_FSStatProc SimpleStat; static Tcl_FSAccessProc SimpleAccess; static Tcl_FSOpenFileChannelProc SimpleOpenFileChannel; @@ -561,6 +561,8 @@ Tcltest_Init( NULL, NULL); Tcl_CreateObjCommand(interp, "testsaveresult", TestsaveresultCmd, NULL, NULL); + Tcl_CreateCommand(interp, "testservicemode", TestServiceModeCmd, + NULL, NULL); Tcl_CreateCommand(interp, "testsetassocdata", TestsetassocdataCmd, NULL, NULL); Tcl_CreateCommand(interp, "testsetnoerr", TestsetCmd, @@ -6049,6 +6051,54 @@ TestChannelEventCmd( /* *---------------------------------------------------------------------- * + * TestServiceModeCmd -- + * + * This procedure implements the "testservicemode" command which gets or + * sets the current Tcl ServiceMode. There are several tests which open + * a file and assign various handlers to it. For these tests to be + * deterministic it is important that file events not be processed until + * all of the handlers are in place. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * May change the ServiceMode setting. + * + *---------------------------------------------------------------------- + */ + +static int +TestServiceModeCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int argc, /* Number of arguments. */ + const char **argv) /* Argument strings. */ +{ + int newmode, oldmode; + if (argc > 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " ?newmode?\"", NULL); + return TCL_ERROR; + } + oldmode = (Tcl_GetServiceMode() != TCL_SERVICE_NONE); + if (argc == 2) { + if (Tcl_GetInt(interp, argv[1], &newmode) == TCL_ERROR) { + return TCL_ERROR; + } + if (newmode == 0) { + Tcl_SetServiceMode(TCL_SERVICE_NONE); + } else { + Tcl_SetServiceMode(TCL_SERVICE_ALL); + } + } + Tcl_SetObjResult(interp, Tcl_NewIntObj(oldmode)); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * TestWrongNumArgsObjCmd -- * * Test the Tcl_WrongNumArgs function. diff --git a/tests/chanio.test b/tests/chanio.test index 4f348f8..c48fe63 100644 --- a/tests/chanio.test +++ b/tests/chanio.test @@ -6394,14 +6394,16 @@ test chan-io-50.2 {testing handler deletion with multiple handlers} -setup { chan close [open $path(test1) w] set z "" } -constraints testchannelevent -body { - set f [open $path(test1) r] - testchannelevent $f add readable [namespace code [list delhandler $f 1]] - testchannelevent $f add readable [namespace code [list delhandler $f 0]] proc delhandler {f i} { variable z lappend z "called delhandler $f $i" testchannelevent $f delete 0 } + testservicemode 0 + set f [open $path(test1) r] + testchannelevent $f add readable [namespace code [list delhandler $f 1]] + testchannelevent $f add readable [namespace code [list delhandler $f 0]] + testservicemode 1 update string equal $z \ [list [list called delhandler $f 0] [list called delhandler $f 1]] @@ -6411,11 +6413,8 @@ test chan-io-50.2 {testing handler deletion with multiple handlers} -setup { test chan-io-50.3 {testing handler deletion with multiple handlers} -setup { file delete $path(test1) chan close [open $path(test1) w] - set z "" + update } -constraints testchannelevent -body { - set f [open $path(test1) r] - testchannelevent $f add readable [namespace code [list notcalled $f 1]] - testchannelevent $f add readable [namespace code [list delhandler $f 0]] proc notcalled {f i} { variable z lappend z "notcalled was called!! $f $i" @@ -6427,6 +6426,12 @@ test chan-io-50.3 {testing handler deletion with multiple handlers} -setup { testchannelevent $f delete 0 lappend z "delhandler $f $i deleted myself" } + set z "" + testservicemode 0 + set f [open $path(test1) r] + testchannelevent $f add readable [namespace code [list notcalled $f 1]] + testchannelevent $f add readable [namespace code [list delhandler $f 0]] + testservicemode 1 update string equal $z \ [list [list delhandler $f 0 called] \ @@ -6438,6 +6443,7 @@ test chan-io-50.4 {testing handler deletion vs reentrant calls} -setup { file delete $path(test1) set f [open $path(test1) w] chan close $f + update } -constraints testchannelevent -body { set f [open $path(test1) r] testchannelevent $f add readable [namespace code { @@ -6456,15 +6462,14 @@ test chan-io-50.4 {testing handler deletion vs reentrant calls} -setup { set z } -cleanup { chan close $f + update } -result {{delrecursive calling recursive} {delrecursive deleting recursive}} test chan-io-50.5 {testing handler deletion vs reentrant calls} -setup { file delete $path(test1) set f [open $path(test1) w] chan close $f + update } -constraints testchannelevent -body { - set f [open $path(test1) r] - testchannelevent $f add readable [namespace code [list notcalled $f]] - testchannelevent $f add readable [namespace code [list del $f]] proc notcalled {f} { variable z lappend z "notcalled was called!! $f" @@ -6480,22 +6485,31 @@ test chan-io-50.5 {testing handler deletion vs reentrant calls} -setup { } else { set u recursive lappend z "del calling recursive" + set mode [test servicemode 1] update + test servicemode $mode lappend z "del after update" } } set z "" set u toplevel + testservicemode 0 + set f [open $path(test1) r] + testchannelevent $f add readable [namespace code [list notcalled $f]] + testservicemode 1 + testchannelevent $f add readable [namespace code [list del $f]] update set z } -cleanup { chan close $f + update } -result [list {del calling recursive} {del deleted notcalled} \ {del deleted myself} {del after update}] test chan-io-50.6 {testing handler deletion vs reentrant calls} -setup { file delete $path(test1) set f [open $path(test1) w] chan close $f + update } -constraints testchannelevent -body { proc first {f} { variable u @@ -6503,7 +6517,9 @@ test chan-io-50.6 {testing handler deletion vs reentrant calls} -setup { if {$u eq "toplevel"} { lappend z "first called" set u first + set mode [testservicemode 1] update + testservicemode $mode lappend z "first after update" } else { lappend z "first called not toplevel" @@ -6526,13 +6542,11 @@ test chan-io-50.6 {testing handler deletion vs reentrant calls} -setup { } set z "" set u toplevel - # This test assume that select will not detect the new open file - # until the update command runs. This is not guaranteed, but it - # seems to help if we make sure that the calls to testchannelevent - # immediately follow the call to open. + testservicemode 0 set f [open $path(test1) r] testchannelevent $f add readable [namespace code [list second $f]] testchannelevent $f add readable [namespace code [list first $f]] + testservicemode 1 update set z } -cleanup { diff --git a/tests/event.test b/tests/event.test index 336c4e4..b42909c 100644 --- a/tests/event.test +++ b/tests/event.test @@ -33,6 +33,7 @@ test event-1.1 {Tcl_CreateFileHandler, reading} -setup { testfilehandler oneevent lappend result [testfilehandler counts 0] testfilehandler fillpartial 0 + update idletasks testfilehandler oneevent lappend result [testfilehandler counts 0] testfilehandler oneevent diff --git a/tests/io.test b/tests/io.test index c9019af..cfa08ed 100644 --- a/tests/io.test +++ b/tests/io.test @@ -6725,18 +6725,22 @@ test io-49.5 {testing crlf reading, leftover cr disgorgment} { test io-50.1 {testing handler deletion} -constraints testchannelevent -setup { file delete $path(test1) } -body { + set f [open $path(test1) w] + close $f + update proc delhandler {f} { variable z set z called testchannelevent $f delete 0 } - set f [open $path(test1) w] - close $f set z not_called - update + set timer [after 50 lappend z timeout] + testservicemode 0 set f [open $path(test1) r] testchannelevent $f add readable [namespace code [list delhandler $f]] - update + testservicemode 1 + vwait z + after cancel $timer set z } -cleanup { close $f @@ -6746,29 +6750,27 @@ test io-50.2 {testing handler deletion with multiple handlers} -constraints test } -body { set f [open $path(test1) w] close $f - set f [open $path(test1) r] - testchannelevent $f add readable [namespace code [list delhandler $f 1]] - testchannelevent $f add readable [namespace code [list delhandler $f 0]] proc delhandler {f i} { variable z - lappend z "called delhandler $f $i" + lappend z "called delhandler $i" testchannelevent $f delete 0 } set z "" + testservicemode 0 + set f [open $path(test1) r] + testchannelevent $f add readable [namespace code [list delhandler $f 1]] + testchannelevent $f add readable [namespace code [list delhandler $f 0]] + testservicemode 1 update - string compare [string tolower $z] \ - [list [list called delhandler $f 0] [list called delhandler $f 1]] + set z } -cleanup { close $f -} -result 0 +} -result {{called delhandler 0} {called delhandler 1}} test io-50.3 {testing handler deletion with multiple handlers} -constraints testchannelevent -setup { file delete $path(test1) } -body { set f [open $path(test1) w] close $f - set f [open $path(test1) r] - testchannelevent $f add readable [namespace code [list notcalled $f 1]] - testchannelevent $f add readable [namespace code [list delhandler $f 0]] set z "" proc notcalled {f i} { variable z @@ -6777,25 +6779,30 @@ test io-50.3 {testing handler deletion with multiple handlers} -constraints test proc delhandler {f i} { variable z testchannelevent $f delete 1 - lappend z "delhandler $f $i called" + lappend z "delhandler $i called" testchannelevent $f delete 0 - lappend z "delhandler $f $i deleted myself" + lappend z "delhandler $i deleted myself" } set z "" - update - string compare [string tolower $z] \ - [list [list delhandler $f 0 called] \ - [list delhandler $f 0 deleted myself]] + testservicemode 0 + set f [open $path(test1) r] + testchannelevent $f add readable [namespace code [list notcalled $f 1]] + testchannelevent $f add readable [namespace code [list delhandler $f 0]] + testservicemode 1 + set timer [after 50 lappend z timeout] + vwait z + after cancel $timer + set z } -cleanup { close $f -} -result 0 +} -result {{delhandler 0 called} {delhandler 0 deleted myself}} test io-50.4 {testing handler deletion vs reentrant calls} -constraints testchannelevent -setup { file delete $path(test1) + update } -body { set f [open $path(test1) w] close $f - set f [open $path(test1) r] - testchannelevent $f add readable [namespace code [list delrecursive $f]] + update proc delrecursive {f} { variable z variable u @@ -6810,7 +6817,13 @@ test io-50.4 {testing handler deletion vs reentrant calls} -constraints testchan } variable u toplevel variable z "" - update + testservicemode 0 + set f [open $path(test1) r] + testchannelevent $f add readable [namespace code [list delrecursive $f]] + testservicemode 1 + set timer [after 50 lappend z timeout] + vwait z + after cancel $timer set z } -cleanup { close $f @@ -6820,9 +6833,6 @@ test io-50.5 {testing handler deletion vs reentrant calls} -constraints testchan } -body { set f [open $path(test1) w] close $f - set f [open $path(test1) r] - testchannelevent $f add readable [namespace code [list notcalled $f]] - testchannelevent $f add readable [namespace code [list del $f]] proc notcalled {f} { variable z lappend z "notcalled was called!! $f" @@ -6832,40 +6842,48 @@ test io-50.5 {testing handler deletion vs reentrant calls} -constraints testchan variable z if {"$u" == "recursive"} { testchannelevent $f delete 1 - testchannelevent $f delete 0 lappend z "del deleted notcalled" + testchannelevent $f delete 0 lappend z "del deleted myself" } else { set u recursive lappend z "del calling recursive" - update - lappend z "del after update" + set timer [after 50 lappend z timeout] + vwait z + after cancel $timer + lappend z "del after recursive" } } set z "" set u toplevel - update + testservicemode 0 + set f [open $path(test1) r] + testchannelevent $f add readable [namespace code [list notcalled $f]] + testchannelevent $f add readable [namespace code [list del $f]] + testservicemode 1 + set timer [after 50 set z timeout] + vwait z + after cancel $timer set z } -cleanup { close $f } -result [list {del calling recursive} {del deleted notcalled} \ - {del deleted myself} {del after update}] + {del deleted myself} {del after recursive}] test io-50.6 {testing handler deletion vs reentrant calls} -constraints testchannelevent -setup { file delete $path(test1) } -body { set f [open $path(test1) w] close $f - set f [open $path(test1) r] - testchannelevent $f add readable [namespace code [list second $f]] - testchannelevent $f add readable [namespace code [list first $f]] proc first {f} { variable u variable z if {"$u" == "toplevel"} { lappend z "first called" set u first - update - lappend z "first after update" + set timer [after 50 lappend z timeout] + vwait z + after cancel $timer + lappend z "first after toplevel" } else { lappend z "first called not toplevel" } @@ -6887,13 +6905,18 @@ test io-50.6 {testing handler deletion vs reentrant calls} -constraints testchan } set z "" set u toplevel + testservicemode 0 + set f [open $path(test1) r] + testchannelevent $f add readable [namespace code [list second $f]] + testchannelevent $f add readable [namespace code [list first $f]] + testservicemode 1 update set z } -cleanup { close $f } -result [list {first called} {first called not toplevel} \ {second called, first time} {second called, second time} \ - {first after update}] + {first after toplevel}] test io-51.1 {Test old socket deletion on Macintosh} {socket} { set x 0 -- cgit v0.12 From 1cadacd498aa05465ad599e11c5deb0a913d1631 Mon Sep 17 00:00:00 2001 From: culler Date: Sat, 8 Aug 2020 21:37:18 +0000 Subject: One more vwait. --- tests/io.test | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/tests/io.test b/tests/io.test index cfa08ed..a81e394 100644 --- a/tests/io.test +++ b/tests/io.test @@ -6761,7 +6761,9 @@ test io-50.2 {testing handler deletion with multiple handlers} -constraints test testchannelevent $f add readable [namespace code [list delhandler $f 1]] testchannelevent $f add readable [namespace code [list delhandler $f 0]] testservicemode 1 - update + set timer [after 50 lappend z timeout] + vwait z + after cancel $timer set z } -cleanup { close $f -- cgit v0.12 From 5ed72038daa012a53d8b654d220d065b7bb3989c Mon Sep 17 00:00:00 2001 From: culler Date: Sun, 9 Aug 2020 14:33:43 +0000 Subject: use vwait in chanio tests too. --- tests/chanio.test | 36 ++++++++++++++++++++++++------------ 1 file changed, 24 insertions(+), 12 deletions(-) diff --git a/tests/chanio.test b/tests/chanio.test index c48fe63..97d5510 100644 --- a/tests/chanio.test +++ b/tests/chanio.test @@ -6399,12 +6399,15 @@ test chan-io-50.2 {testing handler deletion with multiple handlers} -setup { lappend z "called delhandler $f $i" testchannelevent $f delete 0 } + set z "" + set timer [after 50 lappend z timeout] testservicemode 0 set f [open $path(test1) r] testchannelevent $f add readable [namespace code [list delhandler $f 1]] testchannelevent $f add readable [namespace code [list delhandler $f 0]] testservicemode 1 - update + vwait z + after cancel $timer string equal $z \ [list [list called delhandler $f 0] [list called delhandler $f 1]] } -cleanup { @@ -6413,7 +6416,6 @@ test chan-io-50.2 {testing handler deletion with multiple handlers} -setup { test chan-io-50.3 {testing handler deletion with multiple handlers} -setup { file delete $path(test1) chan close [open $path(test1) w] - update } -constraints testchannelevent -body { proc notcalled {f i} { variable z @@ -6427,12 +6429,14 @@ test chan-io-50.3 {testing handler deletion with multiple handlers} -setup { lappend z "delhandler $f $i deleted myself" } set z "" + set timer [after 50 lappend z timeout] testservicemode 0 set f [open $path(test1) r] testchannelevent $f add readable [namespace code [list notcalled $f 1]] testchannelevent $f add readable [namespace code [list delhandler $f 0]] testservicemode 1 - update + vwait z + after cancel $timer string equal $z \ [list [list delhandler $f 0 called] \ [list delhandler $f 0 deleted myself]] @@ -6443,7 +6447,6 @@ test chan-io-50.4 {testing handler deletion vs reentrant calls} -setup { file delete $path(test1) set f [open $path(test1) w] chan close $f - update } -constraints testchannelevent -body { set f [open $path(test1) r] testchannelevent $f add readable [namespace code { @@ -6458,7 +6461,9 @@ test chan-io-50.4 {testing handler deletion vs reentrant calls} -setup { }] variable u toplevel variable z "" - update + set timer [after 50 lappend z timeout] + vwait z + after cancel $timer set z } -cleanup { chan close $f @@ -6485,20 +6490,24 @@ test chan-io-50.5 {testing handler deletion vs reentrant calls} -setup { } else { set u recursive lappend z "del calling recursive" + set timer [after 50 lappend z timeout] set mode [test servicemode 1] - update + vwait z + after cancel $timer test servicemode $mode lappend z "del after update" } } set z "" set u toplevel + set timer [after 50 lappend z timeout] testservicemode 0 set f [open $path(test1) r] testchannelevent $f add readable [namespace code [list notcalled $f]] - testservicemode 1 testchannelevent $f add readable [namespace code [list del $f]] - update + testservicemode 1 + vwait z + after cancel $timer set z } -cleanup { chan close $f @@ -6509,16 +6518,17 @@ test chan-io-50.6 {testing handler deletion vs reentrant calls} -setup { file delete $path(test1) set f [open $path(test1) w] chan close $f - update } -constraints testchannelevent -body { proc first {f} { variable u variable z if {$u eq "toplevel"} { lappend z "first called" - set u first set mode [testservicemode 1] - update + set timer [after 50 lappend z timeout] + set u first + vwait z + after cancel $timer testservicemode $mode lappend z "first after update" } else { @@ -6542,12 +6552,14 @@ test chan-io-50.6 {testing handler deletion vs reentrant calls} -setup { } set z "" set u toplevel + set timer [after 50 lappend z timeout] testservicemode 0 set f [open $path(test1) r] testchannelevent $f add readable [namespace code [list second $f]] testchannelevent $f add readable [namespace code [list first $f]] testservicemode 1 - update + vwait z + after cancel $timer set z } -cleanup { chan close $f -- cgit v0.12 From 823d13656d0f81807f40c7029fcf4bf38215dedc Mon Sep 17 00:00:00 2001 From: culler Date: Mon, 10 Aug 2020 01:27:37 +0000 Subject: More places where vwait needs to be used instead of update. --- tests/chanio.test | 4 ++-- tests/io.test | 6 +++--- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/tests/chanio.test b/tests/chanio.test index 97d5510..bc6bb1b 100644 --- a/tests/chanio.test +++ b/tests/chanio.test @@ -5731,9 +5731,9 @@ test chan-io-46.1 {Tcl event loop vs multiple interpreters} {testfevent fileeven chan event $f readable {} }] } + set timer [after 10 lappend x timeout] testfevent cmd $script - after 1 ;# We must delay because Windows takes a little time to notice - update + vwait x testfevent cmd {chan close $f} list [testfevent cmd {set x}] [testfevent cmd {info commands after}] } {{f triggered: foo bar} after} diff --git a/tests/io.test b/tests/io.test index a81e394..8c44db9 100644 --- a/tests/io.test +++ b/tests/io.test @@ -6033,10 +6033,10 @@ test io-46.1 {Tcl event loop vs multiple interpreters} {testfevent fileevent} { fileevent $f readable {} }] } + set timer [after 10 lappend x timeout] testfevent cmd $script - after 1 ;# We must delay because Windows takes a little time to notice - update - testfevent cmd {close $f} + vwait x + testfevent cmd {chan close $f} list [testfevent cmd {set x}] [testfevent cmd {info commands after}] } {{f triggered: foo bar} after} test io-46.2 {Tcl event loop vs multiple interpreters} testfevent { -- cgit v0.12 From fd3f2b486c4c480c2fc90ae0a6845bfe0fb310a7 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 10 Aug 2020 14:57:19 +0000 Subject: Remove use of (always enabled) "openpipe" constraint. Add "testservicemode" constraint. Change a single "chan close" into a "close" in a test-case --- tests/chanio.test | 144 ++++++++++++++++++++++++------------------------ tests/io.test | 160 +++++++++++++++++++++++++++--------------------------- 2 files changed, 152 insertions(+), 152 deletions(-) diff --git a/tests/chanio.test b/tests/chanio.test index bc6bb1b..93375a0 100644 --- a/tests/chanio.test +++ b/tests/chanio.test @@ -39,10 +39,10 @@ namespace eval ::tcl::test::io { testConstraint testbytestring [llength [info commands testbytestring]] testConstraint testchannel [llength [info commands testchannel]] - testConstraint openpipe 1 testConstraint testfevent [llength [info commands testfevent]] testConstraint testchannelevent [llength [info commands testchannelevent]] testConstraint testmainthread [llength [info commands testmainthread]] + testConstraint testservicemode [llength [info commands testservicemode]] testConstraint knownMsvcBug [expr {![info exists ::env(TRAVIS_OS_NAME)] || ![string match windows $::env(TRAVIS_OS_NAME)]}] # You need a *very* special environment to do some tests. In particular, @@ -448,7 +448,7 @@ test chan-io-6.6 {Tcl_GetsObj: loop test} -body { } -cleanup { chan close $f } -result [list 256 $a] -test chan-io-6.7 {Tcl_GetsObj: error in input} -constraints {stdio openpipe} -body { +test chan-io-6.7 {Tcl_GetsObj: error in input} -constraints stdio -body { # if (FilterInputBytes(chanPtr, &gs) != 0) set f [openpipe w+ $path(cat)] chan puts -nonewline $f "hi\nwould" @@ -709,7 +709,7 @@ test chan-io-6.30 {Tcl_GetsObj: crlf mode: buffer exhausted} -constraints {testc } -result [list 15 "123456789012345" 15] test chan-io-6.31 {Tcl_GetsObj: crlf mode: buffer exhausted, blocked} -setup { set x "" -} -constraints {stdio testchannel openpipe fileevent} -body { +} -constraints {stdio testchannel fileevent} -body { # (FilterInputBytes() != 0) set f [openpipe w+ $path(cat)] chan configure $f -translation {crlf lf} -buffering none @@ -849,7 +849,7 @@ test chan-io-6.42 {Tcl_GetsObj: auto mode: several chars} -setup { } -result {4 abcd 4 efgh 4 ijkl 4 mnop -1 {}} test chan-io-6.43 {Tcl_GetsObj: input saw cr} -setup { set x "" -} -constraints {stdio testchannel openpipe fileevent} -body { +} -constraints {stdio testchannel fileevent} -body { # if (chanPtr->flags & INPUT_SAW_CR) set f [openpipe w+ $path(cat)] chan configure $f -translation {auto lf} -buffering none @@ -867,7 +867,7 @@ test chan-io-6.43 {Tcl_GetsObj: input saw cr} -setup { } -result {bbbbbbbbbbbbbbb 15 123456789abcdef 1 4 abcd 0 3 efg} test chan-io-6.44 {Tcl_GetsObj: input saw cr, not followed by cr} -setup { set x "" -} -constraints {stdio testchannel openpipe fileevent} -body { +} -constraints {stdio testchannel fileevent} -body { # not (*eol == '\n') set f [openpipe w+ $path(cat)] chan configure $f -translation {auto lf} -buffering none @@ -885,7 +885,7 @@ test chan-io-6.44 {Tcl_GetsObj: input saw cr, not followed by cr} -setup { } -result {bbbbbbbbbbbbbbb 15 123456789abcdef 1 4 abcd 0 3 efg} test chan-io-6.45 {Tcl_GetsObj: input saw cr, skip right number of bytes} -setup { set x "" -} -constraints {stdio testchannel openpipe fileevent} -body { +} -constraints {stdio testchannel fileevent} -body { # Tcl_ExternalToUtf() set f [openpipe w+ $path(cat)] chan configure $f -translation {auto lf} -buffering none @@ -903,7 +903,7 @@ test chan-io-6.45 {Tcl_GetsObj: input saw cr, skip right number of bytes} -setup } -result {15 123456789abcdef 1 4 abcd 0} test chan-io-6.46 {Tcl_GetsObj: input saw cr, followed by just \n should give eof} -setup { set x "" -} -constraints {stdio testchannel openpipe fileevent} -body { +} -constraints {stdio testchannel fileevent} -body { # memmove() set f [openpipe w+ $path(cat)] chan configure $f -translation {auto lf} -buffering none @@ -1021,7 +1021,7 @@ test chan-io-6.55 {Tcl_GetsObj: overconverted} -body { test chan-io-6.56 {Tcl_GetsObj: incomplete lines should disable file events} -setup { update variable x {} -} -constraints {stdio openpipe fileevent} -body { +} -constraints {stdio fileevent} -body { set f [openpipe w+ $path(cat)] chan configure $f -buffering none chan puts -nonewline $f "foobar" @@ -1088,7 +1088,7 @@ test chan-io-7.3 {FilterInputBytes: split up character at EOF} -setup { } -result [list 15 "1234567890123\uff10\uff11" 18 0 1 -1 ""] test chan-io-7.4 {FilterInputBytes: recover from split up character} -setup { variable x "" -} -constraints {stdio openpipe fileevent} -body { +} -constraints {stdio fileevent} -body { set f [openpipe w+ $path(cat)] chan configure $f -encoding binary -buffering none chan puts -nonewline $f "1234567890123\x82\x4f\x82\x50\x82" @@ -1122,7 +1122,7 @@ test chan-io-8.1 {PeekAhead: only go to device if no more cached data} -constrai } -result 7 test chan-io-8.2 {PeekAhead: only go to device if no more cached data} -setup { variable x {} -} -constraints {stdio testchannel openpipe fileevent} -body { +} -constraints {stdio testchannel fileevent} -body { # not (bufPtr->nextPtr == NULL) set f [openpipe w+ $path(cat)] chan configure $f -translation lf -encoding ascii -buffering none @@ -1139,7 +1139,7 @@ test chan-io-8.2 {PeekAhead: only go to device if no more cached data} -setup { } -cleanup { chan close $f } -result {-1 {} 42 15 123456789012345 25} -test chan-io-8.3 {PeekAhead: no cached data available} -constraints {stdio testchannel openpipe fileevent} -body { +test chan-io-8.3 {PeekAhead: no cached data available} -constraints {stdio testchannel fileevent} -body { # (bytesLeft == 0) set f [openpipe w+ $path(cat)] chan configure $f -translation {auto binary} @@ -1168,7 +1168,7 @@ test chan-io-8.4 {PeekAhead: cached data available in this buffer} -body { chan close $f } -result $a unset a -test chan-io-8.5 {PeekAhead: don't peek if last read was short} -constraints {stdio testchannel openpipe fileevent} -body { +test chan-io-8.5 {PeekAhead: don't peek if last read was short} -constraints {stdio testchannel fileevent} -body { # (bufPtr->nextAdded < bufPtr->length) set f [openpipe w+ $path(cat)] chan configure $f -translation {auto binary} @@ -1179,7 +1179,7 @@ test chan-io-8.5 {PeekAhead: don't peek if last read was short} -constraints {st } -cleanup { chan close $f } -result {15 abcdefghijklmno 1} -test chan-io-8.6 {PeekAhead: change to non-blocking mode} -constraints {stdio testchannel openpipe fileevent} -body { +test chan-io-8.6 {PeekAhead: change to non-blocking mode} -constraints {stdio testchannel fileevent} -body { # ((chanPtr->flags & CHANNEL_NONBLOCKING) == 0) set f [openpipe w+ $path(cat)] chan configure $f -translation {auto binary} -buffersize 16 @@ -1192,7 +1192,7 @@ test chan-io-8.6 {PeekAhead: change to non-blocking mode} -constraints {stdio te } -result {15 abcdefghijklmno 1} test chan-io-8.7 {PeekAhead: cleanup} -setup { set x "" -} -constraints {stdio testchannel openpipe fileevent} -body { +} -constraints {stdio testchannel fileevent} -body { # Make sure bytes are removed from buffer. set f [openpipe w+ $path(cat)] chan configure $f -translation {auto binary} -buffering none @@ -1343,7 +1343,7 @@ test chan-io-12.3 {ReadChars: allocate more space} -body { } -result {abcdefghijklmnopqrstuvwxyz} test chan-io-12.4 {ReadChars: split-up char} -setup { variable x {} -} -constraints {stdio testchannel openpipe fileevent} -body { +} -constraints {stdio testchannel fileevent} -body { # (srcRead == 0) set f [openpipe w+ $path(cat)] chan configure $f -encoding binary -buffering none -buffersize 16 @@ -1365,7 +1365,7 @@ test chan-io-12.4 {ReadChars: split-up char} -setup { } -result [list "123456789012345" 1 "\u672c" 0] test chan-io-12.5 {ReadChars: chan events on partial characters} -setup { variable x {} -} -constraints {stdio openpipe fileevent} -body { +} -constraints {stdio fileevent} -body { set path(test1) [makeFile { chan configure stdout -encoding binary -buffering none chan gets stdin; chan puts -nonewline "\xe7" @@ -1458,7 +1458,7 @@ test chan-io-13.5 {TranslateInputEOL: crlf mode: naked lf} -body { test chan-io-13.6 {TranslateInputEOL: auto mode: saw cr in last segment} -setup { variable x {} variable y {} -} -constraints {stdio testchannel openpipe fileevent} -body { +} -constraints {stdio testchannel fileevent} -body { # (chanPtr->flags & INPUT_SAW_CR) # This test may fail on slower machines. set f [openpipe w+ $path(cat)] @@ -1476,7 +1476,7 @@ test chan-io-13.6 {TranslateInputEOL: auto mode: saw cr in last segment} -setup } -cleanup { chan close $f } -result [list "abcdefghj\n" 1 "01234" 0] -test chan-io-13.7 {TranslateInputEOL: auto mode: naked \r} -constraints {testchannel openpipe} -body { +test chan-io-13.7 {TranslateInputEOL: auto mode: naked \r} -constraints testchannel -body { # (src >= srcMax) set f [open $path(test1) w] chan configure $f -translation lf @@ -1577,7 +1577,7 @@ test chan-io-14.2 {Tcl_SetStdChannel and Tcl_GetStdChannel} -setup { interp delete x } -result {line line none} set path(test3) [makeFile {} test3] -test chan-io-14.3 {Tcl_SetStdChannel & Tcl_GetStdChannel} -constraints {exec openpipe} -body { +test chan-io-14.3 {Tcl_SetStdChannel & Tcl_GetStdChannel} -constraints exec -body { set f [open $path(test1) w] chan puts -nonewline $f { chan close stdin @@ -1674,7 +1674,7 @@ set path(script) [makeFile {} script] test chan-io-14.8 {reuse of stdio special channels} -setup { file delete $path(script) file delete $path(test1) -} -constraints {stdio openpipe} -body { +} -constraints stdio -body { set f [open $path(script) w] chan puts -nonewline $f { chan close stderr @@ -1697,7 +1697,7 @@ test chan-io-14.8 {reuse of stdio special channels} -setup { test chan-io-14.9 {reuse of stdio special channels} -setup { file delete $path(script) file delete $path(test1) -} -constraints {stdio openpipe fileevent} -body { +} -constraints {stdio fileevent} -body { set f [open $path(script) w] chan puts $f { array set path [lindex $argv 0] @@ -1881,7 +1881,7 @@ test chan-io-20.3 {Tcl_CreateChannel: initial settings} -constraints {unix} -bod } -result {{{} {}} {auto lf}} test chan-io-20.5 {Tcl_CreateChannel: install channel in empty slot} -setup { set path(stdout) [makeFile {} stdout] -} -constraints {stdio openpipe knownMsvcBug} -body { +} -constraints {stdio knownMsvcBug} -body { set f [open $path(script) w] chan puts -nonewline $f { chan close stdout @@ -1966,7 +1966,7 @@ test chan-io-26.1 {Tcl_GetChannelInstanceData} -body { # Don't care what pid is (but must be a number), just want to exercise it. set f [openpipe r << exit] pid $f -} -constraints {stdio openpipe} -cleanup { +} -constraints stdio -cleanup { chan close $f } -match regexp -result {^\d+$} @@ -2041,7 +2041,7 @@ set path(output) [makeFile {} output] test chan-io-27.6 {FlushChannel, async flushing, async chan close} -setup { file delete $path(pipe) file delete $path(output) -} -constraints {stdio asyncPipeChan Close openpipe} -body { +} -constraints {stdio asyncPipeChan Close} -body { set f [open $path(pipe) w] chan puts $f "set f \[[list open $path(output) w]]" chan puts $f { @@ -2111,7 +2111,7 @@ test chan-io-28.2 {Chan CloseChannel called when all references are dropped} -se test chan-io-28.3 {Chan CloseChannel, not called before output queue is empty} -setup { file delete $path(pipe) file delete $path(output) -} -constraints {stdio asyncPipeChan Close nonPortable openpipe} -body { +} -constraints {stdio asyncPipeChan Close nonPortable} -body { set f [open $path(pipe) w] chan puts $f { # Need to not have eof char appended on chan close, because the other @@ -2165,7 +2165,7 @@ test chan-io-28.4 {Tcl_Chan Close} -constraints {testchannel} -setup { } -result ok test chan-io-28.5 {Tcl_Chan Close vs standard handles} -setup { file delete $path(script) -} -constraints {stdio unix testchannel openpipe} -body { +} -constraints {stdio unix testchannel} -body { set f [open $path(script) w] chan puts $f { chan close stdin @@ -2382,7 +2382,7 @@ test chan-io-29.11 {Tcl_WriteChars, no newline, implicit flush} -setup { test chan-io-29.12 {Tcl_WriteChars on a pipe} -setup { file delete $path(test1) file delete $path(pipe) -} -constraints {stdio openpipe} -body { +} -constraints stdio -body { set f1 [open $path(pipe) w] chan puts $f1 "set f1 \[[list open $path(longfile) r]]" chan puts $f1 { @@ -2409,7 +2409,7 @@ test chan-io-29.12 {Tcl_WriteChars on a pipe} -setup { test chan-io-29.13 {Tcl_WriteChars to a pipe, line buffered} -setup { file delete $path(test1) file delete $path(pipe) -} -constraints {stdio openpipe} -body { +} -constraints stdio -body { set f1 [open $path(pipe) w] chan puts $f1 { chan puts [chan gets stdin] @@ -2462,7 +2462,7 @@ test chan-io-29.15 {Tcl_Flush, channel not open for writing} -setup { } -match glob -result {channel "*" wasn't opened for writing} test chan-io-29.16 {Tcl_Flush on pipe opened only for reading} -setup { set fd [openpipe r cat longfile] -} -constraints {stdio openpipe} -body { +} -constraints stdio -body { chan flush $fd } -returnCodes error -cleanup { catch {chan close $fd} @@ -2538,7 +2538,7 @@ test chan-io-29.20 {Implicit flush when buffer is full} -setup { } -result {4096 12288 12600} test chan-io-29.21 {Tcl_Flush to pipe} -setup { file delete $path(pipe) -} -constraints {stdio openpipe} -body { +} -constraints stdio -body { set f1 [open $path(pipe) w] chan puts $f1 {set x [chan read stdin 6]} chan puts $f1 {set cnt [string length $x]} @@ -2553,7 +2553,7 @@ test chan-io-29.21 {Tcl_Flush to pipe} -setup { } -result "read 6 characters" test chan-io-29.22 {Tcl_Flush called at other end of pipe} -setup { file delete $path(pipe) -} -constraints {stdio openpipe} -body { +} -constraints stdio -body { set f1 [open $path(pipe) w] chan puts $f1 { chan configure stdout -buffering full @@ -2577,7 +2577,7 @@ test chan-io-29.22 {Tcl_Flush called at other end of pipe} -setup { } -result {hello hello bye} test chan-io-29.23 {Tcl_Flush and line buffering at end of pipe} -setup { file delete $path(pipe) -} -constraints {stdio openpipe} -body { +} -constraints stdio -body { set f1 [open $path(pipe) w] chan puts $f1 { chan puts hello @@ -2614,7 +2614,7 @@ test chan-io-29.24 {Tcl_WriteChars and Tcl_Flush move end of file} -setup { } -result "{} {Line 1\nLine 2}" test chan-io-29.25 {Implicit flush with Tcl_Flush to command pipelines} -setup { file delete $path(test3) -} -constraints {stdio openpipe fileevent} -body { +} -constraints {stdio fileevent} -body { set f [openpipe w $path(cat) | [interpreter] $path(cat) > $path(test3)] chan puts $f "Line 1" chan puts $f "Line 2" @@ -2625,7 +2625,7 @@ test chan-io-29.25 {Implicit flush with Tcl_Flush to command pipelines} -setup { } -cleanup { chan close $f } -result "Line 1\nLine 2\n" -test chan-io-29.26 {Tcl_Flush, Tcl_Write on bidirectional pipelines} -constraints {stdio unixExecs openpipe} -body { +test chan-io-29.26 {Tcl_Flush, Tcl_Write on bidirectional pipelines} -constraints {stdio unixExecs} -body { set f [open "|[list cat -u]" r+] chan puts $f "Line1" chan flush $f @@ -2638,7 +2638,7 @@ test chan-io-29.27 {Tcl_Flush on chan closed pipeline} -setup { set f [open $path(pipe) w] chan puts $f {exit} chan close $f -} -constraints {stdio openpipe} -body { +} -constraints stdio -body { set f [openpipe r+ $path(pipe)] chan gets $f chan puts $f output @@ -2691,7 +2691,7 @@ test chan-io-29.30 {Tcl_WriteChars, crlf mode} -setup { test chan-io-29.31 {Tcl_WriteChars, background flush} -setup { file delete $path(pipe) file delete $path(output) -} -constraints {stdio openpipe} -body { +} -constraints stdio -body { set f [open $path(pipe) w] chan puts $f "set f \[[list open $path(output) w]]" chan puts $f {chan configure $f -translation lf} @@ -2732,7 +2732,7 @@ test chan-io-29.31 {Tcl_WriteChars, background flush} -setup { test chan-io-29.32 {Tcl_WriteChars, background flush to slow reader} -setup { file delete $path(pipe) file delete $path(output) -} -constraints {stdio asyncPipeChan Close openpipe} -body { +} -constraints {stdio asyncPipeChan Close} -body { set f [open $path(pipe) w] chan puts $f "set f \[[list open $path(output) w]]" chan puts $f {chan configure $f -translation lf} @@ -4005,7 +4005,7 @@ test chan-io-32.9 {Tcl_Read, read to end of file} { } ok test chan-io-32.10 {Tcl_Read from a pipe} -setup { file delete $path(pipe) -} -constraints {stdio openpipe} -body { +} -constraints stdio -body { set f1 [open $path(pipe) w] chan puts $f1 {chan puts [chan gets stdin]} chan close $f1 @@ -4019,7 +4019,7 @@ test chan-io-32.10 {Tcl_Read from a pipe} -setup { test chan-io-32.11 {Tcl_Read from a pipe} -setup { file delete $path(pipe) set x "" -} -constraints {stdio openpipe} -body { +} -constraints stdio -body { set f1 [open $path(pipe) w] chan puts $f1 {chan puts [chan gets stdin]} chan puts $f1 {chan puts [chan gets stdin]} @@ -4131,7 +4131,7 @@ test chan-io-33.2 {Tcl_Gets into variable} { } ok test chan-io-33.3 {Tcl_Gets from pipe} -setup { file delete $path(pipe) -} -constraints {stdio openpipe} -body { +} -constraints stdio -body { set f1 [open $path(pipe) w] chan puts $f1 {chan puts [chan gets stdin]} chan close $f1 @@ -4341,7 +4341,7 @@ test chan-io-34.7 {Tcl_Seek to offset from end of file, then to current position } -result {44 rstuv 49} test chan-io-34.8 {Tcl_Seek on pipes: not supported} -setup { set pipe [openpipe] -} -constraints {stdio openpipe} -body { +} -constraints stdio -body { chan seek $pipe 0 current } -returnCodes error -cleanup { chan close $pipe @@ -4451,13 +4451,13 @@ test chan-io-34.15 {Tcl_Tell combined with seeking} -setup { } -cleanup { chan close $f1 } -result {10 20} -test chan-io-34.16 {Tcl_Tell on pipe: always -1} -constraints {stdio openpipe} -body { +test chan-io-34.16 {Tcl_Tell on pipe: always -1} -constraints stdio -body { set f1 [openpipe] chan tell $f1 } -cleanup { chan close $f1 } -result -1 -test chan-io-34.17 {Tcl_Tell on pipe: always -1} {stdio openpipe} { +test chan-io-34.17 {Tcl_Tell on pipe: always -1} stdio { set f1 [openpipe] chan puts $f1 {chan puts hello} chan flush $f1 @@ -4559,7 +4559,7 @@ test chan-io-35.1 {Tcl_Eof} -setup { } -cleanup { chan close $f } -result {0 0 0 0 1 1} -test chan-io-35.2 {Tcl_Eof with pipe} -constraints {stdio openpipe} -setup { +test chan-io-35.2 {Tcl_Eof with pipe} -constraints stdio -setup { file delete $path(pipe) } -body { set f1 [open $path(pipe) w] @@ -4578,7 +4578,7 @@ test chan-io-35.2 {Tcl_Eof with pipe} -constraints {stdio openpipe} -setup { } -cleanup { chan close $f1 } -result {0 0 0 1} -test chan-io-35.3 {Tcl_Eof with pipe} -constraints {stdio openpipe} -setup { +test chan-io-35.3 {Tcl_Eof with pipe} -constraints stdio -setup { file delete $path(pipe) } -body { set f1 [open $path(pipe) w] @@ -4616,7 +4616,7 @@ test chan-io-35.4 {Tcl_Eof, eof detection on nonblocking file} -setup { test chan-io-35.5 {Tcl_Eof, eof detection on nonblocking pipe} -setup { file delete $path(pipe) set l "" -} -constraints {stdio openpipe} -body { +} -constraints stdio -body { set f [open $path(pipe) w] chan puts $f { exit @@ -4801,7 +4801,7 @@ test chan-io-35.17 {Tcl_Eof, eof char in middle, crlf write, crlf read} -setup { test chan-io-36.1 {Tcl_InputBlocked on nonblocking pipe} -setup { set x "" -} -constraints {stdio openpipe} -body { +} -constraints stdio -body { set f1 [openpipe] chan puts $f1 {chan puts hello_from_pipe} chan flush $f1 @@ -4821,7 +4821,7 @@ test chan-io-36.1 {Tcl_InputBlocked on nonblocking pipe} -setup { } -result {{} 1 hello 0 {} 1} test chan-io-36.2 {Tcl_InputBlocked on blocking pipe} -setup { set x "" -} -constraints {stdio openpipe} -body { +} -constraints stdio -body { set f1 [openpipe] chan configure $f1 -buffering line chan puts $f1 {chan puts hello_from_pipe} @@ -5095,7 +5095,7 @@ test chan-io-39.9 {Tcl_SetChannelOption, blocking mode} -setup { test chan-io-39.10 {Tcl_SetChannelOption, blocking mode} -setup { file delete $path(pipe) set x "" -} -constraints {stdio openpipe} -body { +} -constraints stdio -body { set f1 [open $path(pipe) w] chan puts $f1 { chan gets stdin @@ -5192,7 +5192,7 @@ test chan-io-39.16 {Tcl_SetChannelOption: -encoding, errors} -setup { } -result {unknown encoding "foobar"} test chan-io-39.17 {Tcl_SetChannelOption: -encoding, clearing CHANNEL_NEED_MORE_DATA} -setup { variable x {} -} -constraints {stdio openpipe fileevent} -body { +} -constraints {stdio fileevent} -body { set f [openpipe r+ $path(cat)] chan configure $f -encoding binary chan puts -nonewline $f "\xe7" @@ -5552,7 +5552,7 @@ test chan-io-43.2 {Tcl_FileeventCmd: deleting when many present} -setup { set f2 [open "|[list cat -u]" r+] set f3 [open "|[list cat -u]" r+] set result {} -} -constraints {stdio unixExecs fileevent openpipe} -body { +} -constraints {stdio unixExecs fileevent} -body { lappend result [chan event $f r] [chan event $f2 r] [chan event $f3 r] chan event $f r "chan read f" chan event $f2 r "chan read f2" @@ -5572,7 +5572,7 @@ test chan-io-43.2 {Tcl_FileeventCmd: deleting when many present} -setup { test chan-io-44.1 {FileEventProc procedure: normal read event} -setup { set f2 [open "|[list cat -u]" r+] set f3 [open "|[list cat -u]" r+] -} -constraints {stdio unixExecs fileevent openpipe} -body { +} -constraints {stdio unixExecs fileevent} -body { chan event $f2 readable [namespace code { set x [chan gets $f2]; chan event $f2 readable {} }] @@ -5592,7 +5592,7 @@ test chan-io-44.2 {FileEventProc procedure: error in read event} -setup { } set handler [interp bgerror {}] interp bgerror {} [namespace which myHandler] -} -constraints {stdio unixExecs fileevent openpipe} -body { +} -constraints {stdio unixExecs fileevent} -body { chan event $f2 readable {error bogus} chan puts $f2 text; chan flush $f2 variable x initial @@ -5606,7 +5606,7 @@ test chan-io-44.2 {FileEventProc procedure: error in read event} -setup { test chan-io-44.3 {FileEventProc procedure: normal write event} -setup { set f2 [open "|[list cat -u]" r+] set f3 [open "|[list cat -u]" r+] -} -constraints {stdio unixExecs fileevent openpipe} -body { +} -constraints {stdio unixExecs fileevent} -body { chan event $f2 writable [namespace code { lappend x "triggered" incr count -1 @@ -5632,7 +5632,7 @@ test chan-io-44.4 {FileEventProc procedure: eror in write event} -setup { } set handler [interp bgerror {}] interp bgerror {} [namespace which myHandler] -} -constraints {stdio unixExecs fileevent openpipe} -body { +} -constraints {stdio unixExecs fileevent} -body { chan event $f2 writable {error bad-write} variable x initial vwait [namespace which -variable x] @@ -5643,7 +5643,7 @@ test chan-io-44.4 {FileEventProc procedure: eror in write event} -setup { catch {chan close $f3} } -result {bad-write {}} test chan-io-44.5 {FileEventProc procedure: end of file} -constraints { - stdio unixExecs openpipe fileevent + stdio unixExecs fileevent } -body { set f4 [openpipe r $path(cat) << foo] chan event $f4 readable [namespace code { @@ -5921,7 +5921,7 @@ test chan-io-48.2 {testing readability conditions} {nonBlockFiles fileevent} { set path(my_script) [makeFile {} my_script] test chan-io-48.3 {testing readability conditions} -setup { set l "" -} -constraints {stdio unix nonBlockFiles openpipe fileevent} -body { +} -constraints {stdio unix nonBlockFiles fileevent} -body { set f [open $path(bar) w] chan puts $f abcdefg chan puts $f abcdefg @@ -6393,7 +6393,7 @@ test chan-io-50.2 {testing handler deletion with multiple handlers} -setup { file delete $path(test1) chan close [open $path(test1) w] set z "" -} -constraints testchannelevent -body { +} -constraints {testchannelevent testservicemode} -body { proc delhandler {f i} { variable z lappend z "called delhandler $f $i" @@ -6416,7 +6416,7 @@ test chan-io-50.2 {testing handler deletion with multiple handlers} -setup { test chan-io-50.3 {testing handler deletion with multiple handlers} -setup { file delete $path(test1) chan close [open $path(test1) w] -} -constraints testchannelevent -body { +} -constraints {testchannelevent testservicemode} -body { proc notcalled {f i} { variable z lappend z "notcalled was called!! $f $i" @@ -6474,7 +6474,7 @@ test chan-io-50.5 {testing handler deletion vs reentrant calls} -setup { set f [open $path(test1) w] chan close $f update -} -constraints testchannelevent -body { +} -constraints {testchannelevent testservicemode} -body { proc notcalled {f} { variable z lappend z "notcalled was called!! $f" @@ -6518,7 +6518,7 @@ test chan-io-50.6 {testing handler deletion vs reentrant calls} -setup { file delete $path(test1) set f [open $path(test1) w] chan close $f -} -constraints testchannelevent -body { +} -constraints {testchannelevent testservicemode} -body { proc first {f} { variable u variable z @@ -6742,7 +6742,7 @@ test chan-io-52.7 {TclCopyChannel} -constraints {fcopy} -setup { test chan-io-52.8 {TclCopyChannel} -setup { file delete $path(test1) file delete $path(pipe) -} -constraints {stdio openpipe fcopy} -body { +} -constraints {stdio fcopy} -body { set f1 [open $path(pipe) w] chan configure $f1 -translation lf chan puts $f1 " @@ -6863,7 +6863,7 @@ test chan-io-53.2 {CopyData} -setup { test chan-io-53.3 {CopyData: background read underflow} -setup { file delete $path(test1) file delete $path(pipe) -} -constraints {stdio unix openpipe fcopy} -body { +} -constraints {stdio unix fcopy} -body { set f1 [open $path(pipe) w] chan puts -nonewline $f1 { chan puts ready @@ -6901,7 +6901,7 @@ test chan-io-53.4 {CopyData: background write overflow} -setup { } file delete $path(test1) file delete $path(pipe) -} -constraints {stdio unix openpipe fileevent fcopy} -body { +} -constraints {stdio unix fileevent fcopy} -body { set f1 [open $path(pipe) w] chan puts $f1 { chan puts ready @@ -6965,7 +6965,7 @@ test chan-io-53.6 {CopyData: error during chan copy} -setup { file delete $path(pipe) file delete $path(test1) catch {unset fcopyTestDone} -} -constraints {stdio openpipe fcopy} -body { +} -constraints {stdio fcopy} -body { set f1 [open $path(pipe) w] chan puts $f1 "exit 1" chan close $f1 @@ -6999,7 +6999,7 @@ test chan-io-53.7 {CopyData: Flooding chan copy from pipe} -setup { variable fcopyTestDone file delete $path(pipe) catch {unset fcopyTestDone} -} -constraints {stdio openpipe fcopy} -body { +} -constraints {stdio fcopy} -body { set fcopyTestCount 0 set f1 [open $path(pipe) w] chan puts $f1 { @@ -7049,7 +7049,7 @@ test chan-io-53.8 {CopyData: async callback and error handling, Bug 1932639} -se # Channels to copy between set f [open $foo r] ; fconfigure $f -translation binary set g [open $bar w] ; fconfigure $g -translation binary -buffering none -} -constraints {stdio openpipe fcopy} -body { +} -constraints {stdio fcopy} -body { # Record input size, so that result is always defined lappend ::RES [file size $bar] # Run the copy. Should not invoke -command now. @@ -7089,7 +7089,7 @@ test chan-io-53.8a {CopyData: async callback and error handling, Bug 1932639, at # Channels to copy between set f [open $foo r] ; chan configure $f -translation binary set g [open $bar w] ; chan configure $g -translation binary -buffering none -} -constraints {stdio openpipe fcopy} -body { +} -constraints {stdio fcopy} -body { # Initialize and force eof on the input. chan seek $f 0 end ; chan read $f 1 set ::RES [chan eof $f] @@ -7147,7 +7147,7 @@ test chan-io-53.9 {CopyData: -size and event interaction, Bug 780533} -setup { } set ::forever {} set out [open $out w] -} -constraints {stdio openpipe fcopy} -body { +} -constraints {stdio fcopy} -body { chan copy $pipe $out -size 6 -command ::done set token [after 5000 { set ::forever {fcopy hangs} @@ -7220,7 +7220,7 @@ test chan-io-53.10 {Bug 1350564, multi-directional fcopy} -setup { chan configure $b -translation binary -buffering none chan event $a readable [namespace code "done $a"] chan event $b readable [namespace code "done $b"] -} -constraints {stdio openpipe fcopy} -body { +} -constraints {stdio fcopy} -body { # Now pass data through the server in both directions. set ::forever {} chan puts $a AB @@ -7442,7 +7442,7 @@ test chan-io-57.2 {buffered data and file events, read} -setup { chan close $server } -result {1 readable 234567890 timer} -test chan-io-58.1 {Tcl_NotifyChannel and error when closing} {stdio unixOrWin openpipe fileevent} { +test chan-io-58.1 {Tcl_NotifyChannel and error when closing} {stdio unixOrWin fileevent} { set out [open $path(script) w] chan puts $out { chan puts "normal message from pipe" @@ -7480,7 +7480,7 @@ test chan-io-59.1 {Thread reference of channels} {testmainthread testchannel} { string equal $result [testmainthread] } {1} -test chan-io-60.1 {writing illegal utf sequences} {openpipe fileevent testbytestring} { +test chan-io-60.1 {writing illegal utf sequences} {fileevent testbytestring} { # This test will hang in older revisions of the core. set out [open $path(script) w] chan puts $out "catch {load $::tcltestlib Tcltest}" diff --git a/tests/io.test b/tests/io.test index 8c44db9..0db6afb 100644 --- a/tests/io.test +++ b/tests/io.test @@ -38,11 +38,11 @@ namespace eval ::tcl::test::io { testConstraint testbytestring [llength [info commands testbytestring]] testConstraint testchannel [llength [info commands testchannel]] -testConstraint openpipe 1 testConstraint testfevent [llength [info commands testfevent]] testConstraint testchannelevent [llength [info commands testchannelevent]] testConstraint testmainthread [llength [info commands testmainthread]] testConstraint testobj [llength [info commands testobj]] +testConstraint testservicemode [llength [info commands testservicemode]] testConstraint knownMsvcBug [expr {![info exists ::env(TRAVIS_OS_NAME)] || ![string match windows $::env(TRAVIS_OS_NAME)]}] # You need a *very* special environment to do some tests. In @@ -481,7 +481,7 @@ test io-6.6 {Tcl_GetsObj: loop test} { close $f set x } [list 256 $a] -test io-6.7 {Tcl_GetsObj: error in input} {stdio openpipe} { +test io-6.7 {Tcl_GetsObj: error in input} stdio { # if (FilterInputBytes(chanPtr, &gs) != 0) set f [open "|[list [interpreter] $path(cat)]" w+] @@ -741,7 +741,7 @@ test io-6.30 {Tcl_GetsObj: crlf mode: buffer exhausted} {testchannel} { close $f set x } [list 15 "123456789012345" 15] -test io-6.31 {Tcl_GetsObj: crlf mode: buffer exhausted, blocked} {stdio testchannel openpipe fileevent} { +test io-6.31 {Tcl_GetsObj: crlf mode: buffer exhausted, blocked} {stdio testchannel fileevent} { # (FilterInputBytes() != 0) set f [open "|[list [interpreter] $path(cat)]" w+] @@ -880,7 +880,7 @@ test io-6.42 {Tcl_GetsObj: auto mode: several chars} { close $f set x } [list 4 "abcd" 4 "efgh" 4 "ijkl" 4 "mnop" -1 ""] -test io-6.43 {Tcl_GetsObj: input saw cr} {stdio testchannel openpipe fileevent} { +test io-6.43 {Tcl_GetsObj: input saw cr} {stdio testchannel fileevent} { # if (chanPtr->flags & INPUT_SAW_CR) set f [open "|[list [interpreter] $path(cat)]" w+] @@ -897,7 +897,7 @@ test io-6.43 {Tcl_GetsObj: input saw cr} {stdio testchannel openpipe fileevent} close $f set x } [list "bbbbbbbbbbbbbbb" 15 "123456789abcdef" 1 4 "abcd" 0 3 "efg"] -test io-6.44 {Tcl_GetsObj: input saw cr, not followed by cr} {stdio testchannel openpipe fileevent} { +test io-6.44 {Tcl_GetsObj: input saw cr, not followed by cr} {stdio testchannel fileevent} { # not (*eol == '\n') set f [open "|[list [interpreter] $path(cat)]" w+] @@ -914,7 +914,7 @@ test io-6.44 {Tcl_GetsObj: input saw cr, not followed by cr} {stdio testchannel close $f set x } [list "bbbbbbbbbbbbbbb" 15 "123456789abcdef" 1 4 "abcd" 0 3 "efg"] -test io-6.45 {Tcl_GetsObj: input saw cr, skip right number of bytes} {stdio testchannel openpipe fileevent} { +test io-6.45 {Tcl_GetsObj: input saw cr, skip right number of bytes} {stdio testchannel fileevent} { # Tcl_ExternalToUtf() set f [open "|[list [interpreter] $path(cat)]" w+] @@ -931,7 +931,7 @@ test io-6.45 {Tcl_GetsObj: input saw cr, skip right number of bytes} {stdio test close $f set x } [list 15 "123456789abcdef" 1 4 "abcd" 0] -test io-6.46 {Tcl_GetsObj: input saw cr, followed by just \n should give eof} {stdio testchannel openpipe fileevent} { +test io-6.46 {Tcl_GetsObj: input saw cr, followed by just \n should give eof} {stdio testchannel fileevent} { # memmove() set f [open "|[list [interpreter] $path(cat)]" w+] @@ -1056,7 +1056,7 @@ test io-6.55 {Tcl_GetsObj: overconverted} { close $f set x } [list 8 "there\u4e00ok" 11 "\u4e01more bytes" 4 "here"] -test io-6.56 {Tcl_GetsObj: incomplete lines should disable file events} {stdio openpipe fileevent} { +test io-6.56 {Tcl_GetsObj: incomplete lines should disable file events} {stdio fileevent} { update set f [open "|[list [interpreter] $path(cat)]" w+] fconfigure $f -buffering none @@ -1116,7 +1116,7 @@ test io-7.3 {FilterInputBytes: split up character at EOF} {testchannel} { close $f set x } [list 15 "1234567890123\uff10\uff11" 18 0 1 -1 ""] -test io-7.4 {FilterInputBytes: recover from split up character} {stdio openpipe fileevent} { +test io-7.4 {FilterInputBytes: recover from split up character} {stdio fileevent} { set f [open "|[list [interpreter] $path(cat)]" w+] fconfigure $f -encoding binary -buffering none puts -nonewline $f "1234567890123\x82\x4f\x82\x50\x82" @@ -1151,7 +1151,7 @@ test io-8.1 {PeekAhead: only go to device if no more cached data} {testchannel} close $f set x } "7" -test io-8.2 {PeekAhead: only go to device if no more cached data} {stdio testchannel openpipe fileevent} { +test io-8.2 {PeekAhead: only go to device if no more cached data} {stdio testchannel fileevent} { # not (bufPtr->nextPtr == NULL) set f [open "|[list [interpreter] $path(cat)]" w+] @@ -1171,7 +1171,7 @@ test io-8.2 {PeekAhead: only go to device if no more cached data} {stdio testcha close $f set x } [list -1 "" 42 15 "123456789012345" 25] -test io-8.3 {PeekAhead: no cached data available} {stdio testchannel openpipe fileevent} { +test io-8.3 {PeekAhead: no cached data available} {stdio testchannel fileevent} { # (bytesLeft == 0) set f [open "|[list [interpreter] $path(cat)]" w+] @@ -1204,7 +1204,7 @@ test io-8.4 {PeekAhead: cached data available in this buffer} { set x } $a unset a -test io-8.5 {PeekAhead: don't peek if last read was short} {stdio testchannel openpipe fileevent} { +test io-8.5 {PeekAhead: don't peek if last read was short} {stdio testchannel fileevent} { # (bufPtr->nextAdded < bufPtr->length) set f [open "|[list [interpreter] $path(cat)]" w+] @@ -1216,7 +1216,7 @@ test io-8.5 {PeekAhead: don't peek if last read was short} {stdio testchannel op close $f set x } {15 abcdefghijklmno 1} -test io-8.6 {PeekAhead: change to non-blocking mode} {stdio testchannel openpipe fileevent} { +test io-8.6 {PeekAhead: change to non-blocking mode} {stdio testchannel fileevent} { # ((chanPtr->flags & CHANNEL_NONBLOCKING) == 0) set f [open "|[list [interpreter] $path(cat)]" w+] @@ -1228,7 +1228,7 @@ test io-8.6 {PeekAhead: change to non-blocking mode} {stdio testchannel openpipe close $f set x } {15 abcdefghijklmno 1} -test io-8.7 {PeekAhead: cleanup} {stdio testchannel openpipe fileevent} { +test io-8.7 {PeekAhead: cleanup} {stdio testchannel fileevent} { # Make sure bytes are removed from buffer. set f [open "|[list [interpreter] $path(cat)]" w+] @@ -1393,7 +1393,7 @@ test io-12.3 {ReadChars: allocate more space} { close $f set x } {abcdefghijklmnopqrstuvwxyz} -test io-12.4 {ReadChars: split-up char} {stdio testchannel openpipe fileevent} { +test io-12.4 {ReadChars: split-up char} {stdio testchannel fileevent} { # (srcRead == 0) set f [open "|[list [interpreter] $path(cat)]" w+] @@ -1418,7 +1418,7 @@ test io-12.4 {ReadChars: split-up char} {stdio testchannel openpipe fileevent} { close $f set x } [list "123456789012345" 1 "\u672c" 0] -test io-12.5 {ReadChars: fileevents on partial characters} {stdio openpipe fileevent} { +test io-12.5 {ReadChars: fileevents on partial characters} {stdio fileevent} { set path(test1) [makeFile { fconfigure stdout -encoding binary -buffering none gets stdin; puts -nonewline "\xe7" @@ -1612,7 +1612,7 @@ test io-13.5 {TranslateInputEOL: crlf mode: naked lf} { close $f set x } "abcd\ndef\nfgh" -test io-13.6 {TranslateInputEOL: auto mode: saw cr in last segment} {stdio testchannel openpipe fileevent} { +test io-13.6 {TranslateInputEOL: auto mode: saw cr in last segment} {stdio testchannel fileevent} { # (chanPtr->flags & INPUT_SAW_CR) # This test may fail on slower machines. @@ -1638,7 +1638,7 @@ test io-13.6 {TranslateInputEOL: auto mode: saw cr in last segment} {stdio testc close $f set x } [list "abcdefghj\n" 1 "01234" 0] -test io-13.7 {TranslateInputEOL: auto mode: naked \r} {testchannel openpipe} { +test io-13.7 {TranslateInputEOL: auto mode: naked \r} testchannel { # (src >= srcMax) set f [open $path(test1) w] @@ -1783,7 +1783,7 @@ test io-14.2 {Tcl_SetStdChannel and Tcl_GetStdChannel} { set l } {line line none} set path(test3) [makeFile {} test3] -test io-14.3 {Tcl_SetStdChannel & Tcl_GetStdChannel} {exec openpipe} { +test io-14.3 {Tcl_SetStdChannel & Tcl_GetStdChannel} exec { set f [open $path(test1) w] puts -nonewline $f { close stdin @@ -1873,7 +1873,7 @@ test io-14.7 {Tcl_GetChannel: stdio name translation} { set result } {{} {} {can not find channel named "stderr"}} set path(script) [makeFile {} script] -test io-14.8 {reuse of stdio special channels} {stdio openpipe} { +test io-14.8 {reuse of stdio special channels} stdio { file delete $path(script) file delete $path(test1) set f [open $path(script) w] @@ -1895,7 +1895,7 @@ test io-14.8 {reuse of stdio special channels} {stdio openpipe} { close $f set c } hello -test io-14.9 {reuse of stdio special channels} {stdio openpipe fileevent} { +test io-14.9 {reuse of stdio special channels} {stdio fileevent} { file delete $path(script) file delete $path(test1) set f [open $path(script) w] @@ -2078,7 +2078,7 @@ test io-20.3 {Tcl_CreateChannel: initial settings} {unix} { set x } {{{} {}} {auto lf}} set path(stdout) [makeFile {} stdout] -test io-20.5 {Tcl_CreateChannel: install channel in empty slot} {stdio openpipe} { +test io-20.5 {Tcl_CreateChannel: install channel in empty slot} stdio { set f [open $path(script) w] puts -nonewline $f { close stdout @@ -2152,7 +2152,7 @@ test io-25.2 {Tcl_GetChannelHandle, output} {testchannel} { set l } {6 6 0 6} -test io-26.1 {Tcl_GetChannelInstanceData} {stdio openpipe} { +test io-26.1 {Tcl_GetChannelInstanceData} stdio { # "pid" command uses Tcl_GetChannelInstanceData # Don't care what pid is (but must be a number), just want to exercise it. @@ -2229,7 +2229,7 @@ test io-27.5 {FlushChannel, implicit flush when buffer fills and on close} \ set path(pipe) [makeFile {} pipe] set path(output) [makeFile {} output] test io-27.6 {FlushChannel, async flushing, async close} \ - {stdio asyncPipeClose openpipe knownMsvcBug} { + {stdio asyncPipeClose knownMsvcBug} { # This test may fail on old Unix systems (seen on IRIX64 6.5) with # obsolete gettimeofday() calls. See Tcl Bugs 3530533, 1942197. file delete $path(pipe) @@ -2298,7 +2298,7 @@ test io-28.2 {CloseChannel called when all references are dropped} { set l } abcdef test io-28.3 {CloseChannel, not called before output queue is empty} \ - {stdio asyncPipeClose nonPortable openpipe} { + {stdio asyncPipeClose nonPortable} { file delete $path(pipe) file delete $path(output) set f [open $path(pipe) w] @@ -2355,7 +2355,7 @@ test io-28.4 {Tcl_Close} {testchannel} { $consoleFileNames] string compare $l $x } 0 -test io-28.5 {Tcl_Close vs standard handles} {stdio unix testchannel openpipe} { +test io-28.5 {Tcl_Close vs standard handles} {stdio unix testchannel} { file delete $path(script) set f [open $path(script) w] puts $f { @@ -2494,7 +2494,7 @@ test io-29.11 {Tcl_WriteChars, no newline, implicit flush} { close $f2 file size $path(test1) } 377 -test io-29.12 {Tcl_WriteChars on a pipe} {stdio openpipe} { +test io-29.12 {Tcl_WriteChars on a pipe} stdio { file delete $path(test1) file delete $path(pipe) set f1 [open $path(pipe) w] @@ -2519,7 +2519,7 @@ test io-29.12 {Tcl_WriteChars on a pipe} {stdio openpipe} { close $f2 set y } ok -test io-29.13 {Tcl_WriteChars to a pipe, line buffered} {stdio openpipe} { +test io-29.13 {Tcl_WriteChars to a pipe, line buffered} stdio { file delete $path(test1) file delete $path(pipe) set f1 [open $path(pipe) w] @@ -2570,7 +2570,7 @@ test io-29.15 {Tcl_Flush, channel not open for writing} { string compare $x \ [list 1 "channel \"$fd\" wasn't opened for writing"] } 0 -test io-29.16 {Tcl_Flush on pipe opened only for reading} {stdio openpipe} { +test io-29.16 {Tcl_Flush on pipe opened only for reading} stdio { set fd [open "|[list [interpreter] cat longfile]" r] set x [list [catch {flush $fd} msg] $msg] catch {close $fd} @@ -2644,7 +2644,7 @@ test io-29.20 {Implicit flush when buffer is full} { lappend z [file size $path(test1)] set z } {4096 12288 12600} -test io-29.21 {Tcl_Flush to pipe} {stdio openpipe} { +test io-29.21 {Tcl_Flush to pipe} stdio { file delete $path(pipe) set f1 [open $path(pipe) w] puts $f1 {set x [read stdin 6]} @@ -2658,7 +2658,7 @@ test io-29.21 {Tcl_Flush to pipe} {stdio openpipe} { catch {close $f1} set x } "read 6 characters" -test io-29.22 {Tcl_Flush called at other end of pipe} {stdio openpipe} { +test io-29.22 {Tcl_Flush called at other end of pipe} stdio { file delete $path(pipe) set f1 [open $path(pipe) w] puts $f1 { @@ -2681,7 +2681,7 @@ test io-29.22 {Tcl_Flush called at other end of pipe} {stdio openpipe} { close $f1 set x } {hello hello bye} -test io-29.23 {Tcl_Flush and line buffering at end of pipe} {stdio openpipe} { +test io-29.23 {Tcl_Flush and line buffering at end of pipe} stdio { file delete $path(pipe) set f1 [open $path(pipe) w] puts $f1 { @@ -2716,7 +2716,7 @@ test io-29.24 {Tcl_WriteChars and Tcl_Flush move end of file} { close $f set x } "{} {Line 1\nLine 2}" -test io-29.25 {Implicit flush with Tcl_Flush to command pipelines} {stdio openpipe fileevent} { +test io-29.25 {Implicit flush with Tcl_Flush to command pipelines} {stdio fileevent} { file delete $path(test3) set f [open "|[list [interpreter] $path(cat) | [interpreter] $path(cat) > $path(test3)]" w] puts $f "Line 1" @@ -2728,7 +2728,7 @@ test io-29.25 {Implicit flush with Tcl_Flush to command pipelines} {stdio openpi close $f set x } "Line 1\nLine 2\n" -test io-29.26 {Tcl_Flush, Tcl_Write on bidirectional pipelines} {stdio unixExecs openpipe} { +test io-29.26 {Tcl_Flush, Tcl_Write on bidirectional pipelines} {stdio unixExecs} { set f [open "|[list cat -u]" r+] puts $f "Line1" flush $f @@ -2736,7 +2736,7 @@ test io-29.26 {Tcl_Flush, Tcl_Write on bidirectional pipelines} {stdio unixExecs close $f set x } {Line1} -test io-29.27 {Tcl_Flush on closed pipeline} {stdio openpipe} { +test io-29.27 {Tcl_Flush on closed pipeline} stdio { file delete $path(pipe) set f [open $path(pipe) w] puts $f {exit} @@ -2790,7 +2790,7 @@ test io-29.30 {Tcl_WriteChars, crlf mode} { close $f file size $path(test1) } 25 -test io-29.31 {Tcl_WriteChars, background flush} {stdio openpipe} { +test io-29.31 {Tcl_WriteChars, background flush} stdio { # This test may fail on old Unix systems (seen on IRIX64 6.5) with # obsolete gettimeofday() calls. See Tcl Bugs 3530533, 1942197. file delete $path(pipe) @@ -2833,7 +2833,7 @@ test io-29.31 {Tcl_WriteChars, background flush} {stdio openpipe} { set result } ok test io-29.32 {Tcl_WriteChars, background flush to slow reader} \ - {stdio asyncPipeClose openpipe knownMsvcBug} { + {stdio asyncPipeClose knownMsvcBug} { # This test may fail on old Unix systems (seen on IRIX64 6.5) with # obsolete gettimeofday() calls. See Tcl Bugs 3530533, 1942197. file delete $path(pipe) @@ -4093,7 +4093,7 @@ test io-32.9 {Tcl_Read, read to end of file} { } set x } ok -test io-32.10 {Tcl_Read from a pipe} {stdio openpipe} { +test io-32.10 {Tcl_Read from a pipe} stdio { file delete $path(pipe) set f1 [open $path(pipe) w] puts $f1 {puts [gets stdin]} @@ -4105,7 +4105,7 @@ test io-32.10 {Tcl_Read from a pipe} {stdio openpipe} { close $f1 set x } "hello\n" -test io-32.11 {Tcl_Read from a pipe} {stdio openpipe} { +test io-32.11 {Tcl_Read from a pipe} stdio { file delete $path(pipe) set f1 [open $path(pipe) w] puts $f1 {puts [gets stdin]} @@ -4124,7 +4124,7 @@ test io-32.11 {Tcl_Read from a pipe} {stdio openpipe} { } {{hello } {hello }} -test io-32.11.1 {Tcl_Read from a pipe} {stdio openpipe} { +test io-32.11.1 {Tcl_Read from a pipe} stdio { file delete $path(pipe) set f1 [open $path(pipe) w] puts $f1 {chan configure stdout -translation crlf} @@ -4144,7 +4144,7 @@ test io-32.11.1 {Tcl_Read from a pipe} {stdio openpipe} { } {{hello } {hello }} -test io-32.11.2 {Tcl_Read from a pipe} {stdio openpipe} { +test io-32.11.2 {Tcl_Read from a pipe} stdio { file delete $path(pipe) set f1 [open $path(pipe) w] puts $f1 {chan configure stdout -translation crlf} @@ -4255,7 +4255,7 @@ test io-33.2 {Tcl_Gets into variable} { close $f1 set z } ok -test io-33.3 {Tcl_Gets from pipe} {stdio openpipe} { +test io-33.3 {Tcl_Gets from pipe} stdio { file delete $path(pipe) set f1 [open $path(pipe) w] puts $f1 {puts [gets stdin]} @@ -4563,7 +4563,7 @@ test io-34.7 {Tcl_Seek to offset from end of file, then to current position} { close $f1 list $c1 $r1 $c2 } {44 rstuv 49} -test io-34.8 {Tcl_Seek on pipes: not supported} {stdio openpipe} { +test io-34.8 {Tcl_Seek on pipes: not supported} stdio { set f1 [open "|[list [interpreter]]" r+] set x [list [catch {seek $f1 0 current} msg] $msg] close $f1 @@ -4671,13 +4671,13 @@ test io-34.15 {Tcl_Tell combined with seeking} { close $f1 list $c1 $c2 } {10 20} -test io-34.16 {Tcl_Tell on pipe: always -1} {stdio openpipe} { +test io-34.16 {Tcl_Tell on pipe: always -1} stdio { set f1 [open "|[list [interpreter]]" r+] set c [tell $f1] close $f1 set c } -1 -test io-34.17 {Tcl_Tell on pipe: always -1} {stdio openpipe} { +test io-34.17 {Tcl_Tell on pipe: always -1} stdio { set f1 [open "|[list [interpreter]]" r+] puts $f1 {puts hello} flush $f1 @@ -4776,7 +4776,7 @@ test io-35.1 {Tcl_Eof} { close $f set x } {0 0 0 0 1 1} -test io-35.2 {Tcl_Eof with pipe} {stdio openpipe} { +test io-35.2 {Tcl_Eof with pipe} stdio { file delete $path(pipe) set f1 [open $path(pipe) w] puts $f1 {gets stdin} @@ -4794,7 +4794,7 @@ test io-35.2 {Tcl_Eof with pipe} {stdio openpipe} { close $f1 set x } {0 0 0 1} -test io-35.3 {Tcl_Eof with pipe} {stdio openpipe} { +test io-35.3 {Tcl_Eof with pipe} stdio { file delete $path(pipe) set f1 [open $path(pipe) w] puts $f1 {gets stdin} @@ -4828,7 +4828,7 @@ test io-35.4 {Tcl_Eof, eof detection on nonblocking file} {nonBlockFiles} { close $f set l } {{} 1} -test io-35.5 {Tcl_Eof, eof detection on nonblocking pipe} {stdio openpipe} { +test io-35.5 {Tcl_Eof, eof detection on nonblocking pipe} stdio { file delete $path(pipe) set f [open $path(pipe) w] puts $f { @@ -5105,7 +5105,7 @@ test io-35.20 {Tcl_Eof, eof char in middle, cr write, crlf read} { # Test Tcl_InputBlocked -test io-36.1 {Tcl_InputBlocked on nonblocking pipe} {stdio openpipe} { +test io-36.1 {Tcl_InputBlocked on nonblocking pipe} stdio { set f1 [open "|[list [interpreter]]" r+] puts $f1 {puts hello_from_pipe} flush $f1 @@ -5124,7 +5124,7 @@ test io-36.1 {Tcl_InputBlocked on nonblocking pipe} {stdio openpipe} { close $f1 set x } {{} 1 hello 0 {} 1} -test io-36.1.1 {Tcl_InputBlocked on nonblocking binary pipe} {stdio openpipe} { +test io-36.1.1 {Tcl_InputBlocked on nonblocking binary pipe} stdio { set f1 [open "|[list [interpreter]]" r+] chan configure $f1 -encoding binary -translation lf -eofchar {} puts $f1 { @@ -5147,7 +5147,7 @@ test io-36.1.1 {Tcl_InputBlocked on nonblocking binary pipe} {stdio openpipe} { close $f1 set x } {{} 1 hello 0 {} 1} -test io-36.2 {Tcl_InputBlocked on blocking pipe} {stdio openpipe} { +test io-36.2 {Tcl_InputBlocked on blocking pipe} stdio { set f1 [open "|[list [interpreter]]" r+] fconfigure $f1 -buffering line puts $f1 {puts hello_from_pipe} @@ -5411,7 +5411,7 @@ test io-39.9 {Tcl_SetChannelOption, blocking mode} {nonBlockFiles} { close $f1 set x } {1 0 {} {} 0 1} -test io-39.10 {Tcl_SetChannelOption, blocking mode} {stdio openpipe} { +test io-39.10 {Tcl_SetChannelOption, blocking mode} stdio { file delete $path(pipe) set f1 [open $path(pipe) w] puts $f1 { @@ -5502,7 +5502,7 @@ test io-39.16 {Tcl_SetChannelOption: -encoding, errors} { close $f set result } {1 {unknown encoding "foobar"}} -test io-39.17 {Tcl_SetChannelOption: -encoding, clearing CHANNEL_NEED_MORE_DATA} {stdio openpipe fileevent} { +test io-39.17 {Tcl_SetChannelOption: -encoding, clearing CHANNEL_NEED_MORE_DATA} {stdio fileevent} { set f [open "|[list [interpreter] $path(cat)]" r+] fconfigure $f -encoding binary puts -nonewline $f "\xe7" @@ -5851,7 +5851,7 @@ test io-43.1 {Tcl_FileeventCmd: creating, deleting, querying} {stdio unixExecs f test io-43.2 {Tcl_FileeventCmd: deleting when many present} -setup { set f2 [open "|[list cat -u]" r+] set f3 [open "|[list cat -u]" r+] -} -constraints {stdio unixExecs fileevent openpipe} -body { +} -constraints {stdio unixExecs fileevent} -body { set result {} lappend result [fileevent $f r] [fileevent $f2 r] [fileevent $f3 r] fileevent $f r "read f" @@ -5872,7 +5872,7 @@ test io-43.2 {Tcl_FileeventCmd: deleting when many present} -setup { test io-44.1 {FileEventProc procedure: normal read event} -setup { set f2 [open "|[list cat -u]" r+] set f3 [open "|[list cat -u]" r+] -} -constraints {stdio unixExecs fileevent openpipe} -body { +} -constraints {stdio unixExecs fileevent} -body { fileevent $f2 readable [namespace code { set x [gets $f2]; fileevent $f2 readable {} }] @@ -5885,7 +5885,7 @@ test io-44.1 {FileEventProc procedure: normal read event} -setup { catch {close $f3} } -result {text} test io-44.2 {FileEventProc procedure: error in read event} -constraints { - stdio unixExecs fileevent openpipe + stdio unixExecs fileevent } -setup { set f2 [open "|[list cat -u]" r+] set f3 [open "|[list cat -u]" r+] @@ -5908,7 +5908,7 @@ test io-44.2 {FileEventProc procedure: error in read event} -constraints { test io-44.3 {FileEventProc procedure: normal write event} -setup { set f2 [open "|[list cat -u]" r+] set f3 [open "|[list cat -u]" r+] -} -constraints {stdio unixExecs fileevent openpipe} -body { +} -constraints {stdio unixExecs fileevent} -body { fileevent $f2 writable [namespace code { lappend x "triggered" incr count -1 @@ -5927,7 +5927,7 @@ test io-44.3 {FileEventProc procedure: normal write event} -setup { catch {close $f3} } -result {initial triggered triggered triggered} test io-44.4 {FileEventProc procedure: eror in write event} -constraints { - stdio unixExecs fileevent openpipe + stdio unixExecs fileevent } -setup { set f2 [open "|[list cat -u]" r+] set f3 [open "|[list cat -u]" r+] @@ -5947,7 +5947,7 @@ test io-44.4 {FileEventProc procedure: eror in write event} -constraints { catch {close $f3} } -result {bad-write {}} test io-44.5 {FileEventProc procedure: end of file} -constraints { - stdio unixExecs openpipe fileevent + stdio unixExecs fileevent } -body { set f4 [open "|[list [interpreter] $path(cat) << foo]" r] fileevent $f4 readable [namespace code { @@ -6036,7 +6036,7 @@ test io-46.1 {Tcl event loop vs multiple interpreters} {testfevent fileevent} { set timer [after 10 lappend x timeout] testfevent cmd $script vwait x - testfevent cmd {chan close $f} + testfevent cmd {close $f} list [testfevent cmd {set x}] [testfevent cmd {info commands after}] } {{f triggered: foo bar} after} test io-46.2 {Tcl event loop vs multiple interpreters} testfevent { @@ -6224,7 +6224,7 @@ test io-48.2 {testing readability conditions} {nonBlockFiles fileevent} { list $x $l } {done {called called called called called called called}} set path(my_script) [makeFile {} my_script] -test io-48.3 {testing readability conditions} {stdio unix nonBlockFiles openpipe fileevent} { +test io-48.3 {testing readability conditions} {stdio unix nonBlockFiles fileevent} { set f [open $path(bar) w] puts $f abcdefg puts $f abcdefg @@ -6722,7 +6722,7 @@ test io-49.5 {testing crlf reading, leftover cr disgorgment} { set l } [list 7 a\rb\rc 7 {} 7 1] -test io-50.1 {testing handler deletion} -constraints testchannelevent -setup { +test io-50.1 {testing handler deletion} -constraints {testchannelevent testservicemode} -setup { file delete $path(test1) } -body { set f [open $path(test1) w] @@ -6745,7 +6745,7 @@ test io-50.1 {testing handler deletion} -constraints testchannelevent -setup { } -cleanup { close $f } -result called -test io-50.2 {testing handler deletion with multiple handlers} -constraints testchannelevent -setup { +test io-50.2 {testing handler deletion with multiple handlers} -constraints {testchannelevent testservicemode} -setup { file delete $path(test1) } -body { set f [open $path(test1) w] @@ -6768,7 +6768,7 @@ test io-50.2 {testing handler deletion with multiple handlers} -constraints test } -cleanup { close $f } -result {{called delhandler 0} {called delhandler 1}} -test io-50.3 {testing handler deletion with multiple handlers} -constraints testchannelevent -setup { +test io-50.3 {testing handler deletion with multiple handlers} -constraints {testchannelevent testservicemode} -setup { file delete $path(test1) } -body { set f [open $path(test1) w] @@ -6798,7 +6798,7 @@ test io-50.3 {testing handler deletion with multiple handlers} -constraints test } -cleanup { close $f } -result {{delhandler 0 called} {delhandler 0 deleted myself}} -test io-50.4 {testing handler deletion vs reentrant calls} -constraints testchannelevent -setup { +test io-50.4 {testing handler deletion vs reentrant calls} -constraints {testchannelevent testservicemode} -setup { file delete $path(test1) update } -body { @@ -6830,7 +6830,7 @@ test io-50.4 {testing handler deletion vs reentrant calls} -constraints testchan } -cleanup { close $f } -result {{delrecursive calling recursive} {delrecursive deleting recursive}} -test io-50.5 {testing handler deletion vs reentrant calls} -constraints testchannelevent -setup { +test io-50.5 {testing handler deletion vs reentrant calls} -constraints {testchannelevent testservicemode} -setup { file delete $path(test1) } -body { set f [open $path(test1) w] @@ -6871,7 +6871,7 @@ test io-50.5 {testing handler deletion vs reentrant calls} -constraints testchan close $f } -result [list {del calling recursive} {del deleted notcalled} \ {del deleted myself} {del after recursive}] -test io-50.6 {testing handler deletion vs reentrant calls} -constraints testchannelevent -setup { +test io-50.6 {testing handler deletion vs reentrant calls} -constraints {testchannelevent testservicemode} -setup { file delete $path(test1) } -body { set f [open $path(test1) w] @@ -7109,7 +7109,7 @@ test io-52.7 {TclCopyChannel} {fcopy} { } set result } {0 0 ok} -test io-52.8 {TclCopyChannel} {stdio openpipe fcopy} { +test io-52.8 {TclCopyChannel} {stdio fcopy} { file delete $path(test1) file delete $path(pipe) set f1 [open $path(pipe) w] @@ -7389,7 +7389,7 @@ test io-53.2 {CopyData} {fcopy} { } set result } {0 0 ok} -test io-53.3 {CopyData: background read underflow} {stdio unix openpipe fcopy} { +test io-53.3 {CopyData: background read underflow} {stdio unix fcopy} { file delete $path(test1) file delete $path(pipe) set f1 [open $path(pipe) w] @@ -7421,7 +7421,7 @@ test io-53.3 {CopyData: background read underflow} {stdio unix openpipe fcopy} { close $f set result } "ready line1 line2 {done\n}" -test io-53.4 {CopyData: background write overflow} {stdio openpipe fileevent fcopy} { +test io-53.4 {CopyData: background write overflow} {stdio fileevent fcopy} { set big bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb\n variable x for {set x 0} {$x < 12} {incr x} { @@ -7512,7 +7512,7 @@ test io-53.5 {CopyData: error during fcopy} {socket fcopy} { close $out set fcopyTestDone ;# 1 for error condition } 1 -test io-53.6 {CopyData: error during fcopy} {stdio openpipe fcopy} { +test io-53.6 {CopyData: error during fcopy} {stdio fcopy} { variable fcopyTestDone file delete $path(pipe) file delete $path(test1) @@ -7545,7 +7545,7 @@ proc doFcopy {in out {bytes 0} {error {}}} { -command [namespace code [list doFcopy $in $out]]] } } -test io-53.7 {CopyData: Flooding fcopy from pipe} {stdio openpipe fcopy} { +test io-53.7 {CopyData: Flooding fcopy from pipe} {stdio fcopy} { variable fcopyTestDone file delete $path(pipe) catch {unset fcopyTestDone} @@ -7597,7 +7597,7 @@ test io-53.8 {CopyData: async callback and error handling, Bug 1932639} -setup { # Channels to copy between set f [open $foo r] ; fconfigure $f -translation binary set g [open $bar w] ; fconfigure $g -translation binary -buffering none -} -constraints {stdio openpipe fcopy} -body { +} -constraints {stdio fcopy} -body { # Record input size, so that result is always defined lappend ::RES [file size $bar] # Run the copy. Should not invoke -command now. @@ -7638,7 +7638,7 @@ test io-53.8a {CopyData: async callback and error handling, Bug 1932639, at eof} # Channels to copy between set f [open $foo r] ; fconfigure $f -translation binary set g [open $bar w] ; fconfigure $g -translation binary -buffering none -} -constraints {stdio openpipe fcopy} -body { +} -constraints {stdio fcopy} -body { # Initialize and force eof on the input. seek $f 0 end ; read $f 1 set ::RES [eof $f] @@ -7678,7 +7678,7 @@ test io-53.8b {CopyData: async callback and -size 0} -setup { # Channels to copy between set f [open $foo r] ; fconfigure $f -translation binary set g [open $bar w] ; fconfigure $g -translation binary -buffering none -} -constraints {stdio openpipe fcopy} -body { +} -constraints {stdio fcopy} -body { set ::RES {} # Run the copy. Should not invoke -command now. fcopy $f $g -size 0 -command ::cmd @@ -7735,7 +7735,7 @@ test io-53.9 {CopyData: -size and event interaction, Bug 780533} -setup { } set ::forever {} set out [open $out w] -} -constraints {stdio openpipe fcopy} -body { +} -constraints {stdio fcopy} -body { fcopy $pipe $out -size 6 -command ::done set token [after 5000 { set ::forever {fcopy hangs} @@ -7805,7 +7805,7 @@ test io-53.10 {Bug 1350564, multi-directional fcopy} -setup { fconfigure $b -translation binary -buffering none fileevent $a readable [list ::done $a] fileevent $b readable [list ::done $b] -} -constraints {stdio openpipe fcopy} -body { +} -constraints {stdio fcopy} -body { # Now pass data through the server in both directions. set ::forever {} puts $a AB @@ -7853,7 +7853,7 @@ test io-53.11 {Bug 2895565} -setup { removeFile out removeFile in } -result {40 bytes copied} -test io-53.12 {CopyData: foreground short reads, aka bug 3096275} {stdio unix openpipe fcopy} { +test io-53.12 {CopyData: foreground short reads, aka bug 3096275} {stdio unix fcopy} { file delete $path(pipe) set f1 [open $path(pipe) w] puts -nonewline $f1 { @@ -8268,7 +8268,7 @@ test io-57.2 {buffered data and file events, read} {fileevent} { set result } {1 readable 234567890 timer} -test io-58.1 {Tcl_NotifyChannel and error when closing} {stdio unixOrWin openpipe fileevent} { +test io-58.1 {Tcl_NotifyChannel and error when closing} {stdio unixOrWin fileevent} { set out [open $path(script) w] puts $out { puts "normal message from pipe" @@ -8308,7 +8308,7 @@ test io-59.1 {Thread reference of channels} {testmainthread testchannel} { string equal $result [testmainthread] } {1} -test io-60.1 {writing illegal utf sequences} {openpipe fileevent testbytestring} { +test io-60.1 {writing illegal utf sequences} {fileevent testbytestring} { # This test will hang in older revisions of the core. set out [open $path(script) w] -- cgit v0.12 From 3cd49200d7d04605090a8dbaba57a127b785ceb5 Mon Sep 17 00:00:00 2001 From: sebres Date: Mon, 10 Aug 2020 16:16:36 +0000 Subject: windows: replace gethostbyname with getaddrinfo (gethostbyname can hang sporadically, closes [7cf7cce423]); corresponding to MS (https://docs.microsoft.com/en-us/windows/win32/api/winsock/nf-winsock-gethostbyname): Developers creating Windows Sockets 2 applications are urged to use the getaddrinfo function instead of gethostbyname --- win/tclWinSock.c | 102 +++++++++++++++++++++++++++++++------------------------ 1 file changed, 58 insertions(+), 44 deletions(-) diff --git a/win/tclWinSock.c b/win/tclWinSock.c index 882aa4a..11632c4 100644 --- a/win/tclWinSock.c +++ b/win/tclWinSock.c @@ -45,6 +45,8 @@ * SocketCheckProc(). */ +#include +#include #include "tclWinInt.h" #ifdef _MSC_VER @@ -187,8 +189,8 @@ static WNDCLASS windowClass; static SocketInfo * CreateSocket(Tcl_Interp *interp, int port, const char *host, int server, const char *myaddr, int myport, int async); -static int CreateSocketAddress(LPSOCKADDR_IN sockaddrPtr, - const char *host, int port); +static int CreateSocketAddress(struct sockaddr_in *sockaddrPtr, + const char *host, int port, int willBind); static void InitSockets(void); static SocketInfo * NewSocketInfo(SOCKET socket); static void SocketExitHandler(ClientData clientData); @@ -917,8 +919,8 @@ CreateSocket( * asynchronously. */ { u_long flag = 1; /* Indicates nonblocking mode. */ - SOCKADDR_IN sockaddr; /* Socket address */ - SOCKADDR_IN mysockaddr; /* Socket address for client */ + struct sockaddr_in sockaddr; /* Socket address */ + struct sockaddr_in mysockaddr; /* Socket address for client */ SOCKET sock = INVALID_SOCKET; SocketInfo *infoPtr=NULL; /* The returned value. */ ThreadSpecificData *tsdPtr = (ThreadSpecificData *) @@ -934,11 +936,11 @@ CreateSocket( return NULL; } - if (!CreateSocketAddress(&sockaddr, host, port)) { + if (!CreateSocketAddress(&sockaddr, host, port, server)) { goto error; } if ((myaddr != NULL || myport != 0) && - !CreateSocketAddress(&mysockaddr, myaddr, myport)) { + !CreateSocketAddress(&mysockaddr, myaddr, myport, 1)) { goto error; } @@ -1149,55 +1151,67 @@ static int CreateSocketAddress( LPSOCKADDR_IN sockaddrPtr, /* Socket address */ const char *host, /* Host. NULL implies INADDR_ANY */ - int port) /* Port number */ + int port, /* Port number */ + int willBind) /* Is this an address to bind() to or + * to connect() to? */ { - struct hostent *hostent; /* Host database entry */ - struct in_addr addr; /* For 64/32 bit madness */ + struct addrinfo hints, *resPtr = NULL; + char *native; + Tcl_DString ds; + int result; + + if (host == NULL) { + sockaddrPtr->sin_family = AF_INET; + sockaddrPtr->sin_addr.s_addr = INADDR_ANY; + addPort: + sockaddrPtr->sin_port = htons((unsigned short) (port & 0xFFFF)); + return 1; + } + + (void) memset(&hints, 0, sizeof(struct addrinfo)); + hints.ai_family = AF_INET; + hints.ai_socktype = SOCK_STREAM; + if (willBind) { + hints.ai_flags |= AI_PASSIVE; + } /* - * Check that WinSock is initialized; do not call it if not, to prevent - * system crashes. This can happen at exit time if the exit handler for - * WinSock ran before other exit handlers that want to use sockets. + * Note that getaddrinfo() *is* thread-safe. If a platform doesn't get + * that right, it shouldn't use this part of the code. */ - if (!SocketsEnabled()) { - Tcl_SetErrno(EFAULT); - return 0; + native = Tcl_UtfToExternalDString(NULL, host, -1, &ds); + result = getaddrinfo(native, NULL, &hints, &resPtr); + Tcl_DStringFree(&ds); + if (result == 0) { + memcpy(sockaddrPtr, resPtr->ai_addr, sizeof(struct sockaddr_in)); + freeaddrinfo(resPtr); + goto addPort; } - ZeroMemory(sockaddrPtr, sizeof(SOCKADDR_IN)); - sockaddrPtr->sin_family = AF_INET; - sockaddrPtr->sin_port = htons((unsigned short) (port & 0xFFFF)); - if (host == NULL) { - addr.s_addr = INADDR_ANY; - } else { - addr.s_addr = inet_addr(host); - if (addr.s_addr == INADDR_NONE) { - hostent = gethostbyname(host); - if (hostent != NULL) { - memcpy(&addr, hostent->h_addr, (size_t) hostent->h_length); - } else { + /* + * errno corresponding result ... + */ + + switch (result) { + case EAI_NONAME: + case EAI_SERVICE: +#if defined(EAI_ADDRFAMILY) && EAI_ADDRFAMILY != EAI_NONAME + case EAI_ADDRFAMILY: +#endif +#if defined(EAI_NODATA) && EAI_NODATA != EAI_NONAME + case EAI_NODATA: +#endif #ifdef EHOSTUNREACH - Tcl_SetErrno(EHOSTUNREACH); -#else -#ifdef ENXIO - Tcl_SetErrno(ENXIO); + Tcl_SetErrno(EHOSTUNREACH); + return 0; #endif + default: +#ifdef ENXIO + Tcl_SetErrno(ENXIO); #endif - return 0; /* Error. */ - } - } + return 0; } - - /* - * NOTE: On 64 bit machines the assignment below is rumored to not do the - * right thing. Please report errors related to this if you observe - * incorrect behavior on 64 bit machines such as DEC Alphas. Should we - * modify this code to do an explicit memcpy? - */ - - sockaddrPtr->sin_addr.s_addr = addr.s_addr; - return 1; /* Success. */ } /* -- cgit v0.12 From f397a9ac9d2bc4a067fdc01f1e08188db53f5f93 Mon Sep 17 00:00:00 2001 From: sebres Date: Mon, 10 Aug 2020 16:16:46 +0000 Subject: create server socket with AI_PASSIVE flag (used for bind) --- unix/tclUnixChan.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/unix/tclUnixChan.c b/unix/tclUnixChan.c index d3207e2..39bb64f 100644 --- a/unix/tclUnixChan.c +++ b/unix/tclUnixChan.c @@ -2378,7 +2378,7 @@ CreateSocket( const char *errorMsg = NULL; sock = -1; - if (!CreateSocketAddress(&sockaddr, host, port, 0, &errorMsg)) { + if (!CreateSocketAddress(&sockaddr, host, port, server, &errorMsg)) { goto addressError; } if ((myaddr != NULL || myport != 0) && -- cgit v0.12 From 6c0be70d2b1cc5dbfd1277556ac27ea2e39be4bb Mon Sep 17 00:00:00 2001 From: sebres Date: Mon, 10 Aug 2020 16:54:46 +0000 Subject: amend to [8054e19451]: clean up timeout timer event (avoid timing issues on further tests) --- tests/chanio.test | 1 + tests/io.test | 1 + 2 files changed, 2 insertions(+) diff --git a/tests/chanio.test b/tests/chanio.test index 93375a0..66f4a30 100644 --- a/tests/chanio.test +++ b/tests/chanio.test @@ -5734,6 +5734,7 @@ test chan-io-46.1 {Tcl event loop vs multiple interpreters} {testfevent fileeven set timer [after 10 lappend x timeout] testfevent cmd $script vwait x + after cancel $timer testfevent cmd {chan close $f} list [testfevent cmd {set x}] [testfevent cmd {info commands after}] } {{f triggered: foo bar} after} diff --git a/tests/io.test b/tests/io.test index 0db6afb..685394c 100644 --- a/tests/io.test +++ b/tests/io.test @@ -6036,6 +6036,7 @@ test io-46.1 {Tcl event loop vs multiple interpreters} {testfevent fileevent} { set timer [after 10 lappend x timeout] testfevent cmd $script vwait x + after cancel $timer testfevent cmd {close $f} list [testfevent cmd {set x}] [testfevent cmd {info commands after}] } {{f triggered: foo bar} after} -- cgit v0.12 From e29e808f57505a56193de6e0717c7abe95755b03 Mon Sep 17 00:00:00 2001 From: pooryorick Date: Mon, 10 Aug 2020 18:05:10 +0000 Subject: Fix for [29e8848eb976], imported alias in a deletion trace. --- generic/tclBasic.c | 3 ++- generic/tclInt.h | 1 + tests/namespace.test | 43 +++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 46 insertions(+), 1 deletion(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index fe64f18..f52ecf5 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -3268,6 +3268,7 @@ Tcl_DeleteCommandFromToken( * TclNRExecuteByteCode looks up the command in the command hashtable). */ + cmdPtr->flags |= CMD_IS_DELETED; TclCleanupCommandMacro(cmdPtr); return 0; } @@ -4331,7 +4332,7 @@ EvalObjvCore( * Caller gave it to us. */ - if (!(preCmdPtr->flags & CMD_IS_DELETED)) { + if (!(preCmdPtr->flags & CMD_DEAD)) { /* * So long as it exists, use it. */ diff --git a/generic/tclInt.h b/generic/tclInt.h index 31108c7..1e90b70 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -1682,6 +1682,7 @@ typedef struct Command { #define CMD_COMPILES_EXPANDED 0x08 #define CMD_REDEF_IN_PROGRESS 0x10 #define CMD_VIA_RESOLVER 0x20 +#define CMD_DEAD 0x30 /* diff --git a/tests/namespace.test b/tests/namespace.test index dd71697..796b46b 100644 --- a/tests/namespace.test +++ b/tests/namespace.test @@ -3337,6 +3337,49 @@ test namespace-56.5 {Bug 8b9854c3d8} -setup { namespace delete namespace-56.5 } -result 1 + + +test namespace-57.0 { + an imported alias should be usable in the deletion trace for the alias + + see 29e8848eb976 +} -body { + variable res {} + namespace eval ns2 { + namespace export * + proc p1 {oldname newname op} { + return success + } + + interp alias {} [namespace current]::p2 {} [namespace which p1] + } + + + namespace eval ns3 { + namespace import ::ns2::p2 + } + + + set ondelete [list apply [list {oldname newname op} { + variable res + catch { + ns3::p2 $oldname $newname $op + } cres + lappend res $cres + } [namespace current]]] + + + trace add command ::ns2::p2 delete $ondelete + rename ns2::p2 {} + return $res +} -cleanup { + unset res + namespace delete ns2 + namespace delete ns3 +} -result success + + + # cleanup catch {rename cmd1 {}} -- cgit v0.12 From 36d06e1e0b240999e478c750f746a86dbd63caae Mon Sep 17 00:00:00 2001 From: pooryorick Date: Mon, 10 Aug 2020 19:33:18 +0000 Subject: Fix mistake in [7eed2baf73] --- generic/tclBasic.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index f52ecf5..50bc84e 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -3268,7 +3268,7 @@ Tcl_DeleteCommandFromToken( * TclNRExecuteByteCode looks up the command in the command hashtable). */ - cmdPtr->flags |= CMD_IS_DELETED; + cmdPtr->flags |= CMD_DEAD; TclCleanupCommandMacro(cmdPtr); return 0; } -- cgit v0.12 From d73c6dbd81c0537e3d6df60dc145af1b6539d6d2 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 11 Aug 2020 05:39:08 +0000 Subject: Eliminate many unnecessary type-casts, mostly (size_t) when value is already size_t or int --- generic/tclAlloc.c | 2 +- generic/tclBasic.c | 2 +- generic/tclBinary.c | 16 ++++++++-------- generic/tclCkalloc.c | 6 +++--- generic/tclCmdMZ.c | 4 ++-- generic/tclCompCmdsSZ.c | 2 +- generic/tclCompExpr.c | 2 +- generic/tclCompile.c | 8 ++++---- generic/tclExecute.c | 4 ++-- generic/tclFileName.c | 2 +- generic/tclIO.c | 6 +++--- generic/tclIOUtil.c | 2 +- generic/tclInterp.c | 8 ++++---- generic/tclListObj.c | 6 +++--- generic/tclObj.c | 12 ++++++------ generic/tclPathObj.c | 2 +- generic/tclStubInit.c | 2 +- generic/tclThread.c | 4 ++-- generic/tclThreadTest.c | 4 ++-- generic/tclTrace.c | 4 ++-- macosx/tclMacOSXFCmd.c | 2 +- unix/tclUnixFile.c | 2 +- unix/tclUnixInit.c | 4 ++-- unix/tclUnixSock.c | 2 +- win/tclWinConsole.c | 6 +++--- win/tclWinFCmd.c | 2 +- win/tclWinInit.c | 4 ++-- win/tclWinPipe.c | 2 +- win/tclWinSerial.c | 2 +- win/tclWinSock.c | 2 +- 30 files changed, 63 insertions(+), 63 deletions(-) diff --git a/generic/tclAlloc.c b/generic/tclAlloc.c index 6187ce2..39b9395 100644 --- a/generic/tclAlloc.c +++ b/generic/tclAlloc.c @@ -604,7 +604,7 @@ TclpRealloc( if (maxSize < numBytes) { numBytes = maxSize; } - memcpy(newPtr, oldPtr, (size_t) numBytes); + memcpy(newPtr, oldPtr, numBytes); TclpFree(oldPtr); return newPtr; } diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 50bc84e..2ac6fef 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -4139,7 +4139,7 @@ Tcl_CancelEval( if (resultObjPtr != NULL) { result = Tcl_GetStringFromObj(resultObjPtr, &cancelInfo->length); cancelInfo->result = ckrealloc(cancelInfo->result,cancelInfo->length); - memcpy(cancelInfo->result, result, (size_t) cancelInfo->length); + memcpy(cancelInfo->result, result, cancelInfo->length); TclDecrRefCount(resultObjPtr); /* Discard their result object. */ } else { cancelInfo->result = NULL; diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 8f4f6ab..f66aff7 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -339,7 +339,7 @@ Tcl_SetByteArrayObj( byteArrayPtr->allocated = length; if ((bytes != NULL) && (length > 0)) { - memcpy(byteArrayPtr->bytes, bytes, (size_t) length); + memcpy(byteArrayPtr->bytes, bytes, length); } objPtr->typePtr = &tclByteArrayType; SET_BYTEARRAY(objPtr, byteArrayPtr); @@ -532,7 +532,7 @@ DupByteArrayInternalRep( copyArrayPtr = ckalloc(BYTEARRAY_SIZE(length)); copyArrayPtr->used = length; copyArrayPtr->allocated = length; - memcpy(copyArrayPtr->bytes, srcArrayPtr->bytes, (size_t) length); + memcpy(copyArrayPtr->bytes, srcArrayPtr->bytes, length); SET_BYTEARRAY(copyPtr, copyArrayPtr); copyPtr->typePtr = &tclByteArrayType; @@ -593,7 +593,7 @@ UpdateStringOfByteArray( objPtr->length = size; if (size == length) { - memcpy(dst, src, (size_t) size); + memcpy(dst, src, size); dst[size] = '\0'; } else { for (i = 0; i < length; i++) { @@ -945,7 +945,7 @@ BinaryFormatCmd( resultPtr = Tcl_NewObj(); buffer = Tcl_SetByteArrayLength(resultPtr, length); - memset(buffer, 0, (size_t) length); + memset(buffer, 0, length); /* * Pack the data into the result object. Note that we can skip the error @@ -982,10 +982,10 @@ BinaryFormatCmd( count = 1; } if (length >= count) { - memcpy(cursor, bytes, (size_t) count); + memcpy(cursor, bytes, count); } else { - memcpy(cursor, bytes, (size_t) length); - memset(cursor + length, pad, (size_t) (count - length)); + memcpy(cursor, bytes, length); + memset(cursor + length, pad, count - length); } cursor += count; break; @@ -1174,7 +1174,7 @@ BinaryFormatCmd( if (count == BINARY_NOCOUNT) { count = 1; } - memset(cursor, 0, (size_t) count); + memset(cursor, 0, count); cursor += count; break; case 'X': diff --git a/generic/tclCkalloc.c b/generic/tclCkalloc.c index 9c3cbff..2730443 100644 --- a/generic/tclCkalloc.c +++ b/generic/tclCkalloc.c @@ -623,7 +623,7 @@ Tcl_DbCkfree( Tcl_MutexLock(ckallocMutexPtr); ValidateMemory(memp, file, line, TRUE); if (init_malloced_bodies) { - memset(ptr, GUARD_VALUE, (size_t) memp->length); + memset(ptr, GUARD_VALUE, memp->length); } total_frees++; @@ -693,7 +693,7 @@ Tcl_DbCkrealloc( copySize = memp->length; } newPtr = Tcl_DbCkalloc(size, file, line); - memcpy(newPtr, ptr, (size_t) copySize); + memcpy(newPtr, ptr, copySize); Tcl_DbCkfree(ptr, file, line); return newPtr; } @@ -727,7 +727,7 @@ Tcl_AttemptDbCkrealloc( if (newPtr == NULL) { return NULL; } - memcpy(newPtr, ptr, (size_t) copySize); + memcpy(newPtr, ptr, copySize); Tcl_DbCkfree(ptr, file, line); return newPtr; } diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 298b3b7..b9b6b6c 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -2288,7 +2288,7 @@ StringReptCmd( return TCL_ERROR; } for (index = 0; index < count; index++) { - memcpy(string2 + (length1 * index), string1, (size_t) length1); + memcpy(string2 + (length1 * index), string1, length1); } string2[length2] = '\0'; @@ -2850,7 +2850,7 @@ TclStringCmp( * The comparison function should compare up to the minimum byte * length only. */ - match = memCmpFn(s1, s2, (size_t) length); + match = memCmpFn(s1, s2, length); } if ((match == 0) && (reqlength > length)) { match = s1len - s2len; diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 31e2c88..ddfe0dc 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -756,7 +756,7 @@ TclCompileStringMatchCmd( } str = tokenPtr[1].start; length = tokenPtr[1].size; - if ((length <= 1) || strncmp(str, "-nocase", (size_t) length)) { + if ((length <= 1) || strncmp(str, "-nocase", length)) { /* * Fail at run time, not in compilation. */ diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c index 9c7ab8d..0d33821 100644 --- a/generic/tclCompExpr.c +++ b/generic/tclCompExpr.c @@ -2068,7 +2068,7 @@ ParseLexeme( } else { char utfBytes[TCL_UTF_MAX]; - memcpy(utfBytes, start, (size_t) numBytes); + memcpy(utfBytes, start, numBytes); utfBytes[numBytes] = '\0'; scanned = TclUtfToUniChar(utfBytes, &ch); } diff --git a/generic/tclCompile.c b/generic/tclCompile.c index ece0cae..1cc655e 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -2820,7 +2820,7 @@ TclInitByteCodeObj( p += sizeof(ByteCode); codePtr->codeStart = p; - memcpy(p, envPtr->codeStart, (size_t) codeBytes); + memcpy(p, envPtr->codeStart, codeBytes); p += TCL_ALIGN(codeBytes); /* align object array */ codePtr->objArrayPtr = (Tcl_Obj **) p; @@ -2853,7 +2853,7 @@ TclInitByteCodeObj( p += TCL_ALIGN(objArrayBytes); /* align exception range array */ if (exceptArrayBytes > 0) { codePtr->exceptArrayPtr = (ExceptionRange *) p; - memcpy(p, envPtr->exceptArrayPtr, (size_t) exceptArrayBytes); + memcpy(p, envPtr->exceptArrayPtr, exceptArrayBytes); } else { codePtr->exceptArrayPtr = NULL; } @@ -2861,7 +2861,7 @@ TclInitByteCodeObj( p += TCL_ALIGN(exceptArrayBytes); /* align AuxData array */ if (auxDataArrayBytes > 0) { codePtr->auxDataArrayPtr = (AuxData *) p; - memcpy(p, envPtr->auxDataArrayPtr, (size_t) auxDataArrayBytes); + memcpy(p, envPtr->auxDataArrayPtr, auxDataArrayBytes); } else { codePtr->auxDataArrayPtr = NULL; } @@ -3028,7 +3028,7 @@ TclFindCompiledLocal( localPtr->resolveInfo = NULL; if (name != NULL) { - memcpy(localPtr->name, name, (size_t) nameBytes); + memcpy(localPtr->name, name, nameBytes); } localPtr->name[nameBytes] = '\0'; procPtr->numCompiledLocals++; diff --git a/generic/tclExecute.c b/generic/tclExecute.c index dd82f95..aacf565 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -2838,7 +2838,7 @@ TEBCresume( for (; currPtr <= &OBJ_AT_TOS; currPtr++) { bytes = TclGetStringFromObj(*currPtr, &length); if (bytes != NULL) { - memcpy(p, bytes, (size_t) length); + memcpy(p, bytes, length); p += length; } } @@ -2873,7 +2873,7 @@ TEBCresume( for (; currPtr <= &OBJ_AT_TOS; currPtr++) { if ((*currPtr)->bytes != tclEmptyStringRep) { bytes = (char *) Tcl_GetByteArrayFromObj(*currPtr,&length); - memcpy(p, bytes, (size_t) length); + memcpy(p, bytes, length); p += length; } } diff --git a/generic/tclFileName.c b/generic/tclFileName.c index f7de10c..6cdfa7e 100644 --- a/generic/tclFileName.c +++ b/generic/tclFileName.c @@ -598,7 +598,7 @@ Tcl_SplitPath( for (i = 0; i < *argcPtr; i++) { Tcl_ListObjIndex(NULL, resultPtr, i, &eltPtr); str = Tcl_GetStringFromObj(eltPtr, &len); - memcpy(p, str, (size_t) len+1); + memcpy(p, str, len+1); p += len+1; } diff --git a/generic/tclIO.c b/generic/tclIO.c index ab8d8ac..7abeb68 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -4314,7 +4314,7 @@ Write( * that we need to stick at the beginning of this buffer. */ - memcpy(InsertPoint(bufPtr), safe, (size_t) saved); + memcpy(InsertPoint(bufPtr), safe, saved); bufPtr->nextAdded += saved; saved = 0; } @@ -4711,7 +4711,7 @@ Tcl_GetsObj( gs.rawRead -= rawRead; gs.bytesWrote--; gs.charsWrote--; - memmove(dst, dst + 1, (size_t) (dstEnd - dst)); + memmove(dst, dst + 1, dstEnd - dst); dstEnd--; } } @@ -10475,7 +10475,7 @@ Tcl_IsChannelExisting( } if ((*chanName == *name) && - (memcmp(name, chanName, (size_t) chanNameLen + 1) == 0)) { + (memcmp(name, chanName, chanNameLen + 1) == 0)) { return 1; } } diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c index 7c2c478..e67da14 100644 --- a/generic/tclIOUtil.c +++ b/generic/tclIOUtil.c @@ -4209,7 +4209,7 @@ TclFSNonnativePathType( if (pathLen < len) { continue; } - if (strncmp(strVol, path, (size_t) len) == 0) { + if (strncmp(strVol, path, len) == 0) { type = TCL_PATH_ABSOLUTE; if (filesystemPtrPtr != NULL) { *filesystemPtrPtr = fsRecPtr->fsPtr; diff --git a/generic/tclInterp.c b/generic/tclInterp.c index 95c68ee..d4cf1a1 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -1813,8 +1813,8 @@ AliasNRCmd( cmdv = &listRep->elements; prefv = &aliasPtr->objPtr; - memcpy(cmdv, prefv, (size_t) (prefc * sizeof(Tcl_Obj *))); - memcpy(cmdv+prefc, objv+1, (size_t) ((objc-1) * sizeof(Tcl_Obj *))); + memcpy(cmdv, prefv, prefc * sizeof(Tcl_Obj *)); + memcpy(cmdv+prefc, objv+1, (objc-1) * sizeof(Tcl_Obj *)); for (i=0; i 0) && (shift != 0)) { Tcl_Obj **src = elemPtrs + start; - memmove(src+shift, src, (size_t) numAfterLast * sizeof(Tcl_Obj*)); + memmove(src+shift, src, numAfterLast * sizeof(Tcl_Obj*)); } } else { /* @@ -1024,7 +1024,7 @@ Tcl_ListObjReplace( */ if (first > 0) { - memcpy(elemPtrs, oldPtrs, (size_t) first * sizeof(Tcl_Obj *)); + memcpy(elemPtrs, oldPtrs, first * sizeof(Tcl_Obj *)); } /* diff --git a/generic/tclObj.c b/generic/tclObj.c index a4df3e7..28fb3da 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -2059,25 +2059,25 @@ ParseBoolean( /* * Checking the 'y' is redundant, but makes the code clearer. */ - if (strncmp(lowerCase, "yes", (size_t) length) == 0) { + if (strncmp(lowerCase, "yes", length) == 0) { newBool = 1; goto goodBoolean; } return TCL_ERROR; case 'n': - if (strncmp(lowerCase, "no", (size_t) length) == 0) { + if (strncmp(lowerCase, "no", length) == 0) { newBool = 0; goto goodBoolean; } return TCL_ERROR; case 't': - if (strncmp(lowerCase, "true", (size_t) length) == 0) { + if (strncmp(lowerCase, "true", length) == 0) { newBool = 1; goto goodBoolean; } return TCL_ERROR; case 'f': - if (strncmp(lowerCase, "false", (size_t) length) == 0) { + if (strncmp(lowerCase, "false", length) == 0) { newBool = 0; goto goodBoolean; } @@ -2086,10 +2086,10 @@ ParseBoolean( if (length < 2) { return TCL_ERROR; } - if (strncmp(lowerCase, "on", (size_t) length) == 0) { + if (strncmp(lowerCase, "on", length) == 0) { newBool = 1; goto goodBoolean; - } else if (strncmp(lowerCase, "off", (size_t) length) == 0) { + } else if (strncmp(lowerCase, "off", length) == 0) { newBool = 0; goto goodBoolean; } diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c index c5b1ef6..0f98881 100644 --- a/generic/tclPathObj.c +++ b/generic/tclPathObj.c @@ -1745,7 +1745,7 @@ Tcl_FSGetTranslatedStringPath( const char *orig = Tcl_GetStringFromObj(transPtr, &len); char *result = ckalloc(len+1); - memcpy(result, orig, (size_t) len+1); + memcpy(result, orig, len+1); TclDecrRefCount(transPtr); return result; } diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 7807083..bab9d5e 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -465,7 +465,7 @@ mp_err mp_toradix_n(const mp_int *a, char *str, int radix, int maxlen) if (maxlen < 0) { return MP_VAL; } - return mp_to_radix(a, str, (size_t)maxlen, NULL, radix); + return mp_to_radix(a, str, maxlen, NULL, radix); } void bn_reverse(unsigned char *s, int len) diff --git a/generic/tclThread.c b/generic/tclThread.c index 8915792..03937de 100644 --- a/generic/tclThread.c +++ b/generic/tclThread.c @@ -88,13 +88,13 @@ Tcl_GetThreadData( if (result == NULL) { result = ckalloc(size); - memset(result, 0, (size_t) size); + memset(result, 0, size); TclThreadStorageKeySet(keyPtr, result); } #else /* TCL_THREADS */ if (*keyPtr == NULL) { result = ckalloc(size); - memset(result, 0, (size_t)size); + memset(result, 0, size); *keyPtr = result; RememberSyncObject(keyPtr, &keyRecord); } else { diff --git a/generic/tclThreadTest.c b/generic/tclThreadTest.c index 35b3fc3..ff18077 100644 --- a/generic/tclThreadTest.c +++ b/generic/tclThreadTest.c @@ -294,7 +294,7 @@ ThreadObjCmd( script = Tcl_GetStringFromObj(objv[2], &len); if ((len > 1) && (script[0] == '-') && (script[1] == 'j') && - (0 == strncmp(script, "-joinable", (size_t) len))) { + (0 == strncmp(script, "-joinable", len))) { joinable = 1; script = "testthread wait"; /* Just enter event loop */ } else { @@ -311,7 +311,7 @@ ThreadObjCmd( script = Tcl_GetStringFromObj(objv[2], &len); joinable = ((len > 1) && (script[0] == '-') && (script[1] == 'j') - && (0 == strncmp(script, "-joinable", (size_t) len))); + && (0 == strncmp(script, "-joinable", len))); script = Tcl_GetString(objv[3]); } else { Tcl_WrongNumArgs(interp, 2, objv, "?-joinable? ?script?"); diff --git a/generic/tclTrace.c b/generic/tclTrace.c index 882dc39..3178441 100644 --- a/generic/tclTrace.c +++ b/generic/tclTrace.c @@ -1689,8 +1689,8 @@ CallTraceFunction( * Copy the command characters into a new string. */ - commandCopy = TclStackAlloc(interp, (unsigned) numChars + 1); - memcpy(commandCopy, command, (size_t) numChars); + commandCopy = TclStackAlloc(interp, numChars + 1); + memcpy(commandCopy, command, numChars); commandCopy[numChars] = '\0'; /* diff --git a/macosx/tclMacOSXFCmd.c b/macosx/tclMacOSXFCmd.c index e462e5e..53b01e0 100644 --- a/macosx/tclMacOSXFCmd.c +++ b/macosx/tclMacOSXFCmd.c @@ -654,7 +654,7 @@ SetOSTypeFromAny( OSType osType; char bytes[4] = {'\0','\0','\0','\0'}; - memcpy(bytes, Tcl_DStringValue(&ds), (size_t)Tcl_DStringLength(&ds)); + memcpy(bytes, Tcl_DStringValue(&ds), Tcl_DStringLength(&ds)); osType = (OSType) bytes[0] << 24 | (OSType) bytes[1] << 16 | (OSType) bytes[2] << 8 | diff --git a/unix/tclUnixFile.c b/unix/tclUnixFile.c index f70ce6a..35046a5 100644 --- a/unix/tclUnixFile.c +++ b/unix/tclUnixFile.c @@ -1116,7 +1116,7 @@ TclNativeCreateNativeRep( } Tcl_DecrRefCount(validPathPtr); nativePathPtr = ckalloc(len); - memcpy(nativePathPtr, Tcl_DStringValue(&ds), (size_t) len); + memcpy(nativePathPtr, Tcl_DStringValue(&ds), len); Tcl_DStringFree(&ds); return nativePathPtr; diff --git a/unix/tclUnixInit.c b/unix/tclUnixInit.c index b189fee..0ae0fa7 100644 --- a/unix/tclUnixInit.c +++ b/unix/tclUnixInit.c @@ -546,8 +546,8 @@ TclpInitLibraryPath( *encodingPtr = Tcl_GetEncoding(NULL, NULL); str = Tcl_GetStringFromObj(pathPtr, lengthPtr); - *valuePtr = (char *)ckalloc((*lengthPtr) + 1); - memcpy(*valuePtr, str, (size_t)(*lengthPtr)+1); + *valuePtr = (char *)ckalloc(*lengthPtr + 1); + memcpy(*valuePtr, str, *lengthPtr + 1); Tcl_DecrRefCount(pathPtr); } diff --git a/unix/tclUnixSock.c b/unix/tclUnixSock.c index ddba078..1a54914 100644 --- a/unix/tclUnixSock.c +++ b/unix/tclUnixSock.c @@ -277,7 +277,7 @@ InitializeHostName( *encodingPtr = Tcl_GetEncoding(NULL, NULL); *lengthPtr = strlen(native); *valuePtr = ckalloc(*lengthPtr + 1); - memcpy(*valuePtr, native, (size_t)(*lengthPtr) + 1); + memcpy(*valuePtr, native, *lengthPtr + 1); } /* diff --git a/win/tclWinConsole.c b/win/tclWinConsole.c index 1293ebe..a223a1f 100644 --- a/win/tclWinConsole.c +++ b/win/tclWinConsole.c @@ -672,11 +672,11 @@ ConsoleInputProc( */ if (bufSize < (infoPtr->bytesRead - infoPtr->offset)) { - memcpy(buf, &infoPtr->buffer[infoPtr->offset], (size_t) bufSize); + memcpy(buf, &infoPtr->buffer[infoPtr->offset], bufSize); bytesRead = bufSize; infoPtr->offset += bufSize; } else { - memcpy(buf, &infoPtr->buffer[infoPtr->offset], (size_t) bufSize); + memcpy(buf, &infoPtr->buffer[infoPtr->offset], bufSize); bytesRead = infoPtr->bytesRead - infoPtr->offset; /* @@ -783,7 +783,7 @@ ConsoleOutputProc( infoPtr->writeBufLen = toWrite; infoPtr->writeBuf = ckalloc(toWrite); } - memcpy(infoPtr->writeBuf, buf, (size_t) toWrite); + memcpy(infoPtr->writeBuf, buf, toWrite); infoPtr->toWrite = toWrite; ResetEvent(threadInfo->readyEvent); TclPipeThreadSignal(&threadInfo->TI); diff --git a/win/tclWinFCmd.c b/win/tclWinFCmd.c index 357f0a1..a7a98a4 100644 --- a/win/tclWinFCmd.c +++ b/win/tclWinFCmd.c @@ -337,7 +337,7 @@ DoRenameFile( * character is either end-of-string or a directory separator */ - if ((strncmp(src, dst, (size_t) Tcl_DStringLength(&srcString))==0) + if ((strncmp(src, dst, Tcl_DStringLength(&srcString))==0) && (dst[Tcl_DStringLength(&srcString)] == '\\' || dst[Tcl_DStringLength(&srcString)] == '/' || dst[Tcl_DStringLength(&srcString)] == '\0')) { diff --git a/win/tclWinInit.c b/win/tclWinInit.c index b1dd0f3..b0e08d0 100644 --- a/win/tclWinInit.c +++ b/win/tclWinInit.c @@ -229,8 +229,8 @@ TclpInitLibraryPath( *encodingPtr = NULL; bytes = Tcl_GetStringFromObj(pathPtr, lengthPtr); - *valuePtr = (char *)ckalloc((*lengthPtr) + 1); - memcpy(*valuePtr, bytes, (size_t)(*lengthPtr)+1); + *valuePtr = (char *)ckalloc(*lengthPtr + 1); + memcpy(*valuePtr, bytes, *lengthPtr + 1); Tcl_DecrRefCount(pathPtr); } diff --git a/win/tclWinPipe.c b/win/tclWinPipe.c index 04c371e..098ead4 100644 --- a/win/tclWinPipe.c +++ b/win/tclWinPipe.c @@ -2317,7 +2317,7 @@ PipeOutputProc( infoPtr->writeBufLen = toWrite; infoPtr->writeBuf = ckalloc(toWrite); } - memcpy(infoPtr->writeBuf, buf, (size_t) toWrite); + memcpy(infoPtr->writeBuf, buf, toWrite); infoPtr->toWrite = toWrite; ResetEvent(infoPtr->writable); TclPipeThreadSignal(&infoPtr->writeTI); diff --git a/win/tclWinSerial.c b/win/tclWinSerial.c index aeebb56..9023928 100644 --- a/win/tclWinSerial.c +++ b/win/tclWinSerial.c @@ -1038,7 +1038,7 @@ SerialOutputProc( infoPtr->writeBufLen = toWrite; infoPtr->writeBuf = ckalloc(toWrite); } - memcpy(infoPtr->writeBuf, buf, (size_t) toWrite); + memcpy(infoPtr->writeBuf, buf, toWrite); infoPtr->toWrite = toWrite; ResetEvent(infoPtr->evWritable); TclPipeThreadSignal(&infoPtr->writeTI); diff --git a/win/tclWinSock.c b/win/tclWinSock.c index fdb7e12..a05b8f6 100644 --- a/win/tclWinSock.c +++ b/win/tclWinSock.c @@ -378,7 +378,7 @@ InitializeHostName( *encodingPtr = Tcl_GetEncoding(NULL, "utf-8"); *lengthPtr = Tcl_DStringLength(&ds); *valuePtr = ckalloc((*lengthPtr) + 1); - memcpy(*valuePtr, Tcl_DStringValue(&ds), (size_t)(*lengthPtr)+1); + memcpy(*valuePtr, Tcl_DStringValue(&ds), *lengthPtr + 1); Tcl_DStringFree(&ds); } -- cgit v0.12 From 30710a3cbde4192fff4a2f255c2fff0491dec7ac Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 11 Aug 2020 12:44:21 +0000 Subject: Code cleanup: less of use "register" keyword, and better use of typecasts --- compat/mkstemp.c | 2 +- macosx/tclMacOSXFCmd.c | 2 +- unix/tclLoadAix.c | 24 ++++++++++++------------ unix/tclUnixCompat.c | 40 +++++++++++++++++++++------------------- unix/tclUnixInit.c | 39 ++++++++++++++++++++++++--------------- unix/tclUnixThrd.c | 37 +++++++++++++++++++------------------ 6 files changed, 78 insertions(+), 66 deletions(-) diff --git a/compat/mkstemp.c b/compat/mkstemp.c index 1a44dfa..6807414 100644 --- a/compat/mkstemp.c +++ b/compat/mkstemp.c @@ -36,7 +36,7 @@ mkstemp( { static const char alphanumerics[] = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789"; - register char *a, *b; + char *a, *b; int fd, count, alphanumericsLen = strlen(alphanumerics); /* == 62 */ a = template + strlen(template); diff --git a/macosx/tclMacOSXFCmd.c b/macosx/tclMacOSXFCmd.c index 53b01e0..6275aac 100644 --- a/macosx/tclMacOSXFCmd.c +++ b/macosx/tclMacOSXFCmd.c @@ -689,7 +689,7 @@ SetOSTypeFromAny( static void UpdateStringOfOSType( - register Tcl_Obj *objPtr) /* OSType object whose string rep to + Tcl_Obj *objPtr) /* OSType object whose string rep to * update. */ { char string[5]; diff --git a/unix/tclLoadAix.c b/unix/tclLoadAix.c index 88e6b50..fea9494 100644 --- a/unix/tclLoadAix.c +++ b/unix/tclLoadAix.c @@ -98,7 +98,7 @@ dlopen( const char *path, int mode) { - register ModulePtr mp; + ModulePtr mp; static void *mainModule; /* @@ -134,7 +134,7 @@ dlopen( return NULL; } - mp->name = malloc((unsigned) (strlen(path) + 1)); + mp->name = malloc(strlen(path) + 1); strcpy(mp->name, path); /* @@ -191,7 +191,7 @@ dlopen( */ if (mode & RTLD_GLOBAL) { - register ModulePtr mp1; + ModulePtr mp1; for (mp1 = mp->next; mp1; mp1 = mp1->next) { if (loadbind(0, mp1->entry, mp->entry) == -1) { @@ -243,7 +243,7 @@ static void caterr( char *s) { - register char *p = s; + char *p = s; while (*p >= '0' && *p <= '9') { p++; @@ -282,9 +282,9 @@ dlsym( void *handle, const char *symbol) { - register ModulePtr mp = (ModulePtr)handle; - register ExportPtr ep; - register int i; + ModulePtr mp = (ModulePtr)handle; + ExportPtr ep; + int i; /* * Could speed up the search, but I assume that one assigns the result to @@ -317,9 +317,9 @@ int dlclose( void *handle) { - register ModulePtr mp = (ModulePtr)handle; + ModulePtr mp = (ModulePtr)handle; int result; - register ModulePtr mp1; + ModulePtr mp1; if (--mp->refCnt > 0) { return 0; @@ -343,8 +343,8 @@ dlclose( } if (mp->exports) { - register ExportPtr ep; - register int i; + ExportPtr ep; + int i; for (ep = mp->exports, i = mp->nExports; i; i--, ep++) { if (ep->name) { free(ep->name); @@ -541,7 +541,7 @@ readExports( tmpsym[SYMNMLEN] = '\0'; symname = tmpsym; } - ep->name = malloc((unsigned) (strlen(symname) + 1)); + ep->name = malloc(strlen(symname) + 1); strcpy(ep->name, symname); ep->addr = (void *)((unsigned long) mp->entry + ls->l_value - shdata.s_vaddr); diff --git a/unix/tclUnixCompat.c b/unix/tclUnixCompat.c index 2a68f7f..4f7af3e 100644 --- a/unix/tclUnixCompat.c +++ b/unix/tclUnixCompat.c @@ -49,7 +49,7 @@ #ifdef TCL_THREADS -typedef struct ThreadSpecificData { +typedef struct { struct passwd pwd; #if defined(HAVE_GETPWNAM_R_5) || defined(HAVE_GETPWUID_R_5) #define NEED_PW_CLEANER 1 @@ -118,10 +118,10 @@ static int CopyString(const char *src, char *buf, int buflen); #endif #ifdef NEED_PW_CLEANER -static void FreePwBuf(ClientData ignored); +static void FreePwBuf(ClientData dummy); #endif #ifdef NEED_GR_CLEANER -static void FreeGrBuf(ClientData ignored); +static void FreeGrBuf(ClientData dummy); #endif #endif /* TCL_THREADS */ @@ -201,7 +201,7 @@ TclpGetPwNam( if (tsdPtr->pbuflen < 1) { tsdPtr->pbuflen = 1024; } - tsdPtr->pbuf = ckalloc(tsdPtr->pbuflen); + tsdPtr->pbuf = (char *)Tcl_Alloc(tsdPtr->pbuflen); Tcl_CreateThreadExitHandler(FreePwBuf, NULL); } while (1) { @@ -214,7 +214,7 @@ TclpGetPwNam( return NULL; } tsdPtr->pbuflen *= 2; - tsdPtr->pbuf = ckrealloc(tsdPtr->pbuf, tsdPtr->pbuflen); + tsdPtr->pbuf = (char *)Tcl_Realloc(tsdPtr->pbuf, tsdPtr->pbuflen); } return (pwPtr != NULL ? &tsdPtr->pwd : NULL); @@ -281,7 +281,7 @@ TclpGetPwUid( if (tsdPtr->pbuflen < 1) { tsdPtr->pbuflen = 1024; } - tsdPtr->pbuf = ckalloc(tsdPtr->pbuflen); + tsdPtr->pbuf = (char *)Tcl_Alloc(tsdPtr->pbuflen); Tcl_CreateThreadExitHandler(FreePwBuf, NULL); } while (1) { @@ -294,7 +294,7 @@ TclpGetPwUid( return NULL; } tsdPtr->pbuflen *= 2; - tsdPtr->pbuf = ckrealloc(tsdPtr->pbuf, tsdPtr->pbuflen); + tsdPtr->pbuf = (char *)Tcl_Realloc(tsdPtr->pbuf, tsdPtr->pbuflen); } return (pwPtr != NULL ? &tsdPtr->pwd : NULL); @@ -336,9 +336,10 @@ TclpGetPwUid( #ifdef NEED_PW_CLEANER static void FreePwBuf( - ClientData ignored) + ClientData dummy) { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + (void)dummy; ckfree(tsdPtr->pbuf); } @@ -384,7 +385,7 @@ TclpGetGrNam( if (tsdPtr->gbuflen < 1) { tsdPtr->gbuflen = 1024; } - tsdPtr->gbuf = ckalloc(tsdPtr->gbuflen); + tsdPtr->gbuf = (char *)ckalloc(tsdPtr->gbuflen); Tcl_CreateThreadExitHandler(FreeGrBuf, NULL); } while (1) { @@ -397,7 +398,7 @@ TclpGetGrNam( return NULL; } tsdPtr->gbuflen *= 2; - tsdPtr->gbuf = ckrealloc(tsdPtr->gbuf, tsdPtr->gbuflen); + tsdPtr->gbuf = (char *)ckrealloc(tsdPtr->gbuf, tsdPtr->gbuflen); } return (grPtr != NULL ? &tsdPtr->grp : NULL); @@ -464,7 +465,7 @@ TclpGetGrGid( if (tsdPtr->gbuflen < 1) { tsdPtr->gbuflen = 1024; } - tsdPtr->gbuf = ckalloc(tsdPtr->gbuflen); + tsdPtr->gbuf = (char *)ckalloc(tsdPtr->gbuflen); Tcl_CreateThreadExitHandler(FreeGrBuf, NULL); } while (1) { @@ -477,7 +478,7 @@ TclpGetGrGid( return NULL; } tsdPtr->gbuflen *= 2; - tsdPtr->gbuf = ckrealloc(tsdPtr->gbuf, tsdPtr->gbuflen); + tsdPtr->gbuf = (char *)ckrealloc(tsdPtr->gbuf, tsdPtr->gbuflen); } return (grPtr != NULL ? &tsdPtr->grp : NULL); @@ -519,9 +520,10 @@ TclpGetGrGid( #ifdef NEED_GR_CLEANER static void FreeGrBuf( - ClientData ignored) + ClientData dummy) { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + (void)dummy; ckfree(tsdPtr->gbuf); } @@ -685,8 +687,8 @@ CopyGrp( char *buf, int buflen) { - register char *p = buf; - register int copied, len = 0; + char *p = buf; + int copied, len = 0; /* * Copy username. @@ -887,7 +889,7 @@ CopyArray( int buflen) /* Size of buffer. */ { int i, j, len = 0; - char *p, **new; + char *p, **newBuffer; if (src == NULL) { return 0; @@ -903,7 +905,7 @@ CopyArray( return -1; } - new = (char **) buf; + newBuffer = (char **)buf; p = buf + len; for (j = 0; j < i; j++) { @@ -914,10 +916,10 @@ CopyArray( return -1; } memcpy(p, src[j], sz); - new[j] = p; + newBuffer[j] = p; p = buf + len; } - new[j] = NULL; + newBuffer[j] = NULL; return len; } diff --git a/unix/tclUnixInit.c b/unix/tclUnixInit.c index 0ae0fa7..d0f8521 100644 --- a/unix/tclUnixInit.c +++ b/unix/tclUnixInit.c @@ -33,11 +33,20 @@ #endif #ifdef __CYGWIN__ +#ifdef __cplusplus +extern "C" { +#endif +#ifdef __clang__ +#pragma clang diagnostic ignored "-Wignored-attributes" +#endif DLLIMPORT extern __stdcall unsigned char GetVersionExW(void *); DLLIMPORT extern __stdcall void *GetModuleHandleW(const void *); DLLIMPORT extern __stdcall void FreeLibrary(void *); DLLIMPORT extern __stdcall void *GetProcAddress(void *, const char *); DLLIMPORT extern __stdcall void GetSystemInfo(void *); +#ifdef __cplusplus +} +#endif #define NUMPROCESSORS 11 static const char *const processors[NUMPROCESSORS] = { @@ -110,7 +119,7 @@ static char pkgPath[sizeof(TCL_PACKAGE_PATH)+200] = TCL_PACKAGE_PATH; * first list checked for a mapping from env encoding to Tcl encoding name. */ -typedef struct LocaleTable { +typedef struct { const char *lang; const char *encoding; } LocaleTable; @@ -764,7 +773,7 @@ InitMacLocaleInfoVar( if (!Tcl_CreateNamespace(interp, "::tcl::mac", NULL, NULL)) { Tcl_ResetResult(interp); } - Tcl_SetVar(interp, "::tcl::mac::locale", loc, TCL_GLOBAL_ONLY); + Tcl_SetVar2(interp, "::tcl::mac::locale", NULL, loc, TCL_GLOBAL_ONLY); } CFRelease(localeRef); } @@ -800,9 +809,9 @@ TclpSetVariables( const char *str; CFBundleRef bundleRef; - Tcl_SetVar(interp, "tclDefaultLibrary", tclLibPath, TCL_GLOBAL_ONLY); - Tcl_SetVar(interp, "tcl_pkgPath", tclLibPath, TCL_GLOBAL_ONLY); - Tcl_SetVar(interp, "tcl_pkgPath", " ", + Tcl_SetVar2(interp, "tclDefaultLibrary", NULL, tclLibPath, TCL_GLOBAL_ONLY); + Tcl_SetVar2(interp, "tcl_pkgPath", NULL, tclLibPath, TCL_GLOBAL_ONLY); + Tcl_SetVar2(interp, "tcl_pkgPath", NULL, " ", TCL_GLOBAL_ONLY | TCL_APPEND_VALUE); str = TclGetEnv("DYLD_FRAMEWORK_PATH", &ds); @@ -818,9 +827,9 @@ TclpSetVariables( *p = ' '; } } while (*p++); - Tcl_SetVar(interp, "tcl_pkgPath", Tcl_DStringValue(&ds), + Tcl_SetVar2(interp, "tcl_pkgPath", NULL, Tcl_DStringValue(&ds), TCL_GLOBAL_ONLY | TCL_APPEND_VALUE); - Tcl_SetVar(interp, "tcl_pkgPath", " ", + Tcl_SetVar2(interp, "tcl_pkgPath", NULL, " ", TCL_GLOBAL_ONLY | TCL_APPEND_VALUE); Tcl_DStringFree(&ds); } @@ -835,9 +844,9 @@ TclpSetVariables( (unsigned char*) tclLibPath, MAXPATHLEN) && ! TclOSstat(tclLibPath, &statBuf) && S_ISDIR(statBuf.st_mode)) { - Tcl_SetVar(interp, "tcl_pkgPath", tclLibPath, + Tcl_SetVar2(interp, "tcl_pkgPath", NULL, tclLibPath, TCL_GLOBAL_ONLY | TCL_APPEND_VALUE); - Tcl_SetVar(interp, "tcl_pkgPath", " ", + Tcl_SetVar2(interp, "tcl_pkgPath", NULL, " ", TCL_GLOBAL_ONLY | TCL_APPEND_VALUE); } CFRelease(frameworksURL); @@ -848,20 +857,20 @@ TclpSetVariables( (unsigned char*) tclLibPath, MAXPATHLEN) && ! TclOSstat(tclLibPath, &statBuf) && S_ISDIR(statBuf.st_mode)) { - Tcl_SetVar(interp, "tcl_pkgPath", tclLibPath, + Tcl_SetVar2(interp, "tcl_pkgPath", NULL, tclLibPath, TCL_GLOBAL_ONLY | TCL_APPEND_VALUE); - Tcl_SetVar(interp, "tcl_pkgPath", " ", + Tcl_SetVar2(interp, "tcl_pkgPath", NULL, " ", TCL_GLOBAL_ONLY | TCL_APPEND_VALUE); } CFRelease(frameworksURL); } } - Tcl_SetVar(interp, "tcl_pkgPath", pkgPath, + Tcl_SetVar2(interp, "tcl_pkgPath", NULL, pkgPath, TCL_GLOBAL_ONLY | TCL_APPEND_VALUE); } else #endif /* HAVE_COREFOUNDATION */ { - Tcl_SetVar(interp, "tcl_pkgPath", pkgPath, TCL_GLOBAL_ONLY); + Tcl_SetVar2(interp, "tcl_pkgPath", NULL, pkgPath, TCL_GLOBAL_ONLY); } #ifdef DJGPP @@ -874,7 +883,7 @@ TclpSetVariables( #ifdef __CYGWIN__ unameOK = 1; if (!osInfoInitialized) { - HANDLE handle = GetModuleHandleW(L"NTDLL"); + void *handle = GetModuleHandleW(L"NTDLL"); int(__stdcall *getversion)(void *) = (int(__stdcall *)(void *))GetProcAddress(handle, "RtlGetVersion"); osInfo.dwOSVersionInfoSize = sizeof(OSVERSIONINFOW); @@ -1009,7 +1018,7 @@ TclpFindVariable( * searches). */ { int i, result = -1; - register const char *env, *p1, *p2; + const char *env, *p1, *p2; Tcl_DString envString; Tcl_DStringInit(&envString); diff --git a/unix/tclUnixThrd.c b/unix/tclUnixThrd.c index 68852a1..afb795d 100644 --- a/unix/tclUnixThrd.c +++ b/unix/tclUnixThrd.c @@ -89,7 +89,7 @@ TclpThreadCreate( #ifdef HAVE_PTHREAD_ATTR_SETSTACKSIZE if (stackSize != TCL_THREAD_STACK_DEFAULT) { - pthread_attr_setstacksize(&attr, (size_t) stackSize); + pthread_attr_setstacksize(&attr, stackSize); #ifdef TCL_THREAD_STACK_MIN } else { /* @@ -114,8 +114,8 @@ TclpThreadCreate( } #endif /* HAVE_PTHREAD_ATTR_SETSTACKSIZE */ - if (! (flags & TCL_THREAD_JOINABLE)) { - pthread_attr_setdetachstate (&attr, PTHREAD_CREATE_DETACHED); + if (!(flags & TCL_THREAD_JOINABLE)) { + pthread_attr_setdetachstate(&attr, PTHREAD_CREATE_DETACHED); } if (pthread_create(&theThread, &attr, @@ -252,7 +252,7 @@ TclpInitLock(void) /* *---------------------------------------------------------------------- * - * TclpFinalizeLock + * TclFinalizeLock * * This procedure is used to destroy all private resources used in this * file. @@ -334,7 +334,6 @@ TclpGlobalLock(void) pthread_mutex_lock(&globalLock); #endif } - /* *---------------------------------------------------------------------- @@ -427,7 +426,7 @@ Tcl_MutexLock( * Double inside global lock check to avoid a race condition. */ - pmutexPtr = ckalloc(sizeof(pthread_mutex_t)); + pmutexPtr = (pthread_mutex_t *)ckalloc(sizeof(pthread_mutex_t)); pthread_mutex_init(pmutexPtr, NULL); *mutexPtr = (Tcl_Mutex)pmutexPtr; TclRememberMutex(mutexPtr); @@ -537,7 +536,7 @@ Tcl_ConditionWait( */ if (*condPtr == NULL) { - pcondPtr = ckalloc(sizeof(pthread_cond_t)); + pcondPtr = (pthread_cond_t *)ckalloc(sizeof(pthread_cond_t)); pthread_cond_init(pcondPtr, NULL); *condPtr = (Tcl_Condition) pcondPtr; TclRememberCondition(condPtr); @@ -588,11 +587,12 @@ Tcl_ConditionNotify( Tcl_Condition *condPtr) { pthread_cond_t *pcondPtr = *((pthread_cond_t **)condPtr); + if (pcondPtr != NULL) { pthread_cond_broadcast(pcondPtr); } else { /* - * Noone has used the condition variable, so there are no waiters. + * No-one has used the condition variable, so there are no waiters. */ } } @@ -683,18 +683,18 @@ TclpInetNtoa( static volatile int initialized = 0; static pthread_key_t key; -typedef struct allocMutex { +typedef struct { Tcl_Mutex tlock; pthread_mutex_t plock; -} allocMutex; +} AllocMutex; Tcl_Mutex * TclpNewAllocMutex(void) { - struct allocMutex *lockPtr; - register pthread_mutex_t *plockPtr; + AllocMutex *lockPtr; + pthread_mutex_t *plockPtr; - lockPtr = malloc(sizeof(struct allocMutex)); + lockPtr = (AllocMutex *)malloc(sizeof(AllocMutex)); if (lockPtr == NULL) { Tcl_Panic("could not allocate lock"); } @@ -708,7 +708,8 @@ void TclpFreeAllocMutex( Tcl_Mutex *mutex) /* The alloc mutex to free. */ { - allocMutex* lockPtr = (allocMutex*) mutex; + AllocMutex *lockPtr = (AllocMutex *)mutex; + if (!lockPtr) { return; } @@ -767,7 +768,7 @@ TclpThreadCreateKey(void) { pthread_key_t *ptkeyPtr; - ptkeyPtr = TclpSysAlloc(sizeof *ptkeyPtr, 0); + ptkeyPtr = (pthread_key_t *)TclpSysAlloc(sizeof(pthread_key_t), 0); if (NULL == ptkeyPtr) { Tcl_Panic("unable to allocate thread key!"); } @@ -783,7 +784,7 @@ void TclpThreadDeleteKey( void *keyPtr) { - pthread_key_t *ptkeyPtr = keyPtr; + pthread_key_t *ptkeyPtr = (pthread_key_t *)keyPtr; if (pthread_key_delete(*ptkeyPtr)) { Tcl_Panic("unable to delete key!"); @@ -797,7 +798,7 @@ TclpThreadSetGlobalTSD( void *tsdKeyPtr, void *ptr) { - pthread_key_t *ptkeyPtr = tsdKeyPtr; + pthread_key_t *ptkeyPtr = (pthread_key_t *)tsdKeyPtr; if (pthread_setspecific(*ptkeyPtr, ptr)) { Tcl_Panic("unable to set global TSD value"); @@ -808,7 +809,7 @@ void * TclpThreadGetGlobalTSD( void *tsdKeyPtr) { - pthread_key_t *ptkeyPtr = tsdKeyPtr; + pthread_key_t *ptkeyPtr = (pthread_key_t *)tsdKeyPtr; return pthread_getspecific(*ptkeyPtr); } -- cgit v0.12 From c07c2bb91ccfa02ec939148c02317d2e2978a4c2 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 11 Aug 2020 13:15:37 +0000 Subject: Revert unintended ckalloc -> Tcl_Alloc change from previous commit --- unix/tclUnixCompat.c | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/unix/tclUnixCompat.c b/unix/tclUnixCompat.c index 4f7af3e..451a409 100644 --- a/unix/tclUnixCompat.c +++ b/unix/tclUnixCompat.c @@ -201,7 +201,7 @@ TclpGetPwNam( if (tsdPtr->pbuflen < 1) { tsdPtr->pbuflen = 1024; } - tsdPtr->pbuf = (char *)Tcl_Alloc(tsdPtr->pbuflen); + tsdPtr->pbuf = (char *)ckalloc(tsdPtr->pbuflen); Tcl_CreateThreadExitHandler(FreePwBuf, NULL); } while (1) { @@ -214,7 +214,7 @@ TclpGetPwNam( return NULL; } tsdPtr->pbuflen *= 2; - tsdPtr->pbuf = (char *)Tcl_Realloc(tsdPtr->pbuf, tsdPtr->pbuflen); + tsdPtr->pbuf = (char *)ckrealloc(tsdPtr->pbuf, tsdPtr->pbuflen); } return (pwPtr != NULL ? &tsdPtr->pwd : NULL); @@ -281,7 +281,7 @@ TclpGetPwUid( if (tsdPtr->pbuflen < 1) { tsdPtr->pbuflen = 1024; } - tsdPtr->pbuf = (char *)Tcl_Alloc(tsdPtr->pbuflen); + tsdPtr->pbuf = (char *)ckalloc(tsdPtr->pbuflen); Tcl_CreateThreadExitHandler(FreePwBuf, NULL); } while (1) { @@ -294,7 +294,7 @@ TclpGetPwUid( return NULL; } tsdPtr->pbuflen *= 2; - tsdPtr->pbuf = (char *)Tcl_Realloc(tsdPtr->pbuf, tsdPtr->pbuflen); + tsdPtr->pbuf = (char *)ckrealloc(tsdPtr->pbuf, tsdPtr->pbuflen); } return (pwPtr != NULL ? &tsdPtr->pwd : NULL); -- cgit v0.12 -- cgit v0.12 From 998409ea9b162e1f9a271add26637eb24792a2aa Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 12 Aug 2020 06:36:31 +0000 Subject: Update .travis.yml: remove deprecated "sudo" and rename "matrix" to "jobs" Fix travis build for Windows/Debug --- .travis.yml | 3 +-- win/tclWinPort.h | 4 +++- 2 files changed, 4 insertions(+), 3 deletions(-) diff --git a/.travis.yml b/.travis.yml index b309e51..05c2f6a 100644 --- a/.travis.yml +++ b/.travis.yml @@ -1,4 +1,3 @@ -sudo: false language: c addons: apt: @@ -10,7 +9,7 @@ addons: - gcc-mingw-w64-i686 - gcc-mingw-w64-x86-64 - gcc-multilib -matrix: +jobs: include: # Testing on Linux with various compilers - name: "Linux/GCC/Shared" diff --git a/win/tclWinPort.h b/win/tclWinPort.h index 3cab385..056c7c8 100644 --- a/win/tclWinPort.h +++ b/win/tclWinPort.h @@ -33,7 +33,9 @@ typedef DWORD_PTR * PDWORD_PTR; /* * Ask for the winsock function typedefs, also. */ -#define INCL_WINSOCK_API_TYPEDEFS 1 +#ifndef INCL_WINSOCK_API_TYPEDEFS +# define INCL_WINSOCK_API_TYPEDEFS 1 +#endif #include #ifdef CHECK_UNICODE_CALLS -- cgit v0.12 From 330e4967abb577c06a94a635e415c031030372f8 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 12 Aug 2020 07:10:57 +0000 Subject: Fix value of CMD_DEAD flag --- generic/tclInt.h | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclInt.h b/generic/tclInt.h index 1e90b70..317ae1f 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -1682,7 +1682,7 @@ typedef struct Command { #define CMD_COMPILES_EXPANDED 0x08 #define CMD_REDEF_IN_PROGRESS 0x10 #define CMD_VIA_RESOLVER 0x20 -#define CMD_DEAD 0x30 +#define CMD_DEAD 0x40 /* -- cgit v0.12 From cc21b0be2ad2d9c16af8d9dbdf188110479ebfc7 Mon Sep 17 00:00:00 2001 From: kjnash Date: Wed, 12 Aug 2020 09:20:56 +0000 Subject: Bugfixes to the earlier fix of bug cb0373bb33, which broke HTTP/1.0 transactions in which the server indicates neither a Content-Length nor that it will close the socket on completion ("Connection: close"). The HTTP/1.1 rule is that the response header "Connection", if absent, must default to "keep-alive"; but this rule does not apply to HTTP/1.0. Add test http11-3.4 and bump version to 2.9.4. --- library/http/http.tcl | 40 ++++++++++++++++++++++++++++------------ library/http/pkgIndex.tcl | 2 +- tests/http11.test | 27 +++++++++++++++++++++++++++ tests/httpd11.tcl | 13 +++++++++++-- unix/Makefile.in | 4 ++-- win/Makefile.in | 4 ++-- 6 files changed, 71 insertions(+), 19 deletions(-) diff --git a/library/http/http.tcl b/library/http/http.tcl index f9ec8ca..8b5d686 100644 --- a/library/http/http.tcl +++ b/library/http/http.tcl @@ -11,7 +11,7 @@ package require Tcl 8.6- # Keep this in sync with pkgIndex.tcl and with the install directories in # Makefiles -package provide http 2.9.3 +package provide http 2.9.4 namespace eval http { # Allow resourcing to not clobber existing data @@ -966,6 +966,18 @@ proc http::geturl {url args} { set state(-pipeline) $http(-pipeline) } + # We cannot handle chunked encodings with -handler, so force HTTP/1.0 + # until we can manage this. + if {[info exists state(-handler)]} { + set state(-protocol) 1.0 + } + + # RFC 7320 A.1 - HTTP/1.0 Keep-Alive is problematic. We do not support it. + if {$state(-protocol) eq "1.0"} { + set state(connection) close + set state(-keepalive) 0 + } + # See if we are supposed to use a previously opened channel. # - In principle, ANY call to http::geturl could use a previously opened # channel if it is available - the "Connection: keep-alive" header is a @@ -1338,11 +1350,6 @@ proc http::Connected {token proto phost srvurl} { if {[info exists state(-method)] && ($state(-method) ne "")} { set how $state(-method) } - # We cannot handle chunked encodings with -handler, so force HTTP/1.0 - # until we can manage this. - if {[info exists state(-handler)]} { - set state(-protocol) 1.0 - } set accept_types_seen 0 Log ^B$tk begin sending request - token $token @@ -1361,7 +1368,7 @@ proc http::Connected {token proto phost srvurl} { puts $sock "Host: $host:$port" } puts $sock "User-Agent: $http(-useragent)" - if {($state(-protocol) >= 1.0) && $state(-keepalive)} { + if {($state(-protocol) > 1.0) && $state(-keepalive)} { # Send this header, because a 1.1 server is not compelled to treat # this as the default. puts $sock "Connection: keep-alive" @@ -1369,9 +1376,17 @@ proc http::Connected {token proto phost srvurl} { if {($state(-protocol) > 1.0) && !$state(-keepalive)} { puts $sock "Connection: close" ;# RFC2616 sec 8.1.2.1 } - if {[info exists phost] && ($phost ne "") && $state(-keepalive)} { - puts $sock "Proxy-Connection: Keep-Alive" - } + if {($state(-protocol) < 1.1)} { + # RFC7230 A.1 + # Some server implementations of HTTP/1.0 have a faulty + # implementation of RFC 2068 Keep-Alive. + # Don't leave this to chance. + # For HTTP/1.0 we have already "set state(connection) close" + # and "state(-keepalive) 0". + puts $sock "Connection: close" + } + # RFC7230 A.1 - "clients are encouraged not to send the + # Proxy-Connection header field in any requests" set accept_encoding_seen 0 set content_type_seen 0 dict for {key value} $state(-headers) { @@ -2702,15 +2717,16 @@ proc http::Event {sock token} { # therefore "keep-alive". set tmpHeader keep-alive } else { - set tmpHeader keep-alive + set tmpResult keep-alive set tmpCsl [split $tmpHeader ,] # Optional whitespace either side of separator. foreach el $tmpCsl { if {[string trim $el] eq {close}} { - set tmpHeader close + set tmpResult close break } } + set tmpHeader $tmpResult } set state(connection) $tmpHeader } diff --git a/library/http/pkgIndex.tcl b/library/http/pkgIndex.tcl index 43cd86b..1cc8f46 100644 --- a/library/http/pkgIndex.tcl +++ b/library/http/pkgIndex.tcl @@ -1,2 +1,2 @@ if {![package vsatisfies [package provide Tcl] 8.6-]} {return} -package ifneeded http 2.9.3 [list tclPkgSetup $dir http 2.9.3 {{http.tcl source {::http::config ::http::formatQuery ::http::geturl ::http::reset ::http::wait ::http::register ::http::unregister ::http::mapReply}}}] +package ifneeded http 2.9.4 [list tclPkgSetup $dir http 2.9.4 {{http.tcl source {::http::config ::http::formatQuery ::http::geturl ::http::reset ::http::wait ::http::register ::http::unregister ::http::mapReply}}}] diff --git a/tests/http11.test b/tests/http11.test index 762788e..240bfef 100644 --- a/tests/http11.test +++ b/tests/http11.test @@ -626,6 +626,33 @@ test http11-3.3 "-handler,keepalive,chunked" -setup { halt_httpd } -result {ok {HTTP/1.0 200 OK} ok close {} {} 0} +# http11-3.4 +# This test is a blatant attempt to confuse the client by instructing the server +# to send neither "Connection: close" nor "Content-Length" when in non-chunked +# mode. +# The client has no way to know the response-body is complete unless the +# server signals this by closing the connection. +# In an HTTP/1.1 response the absence of "Connection: close" means +# "Connection: keep-alive", i.e. the server will keep the connection +# open. In HTTP/1.0 this is not the case, and this is a test that +# the Tcl client assumes "Connection: close" by default in HTTP/1.0. +test http11-3.4 "-handler,close,identity; HTTP/1.0 server does not send Connection: close header or Content-Length" -setup { + variable httpd [create_httpd] + set testdata "" +} -body { + set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1&nosendclose=any \ + -timeout 10000 -handler [namespace code [list handler testdata]]] + http::wait $tok + list [http::status $tok] [http::code $tok] [check_crc $tok $testdata]\ + [meta $tok connection] [meta $tok content-encoding] \ + [meta $tok transfer-encoding] \ + [expr {[file size testdoc.html]-[string length $testdata]}] +} -cleanup { + http::cleanup $tok + unset -nocomplain testdata + halt_httpd +} -result {ok {HTTP/1.0 200 OK} ok {} {} {} 0} + test http11-4.0 "normal post request" -setup { variable httpd [create_httpd] } -body { diff --git a/tests/httpd11.tcl b/tests/httpd11.tcl index 7880494..0b02319 100644 --- a/tests/httpd11.tcl +++ b/tests/httpd11.tcl @@ -170,14 +170,19 @@ proc Service {chan addr port} { set close 1 } + set nosendclose 0 foreach pair [split $query &] { if {[scan $pair {%[^=]=%s} key val] != 2} {set val ""} switch -exact -- $key { + nosendclose {set nosendclose 1} close {set close 1 ; set transfer 0} transfer {set transfer $val} content-type {set type $val} } } + if {$protocol eq "HTTP/1.1"} { + set nosendclose 0 + } chan configure $chan -buffering line -encoding iso8859-1 -translation crlf Puts $chan "$protocol $code" @@ -186,12 +191,16 @@ proc Service {chan addr port} { if {$req eq "POST"} { Puts $chan [format "x-query-length: %d" [string length $query]] } - if {$close} { + if {$close && (!$nosendclose)} { Puts $chan "connection: close" } Puts $chan "x-requested-encodings: [dict get? $meta accept-encoding]" - if {$encoding eq "identity"} { + if {$encoding eq "identity" && (!$nosendclose)} { Puts $chan "content-length: [string length $data]" + } elseif {$encoding eq "identity"} { + # This is a blatant attempt to confuse the client by sending neither + # "Connection: close" nor "Content-Length" when in non-chunked mode. + # See test http11-3.4. } else { Puts $chan "content-encoding: $encoding" } diff --git a/unix/Makefile.in b/unix/Makefile.in index 3e0dd1e..07ce3b7 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -944,8 +944,8 @@ install-libraries: libraries do \ $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)/http1.0"; \ done; - @echo "Installing package http 2.9.3 as a Tcl Module"; - @$(INSTALL_DATA) $(TOP_DIR)/library/http/http.tcl "$(MODULE_INSTALL_DIR)/8.6/http-2.9.3.tm"; + @echo "Installing package http 2.9.4 as a Tcl Module"; + @$(INSTALL_DATA) $(TOP_DIR)/library/http/http.tcl "$(MODULE_INSTALL_DIR)/8.6/http-2.9.4.tm"; @echo "Installing package opt0.4 files to $(SCRIPT_INSTALL_DIR)/opt0.4/"; @for i in $(TOP_DIR)/library/opt/*.tcl ; \ do \ diff --git a/win/Makefile.in b/win/Makefile.in index 7c0db47..110f7bf 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -719,8 +719,8 @@ install-libraries: libraries install-tzdata install-msgs do \ $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/http1.0"; \ done; - @echo "Installing package http 2.9.3 as a Tcl Module"; - @$(COPY) $(ROOT_DIR)/library/http/http.tcl "$(MODULE_INSTALL_DIR)/8.6/http-2.9.3.tm"; + @echo "Installing package http 2.9.4 as a Tcl Module"; + @$(COPY) $(ROOT_DIR)/library/http/http.tcl "$(MODULE_INSTALL_DIR)/8.6/http-2.9.4.tm"; @echo "Installing library opt0.4 directory"; @for j in $(ROOT_DIR)/library/opt/*.tcl; \ do \ -- cgit v0.12 From 52549ae747613994a8ced4de9b567bc4cc09443f Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 12 Aug 2020 10:25:49 +0000 Subject: Fix [e87000d8425ab86a]: crash for "fconfigure stdout" in Win32. Even though the crash cannot happen in Tcl 8.6, the function Tcl_BadChannelOption() was to blame, so better fix that in 8.6 too. --- generic/tclIO.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index 7abeb68..82eb581 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -7699,7 +7699,7 @@ Tcl_BadChannelOption( } Tcl_ResetResult(interp); errObj = Tcl_ObjPrintf("bad option \"%s\": should be one of ", - optionName); + optionName ? optionName : ""); argc--; for (i = 0; i < argc; i++) { Tcl_AppendPrintfToObj(errObj, "-%s, ", argv[i]); -- cgit v0.12 From 840355939de3409373a08bc3c0c216916d74521f Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 13 Aug 2020 07:21:34 +0000 Subject: Testcase event-1.1 (still) fails occasionally on macOS --- tests/event.test | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/tests/event.test b/tests/event.test index b42909c..70d4cff 100644 --- a/tests/event.test +++ b/tests/event.test @@ -23,11 +23,12 @@ testConstraint testfilehandler [llength [info commands testfilehandler]] testConstraint testexithandler [llength [info commands testexithandler]] testConstraint testfilewait [llength [info commands testfilewait]] testConstraint exec [llength [info commands exec]] - +testConstraint notOSX [expr {$::tcl_platform(os) ne "Darwin"}] + test event-1.1 {Tcl_CreateFileHandler, reading} -setup { testfilehandler close set result "" -} -constraints testfilehandler -body { +} -constraints {testfilehandler notOSX} -body { testfilehandler create 0 readable off testfilehandler clear 0 testfilehandler oneevent -- cgit v0.12 From e1968256d828d5f86f7ee09eaea945332df127b1 Mon Sep 17 00:00:00 2001 From: culler Date: Mon, 17 Aug 2020 15:53:04 +0000 Subject: Try to make io-50.6 more robust on the Travis macOS VM --- tests/io.test | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) diff --git a/tests/io.test b/tests/io.test index 685394c..016c6bd 100644 --- a/tests/io.test +++ b/tests/io.test @@ -6871,7 +6871,7 @@ test io-50.5 {testing handler deletion vs reentrant calls} -constraints {testcha } -cleanup { close $f } -result [list {del calling recursive} {del deleted notcalled} \ - {del deleted myself} {del after recursive}] + {del deleted myself} {del after recursive}] test io-50.6 {testing handler deletion vs reentrant calls} -constraints {testchannelevent testservicemode} -setup { file delete $path(test1) } -body { @@ -6880,6 +6880,7 @@ test io-50.6 {testing handler deletion vs reentrant calls} -constraints {testcha proc first {f} { variable u variable z + variable done if {"$u" == "toplevel"} { lappend z "first called" set u first @@ -6887,6 +6888,7 @@ test io-50.6 {testing handler deletion vs reentrant calls} -constraints {testcha vwait z after cancel $timer lappend z "first after toplevel" + set done 1 } else { lappend z "first called not toplevel" } @@ -6908,19 +6910,24 @@ test io-50.6 {testing handler deletion vs reentrant calls} -constraints {testcha } set z "" set u toplevel + set done 0 testservicemode 0 set f [open $path(test1) r] testchannelevent $f add readable [namespace code [list second $f]] testchannelevent $f add readable [namespace code [list first $f]] testservicemode 1 update + if {!$done} { + set $timer2 [after 200 lappend done timeout] + vwait done + after cancel timer2 + } set z } -cleanup { close $f } -result [list {first called} {first called not toplevel} \ {second called, first time} {second called, second time} \ {first after toplevel}] - test io-51.1 {Test old socket deletion on Macintosh} {socket} { set x 0 set result "" -- cgit v0.12 From 270c9b99d653dad45f98e06a5c503a6338479ac9 Mon Sep 17 00:00:00 2001 From: culler Date: Mon, 17 Aug 2020 16:21:05 +0000 Subject: Add the missing $. --- tests/io.test | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/io.test b/tests/io.test index 016c6bd..6e2c907 100644 --- a/tests/io.test +++ b/tests/io.test @@ -6920,7 +6920,7 @@ test io-50.6 {testing handler deletion vs reentrant calls} -constraints {testcha if {!$done} { set $timer2 [after 200 lappend done timeout] vwait done - after cancel timer2 + after cancel $timer2 } set z } -cleanup { -- cgit v0.12 From 6560454489df369db2c1edeaaf82a094efda0115 Mon Sep 17 00:00:00 2001 From: culler Date: Mon, 17 Aug 2020 16:28:28 +0000 Subject: And remove the other $ and do the test slightly differently. Inability to test locally is a challenge. --- tests/io.test | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/io.test b/tests/io.test index 6e2c907..18636c1 100644 --- a/tests/io.test +++ b/tests/io.test @@ -6918,7 +6918,7 @@ test io-50.6 {testing handler deletion vs reentrant calls} -constraints {testcha testservicemode 1 update if {!$done} { - set $timer2 [after 200 lappend done timeout] + set timer2 [after 200 set done 1] vwait done after cancel $timer2 } -- cgit v0.12 From 591c90cd3e7e44d16dc721a6b3d7a66c6746c2eb Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 21 Aug 2020 13:59:13 +0000 Subject: Suppress tests that fail starting with OSX Mojave. --- tests/socket.test | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/tests/socket.test b/tests/socket.test index 3544dd9..469367a 100644 --- a/tests/socket.test +++ b/tests/socket.test @@ -199,6 +199,8 @@ if {[testConstraint doTestsWithRemoteServer]} { } } +testConstraint notOSX [string compare $::tcl_platform(os) Darwin] + test socket-1.1 {arg parsing for socket command} {socket} { list [catch {socket -server} msg] $msg } {1 {no argument given for -server option}} @@ -816,7 +818,7 @@ test socket-4.2 {byte order problems, socket numbers, htons} {socket} { } ok test socket-5.1 {byte order problems, socket numbers, htons} \ - {socket unix notRoot} { + {socket unix notRoot notOSX} { set x {couldn't open socket: not owner} if {![catch {socket -server dodo 0x1} msg]} { set x {htons problem, should be disallowed, are you running as SU?} @@ -833,7 +835,7 @@ test socket-5.2 {byte order problems, socket numbers, htons} {socket} { set x } {couldn't open socket: port number too high} test socket-5.3 {byte order problems, socket numbers, htons} \ - {socket unix notRoot} { + {socket unix notRoot notOSX} { set x {couldn't open socket: not owner} if {![catch {socket -server dodo 21} msg]} { set x {htons problem, should be disallowed, are you running as SU?} -- cgit v0.12 From b2d5b24a704988578dfaa93e7cead7428be9ccbc Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 24 Aug 2020 07:57:04 +0000 Subject: Upgrade Travis build from bionic to focal --- .travis.yml | 32 ++++++++++++++++---------------- 1 file changed, 16 insertions(+), 16 deletions(-) diff --git a/.travis.yml b/.travis.yml index 05c2f6a..dd86769 100644 --- a/.travis.yml +++ b/.travis.yml @@ -14,48 +14,48 @@ jobs: # Testing on Linux with various compilers - name: "Linux/GCC/Shared" os: linux - dist: bionic + dist: focal compiler: gcc env: - BUILD_DIR=unix - name: "Linux/GCC/Shared: UTF_MAX=4" os: linux - dist: bionic + dist: focal compiler: gcc env: - BUILD_DIR=unix - CFGOPT=CFLAGS=-DTCL_UTF_MAX=4 - name: "Linux/GCC/Shared: UTF_MAX=5" os: linux - dist: bionic + dist: focal compiler: gcc env: - BUILD_DIR=unix - CFGOPT=CFLAGS=-DTCL_UTF_MAX=5 - name: "Linux/GCC/Shared: UTF_MAX=6" os: linux - dist: bionic + dist: focal compiler: gcc env: - BUILD_DIR=unix - CFGOPT=CFLAGS=-DTCL_UTF_MAX=6 - name: "Linux/GCC/Static" os: linux - dist: bionic + dist: focal compiler: gcc env: - CFGOPT="--disable-shared" - BUILD_DIR=unix - name: "Linux/GCC/Debug" os: linux - dist: bionic + dist: focal compiler: gcc env: - BUILD_DIR=unix - CFGOPT="--enable-symbols" - name: "Linux/GCC/Mem-Debug" os: linux - dist: bionic + dist: focal compiler: gcc env: - BUILD_DIR=unix @@ -63,7 +63,7 @@ jobs: # Older versions of GCC... - name: "Linux/GCC 7/Shared" os: linux - dist: bionic + dist: focal compiler: gcc-7 addons: apt: @@ -75,7 +75,7 @@ jobs: - BUILD_DIR=unix - name: "Linux/GCC 6/Shared" os: linux - dist: bionic + dist: focal compiler: gcc-6 addons: apt: @@ -87,7 +87,7 @@ jobs: - BUILD_DIR=unix - name: "Linux/GCC 5/Shared" os: linux - dist: bionic + dist: focal compiler: gcc-5 addons: apt: @@ -100,27 +100,27 @@ jobs: # Clang - name: "Linux/Clang/Shared" os: linux - dist: bionic + dist: focal compiler: clang env: - BUILD_DIR=unix - name: "Linux/Clang/Static" os: linux - dist: bionic + dist: focal compiler: clang env: - CFGOPT="--disable-shared" - BUILD_DIR=unix - name: "Linux/Clang/Debug" os: linux - dist: bionic + dist: focal compiler: clang env: - BUILD_DIR=unix - CFGOPT="--enable-symbols" - name: "Linux/Clang/Mem-Debug" os: linux - dist: bionic + dist: focal compiler: clang env: - BUILD_DIR=unix @@ -174,7 +174,7 @@ jobs: # Doesn't run tests because wine is only an imperfect Windows emulation - name: "Linux-cross-Windows/GCC/Shared/no test" os: linux - dist: bionic + dist: focal compiler: x86_64-w64-mingw32-gcc env: - BUILD_DIR=win @@ -188,7 +188,7 @@ jobs: # Doesn't run tests because wine is only an imperfect Windows emulation - name: "Linux-cross-Windows-32/GCC/Shared/no test" os: linux - dist: bionic + dist: focal compiler: i686-w64-mingw32-gcc env: - BUILD_DIR=win -- cgit v0.12 From 5f4ef0229dcf7281043e2ece43b807f55ae0c461 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 24 Aug 2020 10:19:49 +0000 Subject: Backport improvemenets in .gitignore .fossil-settings/ignore-glob and win/nmakehlp.c --- .fossil-settings/ignore-glob | 4 ++ .gitignore | 3 + win/nmakehlp.c | 131 ++++++++++++++++++++++++++++++++++++++----- 3 files changed, 125 insertions(+), 13 deletions(-) diff --git a/.fossil-settings/ignore-glob b/.fossil-settings/ignore-glob index eca9bcd..651d616 100644 --- a/.fossil-settings/ignore-glob +++ b/.fossil-settings/ignore-glob @@ -1,9 +1,12 @@ *.a *.dll *.dylib +*.dylib.E *.exe *.exp +*.la *.lib +*.lo *.o *.obj *.pdb @@ -61,4 +64,5 @@ win/*.manifest win/pkgs/* win/coffbase.txt win/tcl.hpj +win/nmakehlp.out win/nmhlp-out.txt diff --git a/.gitignore b/.gitignore index 701419b..33579cf 100644 --- a/.gitignore +++ b/.gitignore @@ -2,6 +2,7 @@ *.bundle *.dll *.dylib +*.dylib.E *.exe *.exp *.lib @@ -14,6 +15,7 @@ .fslckout Makefile Tcl-Info.plist +Tclsh-Info.plist autom4te.cache config.cache config.log @@ -59,4 +61,5 @@ win/*.manifest win/pkgs/* win/coffbase.txt win/tcl.hpj +win/nmakehlp.out win/nmhlp-out.txt diff --git a/win/nmakehlp.c b/win/nmakehlp.c index 821d00b..7536ede 100644 --- a/win/nmakehlp.c +++ b/win/nmakehlp.c @@ -14,13 +14,8 @@ #define _CRT_SECURE_NO_DEPRECATE #include -#define NO_SHLWAPI_GDI -#define NO_SHLWAPI_STREAM -#define NO_SHLWAPI_REG -#include #pragma comment (lib, "user32.lib") #pragma comment (lib, "kernel32.lib") -#pragma comment (lib, "shlwapi.lib") #include #include @@ -46,6 +41,7 @@ static int CheckForLinkerFeature(const char **options, int count); static int IsIn(const char *string, const char *substring); static int SubstituteFile(const char *substs, const char *filename); static int QualifyPath(const char *path); +static int LocateDependency(const char *keyfile); static const char *GetVersionFromFile(const char *filename, const char *match, int numdots); static DWORD WINAPI ReadFromPipe(LPVOID args); @@ -171,6 +167,18 @@ main( return 2; } return QualifyPath(argv[2]); + + case 'L': + if (argc != 3) { + chars = snprintf(msg, sizeof(msg) - 1, + "usage: %s -L keypath\n" + "Emit the fully qualified path of directory containing keypath\n" + "exitcodes: 0 == success, 1 == not found, 2 == error\n", argv[0]); + WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, chars, + &dwWritten, NULL); + return 2; + } + return LocateDependency(argv[2]); } } chars = snprintf(msg, sizeof(msg) - 1, @@ -635,7 +643,7 @@ SubstituteFile( } /* debug: dump the list */ -#ifdef _DEBUG +#ifndef NDEBUG { int n = 0; list_item_t *p = NULL; @@ -675,6 +683,17 @@ SubstituteFile( return 0; } +BOOL FileExists(LPCTSTR szPath) +{ +#ifndef INVALID_FILE_ATTRIBUTES + #define INVALID_FILE_ATTRIBUTES ((DWORD)-1) +#endif + DWORD pathAttr = GetFileAttributes(szPath); + return (pathAttr != INVALID_FILE_ATTRIBUTES && + !(pathAttr & FILE_ATTRIBUTE_DIRECTORY)); +} + + /* * QualifyPath -- * @@ -688,18 +707,104 @@ QualifyPath( const char *szPath) { char szCwd[MAX_PATH + 1]; - char szTmp[MAX_PATH + 1]; - char *p; - GetCurrentDirectory(MAX_PATH, szCwd); - while ((p = strchr(szPath, '/')) && *p) - *p = '\\'; - PathCombine(szTmp, szCwd, szPath); - PathCanonicalize(szCwd, szTmp); + + GetFullPathName(szPath, sizeof(szCwd)-1, szCwd, NULL); printf("%s\n", szCwd); return 0; } /* + * Implements LocateDependency for a single directory. See that command + * for an explanation. + * Returns 0 if found after printing the directory. + * Returns 1 if not found but no errors. + * Returns 2 on any kind of error + * Basically, these are used as exit codes for the process. + */ +static int LocateDependencyHelper(const char *dir, const char *keypath) +{ + HANDLE hSearch; + char path[MAX_PATH+1]; + int dirlen, keylen, ret; + WIN32_FIND_DATA finfo; + + if (dir == NULL || keypath == NULL) + return 2; /* Have no real error reporting mechanism into nmake */ + dirlen = strlen(dir); + if ((dirlen + 3) > sizeof(path)) + return 2; + strncpy(path, dir, dirlen); + strncpy(path+dirlen, "\\*", 3); /* Including terminating \0 */ + keylen = strlen(keypath); + +#if 0 /* This function is not available in Visual C++ 6 */ + /* + * Use numerics 0 -> FindExInfoStandard, + * 1 -> FindExSearchLimitToDirectories, + * as these are not defined in Visual C++ 6 + */ + hSearch = FindFirstFileEx(path, 0, &finfo, 1, NULL, 0); +#else + hSearch = FindFirstFile(path, &finfo); +#endif + if (hSearch == INVALID_HANDLE_VALUE) + return 1; /* Not found */ + + /* Loop through all subdirs checking if the keypath is under there */ + ret = 1; /* Assume not found */ + do { + int sublen; + /* + * We need to check it is a directory despite the + * FindExSearchLimitToDirectories in the above call. See SDK docs + */ + if ((finfo.dwFileAttributes & FILE_ATTRIBUTE_DIRECTORY) == 0) + continue; + sublen = strlen(finfo.cFileName); + if ((dirlen+1+sublen+1+keylen+1) > sizeof(path)) + continue; /* Path does not fit, assume not matched */ + strncpy(path+dirlen+1, finfo.cFileName, sublen); + path[dirlen+1+sublen] = '\\'; + strncpy(path+dirlen+1+sublen+1, keypath, keylen+1); + if (FileExists(path)) { + /* Found a match, print to stdout */ + path[dirlen+1+sublen] = '\0'; + QualifyPath(path); + ret = 0; + break; + } + } while (FindNextFile(hSearch, &finfo)); + FindClose(hSearch); + return ret; +} + +/* + * LocateDependency -- + * + * Locates a dependency for a package. + * keypath - a relative path within the package directory + * that is used to confirm it is the correct directory. + * The search path for the package directory is currently only + * the parent and grandparent of the current working directory. + * If found, the command prints + * name_DIRPATH= + * and returns 0. If not found, does not print anything and returns 1. + */ +static int LocateDependency(const char *keypath) +{ + int i, ret; + static const char *paths[] = {"..", "..\\..", "..\\..\\.."}; + + for (i = 0; i < (sizeof(paths)/sizeof(paths[0])); ++i) { + ret = LocateDependencyHelper(paths[i], keypath); + if (ret == 0) + return ret; + } + return ret; +} + + +/* * Local variables: * mode: c * c-basic-offset: 4 -- cgit v0.12 -- cgit v0.12 From 06a30a3a2acfa22ae71c137e7abb28e61748f496 Mon Sep 17 00:00:00 2001 From: kjnash Date: Mon, 24 Aug 2020 14:28:22 +0000 Subject: Fix for http bug c2dc1da315. Add tests. Add detail about -handler to http(n). Bump version to 2.9.5. --- doc/http.n | 4 ++ library/http/http.tcl | 46 +++++++++++- library/http/pkgIndex.tcl | 2 +- tests/http11.test | 178 ++++++++++++++++++++++++++++++++++++++++++++++ unix/Makefile.in | 4 +- win/Makefile.in | 4 +- 6 files changed, 231 insertions(+), 7 deletions(-) diff --git a/doc/http.n b/doc/http.n index e8c8c90..26bf943 100644 --- a/doc/http.n +++ b/doc/http.n @@ -250,6 +250,10 @@ proc httpHandlerCallback {socket token} { return $nbytes } .CE +.PP +The \fBhttp::geturl\fR code for the \fB-handler\fR option is not compatible with either compression or chunked transfer-encoding. If \fB-handler\fR is specified, then to work around these issues \fBhttp::geturl\fR will reduce the HTTP protocol to 1.0, and override the \fB-zip\fR option (i.e. it will not send the header "\fBAccept-Encoding: gzip,deflate,compress\fR"). +.PP +If options \fB-handler\fR and \fB-channel\fR are used together, the handler is responsible for copying the data from the HTTP socket to the specified channel. The name of the channel is available to the handler as element \fB-channel\fR of the token array. .RE .TP \fB\-headers\fR \fIkeyvaluelist\fR diff --git a/library/http/http.tcl b/library/http/http.tcl index 8b5d686..9d3e5ca 100644 --- a/library/http/http.tcl +++ b/library/http/http.tcl @@ -11,7 +11,7 @@ package require Tcl 8.6- # Keep this in sync with pkgIndex.tcl and with the install directories in # Makefiles -package provide http 2.9.4 +package provide http 2.9.5 namespace eval http { # Allow resourcing to not clobber existing data @@ -1646,9 +1646,51 @@ proc http::ReceiveResponse {token} { Log ^D$tk begin receiving response - token $token coroutine ${token}EventCoroutine http::Event $sock $token - fileevent $sock readable ${token}EventCoroutine + if {[info exists state(-handler)] || [info exists state(-progress)]} { + fileevent $sock readable [list http::EventGateway $sock $token] + } else { + fileevent $sock readable ${token}EventCoroutine + } + return } + +# http::EventGateway +# +# Bug [c2dc1da315]. +# - Recursive launch of the coroutine can occur if a -handler or -progress +# callback is used, and the callback command enters the event loop. +# - To prevent this, the fileevent "binding" is disabled while the +# coroutine is in flight. +# - If a recursive call occurs despite these precautions, it is not +# trapped and discarded here, because it is better to report it as a +# bug. +# - Although this solution is believed to be sufficiently general, it is +# used only if -handler or -progress is specified. In other cases, +# the coroutine is called directly. + +proc http::EventGateway {sock token} { + variable $token + upvar 0 $token state + fileevent $sock readable {} + catch {${token}EventCoroutine} res opts + if {[info commands ${token}EventCoroutine] ne {}} { + # The coroutine can be deleted by completion (a non-yield return), by + # http::Finish (when there is a premature end to the transaction), by + # http::reset or http::cleanup, or if the caller set option -channel + # but not option -handler: in the last case reading from the socket is + # now managed by commands ::http::Copy*, http::ReceiveChunked, and + # http::make-transformation-chunked. + # + # Catch in case the coroutine has closed the socket. + catch {fileevent $sock readable [list http::EventGateway $sock $token]} + } + + # If there was an error, re-throw it. + return -options $opts $res +} + + # http::NextPipelinedWrite # # - Connecting a socket to a token for writing is done by this command and by diff --git a/library/http/pkgIndex.tcl b/library/http/pkgIndex.tcl index 1cc8f46..74c4841 100644 --- a/library/http/pkgIndex.tcl +++ b/library/http/pkgIndex.tcl @@ -1,2 +1,2 @@ if {![package vsatisfies [package provide Tcl] 8.6-]} {return} -package ifneeded http 2.9.4 [list tclPkgSetup $dir http 2.9.4 {{http.tcl source {::http::config ::http::formatQuery ::http::geturl ::http::reset ::http::wait ::http::register ::http::unregister ::http::mapReply}}}] +package ifneeded http 2.9.5 [list tclPkgSetup $dir http 2.9.5 {{http.tcl source {::http::config ::http::formatQuery ::http::geturl ::http::reset ::http::wait ::http::register ::http::unregister ::http::mapReply}}}] diff --git a/tests/http11.test b/tests/http11.test index 240bfef..989b00f 100644 --- a/tests/http11.test +++ b/tests/http11.test @@ -280,6 +280,20 @@ test http11-1.13 "normal, 1.1 and keepalive as server default, no zip" -setup { # ------------------------------------------------------------------------- +proc progress {var token total current} { + upvar #0 $var log + set log [list $current $total] + return +} + +proc progressPause {var token total current} { + upvar #0 $var log + set log [list $current $total] + after 100 set ::WaitHere 0 + vwait ::WaitHere + return +} + test http11-2.0 "-channel" -setup { variable httpd [create_httpd] set chan [open [makeFile {} testfile.tmp] wb+] @@ -376,6 +390,58 @@ test http11-2.4 "-channel,encoding identity" -setup { halt_httpd } -result {ok {HTTP/1.1 200 OK} ok close {} chunked} +test http11-2.4.1 "-channel,encoding identity with -progress" -setup { + variable httpd [create_httpd] + set chan [open [makeFile {} testfile.tmp] wb+] + set logdata "" +} -body { + set tok [http::geturl http://localhost:$httpd_port/testdoc.html \ + -timeout 5000 -channel $chan \ + -headers {accept-encoding identity} \ + -progress [namespace code [list progress logdata]]] + + http::wait $tok + seek $chan 0 + set data [read $chan] + list [http::status $tok] [http::code $tok] [check_crc $tok $data]\ + [meta $tok connection] [meta $tok content-encoding]\ + [meta $tok transfer-encoding] \ + [expr {[lindex $logdata 0] - [lindex $logdata 1]}] \ + [expr {[lindex $logdata 0] - [string length $data]}] +} -cleanup { + http::cleanup $tok + close $chan + removeFile testfile.tmp + halt_httpd + unset -nocomplain logdata data +} -result {ok {HTTP/1.1 200 OK} ok close {} chunked 0 0} + +test http11-2.4.2 "-channel,encoding identity with -progress progressPause enters event loop" -constraints knownBug -setup { + variable httpd [create_httpd] + set chan [open [makeFile {} testfile.tmp] wb+] + set logdata "" +} -body { + set tok [http::geturl http://localhost:$httpd_port/testdoc.html \ + -timeout 5000 -channel $chan \ + -headers {accept-encoding identity} \ + -progress [namespace code [list progressPause logdata]]] + + http::wait $tok + seek $chan 0 + set data [read $chan] + list [http::status $tok] [http::code $tok] [check_crc $tok $data]\ + [meta $tok connection] [meta $tok content-encoding]\ + [meta $tok transfer-encoding] \ + [expr {[lindex $logdata 0] - [lindex $logdata 1]}] \ + [expr {[lindex $logdata 0] - [string length $data]}] +} -cleanup { + http::cleanup $tok + close $chan + removeFile testfile.tmp + halt_httpd + unset -nocomplain logdata data ::WaitHere +} -result {ok {HTTP/1.1 200 OK} ok close {} chunked 0 0} + test http11-2.5 "-channel,encoding unsupported" -setup { variable httpd [create_httpd] set chan [open [makeFile {} testfile.tmp] wb+] @@ -555,6 +621,16 @@ proc handler {var sock token} { return [string length $chunk] } +proc handlerPause {var sock token} { + upvar #0 $var data + set chunk [read $sock] + append data $chunk + #::http::Log "handler read [string length $chunk] ([chan configure $sock -buffersize])" + after 100 set ::WaitHere 0 + vwait ::WaitHere + return [string length $chunk] +} + test http11-3.0 "-handler,close,identity" -setup { variable httpd [create_httpd] set testdata "" @@ -653,6 +729,108 @@ test http11-3.4 "-handler,close,identity; HTTP/1.0 server does not send Connecti halt_httpd } -result {ok {HTTP/1.0 200 OK} ok {} {} {} 0} +# It is not forbidden for a handler to enter the event loop. +test http11-3.5 "-handler,close,identity as http11-3.0 but handlerPause enters event loop" -setup { + variable httpd [create_httpd] + set testdata "" +} -body { + set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1 \ + -timeout 10000 -handler [namespace code [list handlerPause testdata]]] + http::wait $tok + list [http::status $tok] [http::code $tok] [check_crc $tok $testdata]\ + [meta $tok connection] [meta $tok content-encoding] \ + [meta $tok transfer-encoding] \ + [expr {[file size testdoc.html]-[string length $testdata]}] +} -cleanup { + http::cleanup $tok + unset -nocomplain testdata ::WaitHere + halt_httpd +} -result {ok {HTTP/1.0 200 OK} ok close {} {} 0} + +test http11-3.6 "-handler,close,identity as http11-3.0 but with -progress" -setup { + variable httpd [create_httpd] + set testdata "" + set logdata "" +} -body { + set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1 \ + -timeout 10000 -handler [namespace code [list handler testdata]] \ + -progress [namespace code [list progress logdata]]] + http::wait $tok + list [http::status $tok] [http::code $tok] [check_crc $tok $testdata]\ + [meta $tok connection] [meta $tok content-encoding] \ + [meta $tok transfer-encoding] \ + [expr {[file size testdoc.html]-[string length $testdata]}] \ + [expr {[lindex $logdata 0] - [lindex $logdata 1]}] \ + [expr {[lindex $logdata 0] - [string length $testdata]}] +} -cleanup { + http::cleanup $tok + unset -nocomplain testdata logdata ::WaitHere + halt_httpd +} -result {ok {HTTP/1.0 200 OK} ok close {} {} 0 0 0} + +test http11-3.7 "-handler,close,identity as http11-3.0 but with -progress progressPause enters event loop" -setup { + variable httpd [create_httpd] + set testdata "" + set logdata "" +} -body { + set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1 \ + -timeout 10000 -handler [namespace code [list handler testdata]] \ + -progress [namespace code [list progressPause logdata]]] + http::wait $tok + list [http::status $tok] [http::code $tok] [check_crc $tok $testdata]\ + [meta $tok connection] [meta $tok content-encoding] \ + [meta $tok transfer-encoding] \ + [expr {[file size testdoc.html]-[string length $testdata]}] \ + [expr {[lindex $logdata 0] - [lindex $logdata 1]}] \ + [expr {[lindex $logdata 0] - [string length $testdata]}] +} -cleanup { + http::cleanup $tok + unset -nocomplain testdata logdata ::WaitHere + halt_httpd +} -result {ok {HTTP/1.0 200 OK} ok close {} {} 0 0 0} + +test http11-3.8 "close,identity no -handler but with -progress" -setup { + variable httpd [create_httpd] + set logdata "" +} -body { + set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1 \ + -timeout 10000 \ + -progress [namespace code [list progress logdata]] \ + -headers {accept-encoding {}}] + http::wait $tok + list [http::status $tok] [http::code $tok] [check_crc $tok]\ + [meta $tok connection] [meta $tok content-encoding] \ + [meta $tok transfer-encoding] \ + [expr {[file size testdoc.html]-[string length [http::data $tok]]}] \ + [expr {[lindex $logdata 0] - [lindex $logdata 1]}] \ + [expr {[lindex $logdata 0] - [string length [http::data $tok]]}] +} -cleanup { + http::cleanup $tok + unset -nocomplain logdata ::WaitHere + halt_httpd +} -result {ok {HTTP/1.1 200 OK} ok close {} {} 0 0 0} + +test http11-3.9 "close,identity no -handler but with -progress progressPause enters event loop" -setup { + variable httpd [create_httpd] + set logdata "" +} -body { + set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1 \ + -timeout 10000 \ + -progress [namespace code [list progressPause logdata]] \ + -headers {accept-encoding {}}] + http::wait $tok + list [http::status $tok] [http::code $tok] [check_crc $tok]\ + [meta $tok connection] [meta $tok content-encoding] \ + [meta $tok transfer-encoding] \ + [expr {[file size testdoc.html]-[string length [http::data $tok]]}] \ + [expr {[lindex $logdata 0] - [lindex $logdata 1]}] \ + [expr {[lindex $logdata 0] - [string length [http::data $tok]]}] +} -cleanup { + http::cleanup $tok + unset -nocomplain logdata ::WaitHere + halt_httpd +} -result {ok {HTTP/1.1 200 OK} ok close {} {} 0 0 0} + test http11-4.0 "normal post request" -setup { variable httpd [create_httpd] } -body { diff --git a/unix/Makefile.in b/unix/Makefile.in index 07ce3b7..87f0844 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -944,8 +944,8 @@ install-libraries: libraries do \ $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)/http1.0"; \ done; - @echo "Installing package http 2.9.4 as a Tcl Module"; - @$(INSTALL_DATA) $(TOP_DIR)/library/http/http.tcl "$(MODULE_INSTALL_DIR)/8.6/http-2.9.4.tm"; + @echo "Installing package http 2.9.5 as a Tcl Module"; + @$(INSTALL_DATA) $(TOP_DIR)/library/http/http.tcl "$(MODULE_INSTALL_DIR)/8.6/http-2.9.5.tm"; @echo "Installing package opt0.4 files to $(SCRIPT_INSTALL_DIR)/opt0.4/"; @for i in $(TOP_DIR)/library/opt/*.tcl ; \ do \ diff --git a/win/Makefile.in b/win/Makefile.in index 110f7bf..dee6656 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -719,8 +719,8 @@ install-libraries: libraries install-tzdata install-msgs do \ $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/http1.0"; \ done; - @echo "Installing package http 2.9.4 as a Tcl Module"; - @$(COPY) $(ROOT_DIR)/library/http/http.tcl "$(MODULE_INSTALL_DIR)/8.6/http-2.9.4.tm"; + @echo "Installing package http 2.9.5 as a Tcl Module"; + @$(COPY) $(ROOT_DIR)/library/http/http.tcl "$(MODULE_INSTALL_DIR)/8.6/http-2.9.5.tm"; @echo "Installing library opt0.4 directory"; @for j in $(ROOT_DIR)/library/opt/*.tcl; \ do \ -- cgit v0.12 From 171bea3624e84c0fe616ac8bef5d7e8138bdc359 Mon Sep 17 00:00:00 2001 From: kjnash Date: Mon, 24 Aug 2020 14:35:37 +0000 Subject: Try another Travis build --- tests/safe-stock86.test | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/tests/safe-stock86.test b/tests/safe-stock86.test index 2fbe108..ccfdd3f 100644 --- a/tests/safe-stock86.test +++ b/tests/safe-stock86.test @@ -2,8 +2,8 @@ # # This file contains tests for safe Tcl that were previously in the file # safe.test, and use files and packages of stock Tcl 8.6 to perform the tests. -# These files may be changed or disappear in future revisions of Tcl, for -# example package http 1.0 will be removed from Tcl 8.7. +# These files may be changed or disappear in future revisions of Tcl, +# for example package http 1.0 will be removed from Tcl 8.7. # # The tests are replaced in safe.tcl with tests that use files provided in the # tests directory. Test numbering is for comparison with similar tests in -- cgit v0.12 From 0d23451993cbdb14bcb0cef73c5db4a979a23648 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 25 Aug 2020 09:42:37 +0000 Subject: Keep gcc-5 and gcc-6 builds on "bionic", because "focal" doesn't have these --- .travis.yml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.travis.yml b/.travis.yml index dd86769..ad3f03a 100644 --- a/.travis.yml +++ b/.travis.yml @@ -75,7 +75,7 @@ jobs: - BUILD_DIR=unix - name: "Linux/GCC 6/Shared" os: linux - dist: focal + dist: bionic compiler: gcc-6 addons: apt: @@ -87,7 +87,7 @@ jobs: - BUILD_DIR=unix - name: "Linux/GCC 5/Shared" os: linux - dist: focal + dist: bionic compiler: gcc-5 addons: apt: -- cgit v0.12 From 43d2fdc86c454dc83a6fe24125d0fd1188cc1bfa Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 26 Aug 2020 14:52:42 +0000 Subject: Testcase chan-io-50.1 still fails sometimes on MacOSX. So put same measures in place as in io-50.1. See: [f586089a2b] --- tests/chanio.test | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/tests/chanio.test b/tests/chanio.test index 66f4a30..10f3624 100644 --- a/tests/chanio.test +++ b/tests/chanio.test @@ -6380,12 +6380,16 @@ test chan-io-50.1 {testing handler deletion} -setup { set f [open $path(test1) w] chan close $f set f [open $path(test1) r] + variable z not_called + set timer [after 50 lappend z timeout] + testservicemode 0 testchannelevent $f add readable [namespace code { variable z called testchannelevent $f delete 0 }] - variable z not_called - update + testservicemode 1 + vwait z + after cancel $timer set z } -cleanup { chan close $f -- cgit v0.12 From 3b1ca15e0739a1650dbc9c0de1429299326078ee Mon Sep 17 00:00:00 2001 From: kjnash Date: Thu, 27 Aug 2020 15:50:24 +0000 Subject: Provide error message if failed load does not. --- library/safe.tcl | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/library/safe.tcl b/library/safe.tcl index 1c46978..c0a5dc6 100644 --- a/library/safe.tcl +++ b/library/safe.tcl @@ -1068,6 +1068,13 @@ proc ::safe::AliasLoad {slave file args} { try { return [::interp invokehidden $slave load $file $package $target] } on error msg { + # Some packages return no error message. + set msg0 "Load of binary library for package $package failed" + if {$msg eq {}} { + set msg $msg0 + } else { + set msg "$msg0: $msg" + } Log $slave $msg return -code error $msg } -- cgit v0.12 From 953e3ea89962393c4b65866feb0f3d38f4bc8b14 Mon Sep 17 00:00:00 2001 From: kjnash Date: Fri, 28 Aug 2020 01:03:23 +0000 Subject: Update safe.test for new error message. --- library/safe.tcl | 2 +- tests/safe.test | 8 ++++---- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/library/safe.tcl b/library/safe.tcl index c0a5dc6..352b302 100644 --- a/library/safe.tcl +++ b/library/safe.tcl @@ -1069,7 +1069,7 @@ proc ::safe::AliasLoad {slave file args} { return [::interp invokehidden $slave load $file $package $target] } on error msg { # Some packages return no error message. - set msg0 "Load of binary library for package $package failed" + set msg0 "load of binary library for package $package failed" if {$msg eq {}} { set msg $msg0 } else { diff --git a/tests/safe.test b/tests/safe.test index bcb33d7..eba6057 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -1167,7 +1167,7 @@ test safe-10.1 {testing statics loading} -constraints TcltestPackage -setup { interp eval $i {load {} Safepkg1} } -returnCodes error -cleanup { safe::interpDelete $i -} -result {can't use package in a safe interpreter: no Safepkg1_SafeInit procedure} +} -result {load of binary library for package Safepkg1 failed: can't use package in a safe interpreter: no Safepkg1_SafeInit procedure} test safe-10.1.1 {testing statics loading} -constraints TcltestPackage -setup { set i [safe::interpCreate] } -body { @@ -1176,7 +1176,7 @@ test safe-10.1.1 {testing statics loading} -constraints TcltestPackage -setup { } -returnCodes ok -cleanup { unset -nocomplain m o safe::interpDelete $i -} -result {can't use package in a safe interpreter: no Safepkg1_SafeInit procedure +} -result {load of binary library for package Safepkg1 failed: can't use package in a safe interpreter: no Safepkg1_SafeInit procedure invoked from within "load {} Safepkg1" invoked from within @@ -1199,7 +1199,7 @@ test safe-10.4 {testing nested statics loading / -nestedloadok} -constraints Tcl interp eval $i {interp create x; load {} Safepkg1 x} } -returnCodes error -cleanup { safe::interpDelete $i -} -result {can't use package in a safe interpreter: no Safepkg1_SafeInit procedure} +} -result {load of binary library for package Safepkg1 failed: can't use package in a safe interpreter: no Safepkg1_SafeInit procedure} test safe-10.4.1 {testing nested statics loading / -nestedloadok} -constraints TcltestPackage -body { set i [safe::interpCreate -nestedloadok] catch {interp eval $i {interp create x; load {} Safepkg1 x}} m o @@ -1207,7 +1207,7 @@ test safe-10.4.1 {testing nested statics loading / -nestedloadok} -constraints T } -returnCodes ok -cleanup { unset -nocomplain m o safe::interpDelete $i -} -result {can't use package in a safe interpreter: no Safepkg1_SafeInit procedure +} -result {load of binary library for package Safepkg1 failed: can't use package in a safe interpreter: no Safepkg1_SafeInit procedure invoked from within "load {} Safepkg1 x" invoked from within -- cgit v0.12 From 4af0efa4cb10780f9c7d391eb66fe1c3367872d2 Mon Sep 17 00:00:00 2001 From: sebres Date: Fri, 28 Aug 2020 14:02:50 +0000 Subject: tests/regexp.test: added missing test that cover indices if running on string containing multi-byte utf-8 chars (de/ru, byte offsets != char offsets) --- tests/regexp.test | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/tests/regexp.test b/tests/regexp.test index 362f425..99113ce 100644 --- a/tests/regexp.test +++ b/tests/regexp.test @@ -156,6 +156,10 @@ test regexp-3.7 {getting substrings back from regexp} { set foo 1; set f2 1; set f3 1; set f4 1 list [regexp -indices (a)(b)?(c) xacy foo f2 f3 f4] $foo $f2 $f3 $f4 } {1 {1 2} {1 1} {-1 -1} {2 2}} +test regexp-3.8 {-indices by multi-byte utf-8} { + regexp -inline -indices {(\w+)-(\w+)} \ + "gr\u00FC\u00DF-\u043F\u0440\u0438\u0432\u0435\u0442" +} {{0 10} {0 3} {5 10}} test regexp-4.1 {-nocase option to regexp} { regexp -nocase foo abcFOo -- cgit v0.12 From be42098b827423520078e2cb5150275a3a8540e2 Mon Sep 17 00:00:00 2001 From: sebres Date: Fri, 28 Aug 2020 15:01:23 +0000 Subject: tests/regexp.test: more tests for -indices by multi-byte utf-8 (considering -start position now) --- tests/regexp.test | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/tests/regexp.test b/tests/regexp.test index 99113ce..d2bdf7b 100644 --- a/tests/regexp.test +++ b/tests/regexp.test @@ -156,10 +156,17 @@ test regexp-3.7 {getting substrings back from regexp} { set foo 1; set f2 1; set f3 1; set f4 1 list [regexp -indices (a)(b)?(c) xacy foo f2 f3 f4] $foo $f2 $f3 $f4 } {1 {1 2} {1 1} {-1 -1} {2 2}} -test regexp-3.8 {-indices by multi-byte utf-8} { +test regexp-3.8a {-indices by multi-byte utf-8} { regexp -inline -indices {(\w+)-(\w+)} \ "gr\u00FC\u00DF-\u043F\u0440\u0438\u0432\u0435\u0442" } {{0 10} {0 3} {5 10}} +test regexp-3.8b {-indices by multi-byte utf-8, from -start position} { + list\ + [regexp -inline -indices -start 3 {(\w+)-(\w+)} \ + "gr\u00FC\u00DF-\u043F\u0440\u0438\u0432\u0435\u0442"] \ + [regexp -inline -indices -start 4 {(\w+)-(\w+)} \ + "gr\u00FC\u00DF-\u043F\u0440\u0438\u0432\u0435\u0442"] +} {{{3 10} {3 3} {5 10}} {}} test regexp-4.1 {-nocase option to regexp} { regexp -nocase foo abcFOo -- cgit v0.12 From 6c69cf8504626ca091607ff500979c1f738cefb1 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 31 Aug 2020 13:12:01 +0000 Subject: opt package: Change comment. 0.4.7 -> 0.4.8. More Master -> Parent and Slave -> Child changes in (internal) library and test-cases --- library/auto.tcl | 2 +- library/clock.tcl | 4 ++-- library/opt/optparse.tcl | 6 +++--- library/opt/pkgIndex.tcl | 2 +- library/package.tcl | 2 +- library/safe.tcl | 14 ++++++------- tests/interp.test | 52 +++++++++++++++++++++++------------------------ tests/opt.test | 2 +- tests/safe-stock86.test | 4 ++-- tests/safe.test | 30 +++++++++++++-------------- tools/checkLibraryDoc.tcl | 1 + tools/tcltk-man2html.tcl | 1 + 12 files changed, 61 insertions(+), 59 deletions(-) diff --git a/library/auto.tcl b/library/auto.tcl index a7a8979..27173df 100644 --- a/library/auto.tcl +++ b/library/auto.tcl @@ -377,7 +377,7 @@ proc auto_mkindex_parser::mkindex {file} { # auto_mkindex_parser::hook command # # Registers a Tcl command to evaluate when initializing the slave interpreter -# used by the mkindex parser. The command is evaluated in the master +# used by the mkindex parser. The command is evaluated in the parent # interpreter, and can use the variable auto_mkindex_parser::parser to get to # the slave diff --git a/library/clock.tcl b/library/clock.tcl index 49dfdbe..2e42a98 100644 --- a/library/clock.tcl +++ b/library/clock.tcl @@ -3304,7 +3304,7 @@ proc ::tcl::clock::LoadTimeZoneFile { fileName } { return } - # Since an unsafe interp uses the [clock] command in the master, this code + # Since an unsafe interp uses the [clock] command in the parent, this code # is security sensitive. Make sure that the path name cannot escape the # given directory. @@ -3344,7 +3344,7 @@ proc ::tcl::clock::LoadTimeZoneFile { fileName } { proc ::tcl::clock::LoadZoneinfoFile { fileName } { variable ZoneinfoPaths - # Since an unsafe interp uses the [clock] command in the master, this code + # Since an unsafe interp uses the [clock] command in the parent, this code # is security sensitive. Make sure that the path name cannot escape the # given directory. diff --git a/library/opt/optparse.tcl b/library/opt/optparse.tcl index c8946fd..1639379 100644 --- a/library/opt/optparse.tcl +++ b/library/opt/optparse.tcl @@ -11,7 +11,7 @@ package require Tcl 8.5- # When this version number changes, update the pkgIndex.tcl file # and the install directory in the Makefiles. -package provide opt 0.4.7 +package provide opt 0.4.8 namespace eval ::tcl { @@ -44,8 +44,8 @@ namespace eval ::tcl { {-intflag 7} {-weirdflag "help string"} {-noStatics "Not ok to load static packages"} - {-nestedloading1 true "OK to load into nested slaves"} - {-nestedloading2 -boolean true "OK to load into nested slaves"} + {-nestedloading1 true "OK to load into nested children"} + {-nestedloading2 -boolean true "OK to load into nested children"} {-libsOK -choice {Tk SybTcl} "List of packages that can be loaded"} {-precision -int 12 "Number of digits of precision"} diff --git a/library/opt/pkgIndex.tcl b/library/opt/pkgIndex.tcl index daf9aa9..23e118c 100644 --- a/library/opt/pkgIndex.tcl +++ b/library/opt/pkgIndex.tcl @@ -9,4 +9,4 @@ # full path name of this file's directory. if {![package vsatisfies [package provide Tcl] 8.5-]} {return} -package ifneeded opt 0.4.7 [list source [file join $dir optparse.tcl]] +package ifneeded opt 0.4.8 [list source [file join $dir optparse.tcl]] diff --git a/library/package.tcl b/library/package.tcl index d6280ae..4a73346 100644 --- a/library/package.tcl +++ b/library/package.tcl @@ -237,7 +237,7 @@ proc pkg_mkIndex {args} { $c eval [list set ::tcl::file $file] $c eval [list set ::tcl::direct $direct] - # Download needed procedures into the slave because we've just deleted + # Download needed procedures into the child because we've just deleted # the unknown procedure. This doesn't handle procedures with default # arguments. diff --git a/library/safe.tcl b/library/safe.tcl index 352b302..96177d5 100644 --- a/library/safe.tcl +++ b/library/safe.tcl @@ -2,7 +2,7 @@ # # This file provide a safe loading/sourcing mechanism for safe interpreters. # It implements a virtual path mecanism to hide the real pathnames from the -# slave. It runs in a master interpreter and sets up data structure and +# slave. It runs in a parent interpreter and sets up data structure and # aliases that will be invoked when used from a slave interpreter. # # See the safe.n man page for details. @@ -20,7 +20,7 @@ # # Needed utilities package -package require opt 0.4.7 +package require opt 0.4.8 # Create the safe namespace namespace eval ::safe { @@ -270,7 +270,7 @@ proc ::safe::interpConfigure {args} { # Optional Arguments : # + slave name : if empty, generated name will be used # + access_path: path list controlling where load/source can occur, -# if empty: the master auto_path will be used. +# if empty: the parent auto_path will be used. # + staticsok : flag, if 0 :no static package can be loaded (load {} Xxx) # if 1 :static packages are ok. # + nestedok: flag, if 0 :no loading to sub-sub interps (load xx xx sub) @@ -302,7 +302,7 @@ proc ::safe::InterpCreate { # # InterpSetConfig (was setAccessPath) : # Sets up slave virtual auto_path and corresponding structure within -# the master. Also sets the tcl_library in the slave to be the first +# the parent. Also sets the tcl_library in the slave to be the first # directory in the path. # NB: If you change the path after the slave has been initialized you # probably need to call "auto_reset" in the slave in order that it gets @@ -595,7 +595,7 @@ proc ::safe::interpDelete {slave} { # Base. To clean up properly, we call safe::interpDelete recursively on each # Safe Base sub-interpreter, so each one is deleted cleanly and not by # the automatic mechanism built into [interp delete]. - foreach sub [interp slaves $slave] { + foreach sub [interp children $slave] { if {[info exists ::safe::[VarName [list $slave $sub]]]} { ::safe::interpDelete [list $slave $sub] } @@ -667,7 +667,7 @@ proc ::safe::setLogCmd {args} { # ------------------- END OF PUBLIC METHODS ------------ # -# Sets the slave auto_path to the master recorded value. Also sets +# Sets the slave auto_path to the parent recorded value. Also sets # tcl_library to the first token of the virtual path. # proc ::safe::SyncAccessPath {slave} { @@ -1081,7 +1081,7 @@ proc ::safe::AliasLoad {slave file args} { } # FileInAccessPath raises an error if the file is not found in the list of -# directories contained in the (master side recorded) slave's access path. +# directories contained in the (parent side recorded) slave's access path. # the security here relies on "file dirname" answering the proper # result... needs checking ? diff --git a/tests/interp.test b/tests/interp.test index df94678..3fe8c67 100644 --- a/tests/interp.test +++ b/tests/interp.test @@ -22,7 +22,7 @@ testConstraint testinterpdelete [llength [info commands testinterpdelete]] set hidden_cmds {cd encoding exec exit fconfigure file glob load open pwd socket source tcl:encoding:dirs tcl:file:atime tcl:file:attributes tcl:file:copy tcl:file:delete tcl:file:dirname tcl:file:executable tcl:file:exists tcl:file:extension tcl:file:isdirectory tcl:file:isfile tcl:file:link tcl:file:lstat tcl:file:mkdir tcl:file:mtime tcl:file:nativename tcl:file:normalize tcl:file:owned tcl:file:readable tcl:file:readlink tcl:file:rename tcl:file:rootname tcl:file:size tcl:file:stat tcl:file:tail tcl:file:tempfile tcl:file:type tcl:file:volumes tcl:file:writable unload} -foreach i [interp slaves] { +foreach i [interp children] { interp delete $i } @@ -46,8 +46,8 @@ test interp-1.5 {options for interp command} -returnCodes error -body { # test interp-0.6 was removed # test interp-1.6 {options for interp command} -returnCodes error -body { - interp slaves foo bar zop -} -result {wrong # args: should be "interp slaves ?path?"} + interp children foo bar zop +} -result {wrong # args: should be "interp children ?path?"} test interp-1.7 {options for interp command} -returnCodes error -body { interp hello } -result {bad option "hello": must be alias, aliases, bgerror, cancel, children, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer} @@ -120,45 +120,45 @@ test interp-2.13 {correct default when no $path arg is given} -body { interp create -- } -match regexp -result {interp[0-9]+} -foreach i [interp slaves] { +foreach i [interp children] { interp delete $i } -# Part 2: Testing "interp slaves" and "interp exists" -test interp-3.1 {testing interp exists and interp slaves} { - interp slaves +# Part 2: Testing "interp children" and "interp exists" +test interp-3.1 {testing interp exists and interp children} { + interp children } "" -test interp-3.2 {testing interp exists and interp slaves} { +test interp-3.2 {testing interp exists and interp children} { interp create a interp exists a } 1 -test interp-3.3 {testing interp exists and interp slaves} { +test interp-3.3 {testing interp exists and interp children} { interp exists nonexistent } 0 -test interp-3.4 {testing interp exists and interp slaves} -body { - interp slaves a b c -} -returnCodes error -result {wrong # args: should be "interp slaves ?path?"} -test interp-3.5 {testing interp exists and interp slaves} -body { +test interp-3.4 {testing interp exists and interp children} -body { + interp children a b c +} -returnCodes error -result {wrong # args: should be "interp children ?path?"} +test interp-3.5 {testing interp exists and interp children} -body { interp exists a b c } -returnCodes error -result {wrong # args: should be "interp exists ?path?"} -test interp-3.6 {testing interp exists and interp slaves} { +test interp-3.6 {testing interp exists and interp children} { interp exists } 1 -test interp-3.7 {testing interp exists and interp slaves} -setup { +test interp-3.7 {testing interp exists and interp children} -setup { catch {interp create a} } -body { - interp slaves + interp children } -result a -test interp-3.8 {testing interp exists and interp slaves} -body { - interp slaves a b c -} -returnCodes error -result {wrong # args: should be "interp slaves ?path?"} -test interp-3.9 {testing interp exists and interp slaves} -setup { +test interp-3.8 {testing interp exists and interp children} -body { + interp children a b c +} -returnCodes error -result {wrong # args: should be "interp children ?path?"} +test interp-3.9 {testing interp exists and interp children} -setup { catch {interp create a} } -body { interp create {a a2} -safe - expr {"a2" in [interp slaves a]} + expr {"a2" in [interp children a]} } -result 1 -test interp-3.10 {testing interp exists and interp slaves} -setup { +test interp-3.10 {testing interp exists and interp children} -setup { catch {interp create a} catch {interp create {a a2}} } -body { @@ -186,7 +186,7 @@ test interp-4.5 {testing interp delete} { interp create a interp create {a x1} interp delete {a x1} - expr {"x1" in [interp slaves a]} + expr {"x1" in [interp children a]} } 0 test interp-4.6 {testing interp delete} { interp create c1 @@ -203,14 +203,14 @@ test interp-4.8 {testing interp delete} -returnCodes error -body { interp delete {} } -result {cannot delete the current interpreter} -foreach i [interp slaves] { +foreach i [interp children] { interp delete $i } # Part 4: Consistency checking - all nondeleted interpreters should be # there: test interp-5.1 {testing consistency} { - interp slaves + interp children } "" test interp-5.2 {testing consistency} { interp exists a @@ -3667,7 +3667,7 @@ test interp-38.8 {interp debug basic setup} -body { # cleanup unset -nocomplain hidden_cmds -foreach i [interp slaves] { +foreach i [interp children] { interp delete $i } ::tcltest::cleanupTests diff --git a/tests/opt.test b/tests/opt.test index 14a6e04..7ed25b5 100644 --- a/tests/opt.test +++ b/tests/opt.test @@ -17,7 +17,7 @@ if {[lsearch [namespace children] ::tcltest] == -1} { } # the package we are going to test -package require opt 0.4.7 +package require opt 0.4.8 # we are using implementation specifics to test the package diff --git a/tests/safe-stock86.test b/tests/safe-stock86.test index ccfdd3f..3f20d77 100644 --- a/tests/safe-stock86.test +++ b/tests/safe-stock86.test @@ -25,7 +25,7 @@ if {[lsearch [namespace children] ::tcltest] == -1} { namespace import -force ::tcltest::* } -foreach i [interp slaves] { +foreach i [interp children] { interp delete $i } @@ -56,7 +56,7 @@ test safe-stock86-7.1 {tests that everything works at high level, uses http 2} - set i [safe::interpCreate] # no error shall occur: # (because the default access_path shall include 1st level sub dirs so - # package require in a slave works like in the master) + # package require in a slave works like in the parent) set v [interp eval $i {package require http 2}] # no error shall occur: interp eval $i {http::config} diff --git a/tests/safe.test b/tests/safe.test index eba6057..217200c 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -28,7 +28,7 @@ if {[lsearch [namespace children] ::tcltest] == -1} { namespace import -force ::tcltest::* } -foreach i [interp slaves] { +foreach i [interp children] { interp delete $i } @@ -176,7 +176,7 @@ test safe-4.6 {safe::interpDelete, indirectly} -setup { # A replacement test using example files is "safe-9.8". # Tests 5.* test the example files before using them to test safe interpreters. -test safe-5.1 {example tclIndex commands, test in master interpreter} -setup { +test safe-5.1 {example tclIndex commands, test in parent interpreter} -setup { set tmpAutoPath $::auto_path lappend ::auto_path [file join $TestsDir auto0 auto1] [file join $TestsDir auto0 auto2] } -body { @@ -190,7 +190,7 @@ test safe-5.1 {example tclIndex commands, test in master interpreter} -setup { set ::auto_path $tmpAutoPath auto_reset } -match glob -result {0 ok1 0 ok2} -test safe-5.2 {example tclIndex commands, negative test in master interpreter} -setup { +test safe-5.2 {example tclIndex commands, negative test in parent interpreter} -setup { set tmpAutoPath $::auto_path lappend ::auto_path [file join $TestsDir auto0] } -body { @@ -204,7 +204,7 @@ test safe-5.2 {example tclIndex commands, negative test in master interpreter} - set ::auto_path $tmpAutoPath auto_reset } -match glob -result {1 {invalid command name "report1"} 1 {invalid command name "report2"}} -test safe-5.3 {example pkgIndex.tcl packages, test in master interpreter, child directories} -setup { +test safe-5.3 {example pkgIndex.tcl packages, test in parent interpreter, child directories} -setup { set tmpAutoPath $::auto_path lappend ::auto_path [file join $TestsDir auto0] } -body { @@ -221,7 +221,7 @@ test safe-5.3 {example pkgIndex.tcl packages, test in master interpreter, child catch {rename HeresPackage1 {}} catch {rename HeresPackage2 {}} } -match glob -result {0 1.2.3 0 2.3.4 0 OK1 0 OK2} -test safe-5.4 {example pkgIndex.tcl packages, test in master interpreter, main directories} -setup { +test safe-5.4 {example pkgIndex.tcl packages, test in parent interpreter, main directories} -setup { set tmpAutoPath $::auto_path lappend ::auto_path [file join $TestsDir auto0 auto1] \ [file join $TestsDir auto0 auto2] @@ -239,7 +239,7 @@ test safe-5.4 {example pkgIndex.tcl packages, test in master interpreter, main d catch {rename HeresPackage1 {}} catch {rename HeresPackage2 {}} } -match glob -result {0 1.2.3 0 2.3.4 0 OK1 0 OK2} -test safe-5.5 {example modules packages, test in master interpreter, replace path} -setup { +test safe-5.5 {example modules packages, test in parent interpreter, replace path} -setup { set oldTm [tcl::tm::path list] foreach path $oldTm { tcl::tm::path remove $path @@ -265,7 +265,7 @@ test safe-5.5 {example modules packages, test in master interpreter, replace pat catch {namespace delete ::test0} catch {namespace delete ::mod1} } -match glob -result {0 0.5 0 1.0 0 2.0 -- res0 res1 res2} -test safe-5.6 {example modules packages, test in master interpreter, append to path} -setup { +test safe-5.6 {example modules packages, test in parent interpreter, append to path} -setup { tcl::tm::path add [file join $TestsDir auto0 modules] } -body { # Try to load the modules and run a command from each one. @@ -325,7 +325,7 @@ test safe-7.1 {tests that everything works at high level} -setup { } -body { # no error shall occur: # (because the default access_path shall include 1st level sub dirs so - # package require in a slave works like in the master) + # package require in a child works like in the parent) set v [interp eval $i {package require SafeTestPackage1}] # no error shall occur: interp eval $i {HeresPackage1} @@ -338,9 +338,9 @@ test safe-7.2 {tests specific path and interpFind/AddToAccessPath} -setup { set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]] # should not add anything (p0) set token1 [safe::interpAddToAccessPath $i [info library]] - # should add as p* (not p1 if master has a module path) + # should add as p* (not p1 if parent has a module path) set token2 [safe::interpAddToAccessPath $i "/dummy/unixlike/test/path"] - # should add as p* (not p2 if master has a module path) + # should add as p* (not p2 if parent has a module path) set token3 [safe::interpAddToAccessPath $i [file join $TestsDir auto0]] set confA [safe::interpConfigure $i] set mappA [mapList $PathMapp [dict get $confA -accessPath]] @@ -354,7 +354,7 @@ test safe-7.2 {tests specific path and interpFind/AddToAccessPath} -setup { 1 {can't find package SafeTestPackage1} --\ {TCLLIB */dummy/unixlike/test/path TESTSDIR/auto0} -- {}} test safe-7.3 {check that safe subinterpreters work} { - set g [interp slaves] + set g [interp children] if {$g ne {}} { append g { -- residue of an earlier test} } @@ -369,7 +369,7 @@ test safe-7.3 {check that safe subinterpreters work} { } {{} {} ok {} 0 {}} test safe-7.3.1 {check that safe subinterpreters work with namespace names} -setup { } -body { - set g [interp slaves] + set g [interp children] if {$g ne {}} { append g { -- residue of an earlier test} } @@ -389,7 +389,7 @@ test safe-7.4 {tests specific path and positive search} -setup { set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]] # should not add anything (p0) set token1 [safe::interpAddToAccessPath $i [info library]] - # should add as p* (not p1 if master has a module path) + # should add as p* (not p1 if parent has a module path) set token2 [safe::interpAddToAccessPath $i [file join $TestsDir auto0 auto1]] set confA [safe::interpConfigure $i] set mappA [mapList $PathMapp [dict get $confA -accessPath]] @@ -902,7 +902,7 @@ test safe-9.20 {check module loading} -setup { 0 0.5 0 1.0 0 2.0 --\ {TCLLIB TESTSDIR/auto0/modules TESTSDIR/auto0/modules/mod1\ TESTSDIR/auto0/modules/mod2} -- res0 res1 res2} -# - The command safe::InterpSetConfig adds the master's [tcl::tm::list] in +# - The command safe::InterpSetConfig adds the parent's [tcl::tm::list] in # tokenized form to the slave's access path, and then adds all the # descendants, discovered recursively by using glob. # - The order of the directories in the list returned by glob is system-dependent, @@ -1514,7 +1514,7 @@ rename buildEnvironment {} rename buildEnvironment2 {} #### Test for the module path -test safe-14.1 {Check that module path is the same as in the master interpreter [Bug 2964715]} -setup { +test safe-14.1 {Check that module path is the same as in the parent interpreter [Bug 2964715]} -setup { set i [safe::interpCreate] } -body { set tm {} diff --git a/tools/checkLibraryDoc.tcl b/tools/checkLibraryDoc.tcl index 6d147ac..d560b98 100755 --- a/tools/checkLibraryDoc.tcl +++ b/tools/checkLibraryDoc.tcl @@ -69,6 +69,7 @@ set StructList { Tk_GeomMgr \ Tk_Image \ Tk_ImageMaster \ + Tk_ImageModel \ Tk_ImageType \ Tk_Item \ Tk_ItemType \ diff --git a/tools/tcltk-man2html.tcl b/tools/tcltk-man2html.tcl index d607905..a7231f7 100755 --- a/tools/tcltk-man2html.tcl +++ b/tools/tcltk-man2html.tcl @@ -557,6 +557,7 @@ array set remap_link_target { Tk_Font Tk_GetFont Tk_Image Tk_GetImage Tk_ImageMaster Tk_GetImage + Tk_ImageModel Tk_GetImage Tk_ItemType Tk_CreateItemType Tk_Justify Tk_GetJustify Ttk_Theme Ttk_GetTheme -- cgit v0.12 From 6b0b7154f13dc5d47830ef1daaea80c791504f8a Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 1 Sep 2020 09:11:28 +0000 Subject: Eliminate eol-spacing --- tools/encoding/Makefile | 12 ++++++------ tools/encoding/big5.txt | 14 +++++++------- tools/encoding/jis0212.txt | 4 ++-- tools/encoding/ksc5601.txt | 6 +++--- tools/encoding/macCentEuro.txt | 2 +- tools/encoding/macCroatian.txt | 2 +- tools/encoding/macCyrillic.txt | 2 +- tools/encoding/macGreek.txt | 2 +- tools/encoding/macIceland.txt | 2 +- tools/encoding/macRoman.txt | 2 +- tools/encoding/macTurkish.txt | 2 +- tools/encoding/shiftjis.txt | 2 +- tools/encoding/tis-620.txt | 2 +- 13 files changed, 27 insertions(+), 27 deletions(-) diff --git a/tools/encoding/Makefile b/tools/encoding/Makefile index 4c10673..361239e 100644 --- a/tools/encoding/Makefile +++ b/tools/encoding/Makefile @@ -1,5 +1,5 @@ # -# This file is a Makefile to compile all the encoding files. +# This file is a Makefile to compile all the encoding files. # # Run "make" to compile all the encoding files (*.txt,*.esc) into the # format that Tcl can use (*.enc). It is your responsibility to move the @@ -26,16 +26,16 @@ # specifically excludes the right to re-distribute this file directly # to third parties or other organizations whether for profit or not. # -# In other words: Don't put this file on the Internet. People who want to +# In other words: Don't put this file on the Internet. People who want to # get it over the Internet should do so directly from ftp://unicode.org. They # can therefore be assured of getting the most recent and accurate version. # #---------------------------------------------------------------------------- # # The txt2enc program built by this makefile is used to compile individual -# .txt files into .enc files, the format that Tcl understands for encoding +# .txt files into .enc files, the format that Tcl understands for encoding # files. This compilation to a different format is allowed by the above -# restriction. +# restriction. # # The files shiftjis.txt and jis0208.txt were modified from the original # ones provided on the Unicode CD. The double-width backslash character @@ -53,7 +53,7 @@ # SCCS: @(#) Makefile 1.1 98/01/28 11:41:36 # -EUC_ENCODINGS = euc-cn.txt euc-kr.txt euc-jp.txt +EUC_ENCODINGS = euc-cn.txt euc-kr.txt euc-jp.txt encodings: clean txt2enc $(EUC_ENCODINGS) @echo Compiling encoding files. @@ -69,7 +69,7 @@ encodings: clean txt2enc $(EUC_ENCODINGS) echo $$enc; \ ./txt2enc -e 0 -u 1 $$p > $$enc; \ done - @echo + @echo @echo Compiling special versions of encoding files. @for p in ascii.txt; do \ enc=`echo $$p | sed 's/\..*$$/\.enc/'`; \ diff --git a/tools/encoding/big5.txt b/tools/encoding/big5.txt index 5cc9e81..f21484a 100644 --- a/tools/encoding/big5.txt +++ b/tools/encoding/big5.txt @@ -41,7 +41,7 @@ # BIG5 characters map into Unicode. # # WARNING! It is currently impossible to provide round-trip compatibility -# between BIG5 and Unicode. +# between BIG5 and Unicode. # # A number of characters are not currently mapped because # of conflicts with other mappings. They are as follows: @@ -58,8 +58,8 @@ # # We currently map all of these characters to U+FFFD REPLACEMENT CHARACTER. # It is also possible to map these characters to their duplicates, or to -# the user zone. -# +# the user zone. +# # Notes: # # 1. In addition to the above, there is some uncertainty about the @@ -72,13 +72,13 @@ # 0xA3BC. This character occurs within the Big Five block of tone marks # for bopomofo and is intended to be the tone mark for the first tone in # Mandarin Chinese. We have selected the mapping U+02C9 MODIFIER LETTER -# MACRON (Mandarin Chinese first tone) to reflect this semantic. +# MACRON (Mandarin Chinese first tone) to reflect this semantic. # However, because bopomofo uses the absense of a tone mark to indicate # the first Mandarin tone, most implementations of Big Five represent # this character with a blank space, and so a mapping such as U+2003 EM SPACE -# might be preferred. -# -# +# might be preferred. +# +# # # Format: Three tab-separated columns # Column #1 is the BIG5 code (in hex as 0xXXXX) diff --git a/tools/encoding/jis0212.txt b/tools/encoding/jis0212.txt index b6d4cb2..316d28e 100644 --- a/tools/encoding/jis0212.txt +++ b/tools/encoding/jis0212.txt @@ -61,7 +61,7 @@ # # 1. JIS X 0212 apparently unified the following two symbols # into a single character at 0x2922: -# +# # LATIN CAPITAL LETTER D WITH STROKE # LATIN CAPITAL LETTER ETH # @@ -71,7 +71,7 @@ # 0x2922 and 0x2942 are intended to be a capital/small pair. # Consequently, in the Unicode mapping, 0x2922 is treated as # LATIN CAPITAL LETTER D WITH STROKE. -# +# 0x222F 0x02D8 # BREVE 0x2230 0x02C7 # CARON (Mandarin Chinese third tone) 0x2231 0x00B8 # CEDILLA diff --git a/tools/encoding/ksc5601.txt b/tools/encoding/ksc5601.txt index 5c6e7dc..c5a6dd1 100644 --- a/tools/encoding/ksc5601.txt +++ b/tools/encoding/ksc5601.txt @@ -5,7 +5,7 @@ # BUT the mapping table between UHC(Microsoft Unified Hangul Code) # and Unicode 2.0. Hence, in this pacakge, I renamed it as UHC.TXT # -# The Unix command used is +# The Unix command used is # egrep '^0x' < KSC5601.TXT | \ # egrep -v '^0x([8-9]...|A0..|..[4-9].|..A0)' | perl tab.pl # @@ -26,8 +26,8 @@ # Column #3 : the Unicode name (following a comment sign, '#') # The number of characters enumerated in this table is 8824, the # as listed in KS C 5601-987 -# -# +# +# # The entries are in KS C 5601-1987 order # You can use the following algorithms to convert the hex form # of KS C 5601 to other forms diff --git a/tools/encoding/macCentEuro.txt b/tools/encoding/macCentEuro.txt index e6507d6..bf424c1 100644 --- a/tools/encoding/macCentEuro.txt +++ b/tools/encoding/macCentEuro.txt @@ -34,7 +34,7 @@ # Apple makes no warranty or representation, either express or # implied, with respect to these tables, their quality, accuracy, or # fitness for a particular purpose. In no event will Apple be liable -# for direct, indirect, special, incidental, or consequential damages +# for direct, indirect, special, incidental, or consequential damages # resulting from any defect or inaccuracy in this document or the # accompanying tables. # diff --git a/tools/encoding/macCroatian.txt b/tools/encoding/macCroatian.txt index 2d66b6d..538eda3 100644 --- a/tools/encoding/macCroatian.txt +++ b/tools/encoding/macCroatian.txt @@ -36,7 +36,7 @@ # Apple makes no warranty or representation, either express or # implied, with respect to these tables, their quality, accuracy, or # fitness for a particular purpose. In no event will Apple be liable -# for direct, indirect, special, incidental, or consequential damages +# for direct, indirect, special, incidental, or consequential damages # resulting from any defect or inaccuracy in this document or the # accompanying tables. # diff --git a/tools/encoding/macCyrillic.txt b/tools/encoding/macCyrillic.txt index b58bb83..695dade 100644 --- a/tools/encoding/macCyrillic.txt +++ b/tools/encoding/macCyrillic.txt @@ -37,7 +37,7 @@ # Apple makes no warranty or representation, either express or # implied, with respect to these tables, their quality, accuracy, or # fitness for a particular purpose. In no event will Apple be liable -# for direct, indirect, special, incidental, or consequential damages +# for direct, indirect, special, incidental, or consequential damages # resulting from any defect or inaccuracy in this document or the # accompanying tables. # diff --git a/tools/encoding/macGreek.txt b/tools/encoding/macGreek.txt index 28b6ea8..9783259 100644 --- a/tools/encoding/macGreek.txt +++ b/tools/encoding/macGreek.txt @@ -35,7 +35,7 @@ # Apple makes no warranty or representation, either express or # implied, with respect to these tables, their quality, accuracy, or # fitness for a particular purpose. In no event will Apple be liable -# for direct, indirect, special, incidental, or consequential damages +# for direct, indirect, special, incidental, or consequential damages # resulting from any defect or inaccuracy in this document or the # accompanying tables. # diff --git a/tools/encoding/macIceland.txt b/tools/encoding/macIceland.txt index d28bd9d..0a0b27b 100644 --- a/tools/encoding/macIceland.txt +++ b/tools/encoding/macIceland.txt @@ -37,7 +37,7 @@ # Apple makes no warranty or representation, either express or # implied, with respect to these tables, their quality, accuracy, or # fitness for a particular purpose. In no event will Apple be liable -# for direct, indirect, special, incidental, or consequential damages +# for direct, indirect, special, incidental, or consequential damages # resulting from any defect or inaccuracy in this document or the # accompanying tables. # diff --git a/tools/encoding/macRoman.txt b/tools/encoding/macRoman.txt index 8821f3b..7ddcf8d 100644 --- a/tools/encoding/macRoman.txt +++ b/tools/encoding/macRoman.txt @@ -41,7 +41,7 @@ # Apple makes no warranty or representation, either express or # implied, with respect to these tables, their quality, accuracy, or # fitness for a particular purpose. In no event will Apple be liable -# for direct, indirect, special, incidental, or consequential damages +# for direct, indirect, special, incidental, or consequential damages # resulting from any defect or inaccuracy in this document or the # accompanying tables. # diff --git a/tools/encoding/macTurkish.txt b/tools/encoding/macTurkish.txt index 7b143e0..4a1ddab 100644 --- a/tools/encoding/macTurkish.txt +++ b/tools/encoding/macTurkish.txt @@ -34,7 +34,7 @@ # Apple makes no warranty or representation, either express or # implied, with respect to these tables, their quality, accuracy, or # fitness for a particular purpose. In no event will Apple be liable -# for direct, indirect, special, incidental, or consequential damages +# for direct, indirect, special, incidental, or consequential damages # resulting from any defect or inaccuracy in this document or the # accompanying tables. # diff --git a/tools/encoding/shiftjis.txt b/tools/encoding/shiftjis.txt index 7db99ab..b616f85 100644 --- a/tools/encoding/shiftjis.txt +++ b/tools/encoding/shiftjis.txt @@ -47,7 +47,7 @@ # There is an alternative order some people might be preferred, # where all the entries are in order of the top (or only) byte. # This alternate order can be generated from the one given here -# by a simple sort. +# by a simple sort. # # The kanji mappings are a normative part of ISO/IEC 10646. The # non-kanji mappings are provisional, pending definition of diff --git a/tools/encoding/tis-620.txt b/tools/encoding/tis-620.txt index d3656c5..8243d81 100644 --- a/tools/encoding/tis-620.txt +++ b/tools/encoding/tis-620.txt @@ -176,7 +176,7 @@ 0xA8 0x0E08 #THAI CHARACTER CHO CHAN 0xA9 0x0E09 #THAI CHARACTER CHO CHING 0xAA 0x0E0A #THAI CHARACTER CHO CHANG -0xAB 0x0E0B #THAI CHARACTER SO SO +0xAB 0x0E0B #THAI CHARACTER SO SO 0xAC 0x0E0C #THAI CHARACTER CHO CHOE 0xAD 0x0E0D #THAI CHARACTER YO YING 0xAE 0x0E0E #THAI CHARACTER DO CHADA -- cgit v0.12 From 724de352e37dd0fe795024353378cd662593b4a6 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 1 Sep 2020 09:15:11 +0000 Subject: Many more internal master/slave -> parent/child renamings --- generic/regexec.c | 2 +- generic/tclBasic.c | 6 +- generic/tclClock.c | 2 +- generic/tclInterp.c | 1076 +++++++++++++++++++++++----------------------- generic/tclLoad.c | 8 +- generic/tclOO.c | 2 +- generic/tclOOInfo.c | 2 +- generic/tclOOInt.h | 4 +- generic/tclParse.c | 2 +- generic/tclTest.c | 16 +- library/auto.tcl | 12 +- tests/appendComp.test | 6 +- tests/autoMkindex.test | 18 +- tests/basic.test | 28 +- tests/cmdAH.test | 2 +- tests/compExpr.test | 6 +- tests/coroutine.test | 24 +- tests/env.test | 4 +- tests/execute.test | 104 ++--- tests/http.test | 2 +- tests/httpold.test | 2 +- tests/interp.test | 494 ++++++++++----------- tests/io.test | 6 +- tests/ioCmd.test | 4 +- tests/ioTrans.test | 6 +- tests/load.test | 2 +- tests/namespace.test | 92 ++-- tests/oo.test | 32 +- tests/parse.test | 20 +- tests/pkgMkIndex.test | 24 +- tests/proc.test | 12 +- tests/resolver.test | 2 +- tests/safe-stock86.test | 2 +- tests/subst.test | 16 +- tests/tcltest.test | 136 +++--- tests/thread.test | 4 +- tests/timer.test | 12 +- tests/trace.test | 10 +- tests/var.test | 18 +- tools/tcltk-man2html.tcl | 1 + unix/Makefile.in | 6 +- win/rules.vc | 6 +- 42 files changed, 1117 insertions(+), 1116 deletions(-) diff --git a/generic/regexec.c b/generic/regexec.c index f174420..d0d5680 100644 --- a/generic/regexec.c +++ b/generic/regexec.c @@ -73,7 +73,7 @@ struct dfa { chr *lastnopr; /* location of last cache-flushed NOPROGRESS */ struct sset *search; /* replacement-search-pointer memory */ int cptsmalloced; /* were the areas individually malloced? */ - char *mallocarea; /* self, or master malloced area, or NULL */ + char *mallocarea; /* self, or malloced area, or NULL */ }; #define WORK 1 /* number of work bitvectors needed */ diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 124702c..8b3a1b2 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -3444,7 +3444,7 @@ CancelEvalProc( TclSetCancelFlags(iPtr, cancelInfo->flags | CANCELED); /* - * Now, we must set the script cancellation flags on all the slave + * Now, we must set the script cancellation flags on all the child * interpreters belonging to this one. */ @@ -3967,7 +3967,7 @@ TclResetCancellation( * Tcl_Canceled -- * * Check if the script in progress has been canceled, i.e., - * Tcl_CancelEval was called for this interpreter or any of its master + * Tcl_CancelEval was called for this interpreter or any of its parent * interpreters. * * Results: @@ -5047,7 +5047,7 @@ TclEvalEx( * the embedded command, which is refered to * by 'script'. The 'clNextOuter' refers to * the current entry in the table of - * continuation lines in this "master script", + * continuation lines in this "main script", * and the character offsets are relative to * the 'outerScript' as well. * diff --git a/generic/tclClock.c b/generic/tclClock.c index 01058f5..f02e219 100644 --- a/generic/tclClock.c +++ b/generic/tclClock.c @@ -263,7 +263,7 @@ TclClockInit( }; /* - * Safe interps get [::clock] as alias to a master, so do not need their + * Safe interps get [::clock] as alias to a parent, so do not need their * own copies of the support routines. */ diff --git a/generic/tclInterp.c b/generic/tclInterp.c index a222cae..80c2534 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -27,34 +27,34 @@ struct Target; /* * struct Alias: * - * Stores information about an alias. Is stored in the slave interpreter and - * used by the source command to find the target command in the master when + * Stores information about an alias. Is stored in the child interpreter and + * used by the source command to find the target command in the parent when * the source command is invoked. */ typedef struct Alias { - Tcl_Obj *token; /* Token for the alias command in the slave + Tcl_Obj *token; /* Token for the alias command in the child * interp. This used to be the command name in - * the slave when the alias was first + * the child when the alias was first * created. */ Tcl_Interp *targetInterp; /* Interp in which target command will be * invoked. */ - Tcl_Command slaveCmd; /* Source command in slave interpreter, bound + Tcl_Command childCmd; /* Source command in child interpreter, bound * to command that invokes the target command * in the target interpreter. */ Tcl_HashEntry *aliasEntryPtr; - /* Entry for the alias hash table in slave. + /* Entry for the alias hash table in child. * This is used by alias deletion to remove - * the alias from the slave interpreter alias + * the alias from the child interpreter alias * table. */ - struct Target *targetPtr; /* Entry for target command in master. This is - * used in the master interpreter to map back + struct Target *targetPtr; /* Entry for target command in parent. This is + * used in the parent interpreter to map back * from the target command to aliases * redirecting to it. */ int objc; /* Count of Tcl_Obj in the prefix of the * target command to be invoked in the target * interpreter. Additional arguments specified - * when calling the alias in the slave interp + * when calling the alias in the child interp * will be appended to the prefix before the * command is invoked. */ Tcl_Obj *objPtr; /* The first actual prefix object - the target @@ -66,45 +66,45 @@ typedef struct Alias { /* * - * struct Slave: + * struct Child: * - * Used by the "interp" command to record and find information about slave - * interpreters. Maps from a command name in the master to information about a - * slave interpreter, e.g. what aliases are defined in it. + * Used by the "interp" command to record and find information about child + * interpreters. Maps from a command name in the parent to information about a + * child interpreter, e.g. what aliases are defined in it. */ -typedef struct Slave { - Tcl_Interp *masterInterp; /* Master interpreter for this slave. */ - Tcl_HashEntry *slaveEntryPtr; - /* Hash entry in masters slave table for this - * slave interpreter. Used to find this - * record, and used when deleting the slave - * interpreter to delete it from the master's +typedef struct Child { + Tcl_Interp *parentInterp; /* Parent interpreter for this child. */ + Tcl_HashEntry *childEntryPtr; + /* Hash entry in parents child table for this + * child interpreter. Used to find this + * record, and used when deleting the child + * interpreter to delete it from the parent's * table. */ - Tcl_Interp *slaveInterp; /* The slave interpreter. */ + Tcl_Interp *childInterp; /* The child interpreter. */ Tcl_Command interpCmd; /* Interpreter object command. */ Tcl_HashTable aliasTable; /* Table which maps from names of commands in - * slave interpreter to struct Alias defined + * child interpreter to struct Alias defined * below. */ -} Slave; +} Child; /* * struct Target: * - * Maps from master interpreter commands back to the source commands in slave + * Maps from parent interpreter commands back to the source commands in child * interpreters. This is needed because aliases can be created between sibling * interpreters and must be deleted when the target interpreter is deleted. In * case they would not be deleted the source interpreter would be left with a - * "dangling pointer". One such record is stored in the Master record of the - * master interpreter with the master for each alias which directs to a - * command in the master. These records are used to remove the source command - * for an from a slave if/when the master is deleted. They are organized in a - * doubly-linked list attached to the master interpreter. + * "dangling pointer". One such record is stored in the Parent record of the + * parent interpreter with the parent for each alias which directs to a + * command in the parent. These records are used to remove the source command + * for an from a child if/when the parent is deleted. They are organized in a + * doubly-linked list attached to the parent interpreter. */ typedef struct Target { - Tcl_Command slaveCmd; /* Command for alias in slave interp. */ - Tcl_Interp *slaveInterp; /* Slave Interpreter. */ + Tcl_Command childCmd; /* Command for alias in child interp. */ + Tcl_Interp *childInterp; /* Child Interpreter. */ struct Target *nextPtr; /* Next in list of target records, or NULL if * at the end of the list of targets. */ struct Target *prevPtr; /* Previous in list of target records, or NULL @@ -112,43 +112,43 @@ typedef struct Target { } Target; /* - * struct Master: + * struct Parent: * - * This record is used for two purposes: First, slaveTable (a hashtable) maps - * from names of commands to slave interpreters. This hashtable is used to - * store information about slave interpreters of this interpreter, to map over - * all slaves, etc. The second purpose is to store information about all - * aliases in slaves (or siblings) which direct to target commands in this + * This record is used for two purposes: First, childTable (a hashtable) maps + * from names of commands to child interpreters. This hashtable is used to + * store information about child interpreters of this interpreter, to map over + * all children, etc. The second purpose is to store information about all + * aliases in children (or siblings) which direct to target commands in this * interpreter (using the targetsPtr doubly-linked list). * * NB: the flags field in the interp structure, used with SAFE_INTERP mask * denotes whether the interpreter is safe or not. Safe interpreters have - * restricted functionality, can only create safe slave interpreters and can + * restricted functionality, can only create safe child interpreters and can * only load safe extensions. */ -typedef struct Master { - Tcl_HashTable slaveTable; /* Hash table for slave interpreters. Maps - * from command names to Slave records. */ +typedef struct Parent { + Tcl_HashTable childTable; /* Hash table for child interpreters. Maps + * from command names to Child records. */ Target *targetsPtr; /* The head of a doubly-linked list of all the * target records which denote aliases from - * slaves or sibling interpreters that direct + * children or sibling interpreters that direct * to commands in this interpreter. This list * is used to remove dangling pointers from - * the slave (or sibling) interpreters when + * the child (or sibling) interpreters when * this interpreter is deleted. */ -} Master; +} Parent; /* - * The following structure keeps track of all the Master and Slave information + * The following structure keeps track of all the Parent and Child information * on a per-interp basis. */ typedef struct InterpInfo { - Master master; /* Keeps track of all interps for which this - * interp is the Master. */ - Slave slave; /* Information necessary for this interp to - * function as a slave. */ + Parent parent; /* Keeps track of all interps for which this + * interp is the Parent. */ + Child child; /* Information necessary for this interp to + * function as a child. */ } InterpInfo; /* @@ -214,14 +214,14 @@ struct LimitHandler { */ static int AliasCreate(Tcl_Interp *interp, - Tcl_Interp *slaveInterp, Tcl_Interp *masterInterp, + Tcl_Interp *childInterp, Tcl_Interp *parentInterp, Tcl_Obj *namePtr, Tcl_Obj *targetPtr, int objc, Tcl_Obj *const objv[]); static int AliasDelete(Tcl_Interp *interp, - Tcl_Interp *slaveInterp, Tcl_Obj *namePtr); + Tcl_Interp *childInterp, Tcl_Obj *namePtr); static int AliasDescribe(Tcl_Interp *interp, - Tcl_Interp *slaveInterp, Tcl_Obj *objPtr); -static int AliasList(Tcl_Interp *interp, Tcl_Interp *slaveInterp); + Tcl_Interp *childInterp, Tcl_Obj *objPtr); +static int AliasList(Tcl_Interp *interp, Tcl_Interp *childInterp); static int AliasObjCmd(ClientData dummy, Tcl_Interp *currentInterp, int objc, Tcl_Obj *const objv[]); @@ -234,43 +234,43 @@ static Tcl_Interp * GetInterp2(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static void InterpInfoDeleteProc(ClientData clientData, Tcl_Interp *interp); -static int SlaveBgerror(Tcl_Interp *interp, - Tcl_Interp *slaveInterp, int objc, +static int ChildBgerror(Tcl_Interp *interp, + Tcl_Interp *childInterp, int objc, Tcl_Obj *const objv[]); -static Tcl_Interp * SlaveCreate(Tcl_Interp *interp, Tcl_Obj *pathPtr, +static Tcl_Interp * ChildCreate(Tcl_Interp *interp, Tcl_Obj *pathPtr, int safe); -static int SlaveDebugCmd(Tcl_Interp *interp, - Tcl_Interp *slaveInterp, +static int ChildDebugCmd(Tcl_Interp *interp, + Tcl_Interp *childInterp, int objc, Tcl_Obj *const objv[]); -static int SlaveEval(Tcl_Interp *interp, Tcl_Interp *slaveInterp, +static int ChildEval(Tcl_Interp *interp, Tcl_Interp *childInterp, int objc, Tcl_Obj *const objv[]); -static int SlaveExpose(Tcl_Interp *interp, - Tcl_Interp *slaveInterp, int objc, +static int ChildExpose(Tcl_Interp *interp, + Tcl_Interp *childInterp, int objc, Tcl_Obj *const objv[]); -static int SlaveHide(Tcl_Interp *interp, Tcl_Interp *slaveInterp, +static int ChildHide(Tcl_Interp *interp, Tcl_Interp *childInterp, int objc, Tcl_Obj *const objv[]); -static int SlaveHidden(Tcl_Interp *interp, - Tcl_Interp *slaveInterp); -static int SlaveInvokeHidden(Tcl_Interp *interp, - Tcl_Interp *slaveInterp, +static int ChildHidden(Tcl_Interp *interp, + Tcl_Interp *childInterp); +static int ChildInvokeHidden(Tcl_Interp *interp, + Tcl_Interp *childInterp, const char *namespaceName, int objc, Tcl_Obj *const objv[]); -static int SlaveMarkTrusted(Tcl_Interp *interp, - Tcl_Interp *slaveInterp); -static int SlaveObjCmd(ClientData dummy, Tcl_Interp *interp, +static int ChildMarkTrusted(Tcl_Interp *interp, + Tcl_Interp *childInterp); +static int ChildObjCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -static void SlaveObjCmdDeleteProc(ClientData clientData); -static int SlaveRecursionLimit(Tcl_Interp *interp, - Tcl_Interp *slaveInterp, int objc, +static void ChildObjCmdDeleteProc(ClientData clientData); +static int ChildRecursionLimit(Tcl_Interp *interp, + Tcl_Interp *childInterp, int objc, Tcl_Obj *const objv[]); -static int SlaveCommandLimitCmd(Tcl_Interp *interp, - Tcl_Interp *slaveInterp, int consumedObjc, +static int ChildCommandLimitCmd(Tcl_Interp *interp, + Tcl_Interp *childInterp, int consumedObjc, int objc, Tcl_Obj *const objv[]); -static int SlaveTimeLimitCmd(Tcl_Interp *interp, - Tcl_Interp *slaveInterp, int consumedObjc, +static int ChildTimeLimitCmd(Tcl_Interp *interp, + Tcl_Interp *childInterp, int consumedObjc, int objc, Tcl_Obj *const objv[]); -static void InheritLimitsFromMaster(Tcl_Interp *slaveInterp, - Tcl_Interp *masterInterp); +static void InheritLimitsFromParent(Tcl_Interp *childInterp, + Tcl_Interp *parentInterp); static void SetScriptLimitCallback(Tcl_Interp *interp, int type, Tcl_Interp *targetInterp, Tcl_Obj *scriptObj); static void CallScriptLimitCallback(ClientData clientData, @@ -283,7 +283,7 @@ static void TimeLimitCallback(ClientData clientData); /* NRE enabling */ static Tcl_NRPostProc NRPostInvokeHidden; static Tcl_ObjCmdProc NRInterpCmd; -static Tcl_ObjCmdProc NRSlaveCmd; +static Tcl_ObjCmdProc NRChildCmd; /* @@ -452,7 +452,7 @@ Tcl_Init( * * TclInterpInit -- * - * Initializes the invoking interpreter for using the master, slave and + * Initializes the invoking interpreter for using the parent, child and * safe interp facilities. This is called from inside Tcl_CreateInterp(). * * Results: @@ -470,22 +470,22 @@ TclInterpInit( Tcl_Interp *interp) /* Interpreter to initialize. */ { InterpInfo *interpInfoPtr; - Master *masterPtr; - Slave *slavePtr; + Parent *parentPtr; + Child *childPtr; interpInfoPtr = ckalloc(sizeof(InterpInfo)); ((Interp *) interp)->interpInfo = interpInfoPtr; - masterPtr = &interpInfoPtr->master; - Tcl_InitHashTable(&masterPtr->slaveTable, TCL_STRING_KEYS); - masterPtr->targetsPtr = NULL; + parentPtr = &interpInfoPtr->parent; + Tcl_InitHashTable(&parentPtr->childTable, TCL_STRING_KEYS); + parentPtr->targetsPtr = NULL; - slavePtr = &interpInfoPtr->slave; - slavePtr->masterInterp = NULL; - slavePtr->slaveEntryPtr = NULL; - slavePtr->slaveInterp = interp; - slavePtr->interpCmd = NULL; - Tcl_InitHashTable(&slavePtr->aliasTable, TCL_STRING_KEYS); + childPtr = &interpInfoPtr->child; + childPtr->parentInterp = NULL; + childPtr->childEntryPtr = NULL; + childPtr->childInterp = interp; + childPtr->interpCmd = NULL; + Tcl_InitHashTable(&childPtr->aliasTable, TCL_STRING_KEYS); Tcl_NRCreateCommand(interp, "interp", Tcl_InterpObjCmd, NRInterpCmd, NULL, NULL); @@ -500,7 +500,7 @@ TclInterpInit( * InterpInfoDeleteProc -- * * Invoked when an interpreter is being deleted. It releases all storage - * used by the master/slave/safe interpreter facilities. + * used by the parent/child/safe interpreter facilities. * * Results: * None. @@ -515,11 +515,11 @@ static void InterpInfoDeleteProc( ClientData clientData, /* Ignored. */ Tcl_Interp *interp) /* Interp being deleted. All commands for - * slave interps should already be deleted. */ + * child interps should already be deleted. */ { InterpInfo *interpInfoPtr; - Slave *slavePtr; - Master *masterPtr; + Child *childPtr; + Parent *parentPtr; Target *targetPtr; interpInfoPtr = (InterpInfo *) ((Interp *) interp)->interpInfo; @@ -528,11 +528,11 @@ InterpInfoDeleteProc( * There shouldn't be any commands left. */ - masterPtr = &interpInfoPtr->master; - if (masterPtr->slaveTable.numEntries != 0) { + parentPtr = &interpInfoPtr->parent; + if (parentPtr->childTable.numEntries != 0) { Tcl_Panic("InterpInfoDeleteProc: still exist commands"); } - Tcl_DeleteHashTable(&masterPtr->slaveTable); + Tcl_DeleteHashTable(&parentPtr->childTable); /* * Tell any interps that have aliases to this interp that they should @@ -540,35 +540,35 @@ InterpInfoDeleteProc( * have removed the target record already. */ - for (targetPtr = masterPtr->targetsPtr; targetPtr != NULL; ) { + for (targetPtr = parentPtr->targetsPtr; targetPtr != NULL; ) { Target *tmpPtr = targetPtr->nextPtr; - Tcl_DeleteCommandFromToken(targetPtr->slaveInterp, - targetPtr->slaveCmd); + Tcl_DeleteCommandFromToken(targetPtr->childInterp, + targetPtr->childCmd); targetPtr = tmpPtr; } - slavePtr = &interpInfoPtr->slave; - if (slavePtr->interpCmd != NULL) { + childPtr = &interpInfoPtr->child; + if (childPtr->interpCmd != NULL) { /* * Tcl_DeleteInterp() was called on this interpreter, rather "interp - * delete" or the equivalent deletion of the command in the master. + * delete" or the equivalent deletion of the command in the parent. * First ensure that the cleanup callback doesn't try to delete the * interp again. */ - slavePtr->slaveInterp = NULL; - Tcl_DeleteCommandFromToken(slavePtr->masterInterp, - slavePtr->interpCmd); + childPtr->childInterp = NULL; + Tcl_DeleteCommandFromToken(childPtr->parentInterp, + childPtr->interpCmd); } /* * There shouldn't be any aliases left. */ - if (slavePtr->aliasTable.numEntries != 0) { + if (childPtr->aliasTable.numEntries != 0) { Tcl_Panic("InterpInfoDeleteProc: still exist aliases"); } - Tcl_DeleteHashTable(&slavePtr->aliasTable); + Tcl_DeleteHashTable(&childPtr->aliasTable); ckfree(interpInfoPtr); } @@ -607,7 +607,7 @@ NRInterpCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - Tcl_Interp *slaveInterp; + Tcl_Interp *childInterp; int index; static const char *const options[] = { "alias", "aliases", "bgerror", "cancel", @@ -637,7 +637,7 @@ NRInterpCmd( } switch ((enum option) index) { case OPT_ALIAS: { - Tcl_Interp *masterInterp; + Tcl_Interp *parentInterp; if (objc < 4) { aliasArgs: @@ -645,43 +645,43 @@ NRInterpCmd( "slavePath slaveCmd ?masterPath masterCmd? ?arg ...?"); return TCL_ERROR; } - slaveInterp = GetInterp(interp, objv[2]); - if (slaveInterp == NULL) { + childInterp = GetInterp(interp, objv[2]); + if (childInterp == NULL) { return TCL_ERROR; } if (objc == 4) { - return AliasDescribe(interp, slaveInterp, objv[3]); + return AliasDescribe(interp, childInterp, objv[3]); } if ((objc == 5) && (TclGetString(objv[4])[0] == '\0')) { - return AliasDelete(interp, slaveInterp, objv[3]); + return AliasDelete(interp, childInterp, objv[3]); } if (objc > 5) { - masterInterp = GetInterp(interp, objv[4]); - if (masterInterp == NULL) { + parentInterp = GetInterp(interp, objv[4]); + if (parentInterp == NULL) { return TCL_ERROR; } - return AliasCreate(interp, slaveInterp, masterInterp, objv[3], + return AliasCreate(interp, childInterp, parentInterp, objv[3], objv[5], objc - 6, objv + 6); } goto aliasArgs; } case OPT_ALIASES: - slaveInterp = GetInterp2(interp, objc, objv); - if (slaveInterp == NULL) { + childInterp = GetInterp2(interp, objc, objv); + if (childInterp == NULL) { return TCL_ERROR; } - return AliasList(interp, slaveInterp); + return AliasList(interp, childInterp); case OPT_BGERROR: if (objc != 3 && objc != 4) { Tcl_WrongNumArgs(interp, 2, objv, "path ?cmdPrefix?"); return TCL_ERROR; } - slaveInterp = GetInterp(interp, objv[2]); - if (slaveInterp == NULL) { + childInterp = GetInterp(interp, objv[2]); + if (childInterp == NULL) { return TCL_ERROR; } - return SlaveBgerror(interp, slaveInterp, objc - 3, objv + 3); + return ChildBgerror(interp, childInterp, objc - 3, objv + 3); case OPT_CANCEL: { int i, flags; Tcl_Obj *resultObjPtr; @@ -725,18 +725,18 @@ NRInterpCmd( } /* - * Did they specify a slave interp to cancel the script in progress + * Did they specify a child interp to cancel the script in progress * in? If not, use the current interp. */ if (i < objc) { - slaveInterp = GetInterp(interp, objv[i]); - if (slaveInterp == NULL) { + childInterp = GetInterp(interp, objv[i]); + if (childInterp == NULL) { return TCL_ERROR; } i++; } else { - slaveInterp = interp; + childInterp = interp; } if (i < objc) { @@ -752,11 +752,11 @@ NRInterpCmd( resultObjPtr = NULL; } - return Tcl_CancelEval(slaveInterp, resultObjPtr, 0, flags); + return Tcl_CancelEval(childInterp, resultObjPtr, 0, flags); } case OPT_CREATE: { int i, last, safe; - Tcl_Obj *slavePtr; + Tcl_Obj *childPtr; char buf[16 + TCL_INTEGER_SPACE]; static const char *const createOptions[] = { "-safe", "--", NULL @@ -771,7 +771,7 @@ NRInterpCmd( * Weird historical rules: "-safe" is accepted at the end, too. */ - slavePtr = NULL; + childPtr = NULL; last = 0; for (i = 2; i < objc; i++) { if ((last == 0) && (Tcl_GetString(objv[i])[0] == '-')) { @@ -786,21 +786,21 @@ NRInterpCmd( i++; last = 1; } - if (slavePtr != NULL) { + if (childPtr != NULL) { Tcl_WrongNumArgs(interp, 2, objv, "?-safe? ?--? ?path?"); return TCL_ERROR; } if (i < objc) { - slavePtr = objv[i]; + childPtr = objv[i]; } } buf[0] = '\0'; - if (slavePtr == NULL) { + if (childPtr == NULL) { /* * Create an anonymous interpreter -- we choose its name and the * name of the command. We check that the command name that we use * for the interpreter does not collide with an existing command - * in the master interpreter. + * in the parent interpreter. */ for (i = 0; ; i++) { @@ -811,15 +811,15 @@ NRInterpCmd( break; } } - slavePtr = Tcl_NewStringObj(buf, -1); + childPtr = Tcl_NewStringObj(buf, -1); } - if (SlaveCreate(interp, slavePtr, safe) == NULL) { + if (ChildCreate(interp, childPtr, safe) == NULL) { if (buf[0] != '\0') { - Tcl_DecrRefCount(slavePtr); + Tcl_DecrRefCount(childPtr); } return TCL_ERROR; } - Tcl_SetObjResult(interp, slavePtr); + Tcl_SetObjResult(interp, childPtr); return TCL_OK; } case OPT_DEBUG: /* TIP #378 */ @@ -831,29 +831,29 @@ NRInterpCmd( Tcl_WrongNumArgs(interp, 2, objv, "path ?-frame ?bool??"); return TCL_ERROR; } - slaveInterp = GetInterp(interp, objv[2]); - if (slaveInterp == NULL) { + childInterp = GetInterp(interp, objv[2]); + if (childInterp == NULL) { return TCL_ERROR; } - return SlaveDebugCmd(interp, slaveInterp, objc - 3, objv + 3); + return ChildDebugCmd(interp, childInterp, objc - 3, objv + 3); case OPT_DELETE: { int i; InterpInfo *iiPtr; for (i = 2; i < objc; i++) { - slaveInterp = GetInterp(interp, objv[i]); - if (slaveInterp == NULL) { + childInterp = GetInterp(interp, objv[i]); + if (childInterp == NULL) { return TCL_ERROR; - } else if (slaveInterp == interp) { + } else if (childInterp == interp) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "cannot delete the current interpreter", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "DELETESELF", NULL); return TCL_ERROR; } - iiPtr = (InterpInfo *) ((Interp *) slaveInterp)->interpInfo; - Tcl_DeleteCommandFromToken(iiPtr->slave.masterInterp, - iiPtr->slave.interpCmd); + iiPtr = (InterpInfo *) ((Interp *) childInterp)->interpInfo; + Tcl_DeleteCommandFromToken(iiPtr->child.parentInterp, + iiPtr->child.interpCmd); } return TCL_OK; } @@ -862,16 +862,16 @@ NRInterpCmd( Tcl_WrongNumArgs(interp, 2, objv, "path arg ?arg ...?"); return TCL_ERROR; } - slaveInterp = GetInterp(interp, objv[2]); - if (slaveInterp == NULL) { + childInterp = GetInterp(interp, objv[2]); + if (childInterp == NULL) { return TCL_ERROR; } - return SlaveEval(interp, slaveInterp, objc - 3, objv + 3); + return ChildEval(interp, childInterp, objc - 3, objv + 3); case OPT_EXISTS: { int exists = 1; - slaveInterp = GetInterp2(interp, objc, objv); - if (slaveInterp == NULL) { + childInterp = GetInterp2(interp, objc, objv); + if (childInterp == NULL) { if (objc > 3) { return TCL_ERROR; } @@ -886,33 +886,33 @@ NRInterpCmd( Tcl_WrongNumArgs(interp, 2, objv, "path hiddenCmdName ?cmdName?"); return TCL_ERROR; } - slaveInterp = GetInterp(interp, objv[2]); - if (slaveInterp == NULL) { + childInterp = GetInterp(interp, objv[2]); + if (childInterp == NULL) { return TCL_ERROR; } - return SlaveExpose(interp, slaveInterp, objc - 3, objv + 3); + return ChildExpose(interp, childInterp, objc - 3, objv + 3); case OPT_HIDE: if ((objc < 4) || (objc > 5)) { Tcl_WrongNumArgs(interp, 2, objv, "path cmdName ?hiddenCmdName?"); return TCL_ERROR; } - slaveInterp = GetInterp(interp, objv[2]); - if (slaveInterp == NULL) { + childInterp = GetInterp(interp, objv[2]); + if (childInterp == NULL) { return TCL_ERROR; } - return SlaveHide(interp, slaveInterp, objc - 3, objv + 3); + return ChildHide(interp, childInterp, objc - 3, objv + 3); case OPT_HIDDEN: - slaveInterp = GetInterp2(interp, objc, objv); - if (slaveInterp == NULL) { + childInterp = GetInterp2(interp, objc, objv); + if (childInterp == NULL) { return TCL_ERROR; } - return SlaveHidden(interp, slaveInterp); + return ChildHidden(interp, childInterp); case OPT_ISSAFE: - slaveInterp = GetInterp2(interp, objc, objv); - if (slaveInterp == NULL) { + childInterp = GetInterp2(interp, objc, objv); + if (childInterp == NULL) { return TCL_ERROR; } - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(Tcl_IsSafe(slaveInterp))); + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(Tcl_IsSafe(childInterp))); return TCL_OK; case OPT_INVOKEHID: { int i; @@ -951,11 +951,11 @@ NRInterpCmd( "path ?-namespace ns? ?-global? ?--? cmd ?arg ..?"); return TCL_ERROR; } - slaveInterp = GetInterp(interp, objv[2]); - if (slaveInterp == NULL) { + childInterp = GetInterp(interp, objv[2]); + if (childInterp == NULL) { return TCL_ERROR; } - return SlaveInvokeHidden(interp, slaveInterp, namespaceName, objc - i, + return ChildInvokeHidden(interp, childInterp, namespaceName, objc - i, objv + i); } case OPT_LIMIT: { @@ -972,8 +972,8 @@ NRInterpCmd( "path limitType ?-option value ...?"); return TCL_ERROR; } - slaveInterp = GetInterp(interp, objv[2]); - if (slaveInterp == NULL) { + childInterp = GetInterp(interp, objv[2]); + if (childInterp == NULL) { return TCL_ERROR; } if (Tcl_GetIndexFromObj(interp, objv[3], limitTypes, "limit type", 0, @@ -982,9 +982,9 @@ NRInterpCmd( } switch ((enum LimitTypes) limitType) { case LIMIT_TYPE_COMMANDS: - return SlaveCommandLimitCmd(interp, slaveInterp, 4, objc,objv); + return ChildCommandLimitCmd(interp, childInterp, 4, objc,objv); case LIMIT_TYPE_TIME: - return SlaveTimeLimitCmd(interp, slaveInterp, 4, objc, objv); + return ChildTimeLimitCmd(interp, childInterp, 4, objc, objv); } } break; @@ -993,21 +993,21 @@ NRInterpCmd( Tcl_WrongNumArgs(interp, 2, objv, "path"); return TCL_ERROR; } - slaveInterp = GetInterp(interp, objv[2]); - if (slaveInterp == NULL) { + childInterp = GetInterp(interp, objv[2]); + if (childInterp == NULL) { return TCL_ERROR; } - return SlaveMarkTrusted(interp, slaveInterp); + return ChildMarkTrusted(interp, childInterp); case OPT_RECLIMIT: if (objc != 3 && objc != 4) { Tcl_WrongNumArgs(interp, 2, objv, "path ?newlimit?"); return TCL_ERROR; } - slaveInterp = GetInterp(interp, objv[2]); - if (slaveInterp == NULL) { + childInterp = GetInterp(interp, objv[2]); + if (childInterp == NULL) { return TCL_ERROR; } - return SlaveRecursionLimit(interp, slaveInterp, objc - 3, objv + 3); + return ChildRecursionLimit(interp, childInterp, objc - 3, objv + 3); case OPT_CHILDREN: case OPT_SLAVES: { InterpInfo *iiPtr; @@ -1016,15 +1016,15 @@ NRInterpCmd( Tcl_HashSearch hashSearch; char *string; - slaveInterp = GetInterp2(interp, objc, objv); - if (slaveInterp == NULL) { + childInterp = GetInterp2(interp, objc, objv); + if (childInterp == NULL) { return TCL_ERROR; } - iiPtr = (InterpInfo *) ((Interp *) slaveInterp)->interpInfo; + iiPtr = (InterpInfo *) ((Interp *) childInterp)->interpInfo; resultPtr = Tcl_NewObj(); - hPtr = Tcl_FirstHashEntry(&iiPtr->master.slaveTable, &hashSearch); + hPtr = Tcl_FirstHashEntry(&iiPtr->parent.childTable, &hashSearch); for ( ; hPtr != NULL; hPtr = Tcl_NextHashEntry(&hashSearch)) { - string = Tcl_GetHashKey(&iiPtr->master.slaveTable, hPtr); + string = Tcl_GetHashKey(&iiPtr->parent.childTable, hPtr); Tcl_ListObjAppendElement(NULL, resultPtr, Tcl_NewStringObj(string, -1)); } @@ -1033,35 +1033,35 @@ NRInterpCmd( } case OPT_TRANSFER: case OPT_SHARE: { - Tcl_Interp *masterInterp; /* The master of the slave. */ + Tcl_Interp *parentInterp; /* The parent of the child. */ Tcl_Channel chan; if (objc != 5) { Tcl_WrongNumArgs(interp, 2, objv, "srcPath channelId destPath"); return TCL_ERROR; } - masterInterp = GetInterp(interp, objv[2]); - if (masterInterp == NULL) { + parentInterp = GetInterp(interp, objv[2]); + if (parentInterp == NULL) { return TCL_ERROR; } - chan = Tcl_GetChannel(masterInterp, TclGetString(objv[3]), NULL); + chan = Tcl_GetChannel(parentInterp, TclGetString(objv[3]), NULL); if (chan == NULL) { - Tcl_TransferResult(masterInterp, TCL_OK, interp); + Tcl_TransferResult(parentInterp, TCL_OK, interp); return TCL_ERROR; } - slaveInterp = GetInterp(interp, objv[4]); - if (slaveInterp == NULL) { + childInterp = GetInterp(interp, objv[4]); + if (childInterp == NULL) { return TCL_ERROR; } - Tcl_RegisterChannel(slaveInterp, chan); + Tcl_RegisterChannel(childInterp, chan); if (index == OPT_TRANSFER) { /* * When transferring, as opposed to sharing, we must unhitch the * channel from the interpreter where it started. */ - if (Tcl_UnregisterChannel(masterInterp, chan) != TCL_OK) { - Tcl_TransferResult(masterInterp, TCL_OK, interp); + if (Tcl_UnregisterChannel(parentInterp, chan) != TCL_OK) { + Tcl_TransferResult(parentInterp, TCL_OK, interp); return TCL_ERROR; } } @@ -1078,15 +1078,15 @@ NRInterpCmd( return TCL_ERROR; } - slaveInterp = GetInterp(interp, objv[2]); - if (slaveInterp == NULL) { + childInterp = GetInterp(interp, objv[2]); + if (childInterp == NULL) { return TCL_ERROR; } aliasName = TclGetString(objv[3]); - iiPtr = (InterpInfo *) ((Interp *) slaveInterp)->interpInfo; - hPtr = Tcl_FindHashEntry(&iiPtr->slave.aliasTable, aliasName); + iiPtr = (InterpInfo *) ((Interp *) childInterp)->interpInfo; + hPtr = Tcl_FindHashEntry(&iiPtr->child.aliasTable, aliasName); if (hPtr == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "alias \"%s\" in path \"%s\" not found", @@ -1159,46 +1159,46 @@ GetInterp2( * A standard Tcl result. * * Side effects: - * Creates a new alias, manipulates the result field of slaveInterp. + * Creates a new alias, manipulates the result field of childInterp. * *---------------------------------------------------------------------- */ int Tcl_CreateAlias( - Tcl_Interp *slaveInterp, /* Interpreter for source command. */ - const char *slaveCmd, /* Command to install in slave. */ + Tcl_Interp *childInterp, /* Interpreter for source command. */ + const char *childCmd, /* Command to install in child. */ Tcl_Interp *targetInterp, /* Interpreter for target command. */ const char *targetCmd, /* Name of target command. */ int argc, /* How many additional arguments? */ const char *const *argv) /* These are the additional args. */ { - Tcl_Obj *slaveObjPtr, *targetObjPtr; + Tcl_Obj *childObjPtr, *targetObjPtr; Tcl_Obj **objv; int i; int result; - objv = TclStackAlloc(slaveInterp, (unsigned) sizeof(Tcl_Obj *) * argc); + objv = TclStackAlloc(childInterp, (unsigned) sizeof(Tcl_Obj *) * argc); for (i = 0; i < argc; i++) { objv[i] = Tcl_NewStringObj(argv[i], -1); Tcl_IncrRefCount(objv[i]); } - slaveObjPtr = Tcl_NewStringObj(slaveCmd, -1); - Tcl_IncrRefCount(slaveObjPtr); + childObjPtr = Tcl_NewStringObj(childCmd, -1); + Tcl_IncrRefCount(childObjPtr); targetObjPtr = Tcl_NewStringObj(targetCmd, -1); Tcl_IncrRefCount(targetObjPtr); - result = AliasCreate(slaveInterp, slaveInterp, targetInterp, slaveObjPtr, + result = AliasCreate(childInterp, childInterp, targetInterp, childObjPtr, targetObjPtr, argc, objv); for (i = 0; i < argc; i++) { Tcl_DecrRefCount(objv[i]); } - TclStackFree(slaveInterp, objv); + TclStackFree(childInterp, objv); Tcl_DecrRefCount(targetObjPtr); - Tcl_DecrRefCount(slaveObjPtr); + Tcl_DecrRefCount(childObjPtr); return result; } @@ -1221,26 +1221,26 @@ Tcl_CreateAlias( int Tcl_CreateAliasObj( - Tcl_Interp *slaveInterp, /* Interpreter for source command. */ - const char *slaveCmd, /* Command to install in slave. */ + Tcl_Interp *childInterp, /* Interpreter for source command. */ + const char *childCmd, /* Command to install in child. */ Tcl_Interp *targetInterp, /* Interpreter for target command. */ const char *targetCmd, /* Name of target command. */ int objc, /* How many additional arguments? */ Tcl_Obj *const objv[]) /* Argument vector. */ { - Tcl_Obj *slaveObjPtr, *targetObjPtr; + Tcl_Obj *childObjPtr, *targetObjPtr; int result; - slaveObjPtr = Tcl_NewStringObj(slaveCmd, -1); - Tcl_IncrRefCount(slaveObjPtr); + childObjPtr = Tcl_NewStringObj(childCmd, -1); + Tcl_IncrRefCount(childObjPtr); targetObjPtr = Tcl_NewStringObj(targetCmd, -1); Tcl_IncrRefCount(targetObjPtr); - result = AliasCreate(slaveInterp, slaveInterp, targetInterp, slaveObjPtr, + result = AliasCreate(childInterp, childInterp, targetInterp, childObjPtr, targetObjPtr, objc, objv); - Tcl_DecrRefCount(slaveObjPtr); + Tcl_DecrRefCount(childObjPtr); Tcl_DecrRefCount(targetObjPtr); return result; } @@ -1277,7 +1277,7 @@ Tcl_GetAlias( int i, objc; Tcl_Obj **objv; - hPtr = Tcl_FindHashEntry(&iiPtr->slave.aliasTable, aliasName); + hPtr = Tcl_FindHashEntry(&iiPtr->child.aliasTable, aliasName); if (hPtr == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "alias \"%s\" not found", aliasName)); @@ -1339,7 +1339,7 @@ Tcl_GetAliasObj( int objc; Tcl_Obj **objv; - hPtr = Tcl_FindHashEntry(&iiPtr->slave.aliasTable, aliasName); + hPtr = Tcl_FindHashEntry(&iiPtr->child.aliasTable, aliasName); if (hPtr == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "alias \"%s\" not found", aliasName)); @@ -1426,7 +1426,7 @@ TclPreventAliasLoop( if (Tcl_InterpDeleted(nextAliasPtr->targetInterp)) { /* - * The slave interpreter can be deleted while creating the alias. + * The child interpreter can be deleted while creating the alias. * [Bug #641195] */ @@ -1480,7 +1480,7 @@ TclPreventAliasLoop( * * Side effects: * An alias command is created and entered into the alias table for the - * slave interpreter. + * child interpreter. * *---------------------------------------------------------------------- */ @@ -1488,9 +1488,9 @@ TclPreventAliasLoop( static int AliasCreate( Tcl_Interp *interp, /* Interp for error reporting. */ - Tcl_Interp *slaveInterp, /* Interp where alias cmd will live or from + Tcl_Interp *childInterp, /* Interp where alias cmd will live or from * which alias will be deleted. */ - Tcl_Interp *masterInterp, /* Interp in which target command will be + Tcl_Interp *parentInterp, /* Interp in which target command will be * invoked. */ Tcl_Obj *namePtr, /* Name of alias cmd. */ Tcl_Obj *targetNamePtr, /* Name of target cmd. */ @@ -1500,15 +1500,15 @@ AliasCreate( Alias *aliasPtr; Tcl_HashEntry *hPtr; Target *targetPtr; - Slave *slavePtr; - Master *masterPtr; + Child *childPtr; + Parent *parentPtr; Tcl_Obj **prefv; int isNew, i; aliasPtr = ckalloc(sizeof(Alias) + objc * sizeof(Tcl_Obj *)); aliasPtr->token = namePtr; Tcl_IncrRefCount(aliasPtr->token); - aliasPtr->targetInterp = masterInterp; + aliasPtr->targetInterp = parentInterp; aliasPtr->objc = objc + 1; prefv = &aliasPtr->objPtr; @@ -1520,21 +1520,21 @@ AliasCreate( Tcl_IncrRefCount(objv[i]); } - Tcl_Preserve(slaveInterp); - Tcl_Preserve(masterInterp); + Tcl_Preserve(childInterp); + Tcl_Preserve(parentInterp); - if (slaveInterp == masterInterp) { - aliasPtr->slaveCmd = Tcl_NRCreateCommand(slaveInterp, + if (childInterp == parentInterp) { + aliasPtr->childCmd = Tcl_NRCreateCommand(childInterp, TclGetString(namePtr), AliasObjCmd, AliasNRCmd, aliasPtr, AliasObjCmdDeleteProc); } else { - aliasPtr->slaveCmd = Tcl_CreateObjCommand(slaveInterp, + aliasPtr->childCmd = Tcl_CreateObjCommand(childInterp, TclGetString(namePtr), AliasObjCmd, aliasPtr, AliasObjCmdDeleteProc); } - if (TclPreventAliasLoop(interp, slaveInterp, - aliasPtr->slaveCmd) != TCL_OK) { + if (TclPreventAliasLoop(interp, childInterp, + aliasPtr->childCmd) != TCL_OK) { /* * Found an alias loop! The last call to Tcl_CreateObjCommand made the * alias point to itself. Delete the command and its alias record. Be @@ -1550,11 +1550,11 @@ AliasCreate( Tcl_DecrRefCount(objv[i]); } - cmdPtr = (Command *) aliasPtr->slaveCmd; + cmdPtr = (Command *) aliasPtr->childCmd; cmdPtr->clientData = NULL; cmdPtr->deleteProc = NULL; cmdPtr->deleteData = NULL; - Tcl_DeleteCommandFromToken(slaveInterp, aliasPtr->slaveCmd); + Tcl_DeleteCommandFromToken(childInterp, aliasPtr->childCmd); ckfree(aliasPtr); @@ -1562,8 +1562,8 @@ AliasCreate( * The result was already set by TclPreventAliasLoop. */ - Tcl_Release(slaveInterp); - Tcl_Release(masterInterp); + Tcl_Release(childInterp); + Tcl_Release(parentInterp); return TCL_ERROR; } @@ -1571,13 +1571,13 @@ AliasCreate( * Make an entry in the alias table. If it already exists, retry. */ - slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave; + childPtr = &((InterpInfo *) ((Interp *) childInterp)->interpInfo)->child; while (1) { Tcl_Obj *newToken; const char *string; string = TclGetString(aliasPtr->token); - hPtr = Tcl_CreateHashEntry(&slavePtr->aliasTable, string, &isNew); + hPtr = Tcl_CreateHashEntry(&childPtr->aliasTable, string, &isNew); if (isNew != 0) { break; } @@ -1614,22 +1614,22 @@ AliasCreate( */ targetPtr = ckalloc(sizeof(Target)); - targetPtr->slaveCmd = aliasPtr->slaveCmd; - targetPtr->slaveInterp = slaveInterp; + targetPtr->childCmd = aliasPtr->childCmd; + targetPtr->childInterp = childInterp; - masterPtr = &((InterpInfo*) ((Interp*) masterInterp)->interpInfo)->master; - targetPtr->nextPtr = masterPtr->targetsPtr; + parentPtr = &((InterpInfo*) ((Interp*) parentInterp)->interpInfo)->parent; + targetPtr->nextPtr = parentPtr->targetsPtr; targetPtr->prevPtr = NULL; - if (masterPtr->targetsPtr != NULL) { - masterPtr->targetsPtr->prevPtr = targetPtr; + if (parentPtr->targetsPtr != NULL) { + parentPtr->targetsPtr->prevPtr = targetPtr; } - masterPtr->targetsPtr = targetPtr; + parentPtr->targetsPtr = targetPtr; aliasPtr->targetPtr = targetPtr; Tcl_SetObjResult(interp, aliasPtr->token); - Tcl_Release(slaveInterp); - Tcl_Release(masterInterp); + Tcl_Release(childInterp); + Tcl_Release(parentInterp); return TCL_OK; } @@ -1638,13 +1638,13 @@ AliasCreate( * * AliasDelete -- * - * Deletes the given alias from the slave interpreter given. + * Deletes the given alias from the child interpreter given. * * Results: * A standard Tcl result. * * Side effects: - * Deletes the alias from the slave interpreter. + * Deletes the alias from the child interpreter. * *---------------------------------------------------------------------- */ @@ -1652,21 +1652,21 @@ AliasCreate( static int AliasDelete( Tcl_Interp *interp, /* Interpreter for result & errors. */ - Tcl_Interp *slaveInterp, /* Interpreter containing alias. */ + Tcl_Interp *childInterp, /* Interpreter containing alias. */ Tcl_Obj *namePtr) /* Name of alias to delete. */ { - Slave *slavePtr; + Child *childPtr; Alias *aliasPtr; Tcl_HashEntry *hPtr; /* - * If the alias has been renamed in the slave, the master can still use + * If the alias has been renamed in the child, the parent can still use * the original name (with which it was created) to find the alias to * delete it. */ - slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave; - hPtr = Tcl_FindHashEntry(&slavePtr->aliasTable, TclGetString(namePtr)); + childPtr = &((InterpInfo *) ((Interp *) childInterp)->interpInfo)->child; + hPtr = Tcl_FindHashEntry(&childPtr->aliasTable, TclGetString(namePtr)); if (hPtr == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "alias \"%s\" not found", TclGetString(namePtr))); @@ -1675,7 +1675,7 @@ AliasDelete( return TCL_ERROR; } aliasPtr = Tcl_GetHashValue(hPtr); - Tcl_DeleteCommandFromToken(slaveInterp, aliasPtr->slaveCmd); + Tcl_DeleteCommandFromToken(childInterp, aliasPtr->childCmd); return TCL_OK; } @@ -1700,22 +1700,22 @@ AliasDelete( static int AliasDescribe( Tcl_Interp *interp, /* Interpreter for result & errors. */ - Tcl_Interp *slaveInterp, /* Interpreter containing alias. */ + Tcl_Interp *childInterp, /* Interpreter containing alias. */ Tcl_Obj *namePtr) /* Name of alias to describe. */ { - Slave *slavePtr; + Child *childPtr; Tcl_HashEntry *hPtr; Alias *aliasPtr; Tcl_Obj *prefixPtr; /* - * If the alias has been renamed in the slave, the master can still use + * If the alias has been renamed in the child, the parent can still use * the original name (with which it was created) to find the alias to * describe it. */ - slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave; - hPtr = Tcl_FindHashEntry(&slavePtr->aliasTable, Tcl_GetString(namePtr)); + childPtr = &((InterpInfo *) ((Interp *) childInterp)->interpInfo)->child; + hPtr = Tcl_FindHashEntry(&childPtr->aliasTable, Tcl_GetString(namePtr)); if (hPtr == NULL) { return TCL_OK; } @@ -1730,7 +1730,7 @@ AliasDescribe( * * AliasList -- * - * Computes a list of aliases defined in a slave interpreter. + * Computes a list of aliases defined in a child interpreter. * * Results: * A standard Tcl result. @@ -1744,17 +1744,17 @@ AliasDescribe( static int AliasList( Tcl_Interp *interp, /* Interp for data return. */ - Tcl_Interp *slaveInterp) /* Interp whose aliases to compute. */ + Tcl_Interp *childInterp) /* Interp whose aliases to compute. */ { Tcl_HashEntry *entryPtr; Tcl_HashSearch hashSearch; Tcl_Obj *resultPtr = Tcl_NewObj(); Alias *aliasPtr; - Slave *slavePtr; + Child *childPtr; - slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave; + childPtr = &((InterpInfo *) ((Interp *) childInterp)->interpInfo)->child; - entryPtr = Tcl_FirstHashEntry(&slavePtr->aliasTable, &hashSearch); + entryPtr = Tcl_FirstHashEntry(&childPtr->aliasTable, &hashSearch); for ( ; entryPtr != NULL; entryPtr = Tcl_NextHashEntry(&hashSearch)) { aliasPtr = Tcl_GetHashValue(entryPtr); Tcl_ListObjAppendElement(NULL, resultPtr, aliasPtr->token); @@ -1768,10 +1768,10 @@ AliasList( * * AliasObjCmd -- * - * This is the function that services invocations of aliases in a slave + * This is the function that services invocations of aliases in a child * interpreter. One such command exists for each alias. When invoked, * this function redirects the invocation to the target command in the - * master interpreter as designated by the Alias record associated with + * parent interpreter as designated by the Alias record associated with * this command. * * Results: @@ -1929,7 +1929,7 @@ AliasObjCmd( * * AliasObjCmdDeleteProc -- * - * Is invoked when an alias command is deleted in a slave. Cleans up all + * Is invoked when an alias command is deleted in a child. Cleans up all * storage associated with this alias. * * Results: @@ -1959,17 +1959,17 @@ AliasObjCmdDeleteProc( Tcl_DeleteHashEntry(aliasPtr->aliasEntryPtr); /* - * Splice the target record out of the target interpreter's master list. + * Splice the target record out of the target interpreter's parent list. */ targetPtr = aliasPtr->targetPtr; if (targetPtr->prevPtr != NULL) { targetPtr->prevPtr->nextPtr = targetPtr->nextPtr; } else { - Master *masterPtr = &((InterpInfo *) ((Interp *) - aliasPtr->targetInterp)->interpInfo)->master; + Parent *parentPtr = &((InterpInfo *) ((Interp *) + aliasPtr->targetInterp)->interpInfo)->parent; - masterPtr->targetsPtr = targetPtr->nextPtr; + parentPtr->targetsPtr = targetPtr->nextPtr; } if (targetPtr->nextPtr != NULL) { targetPtr->nextPtr->prevPtr = targetPtr->prevPtr; @@ -1984,11 +1984,11 @@ AliasObjCmdDeleteProc( * * Tcl_CreateChild -- * - * Creates a slave interpreter. The slavePath argument denotes the name - * of the new slave relative to the current interpreter; the slave is a + * Creates a child interpreter. The childPath argument denotes the name + * of the new child relative to the current interpreter; the child is a * direct descendant of the one-before-last component of the path, - * e.g. it is a descendant of the current interpreter if the slavePath - * argument contains only one component. Optionally makes the slave + * e.g. it is a descendant of the current interpreter if the childPath + * argument contains only one component. Optionally makes the child * interpreter safe. * * Results: @@ -1997,7 +1997,7 @@ AliasObjCmdDeleteProc( * * Side effects: * Creates a new interpreter and a new interpreter object command in the - * interpreter indicated by the slavePath argument. + * interpreter indicated by the childPath argument. * *---------------------------------------------------------------------- */ @@ -2005,17 +2005,17 @@ AliasObjCmdDeleteProc( Tcl_Interp * Tcl_CreateChild( Tcl_Interp *interp, /* Interpreter to start search at. */ - const char *slavePath, /* Name of slave to create. */ - int isSafe) /* Should new slave be "safe" ? */ + const char *childPath, /* Name of child to create. */ + int isSafe) /* Should new child be "safe" ? */ { Tcl_Obj *pathPtr; - Tcl_Interp *slaveInterp; + Tcl_Interp *childInterp; - pathPtr = Tcl_NewStringObj(slavePath, -1); - slaveInterp = SlaveCreate(interp, pathPtr, isSafe); + pathPtr = Tcl_NewStringObj(childPath, -1); + childInterp = ChildCreate(interp, pathPtr, isSafe); Tcl_DecrRefCount(pathPtr); - return slaveInterp; + return childInterp; } /* @@ -2023,7 +2023,7 @@ Tcl_CreateChild( * * Tcl_GetChild -- * - * Finds a slave interpreter by its path name. + * Finds a child interpreter by its path name. * * Results: * Returns a Tcl_Interp * for the named interpreter or NULL if not found. @@ -2037,16 +2037,16 @@ Tcl_CreateChild( Tcl_Interp * Tcl_GetChild( Tcl_Interp *interp, /* Interpreter to start search from. */ - const char *slavePath) /* Path of slave to find. */ + const char *childPath) /* Path of child to find. */ { Tcl_Obj *pathPtr; - Tcl_Interp *slaveInterp; + Tcl_Interp *childInterp; - pathPtr = Tcl_NewStringObj(slavePath, -1); - slaveInterp = GetInterp(interp, pathPtr); + pathPtr = Tcl_NewStringObj(childPath, -1); + childInterp = GetInterp(interp, pathPtr); Tcl_DecrRefCount(pathPtr); - return slaveInterp; + return childInterp; } /* @@ -2054,10 +2054,10 @@ Tcl_GetChild( * * Tcl_GetParent -- * - * Finds the master interpreter of a slave interpreter. + * Finds the parent interpreter of a child interpreter. * * Results: - * Returns a Tcl_Interp * for the master interpreter or NULL if none. + * Returns a Tcl_Interp * for the parent interpreter or NULL if none. * * Side effects: * None. @@ -2067,15 +2067,15 @@ Tcl_GetChild( Tcl_Interp * Tcl_GetParent( - Tcl_Interp *interp) /* Get the master of this interpreter. */ + Tcl_Interp *interp) /* Get the parent of this interpreter. */ { - Slave *slavePtr; /* Slave record of this interpreter. */ + Child *childPtr; /* Child record of this interpreter. */ if (interp == NULL) { return NULL; } - slavePtr = &((InterpInfo *) ((Interp *) interp)->interpInfo)->slave; - return slavePtr->masterInterp; + childPtr = &((InterpInfo *) ((Interp *) interp)->interpInfo)->child; + return childPtr->parentInterp; } /* @@ -2083,7 +2083,7 @@ Tcl_GetParent( * * TclSetChildCancelFlags -- * - * This function marks all slave interpreters belonging to a given + * This function marks all child interpreters belonging to a given * interpreter as being canceled or not canceled, depending on the * provided flags. * @@ -2106,10 +2106,10 @@ TclSetChildCancelFlags( int force) /* Non-zero to ignore numLevels for the purpose * of resetting the cancellation flags. */ { - Master *masterPtr; /* Master record of given interpreter. */ + Parent *parentPtr; /* Parent record of given interpreter. */ Tcl_HashEntry *hPtr; /* Search element. */ Tcl_HashSearch hashSearch; /* Search variable. */ - Slave *slavePtr; /* Slave record of interpreter. */ + Child *childPtr; /* Child record of interpreter. */ Interp *iPtr; if (interp == NULL) { @@ -2118,12 +2118,12 @@ TclSetChildCancelFlags( flags &= (CANCELED | TCL_CANCEL_UNWIND); - masterPtr = &((InterpInfo *) ((Interp *) interp)->interpInfo)->master; + parentPtr = &((InterpInfo *) ((Interp *) interp)->interpInfo)->parent; - hPtr = Tcl_FirstHashEntry(&masterPtr->slaveTable, &hashSearch); + hPtr = Tcl_FirstHashEntry(&parentPtr->childTable, &hashSearch); for ( ; hPtr != NULL; hPtr = Tcl_NextHashEntry(&hashSearch)) { - slavePtr = Tcl_GetHashValue(hPtr); - iPtr = (Interp *) slavePtr->slaveInterp; + childPtr = Tcl_GetHashValue(hPtr); + iPtr = (Interp *) childPtr->childInterp; if (iPtr == NULL) { continue; @@ -2136,7 +2136,7 @@ TclSetChildCancelFlags( } /* - * Now, recursively handle this for the slaves of this slave + * Now, recursively handle this for the children of this child * interpreter. */ @@ -2152,7 +2152,7 @@ TclSetChildCancelFlags( * Sets the result of the asking interpreter to a proper Tcl list * containing the names of interpreters between the asking and target * interpreters. The target interpreter must be either the same as the - * asking interpreter or one of its slaves (including recursively). + * asking interpreter or one of its children (including recursively). * * Results: * TCL_OK if the target interpreter is the same as, or a descendant of, @@ -2183,12 +2183,12 @@ Tcl_GetInterpPath( return TCL_ERROR; } iiPtr = (InterpInfo *) ((Interp *) targetInterp)->interpInfo; - if (Tcl_GetInterpPath(interp, iiPtr->slave.masterInterp) != TCL_OK){ + if (Tcl_GetInterpPath(interp, iiPtr->child.parentInterp) != TCL_OK){ return TCL_ERROR; } Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), - Tcl_NewStringObj(Tcl_GetHashKey(&iiPtr->master.slaveTable, - iiPtr->slave.slaveEntryPtr), -1)); + Tcl_NewStringObj(Tcl_GetHashKey(&iiPtr->parent.childTable, + iiPtr->child.childEntryPtr), -1)); return TCL_OK; } @@ -2197,10 +2197,10 @@ Tcl_GetInterpPath( * * GetInterp -- * - * Helper function to find a slave interpreter given a pathname. + * Helper function to find a child interpreter given a pathname. * * Results: - * Returns the slave interpreter known by that name in the calling + * Returns the child interpreter known by that name in the calling * interpreter, or NULL if no interpreter known by that name exists. * * Side effects: @@ -2216,11 +2216,11 @@ GetInterp( * be found. */ { Tcl_HashEntry *hPtr; /* Search element. */ - Slave *slavePtr; /* Interim slave record. */ + Child *childPtr; /* Interim child record. */ Tcl_Obj **objv; int objc, i; Tcl_Interp *searchInterp; /* Interim storage for interp. to find. */ - InterpInfo *masterInfoPtr; + InterpInfo *parentInfoPtr; if (TclListObjGetElements(interp, pathPtr, &objc, &objv) != TCL_OK) { return NULL; @@ -2228,15 +2228,15 @@ GetInterp( searchInterp = interp; for (i = 0; i < objc; i++) { - masterInfoPtr = (InterpInfo *) ((Interp *) searchInterp)->interpInfo; - hPtr = Tcl_FindHashEntry(&masterInfoPtr->master.slaveTable, + parentInfoPtr = (InterpInfo *) ((Interp *) searchInterp)->interpInfo; + hPtr = Tcl_FindHashEntry(&parentInfoPtr->parent.childTable, TclGetString(objv[i])); if (hPtr == NULL) { searchInterp = NULL; break; } - slavePtr = Tcl_GetHashValue(hPtr); - searchInterp = slavePtr->slaveInterp; + childPtr = Tcl_GetHashValue(hPtr); + searchInterp = childPtr->childInterp; if (searchInterp == NULL) { break; } @@ -2253,7 +2253,7 @@ GetInterp( /* *---------------------------------------------------------------------- * - * SlaveBgerror -- + * ChildBgerror -- * * Helper function to set/query the background error handling command * prefix of an interp @@ -2262,16 +2262,16 @@ GetInterp( * A standard Tcl result. * * Side effects: - * When (objc == 1), slaveInterp will be set to a new background handler + * When (objc == 1), childInterp will be set to a new background handler * of objv[0]. * *---------------------------------------------------------------------- */ static int -SlaveBgerror( +ChildBgerror( Tcl_Interp *interp, /* Interp for error return. */ - Tcl_Interp *slaveInterp, /* Interp in which limit is set/queried. */ + Tcl_Interp *childInterp, /* Interp in which limit is set/queried. */ int objc, /* Set or Query. */ Tcl_Obj *const objv[]) /* Argument strings. */ { @@ -2286,19 +2286,19 @@ SlaveBgerror( "BGERRORFORMAT", NULL); return TCL_ERROR; } - TclSetBgErrorHandler(slaveInterp, objv[0]); + TclSetBgErrorHandler(childInterp, objv[0]); } - Tcl_SetObjResult(interp, TclGetBgErrorHandler(slaveInterp)); + Tcl_SetObjResult(interp, TclGetBgErrorHandler(childInterp)); return TCL_OK; } /* *---------------------------------------------------------------------- * - * SlaveCreate -- + * ChildCreate -- * - * Helper function to do the actual work of creating a slave interp and - * new object command. Also optionally makes the new slave interpreter + * Helper function to do the actual work of creating a child interp and + * new object command. Also optionally makes the new child interpreter * "safe". * * Results: @@ -2306,20 +2306,20 @@ SlaveBgerror( * the result of the invoking interpreter contains an error message. * * Side effects: - * Creates a new slave interpreter and a new object command. + * Creates a new child interpreter and a new object command. * *---------------------------------------------------------------------- */ static Tcl_Interp * -SlaveCreate( +ChildCreate( Tcl_Interp *interp, /* Interp. to start search from. */ - Tcl_Obj *pathPtr, /* Path (name) of slave to create. */ + Tcl_Obj *pathPtr, /* Path (name) of child to create. */ int safe) /* Should we make it "safe"? */ { - Tcl_Interp *masterInterp, *slaveInterp; - Slave *slavePtr; - InterpInfo *masterInfoPtr; + Tcl_Interp *parentInterp, *childInterp; + Child *childPtr; + InterpInfo *parentInfoPtr; Tcl_HashEntry *hPtr; const char *path; int isNew, objc; @@ -2329,25 +2329,25 @@ SlaveCreate( return NULL; } if (objc < 2) { - masterInterp = interp; + parentInterp = interp; path = TclGetString(pathPtr); } else { Tcl_Obj *objPtr; objPtr = Tcl_NewListObj(objc - 1, objv); - masterInterp = GetInterp(interp, objPtr); + parentInterp = GetInterp(interp, objPtr); Tcl_DecrRefCount(objPtr); - if (masterInterp == NULL) { + if (parentInterp == NULL) { return NULL; } path = TclGetString(objv[objc - 1]); } if (safe == 0) { - safe = Tcl_IsSafe(masterInterp); + safe = Tcl_IsSafe(parentInterp); } - masterInfoPtr = (InterpInfo *) ((Interp *) masterInterp)->interpInfo; - hPtr = Tcl_CreateHashEntry(&masterInfoPtr->master.slaveTable, path, + parentInfoPtr = (InterpInfo *) ((Interp *) parentInterp)->interpInfo; + hPtr = Tcl_CreateHashEntry(&parentInfoPtr->parent.childTable, path, &isNew); if (isNew == 0) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( @@ -2356,51 +2356,51 @@ SlaveCreate( return NULL; } - slaveInterp = Tcl_CreateInterp(); - slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave; - slavePtr->masterInterp = masterInterp; - slavePtr->slaveEntryPtr = hPtr; - slavePtr->slaveInterp = slaveInterp; - slavePtr->interpCmd = Tcl_NRCreateCommand(masterInterp, path, - SlaveObjCmd, NRSlaveCmd, slaveInterp, SlaveObjCmdDeleteProc); - Tcl_InitHashTable(&slavePtr->aliasTable, TCL_STRING_KEYS); - Tcl_SetHashValue(hPtr, slavePtr); - Tcl_SetVar(slaveInterp, "tcl_interactive", "0", TCL_GLOBAL_ONLY); + childInterp = Tcl_CreateInterp(); + childPtr = &((InterpInfo *) ((Interp *) childInterp)->interpInfo)->child; + childPtr->parentInterp = parentInterp; + childPtr->childEntryPtr = hPtr; + childPtr->childInterp = childInterp; + childPtr->interpCmd = Tcl_NRCreateCommand(parentInterp, path, + ChildObjCmd, NRChildCmd, childInterp, ChildObjCmdDeleteProc); + Tcl_InitHashTable(&childPtr->aliasTable, TCL_STRING_KEYS); + Tcl_SetHashValue(hPtr, childPtr); + Tcl_SetVar(childInterp, "tcl_interactive", "0", TCL_GLOBAL_ONLY); /* * Inherit the recursion limit. */ - ((Interp *) slaveInterp)->maxNestingDepth = - ((Interp *) masterInterp)->maxNestingDepth; + ((Interp *) childInterp)->maxNestingDepth = + ((Interp *) parentInterp)->maxNestingDepth; if (safe) { - if (Tcl_MakeSafe(slaveInterp) == TCL_ERROR) { + if (Tcl_MakeSafe(childInterp) == TCL_ERROR) { goto error; } } else { - if (Tcl_Init(slaveInterp) == TCL_ERROR) { + if (Tcl_Init(childInterp) == TCL_ERROR) { goto error; } /* - * This will create the "memory" command in slave interpreters if we + * This will create the "memory" command in child interpreters if we * compiled with TCL_MEM_DEBUG, otherwise it does nothing. */ - Tcl_InitMemory(slaveInterp); + Tcl_InitMemory(childInterp); } /* * Inherit the TIP#143 limits. */ - InheritLimitsFromMaster(slaveInterp, masterInterp); + InheritLimitsFromParent(childInterp, parentInterp); /* * The [clock] command presents a safe API, but uses unsafe features in * its implementation. This means it has to be implemented in safe interps - * as an alias to a version in the (trusted) master. + * as an alias to a version in the (trusted) parent. */ if (safe) { @@ -2409,7 +2409,7 @@ SlaveCreate( TclNewLiteralStringObj(clockObj, "clock"); Tcl_IncrRefCount(clockObj); - status = AliasCreate(interp, slaveInterp, masterInterp, clockObj, + status = AliasCreate(interp, childInterp, parentInterp, clockObj, clockObj, 0, NULL); Tcl_DecrRefCount(clockObj); if (status != TCL_OK) { @@ -2417,12 +2417,12 @@ SlaveCreate( } } - return slaveInterp; + return childInterp; error: - Tcl_TransferResult(slaveInterp, TCL_ERROR, interp); + Tcl_TransferResult(childInterp, TCL_ERROR, interp); error2: - Tcl_DeleteInterp(slaveInterp); + Tcl_DeleteInterp(childInterp); return NULL; } @@ -2430,10 +2430,10 @@ SlaveCreate( /* *---------------------------------------------------------------------- * - * SlaveObjCmd -- + * ChildObjCmd -- * * Command to manipulate an interpreter, e.g. to send commands to it to - * be evaluated. One such command exists for each slave interpreter. + * be evaluated. One such command exists for each child interpreter. * * Results: * A standard Tcl result. @@ -2445,23 +2445,23 @@ SlaveCreate( */ static int -SlaveObjCmd( - ClientData clientData, /* Slave interpreter. */ +ChildObjCmd( + ClientData clientData, /* Child interpreter. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - return Tcl_NRCallObjProc(interp, NRSlaveCmd, clientData, objc, objv); + return Tcl_NRCallObjProc(interp, NRChildCmd, clientData, objc, objv); } static int -NRSlaveCmd( - ClientData clientData, /* Slave interpreter. */ +NRChildCmd( + ClientData clientData, /* Child interpreter. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - Tcl_Interp *slaveInterp = clientData; + Tcl_Interp *childInterp = clientData; int index; static const char *const options[] = { "alias", "aliases", "bgerror", "debug", @@ -2476,8 +2476,8 @@ NRSlaveCmd( OPT_RECLIMIT }; - if (slaveInterp == NULL) { - Tcl_Panic("SlaveObjCmd: interpreter has been deleted"); + if (childInterp == NULL) { + Tcl_Panic("ChildObjCmd: interpreter has been deleted"); } if (objc < 2) { @@ -2493,14 +2493,14 @@ NRSlaveCmd( case OPT_ALIAS: if (objc > 2) { if (objc == 3) { - return AliasDescribe(interp, slaveInterp, objv[2]); + return AliasDescribe(interp, childInterp, objv[2]); } if (TclGetString(objv[3])[0] == '\0') { if (objc == 4) { - return AliasDelete(interp, slaveInterp, objv[2]); + return AliasDelete(interp, childInterp, objv[2]); } } else { - return AliasCreate(interp, slaveInterp, interp, objv[2], + return AliasCreate(interp, childInterp, interp, objv[2], objv[3], objc - 4, objv + 4); } } @@ -2511,13 +2511,13 @@ NRSlaveCmd( Tcl_WrongNumArgs(interp, 2, objv, NULL); return TCL_ERROR; } - return AliasList(interp, slaveInterp); + return AliasList(interp, childInterp); case OPT_BGERROR: if (objc != 2 && objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "?cmdPrefix?"); return TCL_ERROR; } - return SlaveBgerror(interp, slaveInterp, objc - 2, objv + 2); + return ChildBgerror(interp, childInterp, objc - 2, objv + 2); case OPT_DEBUG: /* * TIP #378 @@ -2527,37 +2527,37 @@ NRSlaveCmd( Tcl_WrongNumArgs(interp, 2, objv, "?-frame ?bool??"); return TCL_ERROR; } - return SlaveDebugCmd(interp, slaveInterp, objc - 2, objv + 2); + return ChildDebugCmd(interp, childInterp, objc - 2, objv + 2); case OPT_EVAL: if (objc < 3) { Tcl_WrongNumArgs(interp, 2, objv, "arg ?arg ...?"); return TCL_ERROR; } - return SlaveEval(interp, slaveInterp, objc - 2, objv + 2); + return ChildEval(interp, childInterp, objc - 2, objv + 2); case OPT_EXPOSE: if ((objc < 3) || (objc > 4)) { Tcl_WrongNumArgs(interp, 2, objv, "hiddenCmdName ?cmdName?"); return TCL_ERROR; } - return SlaveExpose(interp, slaveInterp, objc - 2, objv + 2); + return ChildExpose(interp, childInterp, objc - 2, objv + 2); case OPT_HIDE: if ((objc < 3) || (objc > 4)) { Tcl_WrongNumArgs(interp, 2, objv, "cmdName ?hiddenCmdName?"); return TCL_ERROR; } - return SlaveHide(interp, slaveInterp, objc - 2, objv + 2); + return ChildHide(interp, childInterp, objc - 2, objv + 2); case OPT_HIDDEN: if (objc != 2) { Tcl_WrongNumArgs(interp, 2, objv, NULL); return TCL_ERROR; } - return SlaveHidden(interp, slaveInterp); + return ChildHidden(interp, childInterp); case OPT_ISSAFE: if (objc != 2) { Tcl_WrongNumArgs(interp, 2, objv, NULL); return TCL_ERROR; } - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(Tcl_IsSafe(slaveInterp))); + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(Tcl_IsSafe(childInterp))); return TCL_OK; case OPT_INVOKEHIDDEN: { int i; @@ -2596,7 +2596,7 @@ NRSlaveCmd( "?-namespace ns? ?-global? ?--? cmd ?arg ..?"); return TCL_ERROR; } - return SlaveInvokeHidden(interp, slaveInterp, namespaceName, + return ChildInvokeHidden(interp, childInterp, namespaceName, objc - i, objv + i); } case OPT_LIMIT: { @@ -2618,9 +2618,9 @@ NRSlaveCmd( } switch ((enum LimitTypes) limitType) { case LIMIT_TYPE_COMMANDS: - return SlaveCommandLimitCmd(interp, slaveInterp, 3, objc,objv); + return ChildCommandLimitCmd(interp, childInterp, 3, objc,objv); case LIMIT_TYPE_TIME: - return SlaveTimeLimitCmd(interp, slaveInterp, 3, objc, objv); + return ChildTimeLimitCmd(interp, childInterp, 3, objc, objv); } } break; @@ -2629,13 +2629,13 @@ NRSlaveCmd( Tcl_WrongNumArgs(interp, 2, objv, NULL); return TCL_ERROR; } - return SlaveMarkTrusted(interp, slaveInterp); + return ChildMarkTrusted(interp, childInterp); case OPT_RECLIMIT: if (objc != 2 && objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "?newlimit?"); return TCL_ERROR; } - return SlaveRecursionLimit(interp, slaveInterp, objc - 2, objv + 2); + return ChildRecursionLimit(interp, childInterp, objc - 2, objv + 2); } return TCL_ERROR; @@ -2644,71 +2644,71 @@ NRSlaveCmd( /* *---------------------------------------------------------------------- * - * SlaveObjCmdDeleteProc -- + * ChildObjCmdDeleteProc -- * - * Invoked when an object command for a slave interpreter is deleted; - * cleans up all state associated with the slave interpreter and destroys - * the slave interpreter. + * Invoked when an object command for a child interpreter is deleted; + * cleans up all state associated with the child interpreter and destroys + * the child interpreter. * * Results: * None. * * Side effects: - * Cleans up all state associated with the slave interpreter and destroys - * the slave interpreter. + * Cleans up all state associated with the child interpreter and destroys + * the child interpreter. * *---------------------------------------------------------------------- */ static void -SlaveObjCmdDeleteProc( - ClientData clientData) /* The SlaveRecord for the command. */ +ChildObjCmdDeleteProc( + ClientData clientData) /* The ChildRecord for the command. */ { - Slave *slavePtr; /* Interim storage for Slave record. */ - Tcl_Interp *slaveInterp = clientData; - /* And for a slave interp. */ + Child *childPtr; /* Interim storage for Child record. */ + Tcl_Interp *childInterp = clientData; + /* And for a child interp. */ - slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave; + childPtr = &((InterpInfo *) ((Interp *) childInterp)->interpInfo)->child; /* - * Unlink the slave from its master interpreter. + * Unlink the child from its parent interpreter. */ - Tcl_DeleteHashEntry(slavePtr->slaveEntryPtr); + Tcl_DeleteHashEntry(childPtr->childEntryPtr); /* - * Set to NULL so that when the InterpInfo is cleaned up in the slave it + * Set to NULL so that when the InterpInfo is cleaned up in the child it * does not try to delete the command causing all sorts of grief. See - * SlaveRecordDeleteProc(). + * ChildRecordDeleteProc(). */ - slavePtr->interpCmd = NULL; + childPtr->interpCmd = NULL; - if (slavePtr->slaveInterp != NULL) { - Tcl_DeleteInterp(slavePtr->slaveInterp); + if (childPtr->childInterp != NULL) { + Tcl_DeleteInterp(childPtr->childInterp); } } /* *---------------------------------------------------------------------- * - * SlaveDebugCmd -- TIP #378 + * ChildDebugCmd -- TIP #378 * - * Helper function to handle 'debug' command in a slave interpreter. + * Helper function to handle 'debug' command in a child interpreter. * * Results: * A standard Tcl result. * * Side effects: - * May modify INTERP_DEBUG_FRAME flag in the slave. + * May modify INTERP_DEBUG_FRAME flag in the child. * *---------------------------------------------------------------------- */ static int -SlaveDebugCmd( +ChildDebugCmd( Tcl_Interp *interp, /* Interp for error return. */ - Tcl_Interp *slaveInterp, /* The slave interpreter in which command + Tcl_Interp *childInterp, /* The child interpreter in which command * will be evaluated. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -2723,7 +2723,7 @@ SlaveDebugCmd( Interp *iPtr; Tcl_Obj *resultPtr; - iPtr = (Interp *) slaveInterp; + iPtr = (Interp *) childInterp; if (objc == 0) { resultPtr = Tcl_NewObj(); Tcl_ListObjAppendElement(NULL, resultPtr, @@ -2763,9 +2763,9 @@ SlaveDebugCmd( /* *---------------------------------------------------------------------- * - * SlaveEval -- + * ChildEval -- * - * Helper function to evaluate a command in a slave interpreter. + * Helper function to evaluate a command in a child interpreter. * * Results: * A standard Tcl result. @@ -2777,9 +2777,9 @@ SlaveDebugCmd( */ static int -SlaveEval( +ChildEval( Tcl_Interp *interp, /* Interp for error return. */ - Tcl_Interp *slaveInterp, /* The slave interpreter in which command + Tcl_Interp *childInterp, /* The child interpreter in which command * will be evaluated. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -2787,17 +2787,17 @@ SlaveEval( int result; /* - * TIP #285: If necessary, reset the cancellation flags for the slave - * interpreter now; otherwise, canceling a script in a master interpreter - * can result in a situation where a slave interpreter can no longer + * TIP #285: If necessary, reset the cancellation flags for the child + * interpreter now; otherwise, canceling a script in a parent interpreter + * can result in a situation where a child interpreter can no longer * evaluate any scripts unless somebody calls the TclResetCancellation * function for that particular Tcl_Interp. */ - TclSetChildCancelFlags(slaveInterp, 0, 0); + TclSetChildCancelFlags(childInterp, 0, 0); - Tcl_Preserve(slaveInterp); - Tcl_AllowExceptions(slaveInterp); + Tcl_Preserve(childInterp); + Tcl_AllowExceptions(childInterp); if (objc == 1) { /* @@ -2810,40 +2810,40 @@ SlaveEval( TclArgumentGet(interp, objv[0], &invoker, &word); - result = TclEvalObjEx(slaveInterp, objv[0], 0, invoker, word); + result = TclEvalObjEx(childInterp, objv[0], 0, invoker, word); } else { Tcl_Obj *objPtr = Tcl_ConcatObj(objc, objv); Tcl_IncrRefCount(objPtr); - result = Tcl_EvalObjEx(slaveInterp, objPtr, 0); + result = Tcl_EvalObjEx(childInterp, objPtr, 0); Tcl_DecrRefCount(objPtr); } - Tcl_TransferResult(slaveInterp, result, interp); + Tcl_TransferResult(childInterp, result, interp); - Tcl_Release(slaveInterp); + Tcl_Release(childInterp); return result; } /* *---------------------------------------------------------------------- * - * SlaveExpose -- + * ChildExpose -- * - * Helper function to expose a command in a slave interpreter. + * Helper function to expose a command in a child interpreter. * * Results: * A standard Tcl result. * * Side effects: - * After this call scripts in the slave will be able to invoke the newly + * After this call scripts in the child will be able to invoke the newly * exposed command. * *---------------------------------------------------------------------- */ static int -SlaveExpose( +ChildExpose( Tcl_Interp *interp, /* Interp for error return. */ - Tcl_Interp *slaveInterp, /* Interp in which command will be exposed. */ + Tcl_Interp *childInterp, /* Interp in which command will be exposed. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument strings. */ { @@ -2859,9 +2859,9 @@ SlaveExpose( } name = TclGetString(objv[(objc == 1) ? 0 : 1]); - if (Tcl_ExposeCommand(slaveInterp, TclGetString(objv[0]), + if (Tcl_ExposeCommand(childInterp, TclGetString(objv[0]), name) != TCL_OK) { - Tcl_TransferResult(slaveInterp, TCL_ERROR, interp); + Tcl_TransferResult(childInterp, TCL_ERROR, interp); return TCL_ERROR; } return TCL_OK; @@ -2870,7 +2870,7 @@ SlaveExpose( /* *---------------------------------------------------------------------- * - * SlaveRecursionLimit -- + * ChildRecursionLimit -- * * Helper function to set/query the Recursion limit of an interp * @@ -2878,16 +2878,16 @@ SlaveExpose( * A standard Tcl result. * * Side effects: - * When (objc == 1), slaveInterp will be set to a new recursion limit of + * When (objc == 1), childInterp will be set to a new recursion limit of * objv[0]. * *---------------------------------------------------------------------- */ static int -SlaveRecursionLimit( +ChildRecursionLimit( Tcl_Interp *interp, /* Interp for error return. */ - Tcl_Interp *slaveInterp, /* Interp in which limit is set/queried. */ + Tcl_Interp *childInterp, /* Interp in which limit is set/queried. */ int objc, /* Set or Query. */ Tcl_Obj *const objv[]) /* Argument strings. */ { @@ -2912,9 +2912,9 @@ SlaveRecursionLimit( NULL); return TCL_ERROR; } - Tcl_SetRecursionLimit(slaveInterp, limit); - iPtr = (Interp *) slaveInterp; - if (interp == slaveInterp && iPtr->numLevels > limit) { + Tcl_SetRecursionLimit(childInterp, limit); + iPtr = (Interp *) childInterp; + if (interp == childInterp && iPtr->numLevels > limit) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "falling back due to new recursion limit", -1)); Tcl_SetErrorCode(interp, "TCL", "RECURSION", NULL); @@ -2923,7 +2923,7 @@ SlaveRecursionLimit( Tcl_SetObjResult(interp, objv[0]); return TCL_OK; } else { - limit = Tcl_SetRecursionLimit(slaveInterp, 0); + limit = Tcl_SetRecursionLimit(childInterp, 0); Tcl_SetObjResult(interp, Tcl_NewIntObj(limit)); return TCL_OK; } @@ -2932,24 +2932,24 @@ SlaveRecursionLimit( /* *---------------------------------------------------------------------- * - * SlaveHide -- + * ChildHide -- * - * Helper function to hide a command in a slave interpreter. + * Helper function to hide a command in a child interpreter. * * Results: * A standard Tcl result. * * Side effects: - * After this call scripts in the slave will no longer be able to invoke + * After this call scripts in the child will no longer be able to invoke * the named command. * *---------------------------------------------------------------------- */ static int -SlaveHide( +ChildHide( Tcl_Interp *interp, /* Interp for error return. */ - Tcl_Interp *slaveInterp, /* Interp in which command will be exposed. */ + Tcl_Interp *childInterp, /* Interp in which command will be exposed. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument strings. */ { @@ -2965,8 +2965,8 @@ SlaveHide( } name = TclGetString(objv[(objc == 1) ? 0 : 1]); - if (Tcl_HideCommand(slaveInterp, TclGetString(objv[0]), name) != TCL_OK) { - Tcl_TransferResult(slaveInterp, TCL_ERROR, interp); + if (Tcl_HideCommand(childInterp, TclGetString(objv[0]), name) != TCL_OK) { + Tcl_TransferResult(childInterp, TCL_ERROR, interp); return TCL_ERROR; } return TCL_OK; @@ -2975,9 +2975,9 @@ SlaveHide( /* *---------------------------------------------------------------------- * - * SlaveHidden -- + * ChildHidden -- * - * Helper function to compute list of hidden commands in a slave + * Helper function to compute list of hidden commands in a child * interpreter. * * Results: @@ -2990,16 +2990,16 @@ SlaveHide( */ static int -SlaveHidden( +ChildHidden( Tcl_Interp *interp, /* Interp for data return. */ - Tcl_Interp *slaveInterp) /* Interp whose hidden commands to query. */ + Tcl_Interp *childInterp) /* Interp whose hidden commands to query. */ { Tcl_Obj *listObjPtr = Tcl_NewObj(); /* Local object pointer. */ Tcl_HashTable *hTblPtr; /* For local searches. */ Tcl_HashEntry *hPtr; /* For local searches. */ Tcl_HashSearch hSearch; /* For local searches. */ - hTblPtr = ((Interp *) slaveInterp)->hiddenCmdTablePtr; + hTblPtr = ((Interp *) childInterp)->hiddenCmdTablePtr; if (hTblPtr != NULL) { for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch); hPtr != NULL; @@ -3015,9 +3015,9 @@ SlaveHidden( /* *---------------------------------------------------------------------- * - * SlaveInvokeHidden -- + * ChildInvokeHidden -- * - * Helper function to invoke a hidden command in a slave interpreter. + * Helper function to invoke a hidden command in a child interpreter. * * Results: * A standard Tcl result. @@ -3029,9 +3029,9 @@ SlaveHidden( */ static int -SlaveInvokeHidden( +ChildInvokeHidden( Tcl_Interp *interp, /* Interp for error return. */ - Tcl_Interp *slaveInterp, /* The slave interpreter in which command will + Tcl_Interp *childInterp, /* The child interpreter in which command will * be invoked. */ const char *namespaceName, /* The namespace to use, if any. */ int objc, /* Number of arguments. */ @@ -3048,31 +3048,31 @@ SlaveInvokeHidden( return TCL_ERROR; } - Tcl_Preserve(slaveInterp); - Tcl_AllowExceptions(slaveInterp); + Tcl_Preserve(childInterp); + Tcl_AllowExceptions(childInterp); if (namespaceName == NULL) { - NRE_callback *rootPtr = TOP_CB(slaveInterp); + NRE_callback *rootPtr = TOP_CB(childInterp); - Tcl_NRAddCallback(interp, NRPostInvokeHidden, slaveInterp, + Tcl_NRAddCallback(interp, NRPostInvokeHidden, childInterp, rootPtr, NULL, NULL); - return TclNRInvoke(NULL, slaveInterp, objc, objv); + return TclNRInvoke(NULL, childInterp, objc, objv); } else { Namespace *nsPtr, *dummy1, *dummy2; const char *tail; - result = TclGetNamespaceForQualName(slaveInterp, namespaceName, NULL, + result = TclGetNamespaceForQualName(childInterp, namespaceName, NULL, TCL_FIND_ONLY_NS | TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG | TCL_CREATE_NS_IF_UNKNOWN, &nsPtr, &dummy1, &dummy2, &tail); if (result == TCL_OK) { - result = TclObjInvokeNamespace(slaveInterp, objc, objv, + result = TclObjInvokeNamespace(childInterp, objc, objv, (Tcl_Namespace *) nsPtr, TCL_INVOKE_HIDDEN); } } - Tcl_TransferResult(slaveInterp, result, interp); + Tcl_TransferResult(childInterp, result, interp); - Tcl_Release(slaveInterp); + Tcl_Release(childInterp); return result; } @@ -3082,38 +3082,38 @@ NRPostInvokeHidden( Tcl_Interp *interp, int result) { - Tcl_Interp *slaveInterp = (Tcl_Interp *)data[0]; + Tcl_Interp *childInterp = (Tcl_Interp *)data[0]; NRE_callback *rootPtr = (NRE_callback *)data[1]; - if (interp != slaveInterp) { - result = TclNRRunCallbacks(slaveInterp, result, rootPtr); - Tcl_TransferResult(slaveInterp, result, interp); + if (interp != childInterp) { + result = TclNRRunCallbacks(childInterp, result, rootPtr); + Tcl_TransferResult(childInterp, result, interp); } - Tcl_Release(slaveInterp); + Tcl_Release(childInterp); return result; } /* *---------------------------------------------------------------------- * - * SlaveMarkTrusted -- + * ChildMarkTrusted -- * - * Helper function to mark a slave interpreter as trusted (unsafe). + * Helper function to mark a child interpreter as trusted (unsafe). * * Results: * A standard Tcl result. * * Side effects: * After this call the hard-wired security checks in the core no longer - * prevent the slave from performing certain operations. + * prevent the child from performing certain operations. * *---------------------------------------------------------------------- */ static int -SlaveMarkTrusted( +ChildMarkTrusted( Tcl_Interp *interp, /* Interp for error return. */ - Tcl_Interp *slaveInterp) /* The slave interpreter which will be marked + Tcl_Interp *childInterp) /* The child interpreter which will be marked * trusted. */ { if (Tcl_IsSafe(interp)) { @@ -3124,7 +3124,7 @@ SlaveMarkTrusted( NULL); return TCL_ERROR; } - ((Interp *) slaveInterp)->flags &= ~SAFE_INTERP; + ((Interp *) childInterp)->flags &= ~SAFE_INTERP; return TCL_OK; } @@ -3181,23 +3181,23 @@ Tcl_MakeSafe( { Tcl_Channel chan; /* Channel to remove from safe interpreter. */ Interp *iPtr = (Interp *) interp; - Tcl_Interp *master = ((InterpInfo*) iPtr->interpInfo)->slave.masterInterp; + Tcl_Interp *parent = ((InterpInfo*) iPtr->interpInfo)->child.parentInterp; TclHideUnsafeCommands(interp); - if (master != NULL) { + if (parent != NULL) { /* - * Alias these function implementations in the slave to those in the - * master; the overall implementations are safe, but they're normally + * Alias these function implementations in the child to those in the + * parent; the overall implementations are safe, but they're normally * defined by init.tcl which is not sourced by safe interpreters. * Assume these functions all work. [Bug 2895741] */ (void) Tcl_Eval(interp, "namespace eval ::tcl {namespace eval mathfunc {}}"); - (void) Tcl_CreateAlias(interp, "::tcl::mathfunc::min", master, + (void) Tcl_CreateAlias(interp, "::tcl::mathfunc::min", parent, "::tcl::mathfunc::min", 0, NULL); - (void) Tcl_CreateAlias(interp, "::tcl::mathfunc::max", master, + (void) Tcl_CreateAlias(interp, "::tcl::mathfunc::max", parent, "::tcl::mathfunc::max", 0, NULL); } @@ -3209,7 +3209,7 @@ Tcl_MakeSafe( */ /* - * No env array in a safe slave. + * No env array in a safe child. */ Tcl_UnsetVar(interp, "env", TCL_GLOBAL_ONLY); @@ -4113,7 +4113,7 @@ Tcl_LimitGetGranularity( * DeleteScriptLimitCallback -- * * Callback for when a script limit (a limit callback implemented as a - * Tcl script in a master interpreter, as set up from Tcl) is deleted. + * Tcl script in a parent interpreter, as set up from Tcl) is deleted. * * Results: * None. @@ -4326,48 +4326,48 @@ TclInitLimitSupport( /* *---------------------------------------------------------------------- * - * InheritLimitsFromMaster -- + * InheritLimitsFromParent -- * - * Derive the interpreter limit configuration for a slave interpreter - * from the limit config for the master. + * Derive the interpreter limit configuration for a child interpreter + * from the limit config for the parent. * * Results: * None. * * Side effects: - * The slave interpreter limits are set so that if the master has a - * limit, it may not exceed it by handing off work to slave interpreters. - * Note that this does not transfer limit callbacks from the master to - * the slave. + * The child interpreter limits are set so that if the parent has a + * limit, it may not exceed it by handing off work to child interpreters. + * Note that this does not transfer limit callbacks from the parent to + * the child. * *---------------------------------------------------------------------- */ static void -InheritLimitsFromMaster( - Tcl_Interp *slaveInterp, - Tcl_Interp *masterInterp) +InheritLimitsFromParent( + Tcl_Interp *childInterp, + Tcl_Interp *parentInterp) { - Interp *slavePtr = (Interp *) slaveInterp; - Interp *masterPtr = (Interp *) masterInterp; + Interp *childPtr = (Interp *) childInterp; + Interp *parentPtr = (Interp *) parentInterp; - if (masterPtr->limit.active & TCL_LIMIT_COMMANDS) { - slavePtr->limit.active |= TCL_LIMIT_COMMANDS; - slavePtr->limit.cmdCount = 0; - slavePtr->limit.cmdGranularity = masterPtr->limit.cmdGranularity; + if (parentPtr->limit.active & TCL_LIMIT_COMMANDS) { + childPtr->limit.active |= TCL_LIMIT_COMMANDS; + childPtr->limit.cmdCount = 0; + childPtr->limit.cmdGranularity = parentPtr->limit.cmdGranularity; } - if (masterPtr->limit.active & TCL_LIMIT_TIME) { - slavePtr->limit.active |= TCL_LIMIT_TIME; - memcpy(&slavePtr->limit.time, &masterPtr->limit.time, + if (parentPtr->limit.active & TCL_LIMIT_TIME) { + childPtr->limit.active |= TCL_LIMIT_TIME; + memcpy(&childPtr->limit.time, &parentPtr->limit.time, sizeof(Tcl_Time)); - slavePtr->limit.timeGranularity = masterPtr->limit.timeGranularity; + childPtr->limit.timeGranularity = parentPtr->limit.timeGranularity; } } /* *---------------------------------------------------------------------- * - * SlaveCommandLimitCmd -- + * ChildCommandLimitCmd -- * * Implementation of the [interp limit $i commands] and [$i limit * commands] subcommands. See the interp manual page for a full @@ -4383,9 +4383,9 @@ InheritLimitsFromMaster( */ static int -SlaveCommandLimitCmd( +ChildCommandLimitCmd( Tcl_Interp *interp, /* Current interpreter. */ - Tcl_Interp *slaveInterp, /* Interpreter being adjusted. */ + Tcl_Interp *childInterp, /* Interpreter being adjusted. */ int consumedObjc, /* Number of args already parsed. */ int objc, /* Total number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -4409,7 +4409,7 @@ SlaveCommandLimitCmd( * avoid. [Bug 3398794] */ - if (interp == slaveInterp) { + if (interp == childInterp) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "limits on current interpreter inaccessible", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "SELF", NULL); @@ -4420,7 +4420,7 @@ SlaveCommandLimitCmd( Tcl_Obj *dictPtr; TclNewObj(dictPtr); - key.interp = slaveInterp; + key.interp = childInterp; key.type = TCL_LIMIT_COMMANDS; hPtr = Tcl_FindHashEntry(&iPtr->limit.callbacks, (char *) &key); if (hPtr != NULL) { @@ -4440,12 +4440,12 @@ SlaveCommandLimitCmd( Tcl_NewStringObj(options[0], -1), empty); } Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[1], -1), - Tcl_NewIntObj(Tcl_LimitGetGranularity(slaveInterp, + Tcl_NewIntObj(Tcl_LimitGetGranularity(childInterp, TCL_LIMIT_COMMANDS))); - if (Tcl_LimitTypeEnabled(slaveInterp, TCL_LIMIT_COMMANDS)) { + if (Tcl_LimitTypeEnabled(childInterp, TCL_LIMIT_COMMANDS)) { Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[2], -1), - Tcl_NewIntObj(Tcl_LimitGetCommands(slaveInterp))); + Tcl_NewIntObj(Tcl_LimitGetCommands(childInterp))); } else { Tcl_Obj *empty; @@ -4462,7 +4462,7 @@ SlaveCommandLimitCmd( } switch ((enum Options) index) { case OPT_CMD: - key.interp = slaveInterp; + key.interp = childInterp; key.type = TCL_LIMIT_COMMANDS; hPtr = Tcl_FindHashEntry(&iPtr->limit.callbacks, (char *) &key); if (hPtr != NULL) { @@ -4474,12 +4474,12 @@ SlaveCommandLimitCmd( break; case OPT_GRAN: Tcl_SetObjResult(interp, Tcl_NewIntObj( - Tcl_LimitGetGranularity(slaveInterp, TCL_LIMIT_COMMANDS))); + Tcl_LimitGetGranularity(childInterp, TCL_LIMIT_COMMANDS))); break; case OPT_VAL: - if (Tcl_LimitTypeEnabled(slaveInterp, TCL_LIMIT_COMMANDS)) { + if (Tcl_LimitTypeEnabled(childInterp, TCL_LIMIT_COMMANDS)) { Tcl_SetObjResult(interp, - Tcl_NewIntObj(Tcl_LimitGetCommands(slaveInterp))); + Tcl_NewIntObj(Tcl_LimitGetCommands(childInterp))); } break; } @@ -4535,18 +4535,18 @@ SlaveCommandLimitCmd( } } if (scriptObj != NULL) { - SetScriptLimitCallback(interp, TCL_LIMIT_COMMANDS, slaveInterp, + SetScriptLimitCallback(interp, TCL_LIMIT_COMMANDS, childInterp, (scriptLen > 0 ? scriptObj : NULL)); } if (granObj != NULL) { - Tcl_LimitSetGranularity(slaveInterp, TCL_LIMIT_COMMANDS, gran); + Tcl_LimitSetGranularity(childInterp, TCL_LIMIT_COMMANDS, gran); } if (limitObj != NULL) { if (limitLen > 0) { - Tcl_LimitSetCommands(slaveInterp, limit); - Tcl_LimitTypeSet(slaveInterp, TCL_LIMIT_COMMANDS); + Tcl_LimitSetCommands(childInterp, limit); + Tcl_LimitTypeSet(childInterp, TCL_LIMIT_COMMANDS); } else { - Tcl_LimitTypeReset(slaveInterp, TCL_LIMIT_COMMANDS); + Tcl_LimitTypeReset(childInterp, TCL_LIMIT_COMMANDS); } } return TCL_OK; @@ -4556,7 +4556,7 @@ SlaveCommandLimitCmd( /* *---------------------------------------------------------------------- * - * SlaveTimeLimitCmd -- + * ChildTimeLimitCmd -- * * Implementation of the [interp limit $i time] and [$i limit time] * subcommands. See the interp manual page for a full description. @@ -4571,9 +4571,9 @@ SlaveCommandLimitCmd( */ static int -SlaveTimeLimitCmd( +ChildTimeLimitCmd( Tcl_Interp *interp, /* Current interpreter. */ - Tcl_Interp *slaveInterp, /* Interpreter being adjusted. */ + Tcl_Interp *childInterp, /* Interpreter being adjusted. */ int consumedObjc, /* Number of args already parsed. */ int objc, /* Total number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -4597,7 +4597,7 @@ SlaveTimeLimitCmd( * avoid. [Bug 3398794] */ - if (interp == slaveInterp) { + if (interp == childInterp) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "limits on current interpreter inaccessible", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "SELF", NULL); @@ -4608,7 +4608,7 @@ SlaveTimeLimitCmd( Tcl_Obj *dictPtr; TclNewObj(dictPtr); - key.interp = slaveInterp; + key.interp = childInterp; key.type = TCL_LIMIT_TIME; hPtr = Tcl_FindHashEntry(&iPtr->limit.callbacks, (char *) &key); if (hPtr != NULL) { @@ -4627,13 +4627,13 @@ SlaveTimeLimitCmd( Tcl_NewStringObj(options[0], -1), empty); } Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[1], -1), - Tcl_NewIntObj(Tcl_LimitGetGranularity(slaveInterp, + Tcl_NewIntObj(Tcl_LimitGetGranularity(childInterp, TCL_LIMIT_TIME))); - if (Tcl_LimitTypeEnabled(slaveInterp, TCL_LIMIT_TIME)) { + if (Tcl_LimitTypeEnabled(childInterp, TCL_LIMIT_TIME)) { Tcl_Time limitMoment; - Tcl_LimitGetTime(slaveInterp, &limitMoment); + Tcl_LimitGetTime(childInterp, &limitMoment); Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[2], -1), Tcl_NewLongObj(limitMoment.usec/1000)); Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[3], -1), @@ -4656,7 +4656,7 @@ SlaveTimeLimitCmd( } switch ((enum Options) index) { case OPT_CMD: - key.interp = slaveInterp; + key.interp = childInterp; key.type = TCL_LIMIT_TIME; hPtr = Tcl_FindHashEntry(&iPtr->limit.callbacks, (char *) &key); if (hPtr != NULL) { @@ -4668,22 +4668,22 @@ SlaveTimeLimitCmd( break; case OPT_GRAN: Tcl_SetObjResult(interp, Tcl_NewIntObj( - Tcl_LimitGetGranularity(slaveInterp, TCL_LIMIT_TIME))); + Tcl_LimitGetGranularity(childInterp, TCL_LIMIT_TIME))); break; case OPT_MILLI: - if (Tcl_LimitTypeEnabled(slaveInterp, TCL_LIMIT_TIME)) { + if (Tcl_LimitTypeEnabled(childInterp, TCL_LIMIT_TIME)) { Tcl_Time limitMoment; - Tcl_LimitGetTime(slaveInterp, &limitMoment); + Tcl_LimitGetTime(childInterp, &limitMoment); Tcl_SetObjResult(interp, Tcl_NewLongObj(limitMoment.usec/1000)); } break; case OPT_SEC: - if (Tcl_LimitTypeEnabled(slaveInterp, TCL_LIMIT_TIME)) { + if (Tcl_LimitTypeEnabled(childInterp, TCL_LIMIT_TIME)) { Tcl_Time limitMoment; - Tcl_LimitGetTime(slaveInterp, &limitMoment); + Tcl_LimitGetTime(childInterp, &limitMoment); Tcl_SetObjResult(interp, Tcl_NewLongObj(limitMoment.sec)); } break; @@ -4700,7 +4700,7 @@ SlaveTimeLimitCmd( Tcl_Time limitMoment; int tmp; - Tcl_LimitGetTime(slaveInterp, &limitMoment); + Tcl_LimitGetTime(childInterp, &limitMoment); for (i=consumedObjc ; i 0 ? scriptObj : NULL)); } if (granObj != NULL) { - Tcl_LimitSetGranularity(slaveInterp, TCL_LIMIT_TIME, gran); + Tcl_LimitSetGranularity(childInterp, TCL_LIMIT_TIME, gran); } return TCL_OK; } diff --git a/generic/tclLoad.c b/generic/tclLoad.c index 062f007..5a736de 100644 --- a/generic/tclLoad.c +++ b/generic/tclLoad.c @@ -196,9 +196,9 @@ Tcl_LoadObjCmd( target = interp; if (objc == 4) { - const char *slaveIntName = Tcl_GetString(objv[3]); + const char *childIntName = Tcl_GetString(objv[3]); - target = Tcl_GetChild(interp, slaveIntName); + target = Tcl_GetChild(interp, childIntName); if (target == NULL) { code = TCL_ERROR; goto done; @@ -619,9 +619,9 @@ Tcl_UnloadObjCmd( target = interp; if (objc - i == 3) { - const char *slaveIntName = Tcl_GetString(objv[i + 2]); + const char *childIntName = Tcl_GetString(objv[i + 2]); - target = Tcl_GetChild(interp, slaveIntName); + target = Tcl_GetChild(interp, childIntName); if (target == NULL) { return TCL_ERROR; } diff --git a/generic/tclOO.c b/generic/tclOO.c index c1db80c..f8a0f12 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -132,7 +132,7 @@ static const Tcl_MethodType classConstructor = { }; /* - * Scripted parts of TclOO. First, the master script (cannot be outside this + * Scripted parts of TclOO. First, the main script (cannot be outside this * file). */ diff --git a/generic/tclOOInfo.c b/generic/tclOOInfo.c index c9263b5..4b25c1a 100644 --- a/generic/tclOOInfo.c +++ b/generic/tclOOInfo.c @@ -110,7 +110,7 @@ TclOOInitInfo( TclMakeEnsemble(interp, "::oo::InfoClass", infoClassCmds); /* - * Install into the master [info] ensemble. + * Install into the [info] ensemble. */ infoCmd = Tcl_FindCommand(interp, "info", NULL, TCL_GLOBAL_ONLY); diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h index 0e4503a..44316ac 100644 --- a/generic/tclOOInt.h +++ b/generic/tclOOInt.h @@ -277,7 +277,7 @@ typedef struct Class { */ typedef struct ThreadLocalData { - int nsCount; /* Master epoch counter is used for keeping + int nsCount; /* Epoch counter is used for keeping * the values used in Tcl_Obj internal * representations sane. Must be thread-local * because Tcl_Objs can cross interpreter @@ -289,7 +289,7 @@ typedef struct Foundation { Tcl_Interp *interp; Class *objectCls; /* The root of the object system. */ Class *classCls; /* The class of all classes. */ - Tcl_Namespace *ooNs; /* Master ::oo namespace. */ + Tcl_Namespace *ooNs; /* ::oo namespace. */ Tcl_Namespace *defineNs; /* Namespace containing special commands for * manipulating objects and classes. The * "oo::define" command acts as a special kind diff --git a/generic/tclParse.c b/generic/tclParse.c index 7a51dae..57b2b35 100644 --- a/generic/tclParse.c +++ b/generic/tclParse.c @@ -2172,7 +2172,7 @@ TclSubstTokens( * command, which is refered to by 'script'. * The 'clNextOuter' refers to the current * entry in the table of continuation lines in - * this "master script", and the character + * this "main script", and the character * offsets are relative to the 'outerScript' * as well. * diff --git a/generic/tclTest.c b/generic/tclTest.c index 7624004..297cd11 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -1508,15 +1508,15 @@ TestdelCmd( const char **argv) /* Argument strings. */ { DelCmd *dPtr; - Tcl_Interp *slave; + Tcl_Interp *child; if (argc != 4) { Tcl_SetResult(interp, "wrong # args", TCL_STATIC); return TCL_ERROR; } - slave = Tcl_GetChild(interp, argv[1]); - if (slave == NULL) { + child = Tcl_GetChild(interp, argv[1]); + if (child == NULL) { return TCL_ERROR; } @@ -1525,7 +1525,7 @@ TestdelCmd( dPtr->deleteCmd = (char *)ckalloc(strlen(argv[3]) + 1); strcpy(dPtr->deleteCmd, argv[3]); - Tcl_CreateCommand(slave, argv[2], DelCmdProc, (ClientData) dPtr, + Tcl_CreateCommand(child, argv[2], DelCmdProc, (ClientData) dPtr, DelDeleteProc); return TCL_OK; } @@ -2691,18 +2691,18 @@ TestinterpdeleteCmd( int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ { - Tcl_Interp *slaveToDelete; + Tcl_Interp *childToDelete; if (argc != 2) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " path\"", NULL); return TCL_ERROR; } - slaveToDelete = Tcl_GetChild(interp, argv[1]); - if (slaveToDelete == NULL) { + childToDelete = Tcl_GetChild(interp, argv[1]); + if (childToDelete == NULL) { return TCL_ERROR; } - Tcl_DeleteInterp(slaveToDelete); + Tcl_DeleteInterp(childToDelete); return TCL_OK; } diff --git a/library/auto.tcl b/library/auto.tcl index 27173df..825aeeb 100644 --- a/library/auto.tcl +++ b/library/auto.tcl @@ -376,10 +376,10 @@ proc auto_mkindex_parser::mkindex {file} { # auto_mkindex_parser::hook command # -# Registers a Tcl command to evaluate when initializing the slave interpreter +# Registers a Tcl command to evaluate when initializing the child interpreter # used by the mkindex parser. The command is evaluated in the parent # interpreter, and can use the variable auto_mkindex_parser::parser to get to -# the slave +# the child proc auto_mkindex_parser::hook {cmd} { variable initCommands @@ -389,14 +389,14 @@ proc auto_mkindex_parser::hook {cmd} { # auto_mkindex_parser::slavehook command # -# Registers a Tcl command to evaluate when initializing the slave interpreter -# used by the mkindex parser. The command is evaluated in the slave +# Registers a Tcl command to evaluate when initializing the child interpreter +# used by the mkindex parser. The command is evaluated in the child # interpreter. proc auto_mkindex_parser::slavehook {cmd} { variable initCommands - # The $parser variable is defined to be the name of the slave interpreter + # The $parser variable is defined to be the name of the child interpreter # when this command is used later. lappend initCommands "\$parser eval [list $cmd]" @@ -550,7 +550,7 @@ auto_mkindex_parser::command proc {name args} { # Conditionally add support for Tcl byte code files. There are some tricky # details here. First, we need to get the tbcload library initialized in the -# current interpreter. We cannot load tbcload into the slave until we have +# current interpreter. We cannot load tbcload into the child until we have # done so because it needs access to the tcl_patchLevel variable. Second, # because the package index file may defer loading the library until we invoke # a command, we need to explicitly invoke auto_load to force it to be loaded. diff --git a/tests/appendComp.test b/tests/appendComp.test index bbf5f9c..a0069ac 100644 --- a/tests/appendComp.test +++ b/tests/appendComp.test @@ -359,9 +359,9 @@ test appendComp-7.9 {append var does not trigger read trace} -setup { } -result {0} test appendComp-8.1 {defer error to runtime} -setup { - interp create slave + interp create child } -body { - slave eval { + child eval { proc foo {} { proc append args {} append @@ -369,7 +369,7 @@ test appendComp-8.1 {defer error to runtime} -setup { foo } } -cleanup { - interp delete slave + interp delete child } -result {} # New tests for bug 3057639 to show off the more consistent behaviour of diff --git a/tests/autoMkindex.test b/tests/autoMkindex.test index 4721553..6768772 100644 --- a/tests/autoMkindex.test +++ b/tests/autoMkindex.test @@ -146,10 +146,10 @@ test autoMkindex-1.3 {examine tclIndex} -setup { test autoMkindex-2.1 {commands on the autoload path can be imported} -setup { file delete tclIndex - interp create slave + interp create child } -body { auto_mkindex . autoMkindex.tcl - slave eval { + child eval { namespace eval blt {} set auto_path [linsert $auto_path 0 .] set info [list [catch {namespace import buried::*} result] $result] @@ -159,7 +159,7 @@ test autoMkindex-2.1 {commands on the autoload path can be imported} -setup { return $info } } -cleanup { - interp delete slave + interp delete child } -result "0 {} pub_one ::buried::pub_one pub_two ::buried::pub_two" # Test auto_mkindex hooks @@ -180,7 +180,7 @@ test autoMkindex-3.1 {slaveHook} -setup { } -cleanup { # Reset initCommands to avoid trashing other tests AutoMkindexTestReset -} -result 1 +} -result 1 # The auto_mkindex_parser::command is used to register commands that create # new commands. test autoMkindex-3.2 {auto_mkindex_parser::command} -setup { @@ -335,14 +335,14 @@ test autoMkindex-5.2 {correctly locate auto loaded procs with []} -setup { proc {[magic mojo proc]} {} {} } [file join pkg magicchar2.tcl] set result {} - interp create slave + interp create child } -body { auto_mkindex . pkg/magicchar2.tcl - # Make a slave interp to test the autoloading - slave eval {lappend auto_path [pwd]} - slave eval {catch {{[magic mojo proc]}}} + # Make a child interp to test the autoloading + child eval {lappend auto_path [pwd]} + child eval {catch {{[magic mojo proc]}}} } -cleanup { - interp delete slave + interp delete child removeFile [file join pkg magicchar2.tcl] removeDirectory pkg } -result 0 diff --git a/tests/basic.test b/tests/basic.test index 5066877..bea5870 100644 --- a/tests/basic.test +++ b/tests/basic.test @@ -256,7 +256,7 @@ test basic-18.1 {TclRenameCommand, name of existing cmd can have namespace quali } list [test_ns_basic::p] \ [rename test_ns_basic::p test_ns_basic::q] \ - [test_ns_basic::q] + [test_ns_basic::q] } {{p in ::test_ns_basic} {} {p in ::test_ns_basic}} test basic-18.2 {TclRenameCommand, existing cmd must be found} { catch {namespace delete {*}[namespace children :: test_ns_*]} @@ -469,11 +469,11 @@ test basic-26.2 {Tcl_EvalObjEx, pure-list branch: preserve "objv"} -body { # a - the pure-list internal rep is destroyed by shimmering # b - the command returns an error # As the error code in Tcl_EvalObjv accesses the list elements, this will - # cause a segfault if [Bug 1119369] has not been fixed. + # cause a segfault if [Bug 1119369] has not been fixed. # NOTE: a MEM_DEBUG build may be necessary to guarantee the segfault. # - set SRC [list foo 1] ;# pure-list command + set SRC [list foo 1] ;# pure-list command proc foo str { # Shimmer pure-list to cmdName, cleanup and error proc $::SRC {} {}; $::SRC @@ -491,11 +491,11 @@ test basic-26.3 {Tcl_EvalObjEx, pure-list branch: preserve "objv"} -body { # Follow the pure-list branch in a manner that # a - the pure-list internal rep is destroyed by shimmering # b - the command accesses its command line - # This will cause a segfault if [Bug 1119369] has not been fixed. + # This will cause a segfault if [Bug 1119369] has not been fixed. # NOTE: a MEM_DEBUG build may be necessary to guarantee the segfault. # - set SRC [list foo 1] ;# pure-list command + set SRC [list foo 1] ;# pure-list command proc foo str { # Shimmer pure-list to cmdName, cleanup and error proc $::SRC {} {}; $::SRC @@ -607,7 +607,7 @@ test basic-46.2 {Tcl_AllowExceptions: exception return not allowed} -setup { invoked "break" outside of a loop while executing "break" - (file "*BREAKtest" line 3)} + (file "*BREAKtest" line 3)} test basic-46.3 {Tcl_AllowExceptions: exception return not allowed} -setup { set fName [makeFile { @@ -624,7 +624,7 @@ test basic-46.3 {Tcl_AllowExceptions: exception return not allowed} -setup { } -returnCodes error -match glob -result {invoked "break" outside of a loop while executing "break" - (file "*BREAKtest" line 4)} + (file "*BREAKtest" line 4)} test basic-46.4 {Tcl_AllowExceptions: exception return not allowed} -setup { set fName [makeFile { @@ -752,7 +752,7 @@ test basic-48.1.$noComp {expansion: parsing} $constraints { # Another comment list 1 2\ 3 {*}$::l1 - + # Comment again } } {1 2 3 a {b b} c d} @@ -825,7 +825,7 @@ test basic-48.13.$noComp {expansion: odd usage} $constraints { test basic-48.14.$noComp {expansion: hash command} -setup { catch {rename \# ""} set cmd "#" - } -constraints $constraints -body { + } -constraints $constraints -body { run { {*}$cmd apa bepa } } -cleanup { unset cmd @@ -885,7 +885,7 @@ test basic-48.16.$noComp {expansion: testing for leaks} -setup { stress set tmp $end set end [getbytes] - } + } set leak [expr {$end - $tmp}] } -cleanup { unset end i tmp @@ -896,7 +896,7 @@ test basic-48.16.$noComp {expansion: testing for leaks} -setup { test basic-48.17.$noComp {expansion: object safety} -setup { set old_precision $::tcl_precision set ::tcl_precision 4 - } -constraints $constraints -body { + } -constraints $constraints -body { set third [expr {1.0/3.0}] set l [list $third $third] set x [run {list $third {*}$l $third}] @@ -1003,13 +1003,13 @@ test basic-49.2 {Tcl_EvalEx: verify TCL_EVAL_GLOBAL operation} testevalex { } {global} test basic-50.1 {[586e71dce4] EvalObjv level #0 exception handling} -setup { - interp create slave - interp alias {} foo slave return + interp create child + interp alias {} foo child return } -body { list [catch foo m] $m } -cleanup { unset -nocomplain m - interp delete slave + interp delete child } -result {0 {}} # Clean up after expand tests diff --git a/tests/cmdAH.test b/tests/cmdAH.test index f19e11a..3809f23 100644 --- a/tests/cmdAH.test +++ b/tests/cmdAH.test @@ -1638,7 +1638,7 @@ test cmdAH-31.9 {Tcl_FileObjCmd: channels in other interp} { lsort [safeInterp eval [list file channels]] } [lsort [list stdout $newFileId]] test cmdAH-31.10 {Tcl_FileObjCmd: channels in other interp} { - # we can now write to $newFileId from slave + # we can now write to $newFileId from child safeInterp eval [list puts $newFileId "hello"] } {} interp transfer {} $newFileId safeInterp diff --git a/tests/compExpr.test b/tests/compExpr.test index 14c875d..d1739de 100644 --- a/tests/compExpr.test +++ b/tests/compExpr.test @@ -353,9 +353,9 @@ test compExpr-7.1 {Memory Leak} -constraints memory -setup { } -body { set end [getbytes] for {set i 0} {$i < 5} {incr i} { - interp create slave - slave eval expr 1+2+3+4+5+6+7+8+9+10+11+12+13 - interp delete slave + interp create child + child eval expr 1+2+3+4+5+6+7+8+9+10+11+12+13 + interp delete child set tmp $end set end [getbytes] } diff --git a/tests/coroutine.test b/tests/coroutine.test index df545f5..4c35460 100644 --- a/tests/coroutine.test +++ b/tests/coroutine.test @@ -66,7 +66,7 @@ test coroutine-1.3 {yield returns new arg} -setup { incr i } } - coroutine foo ::apply [list {{start 2} {stop 10}} $body] + coroutine foo ::apply [list {{start 2} {stop 10}} $body] set res {} } -body { for {set k 1} {$k < 4} {incr k} { @@ -476,7 +476,7 @@ test coroutine-5.1 {right numLevels on coro return} -constraints {testnrelevels} expr {[lindex [testnrelevels] 1] - 1} } proc relativeLevel base { - # remove the level for this proc's call + # remove the level for this proc's call expr {[getNumLevel] - $base - 1} } proc foo {} { @@ -517,7 +517,7 @@ test coroutine-5.2 {right numLevels within coro} -constraints {testnrelevels} \ expr {[lindex [testnrelevels] 1] - 1} } proc relativeLevel base { - # remove the level for this proc's call + # remove the level for this proc's call expr {[getNumLevel] - $base - 1} } proc foo base { @@ -588,7 +588,7 @@ test coroutine-7.2 {multi-argument yielding with yieldto} -body { coroutine a corobody coroutine b corobody list [a x] [a y z] [a \{p] [a \{q r] [a] [a] [rename a {}] \ - [b ok] [rename b {}] + [b ok] [rename b {}] } -cleanup { rename corobody {} } -result {x {y z 2} \{p {\{q r 2} {} 0 {} ok {}} @@ -771,25 +771,25 @@ test coroutine-8.0.1 {coro inject after error} -body { lappend ::result [catch {demo} err] $err } -result {inject-executed 1 test} test coroutine-8.1.1 {coro inject, ticket 42202ba1e5ff566e} -body { - interp create slave - slave eval { + interp create child + child eval { coroutine demo apply {{} { while {1} yield }} demo tcl::unsupported::inject demo set ::result inject-executed } - interp delete slave + interp delete child } -result {} test coroutine-8.1.2 {coro inject with result, ticket 42202ba1e5ff566e} -body { - interp create slave - slave eval { + interp create child + child eval { coroutine demo apply {{} { while {1} yield }} demo tcl::unsupported::inject demo set ::result inject-executed } - slave eval demo - set result [slave eval {set ::result}] + child eval demo + set result [child eval {set ::result}] - interp delete slave + interp delete child set result } -result {inject-executed} diff --git a/tests/env.test b/tests/env.test index 8eb5612..9b8016c 100644 --- a/tests/env.test +++ b/tests/env.test @@ -324,11 +324,11 @@ test env-5.2 {corner cases - unset the env array} -setup { } -result {0} -test env-5.3 {corner cases: unset the env in master should unset child} -setup { +test env-5.3 {corner cases: unset the env in parent should unset child} -setup { setup1 interp create i } -body { - # Variables deleted in a master interp should be deleted in child interp + # Variables deleted in a parent interp should be deleted in child interp # too. i eval {set env(THIS_SHOULD_EXIST) a} set result [set env(THIS_SHOULD_EXIST)] diff --git a/tests/execute.test b/tests/execute.test index 468901d..da3e2d4 100644 --- a/tests/execute.test +++ b/tests/execute.test @@ -657,56 +657,56 @@ test execute-6.8 {TclCompEvalObj: bytecode name resolution epoch validation} -se namespace delete foo } -result {0 AHA!} test execute-6.9 {TclCompEvalObj: bytecode interp validation} -setup { - interp create slave + interp create child } -body { set script { llength {} } - slave eval {proc llength args {return AHA!}} + child eval {proc llength args {return AHA!}} set result {} lappend result [if 1 $script] - lappend result [slave eval $script] + lappend result [child eval $script] } -cleanup { - interp delete slave + interp delete child } -result {0 AHA!} test execute-6.10 {TclCompEvalObj: bytecode interp validation} -body { set script { llength {} } - interp create slave + interp create child set result {} - lappend result [slave eval $script] - interp delete slave - interp create slave - lappend result [slave eval $script] + lappend result [child eval $script] + interp delete child + interp create child + lappend result [child eval $script] } -cleanup { - catch {interp delete slave} + catch {interp delete child} } -result {0 0} test execute-6.11 {Tcl_ExprObj: exprcode interp validation} -setup { - interp create slave + interp create child } -constraints testexprlongobj -body { set e { [llength {}]+1 } set result {} - load {} Tcltest slave - interp alias {} e slave testexprlongobj + load {} Tcltest child + interp alias {} e child testexprlongobj lappend result [e $e] - interp delete slave - interp create slave - load {} Tcltest slave - interp alias {} e slave testexprlongobj + interp delete child + interp create child + load {} Tcltest child + interp alias {} e child testexprlongobj lappend result [e $e] } -cleanup { - interp delete slave + interp delete child } -result {{This is a result: 1} {This is a result: 1}} test execute-6.12 {Tcl_ExprObj: exprcode interp validation} -setup { - interp create slave + interp create child } -body { set e { [llength {}]+1 } set result {} - interp alias {} e slave expr + interp alias {} e child expr lappend result [e $e] - interp delete slave - interp create slave - interp alias {} e slave expr + interp delete child + interp create child + interp alias {} e child expr lappend result [e $e] } -cleanup { - interp delete slave + interp delete child } -result {1 1} test execute-6.13 {Tcl_ExprObj: exprcode epoch validation} -body { set e { [llength {}]+1 } @@ -747,16 +747,16 @@ test execute-6.15 {Tcl_ExprObj: exprcode name resolution epoch validation} -setu namespace delete foo } -result {1 2} test execute-6.16 {Tcl_ExprObj: exprcode interp validation} -setup { - interp create slave + interp create child } -body { set e { [llength {}]+1 } - interp alias {} e slave expr - slave eval {proc llength args {return 1}} + interp alias {} e child expr + child eval {proc llength args {return 1}} set result {} lappend result [expr $e] lappend result [e $e] } -cleanup { - interp delete slave + interp delete child } -result {1 2} test execute-6.17 {Tcl_ExprObj: exprcode context validation} -body { proc foo e {set v 0; expr $e} @@ -982,8 +982,8 @@ test execute-8.5 {Bug 2038069} -setup { "catch \[list error FOO\] m o"} -errorline 2} test execute-8.6 {Compile epoch bump in global level (bug [fa6bf38d07])} -setup { - interp create slave - slave eval { + interp create child + child eval { package require tcltest catch [list package require -exact Tcltest [info patchlevel]] ::tcltest::loadTestedCommands @@ -992,31 +992,31 @@ test execute-8.6 {Compile epoch bump in global level (bug [fa6bf38d07])} -setup } } } -body { - slave eval { + child eval { lappend res A; testbumpinterpepoch; lappend res B; return; lappend res C; } - slave eval { + child eval { set i 0; while {[incr i] < 3} { lappend res A; testbumpinterpepoch; lappend res B; return; lappend res C; } } - slave eval { + child eval { set i 0; while {[incr i] < 3} { lappend res A; testbumpinterpepoch; lappend res B; break; lappend res C; } } - slave eval { + child eval { catch { lappend res A; testbumpinterpepoch; lappend res B; error test; lappend res C; } } - slave eval {set res} + child eval {set res} } -cleanup { - interp delete slave + interp delete child } -result [lrepeat 4 A B] test execute-8.7 {Compile epoch bump in global level (bug [fa6bf38d07]), exception case} -setup { - interp create slave - slave eval { + interp create child + child eval { package require tcltest catch [list package require -exact Tcltest [info patchlevel]] ::tcltest::loadTestedCommands @@ -1027,28 +1027,28 @@ test execute-8.7 {Compile epoch bump in global level (bug [fa6bf38d07]), excepti } -body { set res {} lappend res [catch { - slave eval { + child eval { lappend res A; testbumpinterpepoch; lappend res B; return -code error test; lappend res C; } } e] $e lappend res [catch { - slave eval { + child eval { lappend res A; testbumpinterpepoch; lappend res B; error test; lappend res C; } } e] $e lappend res [catch { - slave eval { + child eval { lappend res A; testbumpinterpepoch; lappend res B; return -code return test; lappend res C; } } e] $e lappend res [catch { - slave eval { + child eval { lappend res A; testbumpinterpepoch; lappend res B; break; lappend res C; } } e] $e - list $res [slave eval {set res}] + list $res [child eval {set res}] } -cleanup { - interp delete slave + interp delete child } -result [list {1 test 1 test 2 test 3 {}} [lrepeat 4 A B]] test execute-9.1 {Interp result resetting [Bug 1522803]} { @@ -1069,16 +1069,16 @@ test execute-10.1 {TclExecuteByteCode, INST_CONCAT1, bytearrays} { apply {s {binary scan $s c x; list $x [scan $s$s %c%c]}} \u0130 } {48 {304 304}} test execute-10.2 {Bug 2802881} -setup { - interp create slave + interp create child } -body { # If [Bug 2802881] is not fixed, this will segfault - slave eval { + child eval { trace add variable ::errorInfo write {expr {$foo} ;#} proc demo {} {a {}{}} demo } } -cleanup { - interp delete slave + interp delete child } -returnCodes error -match glob -result * test execute-10.3 {Bug 3072640} -setup { proc generate {n} { @@ -1086,8 +1086,8 @@ test execute-10.3 {Bug 3072640} -setup { yield $i } } - proc t {args} { - incr ::foo + proc t {args} { + incr ::foo } set ::foo 0 trace add execution ::generate enterstep ::t @@ -1103,9 +1103,9 @@ test execute-10.3 {Bug 3072640} -setup { } -result 4 test execute-11.1 {Bug 3142026: GrowEvaluationStack off-by-one} -setup { - interp create slave + interp create child } -body { - slave eval { + child eval { set x [lrepeat 1320 199] for {set i 0} {$i < 20} {incr i} { lappend x $i @@ -1115,7 +1115,7 @@ test execute-11.1 {Bug 3142026: GrowEvaluationStack off-by-one} -setup { return ok } } -cleanup { - interp delete slave + interp delete child } -result ok test execute-11.2 {Bug 268b23df11} -setup { diff --git a/tests/http.test b/tests/http.test index 73fe10c..e6255bf 100644 --- a/tests/http.test +++ b/tests/http.test @@ -19,7 +19,7 @@ if {[catch {package require http 2} version]} { catch {puts "Cannot load http 2.* package"} return } else { - catch {puts "Running http 2.* tests in slave interp"} + catch {puts "Running http 2.* tests in child interp"} set interp [interp create http2] $interp eval [list set http2 "running"] $interp eval [list set argv $argv] diff --git a/tests/httpold.test b/tests/httpold.test index e63bcda..acc5a6e 100644 --- a/tests/httpold.test +++ b/tests/httpold.test @@ -22,7 +22,7 @@ if {[catch {package require http 1.0}]} { ::tcltest::cleanupTests return } else { - catch {puts "Running http 1.0 tests in slave interp"} + catch {puts "Running http 1.0 tests in child interp"} set interp [interp create httpold] $interp eval [list set httpold "running"] $interp eval [list set argv $argv] diff --git a/tests/interp.test b/tests/interp.test index 3fe8c67..8a4d064 100644 --- a/tests/interp.test +++ b/tests/interp.test @@ -56,7 +56,7 @@ test interp-1.8 {options for interp command} -returnCodes error -body { } -result {bad option "-froboz": must be alias, aliases, bgerror, cancel, children, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer} test interp-1.9 {options for interp command} -returnCodes error -body { interp -froboz -safe -} -result {bad option "-froboz": must be alias, aliases, bgerror, cancel, children, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer} +} -result {bad option "-froboz": must be alias, aliases, bgerror, cancel, children, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer} test interp-1.10 {options for interp command} -returnCodes error -body { interp target } -result {wrong # args: should be "interp target path alias"} @@ -70,7 +70,7 @@ test interp-2.2 {basic interpreter creation} { } 0 test interp-2.3 {basic interpreter creation} { catch {interp create -safe} -} 0 +} 0 test interp-2.4 {basic interpreter creation} -setup { catch {interp create a} } -returnCodes error -body { @@ -106,7 +106,7 @@ test interp-2.11 {anonymous interps vs existing procs} { set x [interp create] regexp "interp(\[0-9]+)" $x dummy anothernum expr $anothernum > $thenum -} 1 +} 1 test interp-2.12 {anonymous interps vs existing procs} { set x [interp create -safe] regexp "interp(\[0-9]+)" $x dummy thenum @@ -247,27 +247,27 @@ test interp-6.6 {testing eval} -returnCodes error -body { interp eval {a x2} foo } -result {invalid command name "foo"} -# UTILITY PROCEDURE RUNNING IN MASTER INTERPRETER: -proc in_master {args} { - return [list seen in master: $args] +# UTILITY PROCEDURE RUNNING IN PARENT INTERPRETER: +proc in_parent {args} { + return [list seen in parent: $args] } # Part 6: Testing basic alias creation test interp-7.1 {testing basic alias creation} { - a alias foo in_master + a alias foo in_parent } foo -catch {a alias foo in_master} +catch {a alias foo in_parent} test interp-7.2 {testing basic alias creation} { - a alias bar in_master a1 a2 a3 + a alias bar in_parent a1 a2 a3 } bar -catch {a alias bar in_master a1 a2 a3} +catch {a alias bar in_parent a1 a2 a3} # Test 6.3 has been deleted. test interp-7.3 {testing basic alias creation} { a alias foo -} in_master +} in_parent test interp-7.4 {testing basic alias creation} { a alias bar -} {in_master a1 a2 a3} +} {in_parent a1 a2 a3} test interp-7.5 {testing basic alias creation} { lsort [a aliases] } {bar foo} @@ -278,14 +278,14 @@ test interp-7.6 {testing basic aliases arg checking} -returnCodes error -body { # Part 7: testing basic alias invocation test interp-8.1 {testing basic alias invocation} { catch {interp create a} - a alias foo in_master + a alias foo in_parent a eval foo s1 s2 s3 -} {seen in master: {s1 s2 s3}} +} {seen in parent: {s1 s2 s3}} test interp-8.2 {testing basic alias invocation} { catch {interp create a} - a alias bar in_master a1 a2 a3 + a alias bar in_parent a1 a2 a3 a eval bar s1 s2 s3 -} {seen in master: {a1 a2 a3 s1 s2 s3}} +} {seen in parent: {a1 a2 a3 s1 s2 s3}} test interp-8.3 {testing basic alias invocation} -returnCodes error -body { catch {interp create a} a alias @@ -294,13 +294,13 @@ test interp-8.3 {testing basic alias invocation} -returnCodes error -body { # Part 8: Testing aliases for non-existent or hidden targets test interp-9.1 {testing aliases for non-existent targets} { catch {interp create a} - a alias zop nonexistent-command-in-master + a alias zop nonexistent-command-in-parent list [catch {a eval zop} msg] $msg -} {1 {invalid command name "nonexistent-command-in-master"}} +} {1 {invalid command name "nonexistent-command-in-parent"}} test interp-9.2 {testing aliases for non-existent targets} { catch {interp create a} - a alias zop nonexistent-command-in-master - proc nonexistent-command-in-master {} {return i_exist!} + a alias zop nonexistent-command-in-parent + proc nonexistent-command-in-parent {} {return i_exist!} a eval zop } i_exist! test interp-9.3 {testing aliases for hidden commands} { @@ -329,8 +329,8 @@ test interp-9.4 {testing aliases and namespace commands} { set res } {GLOBAL GLOBAL} -if {[info command nonexistent-command-in-master] != ""} { - rename nonexistent-command-in-master {} +if {[info command nonexistent-command-in-parent] != ""} { + rename nonexistent-command-in-parent {} } # Part 9: Aliasing between interpreters @@ -380,9 +380,9 @@ test interp-10.6 {testing aliasing between interpreters} { interp create a interp create b interp alias a a_command b b_command a1 a2 a3 - b alias b_command in_master b1 b2 b3 + b alias b_command in_parent b1 b2 b3 a eval a_command m1 m2 m3 -} {seen in master: {b1 b2 b3 a1 a2 a3 m1 m2 m3}} +} {seen in parent: {b1 b2 b3 a1 a2 a3 m1 m2 m3}} test interp-10.7 {testing aliases between interpreters} { catch {interp delete a} interp create a @@ -513,7 +513,7 @@ test interp-14.3 {testing interp aliases} { interp alias {a x3} froboz "" puts interp aliases {a x3} } froboz -test interp-14.4 {testing interp alias - alias over master} { +test interp-14.4 {testing interp alias - alias over parent} { # SF Bug 641195 catch {interp delete a} interp create a @@ -793,32 +793,32 @@ test interp-17.6 {alias loop prevention} { } {1 {cannot define or rename alias "b": would create a loop}} # -# Test robustness of Tcl_DeleteInterp when applied to a slave interpreter. +# Test robustness of Tcl_DeleteInterp when applied to a child interpreter. # If there are bugs in the implementation these tests are likely to expose # the bugs as a core dump. # -test interp-18.1 {testing Tcl_DeleteInterp vs slaves} testinterpdelete { +test interp-18.1 {testing Tcl_DeleteInterp vs children} testinterpdelete { list [catch {testinterpdelete} msg] $msg } {1 {wrong # args: should be "testinterpdelete path"}} -test interp-18.2 {testing Tcl_DeleteInterp vs slaves} testinterpdelete { +test interp-18.2 {testing Tcl_DeleteInterp vs children} testinterpdelete { catch {interp delete a} interp create a testinterpdelete a } "" -test interp-18.3 {testing Tcl_DeleteInterp vs slaves} testinterpdelete { +test interp-18.3 {testing Tcl_DeleteInterp vs children} testinterpdelete { catch {interp delete a} interp create a interp create {a b} testinterpdelete {a b} } "" -test interp-18.4 {testing Tcl_DeleteInterp vs slaves} testinterpdelete { +test interp-18.4 {testing Tcl_DeleteInterp vs children} testinterpdelete { catch {interp delete a} interp create a interp create {a b} testinterpdelete a } "" -test interp-18.5 {testing Tcl_DeleteInterp vs slaves} testinterpdelete { +test interp-18.5 {testing Tcl_DeleteInterp vs children} testinterpdelete { catch {interp delete a} interp create a interp create {a b} @@ -826,7 +826,7 @@ test interp-18.5 {testing Tcl_DeleteInterp vs slaves} testinterpdelete { proc dodel {x} {testinterpdelete $x} list [catch {interp eval {a b} {dodel {a b}}} msg] $msg } {0 {}} -test interp-18.6 {testing Tcl_DeleteInterp vs slaves} testinterpdelete { +test interp-18.6 {testing Tcl_DeleteInterp vs children} testinterpdelete { catch {interp delete a} interp create a interp create {a b} @@ -876,12 +876,12 @@ test interp-18.9 {eval in deleted interp, bug 495830} { interp create tst interp alias tst suicide {} interp delete tst list [catch {tst eval {suicide; set a 5}} msg] $msg -} {1 {attempt to call eval in deleted interpreter}} +} {1 {attempt to call eval in deleted interpreter}} test interp-18.10 {eval in deleted interp, bug 495830} { interp create tst interp alias tst suicide {} interp delete tst list [catch {tst eval {set set set; suicide; $set a 5}} msg] $msg -} {1 {attempt to call eval in deleted interpreter}} +} {1 {attempt to call eval in deleted interpreter}} # Test alias deletion @@ -971,7 +971,7 @@ test interp-19.9 {alias deletion, renaming} { set l [interp eval a foo] interp delete a set l -} 1156 +} 1156 test interp-20.1 {interp hide, interp expose and interp invokehidden} { set a [interp create] @@ -1192,7 +1192,7 @@ test interp-20.21 {interp hide vs safety} { catch {interp delete a} interp create a -safe set l "" - lappend l [catch {a hide list} msg] + lappend l [catch {a hide list} msg] lappend l $msg interp delete a set l @@ -1201,7 +1201,7 @@ test interp-20.22 {interp hide vs safety} { catch {interp delete a} interp create a -safe set l "" - lappend l [catch {interp hide a list} msg] + lappend l [catch {interp hide a list} msg] lappend l $msg interp delete a set l @@ -1210,7 +1210,7 @@ test interp-20.23 {interp hide vs safety} { catch {interp delete a} interp create a -safe set l "" - lappend l [catch {a eval {interp hide {} list}} msg] + lappend l [catch {a eval {interp hide {} list}} msg] lappend l $msg interp delete a set l @@ -1220,7 +1220,7 @@ test interp-20.24 {interp hide vs safety} { interp create a -safe interp create {a b} set l "" - lappend l [catch {a eval {interp hide b list}} msg] + lappend l [catch {a eval {interp hide b list}} msg] lappend l $msg interp delete a set l @@ -1239,7 +1239,7 @@ test interp-20.26 {interp expoose vs safety} { catch {interp delete a} interp create a -safe set l "" - lappend l [catch {a hide list} msg] + lappend l [catch {a hide list} msg] lappend l $msg lappend l [catch {a expose list} msg] lappend l $msg @@ -1250,9 +1250,9 @@ test interp-20.27 {interp expose vs safety} { catch {interp delete a} interp create a -safe set l "" - lappend l [catch {interp hide a list} msg] + lappend l [catch {interp hide a list} msg] lappend l $msg - lappend l [catch {interp expose a list} msg] + lappend l [catch {interp expose a list} msg] lappend l $msg interp delete a set l @@ -1261,7 +1261,7 @@ test interp-20.28 {interp expose vs safety} { catch {interp delete a} interp create a -safe set l "" - lappend l [catch {a hide list} msg] + lappend l [catch {a hide list} msg] lappend l $msg lappend l [catch {a eval {interp expose {} list}} msg] lappend l $msg @@ -1272,9 +1272,9 @@ test interp-20.29 {interp expose vs safety} { catch {interp delete a} interp create a -safe set l "" - lappend l [catch {interp hide a list} msg] + lappend l [catch {interp hide a list} msg] lappend l $msg - lappend l [catch {a eval {interp expose {} list}} msg] + lappend l [catch {a eval {interp expose {} list}} msg] lappend l $msg interp delete a set l @@ -1284,9 +1284,9 @@ test interp-20.30 {interp expose vs safety} { interp create a -safe interp create {a b} set l "" - lappend l [catch {interp hide {a b} list} msg] + lappend l [catch {interp hide {a b} list} msg] lappend l $msg - lappend l [catch {a eval {interp expose b list}} msg] + lappend l [catch {a eval {interp expose b list}} msg] lappend l $msg interp delete a set l @@ -1296,7 +1296,7 @@ test interp-20.31 {interp expose vs safety} { interp create a -safe interp create {a b} set l "" - lappend l [catch {interp hide {a b} list} msg] + lappend l [catch {interp hide {a b} list} msg] lappend l $msg lappend l [catch {interp expose {a b} list} msg] lappend l $msg @@ -1615,36 +1615,36 @@ test interp-20.49 {interp invokehidden -namespace} -setup { set script [makeFile { set x [namespace current] } script] - interp create -safe slave + interp create -safe child } -body { - slave invokehidden -namespace ::foo source $script - slave eval {set ::foo::x} + child invokehidden -namespace ::foo source $script + child eval {set ::foo::x} } -cleanup { - interp delete slave + interp delete child removeFile script } -result ::foo test interp-20.50 {Bug 2486550} -setup { - interp create slave + interp create child } -body { - slave hide coroutine - slave invokehidden coroutine + child hide coroutine + child invokehidden coroutine } -cleanup { - interp delete slave + interp delete child } -returnCodes error -match glob -result * test interp-20.50.1 {Bug 2486550} -setup { - interp create slave + interp create child } -body { - slave hide coroutine - catch {slave invokehidden coroutine} m o + child hide coroutine + catch {child invokehidden coroutine} m o dict get $o -errorinfo } -cleanup { unset -nocomplain m 0 - interp delete slave + interp delete child } -returnCodes ok -result {wrong # args: should be "coroutine name cmd ?arg ...?" while executing "coroutine" invoked from within -"slave invokehidden coroutine"} +"child invokehidden coroutine"} test interp-21.1 {interp hidden} { interp hidden {} @@ -1676,7 +1676,7 @@ test interp-21.5 {interp hidden} -setup { lsort [interp hidden a] } -cleanup { interp delete a -} -result $hidden_cmds +} -result $hidden_cmds test interp-21.6 {interp hidden vs interp hide, interp expose} -setup { catch {interp delete a} set l "" @@ -2058,8 +2058,8 @@ test interp-25.1 {testing aliasing of string commands} -setup { test interp-26.1 {result code transmission : interp eval direct} { # Test that all the possibles error codes from Tcl get passed up - # from the slave interp's context to the master, even though the - # slave nominally thinks the command is running at the root level. + # from the child interp's context to the parent, even though the + # child nominally thinks the command is running at the root level. catch {interp delete a} interp create a set res {} @@ -2085,7 +2085,7 @@ test interp-26.2 {result code transmission : interp eval indirect} { } {-1 ret-1 0 ret0 1 ret1 0 ret2 3 ret3 4 ret4 5 ret5} test interp-26.3 {result code transmission : aliases} { # Test that all the possibles error codes from Tcl get passed up from the - # slave interp's context to the master, even though the slave nominally + # child interp's context to the parent, even though the child nominally # thinks the command is running at the root level. catch {interp delete a} interp create a @@ -2180,7 +2180,7 @@ test interp-26.8 {errorInfo transmission: safe interps--bug 1637} -setup { } -constraints knownBug -body { # this test fails because the errorInfo is fully transmitted whether the # interp is safe or not. The errorInfo should never report data from the - # master interpreter because it could contain sensitive information. + # parent interpreter because it could contain sensitive information. proc MyError {secret} { return -code error "msg" } @@ -2200,7 +2200,7 @@ test interp-27.1 {interp aliases & namespaces} -setup { set i [interp create] } -body { set aliasTrace {} - proc tstAlias {args} { + proc tstAlias {args} { global aliasTrace lappend aliasTrace [list [namespace current] $args] } @@ -2214,7 +2214,7 @@ test interp-27.2 {interp aliases & namespaces} -setup { set i [interp create] } -body { set aliasTrace {} - proc tstAlias {args} { + proc tstAlias {args} { global aliasTrace lappend aliasTrace [list [namespace current] $args] } @@ -2228,7 +2228,7 @@ test interp-27.3 {interp aliases & namespaces} -setup { set i [interp create] } -body { set aliasTrace {} - proc tstAlias {args} { + proc tstAlias {args} { global aliasTrace lappend aliasTrace [list [namespace current] $args] } @@ -2244,7 +2244,7 @@ test interp-27.4 {interp aliases & namespaces} -setup { } -body { namespace eval foo2 { variable aliasTrace {} - proc bar {args} { + proc bar {args} { variable aliasTrace lappend aliasTrace [list [namespace current] $args] } @@ -2275,22 +2275,22 @@ test interp-27.5 {interp hidden & namespaces} -setup { test interp-27.6 {interp hidden & aliases & namespaces} -setup { set i [interp create] } -constraints knownBug -body { - set v root-master + set v root-parent namespace eval foo { - variable v foo-master + variable v foo-parent proc bar {interp args} { variable v - list "master bar called ($v) ([namespace current]) ($args)"\ + list "parent bar called ($v) ([namespace current]) ($args)"\ [interp invokehidden $interp foo::bar $args] } } interp eval $i { namespace eval foo { namespace export * - variable v foo-slave + variable v foo-child proc bar {args} { variable v - return "slave bar called ($v) ([namespace current]) ($args)" + return "child bar called ($v) ([namespace current]) ($args)" } } } @@ -2298,7 +2298,7 @@ test interp-27.6 {interp hidden & aliases & namespaces} -setup { $i hide foo::bar $i alias foo::bar foo::bar $i set res [concat $res [interp eval $i { - set v root-slave + set v root-child namespace eval test { variable v foo-test namespace import ::foo::* @@ -2308,29 +2308,29 @@ test interp-27.6 {interp hidden & aliases & namespaces} -setup { } -cleanup { namespace delete foo interp delete $i -} -result {{slave bar called (foo-slave) (::foo) (test1)} {master bar called (foo-master) (::foo) (test2)} {slave bar called (foo-slave) (::foo) (test2)}} +} -result {{child bar called (foo-child) (::foo) (test1)} {parent bar called (foo-parent) (::foo) (test2)} {child bar called (foo-child) (::foo) (test2)}} test interp-27.7 {interp hidden & aliases & imports & namespaces} -setup { set i [interp create] } -constraints knownBug -body { - set v root-master + set v root-parent namespace eval mfoo { - variable v foo-master + variable v foo-parent proc bar {interp args} { variable v - list "master bar called ($v) ([namespace current]) ($args)"\ + list "parent bar called ($v) ([namespace current]) ($args)"\ [interp invokehidden $interp test::bar $args] } } interp eval $i { namespace eval foo { namespace export * - variable v foo-slave + variable v foo-child proc bar {args} { variable v - return "slave bar called ($v) ([info level 0]) ([uplevel namespace current]) ([namespace current]) ($args)" + return "child bar called ($v) ([info level 0]) ([uplevel namespace current]) ([namespace current]) ($args)" } } - set v root-slave + set v root-child namespace eval test { variable v foo-test namespace import ::foo::* @@ -2343,7 +2343,7 @@ test interp-27.7 {interp hidden & aliases & imports & namespaces} -setup { } -cleanup { namespace delete mfoo interp delete $i -} -result {{slave bar called (foo-slave) (bar test1) (::tcltest) (::foo) (test1)} {master bar called (foo-master) (::mfoo) (test2)} {slave bar called (foo-slave) (test::bar test2) (::) (::foo) (test2)}} +} -result {{child bar called (foo-child) (bar test1) (::tcltest) (::foo) (test1)} {parent bar called (foo-parent) (::mfoo) (test2)} {child bar called (foo-child) (test::bar test2) (::) (::foo) (test2)}} test interp-27.8 {hiding, namespaces and integrity} knownBug { namespace eval foo { variable v 3 @@ -2355,25 +2355,25 @@ test interp-27.8 {hiding, namespaces and integrity} knownBug { list [catch {interp invokehidden {} foo::bar} msg] $msg } {1 {invalid hidden command name "foo"}} -test interp-28.1 {getting fooled by slave's namespace ?} -setup { +test interp-28.1 {getting fooled by child's namespace ?} -setup { set i [interp create -safe] - proc master {interp args} {interp hide $interp list} + proc parent {interp args} {interp hide $interp list} } -body { - $i alias master master $i + $i alias parent parent $i set r [interp eval $i { namespace eval foo { proc list {args} { return "dummy foo::list" } - master + parent } info commands list }] } -cleanup { - rename master {} + rename parent {} interp delete $i } -result {} -test interp-28.2 {master's nsName cache should not cross} -setup { +test interp-28.2 {parent's nsName cache should not cross} -setup { set i [interp create] $i eval {proc filter lst {lsearch -all -inline -not $lst "::tcl"}} } -body { @@ -2432,31 +2432,31 @@ test interp-29.1.7 {interp recursionlimit argument checking} { interp delete moo list $result [string range $msg 0 35] } {1 {integer value too large to represent}} -test interp-29.1.8 {slave recursionlimit argument checking} { +test interp-29.1.8 {child recursionlimit argument checking} { interp create moo set result [catch {moo recursionlimit foo bar} msg] interp delete moo list $result $msg } {1 {wrong # args: should be "moo recursionlimit ?newlimit?"}} -test interp-29.1.9 {slave recursionlimit argument checking} { +test interp-29.1.9 {child recursionlimit argument checking} { interp create moo set result [catch {moo recursionlimit foo} msg] interp delete moo list $result $msg } {1 {expected integer but got "foo"}} -test interp-29.1.10 {slave recursionlimit argument checking} { +test interp-29.1.10 {child recursionlimit argument checking} { interp create moo set result [catch {moo recursionlimit 0} msg] interp delete moo list $result $msg } {1 {recursion limit must be > 0}} -test interp-29.1.11 {slave recursionlimit argument checking} { +test interp-29.1.11 {child recursionlimit argument checking} { interp create moo set result [catch {moo recursionlimit -1} msg] interp delete moo list $result $msg } {1 {recursion limit must be > 0}} -test interp-29.1.12 {slave recursionlimit argument checking} { +test interp-29.1.12 {child recursionlimit argument checking} { interp create moo set result [catch {moo recursionlimit [expr {wide(1)<<32}]} msg] interp delete moo @@ -2549,8 +2549,8 @@ test interp-29.3.3 {recursion limit} { set r } {1 {too many nested evaluations (infinite loop?)} 49} test interp-29.3.4 {recursion limit error reporting} { - interp create slave - set r1 [slave eval { + interp create child + set r1 [child eval { catch { # nesting level 1 eval { # 2 eval { # 3 @@ -2564,13 +2564,13 @@ test interp-29.3.4 {recursion limit error reporting} { } } msg }] - set r2 [slave eval { set msg }] - interp delete slave + set r2 [child eval { set msg }] + interp delete child list $r1 $r2 } {1 {falling back due to new recursion limit}} test interp-29.3.5 {recursion limit error reporting} { - interp create slave - set r1 [slave eval { + interp create child + set r1 [child eval { catch { # nesting level 1 eval { # 2 eval { # 3 @@ -2584,13 +2584,13 @@ test interp-29.3.5 {recursion limit error reporting} { } } msg }] - set r2 [slave eval { set msg }] - interp delete slave + set r2 [child eval { set msg }] + interp delete child list $r1 $r2 } {1 {falling back due to new recursion limit}} test interp-29.3.6 {recursion limit error reporting} { - interp create slave - set r1 [slave eval { + interp create child + set r1 [child eval { catch { # nesting level 1 eval { # 2 eval { # 3 @@ -2604,8 +2604,8 @@ test interp-29.3.6 {recursion limit error reporting} { } } msg }] - set r2 [slave eval { set msg }] - interp delete slave + set r2 [child eval { set msg }] + interp delete child list $r1 $r2 } {0 ok} # @@ -2613,9 +2613,9 @@ test interp-29.3.6 {recursion limit error reporting} { # level will only be verified when it invokes a non-bcc'd command. # test interp-29.3.7a {recursion limit error reporting} { - interp create slave - after 0 {interp recursionlimit slave 5} - set r1 [slave eval { + interp create child + after 0 {interp recursionlimit child 5} + set r1 [child eval { catch { # nesting level 1 eval { # 2 eval { # 3 @@ -2629,14 +2629,14 @@ test interp-29.3.7a {recursion limit error reporting} { } } msg }] - set r2 [slave eval { set msg }] - interp delete slave + set r2 [child eval { set msg }] + interp delete child list $r1 $r2 } {0 ok} test interp-29.3.7b {recursion limit error reporting} { - interp create slave - after 0 {interp recursionlimit slave 5} - set r1 [slave eval { + interp create child + after 0 {interp recursionlimit child 5} + set r1 [child eval { catch { # nesting level 1 eval { # 2 eval { # 3 @@ -2650,14 +2650,14 @@ test interp-29.3.7b {recursion limit error reporting} { } } msg }] - set r2 [slave eval { set msg }] - interp delete slave + set r2 [child eval { set msg }] + interp delete child list $r1 $r2 } {0 ok} test interp-29.3.7c {recursion limit error reporting} { - interp create slave - after 0 {interp recursionlimit slave 5} - set r1 [slave eval { + interp create child + after 0 {interp recursionlimit child 5} + set r1 [child eval { catch { # nesting level 1 eval { # 2 eval { # 3 @@ -2672,14 +2672,14 @@ test interp-29.3.7c {recursion limit error reporting} { } } msg }] - set r2 [slave eval { set msg }] - interp delete slave + set r2 [child eval { set msg }] + interp delete child list $r1 $r2 } {1 {too many nested evaluations (infinite loop?)}} test interp-29.3.8a {recursion limit error reporting} { - interp create slave - after 0 {interp recursionlimit slave 4} - set r1 [slave eval { + interp create child + after 0 {interp recursionlimit child 4} + set r1 [child eval { catch { # nesting level 1 eval { # 2 eval { # 3 @@ -2693,14 +2693,14 @@ test interp-29.3.8a {recursion limit error reporting} { } } msg }] - set r2 [slave eval { set msg }] - interp delete slave + set r2 [child eval { set msg }] + interp delete child list $r1 $r2 } {0 ok} test interp-29.3.8b {recursion limit error reporting} { - interp create slave - after 0 {interp recursionlimit slave 4} - set r1 [slave eval { + interp create child + after 0 {interp recursionlimit child 4} + set r1 [child eval { catch { # nesting level 1 eval { # 2 eval { # 3 @@ -2714,14 +2714,14 @@ test interp-29.3.8b {recursion limit error reporting} { } } msg }] - set r2 [slave eval { set msg }] - interp delete slave + set r2 [child eval { set msg }] + interp delete child list $r1 $r2 } {1 {too many nested evaluations (infinite loop?)}} test interp-29.3.9a {recursion limit error reporting} { - interp create slave - after 0 {interp recursionlimit slave 6} - set r1 [slave eval { + interp create child + after 0 {interp recursionlimit child 6} + set r1 [child eval { catch { # nesting level 1 eval { # 2 eval { # 3 @@ -2735,14 +2735,14 @@ test interp-29.3.9a {recursion limit error reporting} { } } msg }] - set r2 [slave eval { set msg }] - interp delete slave + set r2 [child eval { set msg }] + interp delete child list $r1 $r2 } {0 ok} test interp-29.3.9b {recursion limit error reporting} { - interp create slave - after 0 {interp recursionlimit slave 6} - set r1 [slave eval { + interp create child + after 0 {interp recursionlimit child 6} + set r1 [child eval { catch { # nesting level 1 eval { # 2 eval { # 3 @@ -2756,14 +2756,14 @@ test interp-29.3.9b {recursion limit error reporting} { } } msg }] - set r2 [slave eval { set msg }] - interp delete slave + set r2 [child eval { set msg }] + interp delete child list $r1 $r2 } {0 ok} test interp-29.3.10a {recursion limit error reporting} { - interp create slave - after 0 {slave recursionlimit 4} - set r1 [slave eval { + interp create child + after 0 {child recursionlimit 4} + set r1 [child eval { catch { # nesting level 1 eval { # 2 eval { # 3 @@ -2777,14 +2777,14 @@ test interp-29.3.10a {recursion limit error reporting} { } } msg }] - set r2 [slave eval { set msg }] - interp delete slave + set r2 [child eval { set msg }] + interp delete child list $r1 $r2 } {0 ok} test interp-29.3.10b {recursion limit error reporting} { - interp create slave - after 0 {slave recursionlimit 4} - set r1 [slave eval { + interp create child + after 0 {child recursionlimit 4} + set r1 [child eval { catch { # nesting level 1 eval { # 2 eval { # 3 @@ -2798,14 +2798,14 @@ test interp-29.3.10b {recursion limit error reporting} { } } msg }] - set r2 [slave eval { set msg }] - interp delete slave + set r2 [child eval { set msg }] + interp delete child list $r1 $r2 } {1 {too many nested evaluations (infinite loop?)}} test interp-29.3.11a {recursion limit error reporting} { - interp create slave - after 0 {slave recursionlimit 5} - set r1 [slave eval { + interp create child + after 0 {child recursionlimit 5} + set r1 [child eval { catch { # nesting level 1 eval { # 2 eval { # 3 @@ -2819,14 +2819,14 @@ test interp-29.3.11a {recursion limit error reporting} { } } msg }] - set r2 [slave eval { set msg }] - interp delete slave + set r2 [child eval { set msg }] + interp delete child list $r1 $r2 } {0 ok} test interp-29.3.11b {recursion limit error reporting} { - interp create slave - after 0 {slave recursionlimit 5} - set r1 [slave eval { + interp create child + after 0 {child recursionlimit 5} + set r1 [child eval { catch { # nesting level 1 eval { # 2 eval { # 3 @@ -2841,14 +2841,14 @@ test interp-29.3.11b {recursion limit error reporting} { } } msg }] - set r2 [slave eval { set msg }] - interp delete slave + set r2 [child eval { set msg }] + interp delete child list $r1 $r2 } {1 {too many nested evaluations (infinite loop?)}} test interp-29.3.12a {recursion limit error reporting} { - interp create slave - after 0 {slave recursionlimit 6} - set r1 [slave eval { + interp create child + after 0 {child recursionlimit 6} + set r1 [child eval { catch { # nesting level 1 eval { # 2 eval { # 3 @@ -2862,14 +2862,14 @@ test interp-29.3.12a {recursion limit error reporting} { } } msg }] - set r2 [slave eval { set msg }] - interp delete slave + set r2 [child eval { set msg }] + interp delete child list $r1 $r2 } {0 ok} test interp-29.3.12b {recursion limit error reporting} { - interp create slave - after 0 {slave recursionlimit 6} - set r1 [slave eval { + interp create child + after 0 {child recursionlimit 6} + set r1 [child eval { catch { # nesting level 1 eval { # 2 eval { # 3 @@ -2884,8 +2884,8 @@ test interp-29.3.12b {recursion limit error reporting} { } } msg }] - set r2 [slave eval { set msg }] - interp delete slave + set r2 [child eval { set msg }] + interp delete child list $r1 $r2 } {0 ok} test interp-29.4.1 {recursion limit inheritance} { @@ -2916,121 +2916,121 @@ test interp-29.4.2 {recursion limit inheritance} { interp delete $i set r } 50 -test interp-29.5.1 {does slave recursion limit affect master?} { +test interp-29.5.1 {does child recursion limit affect parent?} { set before [interp recursionlimit {}] set i [interp create] interp recursionlimit $i 20000 set after [interp recursionlimit {}] - set slavelimit [interp recursionlimit $i] + set childlimit [interp recursionlimit $i] interp delete $i - list [expr {$before == $after}] $slavelimit + list [expr {$before == $after}] $childlimit } {1 20000} -test interp-29.5.2 {does slave recursion limit affect master?} { +test interp-29.5.2 {does child recursion limit affect parent?} { set before [interp recursionlimit {}] set i [interp create] interp recursionlimit $i 20000 set after [interp recursionlimit {}] - set slavelimit [$i recursionlimit] + set childlimit [$i recursionlimit] interp delete $i - list [expr {$before == $after}] $slavelimit + list [expr {$before == $after}] $childlimit } {1 20000} -test interp-29.5.3 {does slave recursion limit affect master?} { +test interp-29.5.3 {does child recursion limit affect parent?} { set before [interp recursionlimit {}] set i [interp create] $i recursionlimit 20000 set after [interp recursionlimit {}] - set slavelimit [interp recursionlimit $i] + set childlimit [interp recursionlimit $i] interp delete $i - list [expr {$before == $after}] $slavelimit + list [expr {$before == $after}] $childlimit } {1 20000} -test interp-29.5.4 {does slave recursion limit affect master?} { +test interp-29.5.4 {does child recursion limit affect parent?} { set before [interp recursionlimit {}] set i [interp create] $i recursionlimit 20000 set after [interp recursionlimit {}] - set slavelimit [$i recursionlimit] + set childlimit [$i recursionlimit] interp delete $i - list [expr {$before == $after}] $slavelimit + list [expr {$before == $after}] $childlimit } {1 20000} test interp-29.6.1 {safe interpreter recursion limit} { - interp create slave -safe - set n [interp recursionlimit slave] - interp delete slave + interp create child -safe + set n [interp recursionlimit child] + interp delete child set n } 1000 test interp-29.6.2 {safe interpreter recursion limit} { - interp create slave -safe - set n [slave recursionlimit] - interp delete slave + interp create child -safe + set n [child recursionlimit] + interp delete child set n } 1000 test interp-29.6.3 {safe interpreter recursion limit} { - interp create slave -safe - set n1 [interp recursionlimit slave 42] - set n2 [interp recursionlimit slave] - interp delete slave + interp create child -safe + set n1 [interp recursionlimit child 42] + set n2 [interp recursionlimit child] + interp delete child list $n1 $n2 } {42 42} test interp-29.6.4 {safe interpreter recursion limit} { - interp create slave -safe - set n1 [slave recursionlimit 42] - set n2 [interp recursionlimit slave] - interp delete slave + interp create child -safe + set n1 [child recursionlimit 42] + set n2 [interp recursionlimit child] + interp delete child list $n1 $n2 } {42 42} test interp-29.6.5 {safe interpreter recursion limit} { - interp create slave -safe - set n1 [interp recursionlimit slave 42] - set n2 [slave recursionlimit] - interp delete slave + interp create child -safe + set n1 [interp recursionlimit child 42] + set n2 [child recursionlimit] + interp delete child list $n1 $n2 } {42 42} test interp-29.6.6 {safe interpreter recursion limit} { - interp create slave -safe - set n1 [slave recursionlimit 42] - set n2 [slave recursionlimit] - interp delete slave + interp create child -safe + set n1 [child recursionlimit 42] + set n2 [child recursionlimit] + interp delete child list $n1 $n2 } {42 42} test interp-29.6.7 {safe interpreter recursion limit} { - interp create slave -safe - set n1 [slave recursionlimit 42] - set n2 [slave recursionlimit] - interp delete slave + interp create child -safe + set n1 [child recursionlimit 42] + set n2 [child recursionlimit] + interp delete child list $n1 $n2 } {42 42} test interp-29.6.8 {safe interpreter recursion limit} { - interp create slave -safe - set n [catch {slave eval {interp recursionlimit {} 42}} msg] - interp delete slave + interp create child -safe + set n [catch {child eval {interp recursionlimit {} 42}} msg] + interp delete child list $n $msg } {1 {permission denied: safe interpreters cannot change recursion limit}} test interp-29.6.9 {safe interpreter recursion limit} { - interp create slave -safe + interp create child -safe set result [ - slave eval { - interp create slave2 -safe + child eval { + interp create child2 -safe set n [catch { - interp recursionlimit slave2 42 + interp recursionlimit child2 42 } msg] list $n $msg } ] - interp delete slave + interp delete child set result } {1 {permission denied: safe interpreters cannot change recursion limit}} test interp-29.6.10 {safe interpreter recursion limit} { - interp create slave -safe + interp create child -safe set result [ - slave eval { - interp create slave2 -safe + child eval { + interp create child2 -safe set n [catch { - slave2 recursionlimit 42 + child2 recursionlimit 42 } msg] list $n $msg } ] - interp delete slave + interp delete child set result } {1 {permission denied: safe interpreters cannot change recursion limit}} @@ -3321,7 +3321,7 @@ test interp-34.9 {time limits trigger in blocking after} { } msg] set t1 [clock seconds] interp delete $i - list $code $msg [expr {($t1-$t0) < 3 ? "OK" : $t1-$t0}] + list $code $msg [expr {($t1-$t0) < 3 ? "OK" : $t1-$t0}] } {1 {time limit exceeded} OK} test interp-34.10 {time limits trigger in vwaits: Bug 1221395} -body { set i [interp create] @@ -3555,48 +3555,48 @@ test interp-35.24 {interp time limits can't touch current interp} -body { test interp-36.1 {interp bgerror syntax} -body { interp bgerror } -returnCodes error -result {wrong # args: should be "interp bgerror path ?cmdPrefix?"} -test interp-36.2 {interp bgerror syntax} -body { +test interp-36.2 {interp bgerror syntax} -body { interp bgerror x y z } -returnCodes error -result {wrong # args: should be "interp bgerror path ?cmdPrefix?"} test interp-36.3 {interp bgerror syntax} -setup { - interp create slave + interp create child } -body { - slave bgerror x y + child bgerror x y } -cleanup { - interp delete slave -} -returnCodes error -result {wrong # args: should be "slave bgerror ?cmdPrefix?"} -test interp-36.4 {SlaveBgerror syntax} -setup { - interp create slave + interp delete child +} -returnCodes error -result {wrong # args: should be "child bgerror ?cmdPrefix?"} +test interp-36.4 {ChildBgerror syntax} -setup { + interp create child } -body { - slave bgerror \{ + child bgerror \{ } -cleanup { - interp delete slave + interp delete child } -returnCodes error -result {cmdPrefix must be list of length >= 1} -test interp-36.5 {SlaveBgerror syntax} -setup { - interp create slave +test interp-36.5 {ChildBgerror syntax} -setup { + interp create child } -body { - slave bgerror {} + child bgerror {} } -cleanup { - interp delete slave + interp delete child } -returnCodes error -result {cmdPrefix must be list of length >= 1} -test interp-36.6 {SlaveBgerror returns handler} -setup { - interp create slave +test interp-36.6 {ChildBgerror returns handler} -setup { + interp create child } -body { - slave bgerror {foo bar soom} + child bgerror {foo bar soom} } -cleanup { - interp delete slave + interp delete child } -result {foo bar soom} -test interp-36.7 {SlaveBgerror sets error handler of slave [1999035]} -setup { - interp create slave - slave alias handler handler - slave bgerror handler +test interp-36.7 {ChildBgerror sets error handler of child [1999035]} -setup { + interp create child + child alias handler handler + child bgerror handler variable result {untouched} proc handler {args} { variable result set result [lindex $args 0] } } -body { - slave eval { + child eval { variable done {} after 0 error foo after 10 [list ::set [namespace which -variable done] {}] @@ -3606,7 +3606,7 @@ test interp-36.7 {SlaveBgerror sets error handler of slave [1999035]} -setup { } -cleanup { variable result {} unset -nocomplain result - interp delete slave + interp delete child } -result foo test interp-37.1 {safe interps and min() and max(): Bug 2895741} -setup { diff --git a/tests/io.test b/tests/io.test index 18636c1..2dc1715 100644 --- a/tests/io.test +++ b/tests/io.test @@ -8694,16 +8694,16 @@ test io-74.1 {[104f2885bb] improper cache validity check} -setup { set fn [makeFile {} io-74.1] set rfd [open $fn r] testobj freeallvars - interp create slave + interp create child } -constraints testobj -body { teststringobj set 1 [string range $rfd 0 end] read [teststringobj get 1] testobj duplicate 1 2 - interp transfer {} $rfd slave + interp transfer {} $rfd child catch {read [teststringobj get 1]} read [teststringobj get 2] } -cleanup { - interp delete slave + interp delete child testobj freeallvars removeFile io-74.1 } -returnCodes error -match glob -result {can not find channel named "*"} diff --git a/tests/ioCmd.test b/tests/ioCmd.test index 5c45630..18b228e 100644 --- a/tests/ioCmd.test +++ b/tests/ioCmd.test @@ -2029,7 +2029,7 @@ test iocmd-32.0 {origin interpreter of moved channel gone} -match glob -body { set ida [interp create];#puts <<$ida>> set idb [interp create];#puts <<$idb>> - # Magic to get the test* commands in the slaves + # Magic to get the test* commands in the children load {} Tcltest $ida load {} Tcltest $idb @@ -2067,7 +2067,7 @@ test iocmd-32.1 {origin interpreter of moved channel destroyed during access} -m set ida [interp create];#puts <<$ida>> set idb [interp create];#puts <<$idb>> - # Magic to get the test* commands in the slaves + # Magic to get the test* commands in the children load {} Tcltest $ida load {} Tcltest $idb diff --git a/tests/ioTrans.test b/tests/ioTrans.test index 85e427a..867362a 100644 --- a/tests/ioTrans.test +++ b/tests/ioTrans.test @@ -1162,7 +1162,7 @@ test iortrans-8.3 {chan flush, bug 2921116} -match glob -setup { test iortrans-11.0 {origin interpreter of moved transform gone} -setup { set ida [interp create]; #puts <<$ida>> set idb [interp create]; #puts <<$idb>> - # Magic to get the test* commands in the slaves + # Magic to get the test* commands in the children load {} Tcltest $ida load {} Tcltest $idb } -constraints {testchannel} -match glob -body { @@ -1205,7 +1205,7 @@ test iortrans-11.0 {origin interpreter of moved transform gone} -setup { test iortrans-11.1 {origin interpreter of moved transform destroyed during access} -setup { set ida [interp create]; #puts <<$ida>> set idb [interp create]; #puts <<$idb>> - # Magic to get the test* commands in the slaves + # Magic to get the test* commands in the children load {} Tcltest $ida load {} Tcltest $idb } -constraints {testchannel} -match glob -body { @@ -1320,7 +1320,7 @@ proc inthread {chan script args} { # forwarded channel operations. set ::tres "" - thread::send -async $tid { + thread::send -async $tid { after 50 catch {s} res; # This runs the script, 's' was defined at (*) thread::send -async $mid [list set ::tres $res] diff --git a/tests/load.test b/tests/load.test index 4cd1fcd..7d2e5df 100644 --- a/tests/load.test +++ b/tests/load.test @@ -103,7 +103,7 @@ test load-3.1 {error in _Init procedure, same interpreter} \ "if 44 {open non_existent}" invoked from within "load [file join $testDir pkge$ext] pkge"} {POSIX ENOENT {no such file or directory}}} -test load-3.2 {error in _Init procedure, slave interpreter} \ +test load-3.2 {error in _Init procedure, child interpreter} \ [list $dll $loaded] { catch {interp delete x} interp create x diff --git a/tests/namespace.test b/tests/namespace.test index 796b46b..2b25803 100644 --- a/tests/namespace.test +++ b/tests/namespace.test @@ -56,7 +56,7 @@ test namespace-2.2 {Tcl_GetCurrentNamespace} { test namespace-3.1 {Tcl_GetGlobalNamespace} { namespace eval test_ns_1 {namespace eval foo {namespace eval bar {} } } - # namespace children uses Tcl_GetGlobalNamespace + # namespace children uses Tcl_GetGlobalNamespace namespace eval test_ns_1 {namespace children foo b*} } {::test_ns_1::foo::bar} @@ -108,7 +108,7 @@ test namespace-6.2 {Tcl_CreateNamespace, odd number of :'s in name is okay} { [namespace eval test_ns_2:::::foo {namespace current}] } {::test_ns_1::foo ::test_ns_2::foo} test namespace-6.3 {Tcl_CreateNamespace, trailing ::s in ns name are ignored} { - list [catch {namespace eval test_ns_7::: {namespace current}} msg] $msg + list [catch {namespace eval test_ns_7::: {namespace current}} msg] $msg } {0 ::test_ns_7} test namespace-6.4 {Tcl_CreateNamespace, trailing ::s in ns name are ignored} { catch {namespace delete {*}[namespace children :: test_ns_*]} @@ -179,21 +179,21 @@ test namespace-7.6 {recursive Tcl_DeleteNamespace, no active call frames in ns} namespace delete test_ns_2 } {} test namespace-7.7 {Bug 1655305} -setup { - interp create slave + interp create child # Can't invoke through the ensemble, since deleting the global namespace # (indirectly, via deleting ::tcl) deletes the ensemble. - slave eval {rename ::tcl::info::commands ::infocommands} - slave hide infocommands - slave eval { + child eval {rename ::tcl::info::commands ::infocommands} + child hide infocommands + child eval { proc foo {} { namespace delete :: } } } -body { - slave eval foo - slave invokehidden infocommands + child eval foo + child invokehidden infocommands } -cleanup { - interp delete slave + interp delete child } -result {} test namespace-7.8 {Bug ba1419303b4c} -setup { @@ -205,7 +205,7 @@ test namespace-7.8 {Bug ba1419303b4c} -setup { namespace delete ns1 } } -body { - # No segmentation fault given --enable-symbols=mem. + # No segmentation fault given --enable-symbols=mem. namespace delete ns1 } -result {} @@ -269,28 +269,28 @@ test namespace-8.4 {TclTeardownNamespace, cmds imported from deleted ns go away} [info commands test_ns_import::*] } [list [lsort {::test_ns_import::p ::test_ns_import::cmd1 ::test_ns_import::cmd2}] {} ::test_ns_import::p] test namespace-8.5 {TclTeardownNamespace: preserve errorInfo; errorCode values} { - interp create slave - slave eval {trace add execution error leave {namespace delete :: ;#}} - catch {slave eval error foo bar baz} - interp delete slave + interp create child + child eval {trace add execution error leave {namespace delete :: ;#}} + catch {child eval error foo bar baz} + interp delete child set ::errorInfo } {bar invoked from within -"slave eval error foo bar baz"} +"child eval error foo bar baz"} test namespace-8.6 {TclTeardownNamespace: preserve errorInfo; errorCode values} { - interp create slave - slave eval {trace add variable errorCode write {namespace delete :: ;#}} - catch {slave eval error foo bar baz} - interp delete slave + interp create child + child eval {trace add variable errorCode write {namespace delete :: ;#}} + catch {child eval error foo bar baz} + interp delete child set ::errorInfo } {bar invoked from within -"slave eval error foo bar baz"} +"child eval error foo bar baz"} test namespace-8.7 {TclTeardownNamespace: preserve errorInfo; errorCode values} { - interp create slave - slave eval {trace add execution error leave {namespace delete :: ;#}} - catch {slave eval error foo bar baz} - interp delete slave + interp create child + child eval {trace add execution error leave {namespace delete :: ;#}} + catch {child eval error foo bar baz} + interp delete child set ::errorCode } baz @@ -1098,17 +1098,17 @@ test namespace-22.5 {NamespaceCodeCmd, in other namespace} { namespace code cmd } } {::namespace inscope ::test_ns_1 cmd} -test namespace-22.6 {NamespaceCodeCmd, in other namespace} { - namespace eval test_ns_1 { - variable v 42 - } - namespace eval test_ns_2 { - proc namespace args {} - } - namespace eval test_ns_2 [namespace eval test_ns_1 { - namespace code {set v} - }] -} {42} +test namespace-22.6 {NamespaceCodeCmd, in other namespace} { + namespace eval test_ns_1 { + variable v 42 + } + namespace eval test_ns_2 { + proc namespace args {} + } + namespace eval test_ns_2 [namespace eval test_ns_1 { + namespace code {set v} + }] +} {42} test namespace-22.7 {NamespaceCodeCmd, Bug 3202171} { namespace eval demo { proc namespace args {puts $args} @@ -1659,7 +1659,7 @@ test namespace-40.1 {Ignoring namespace proc "unknown"} -setup { namespace eval ns {proc unknown args {return local}} list [namespace eval ns aaa bbb] [namespace eval ns aaa] } -cleanup { - rename unknown {} + rename unknown {} rename _unknown unknown namespace delete ns } -result {global global} @@ -1670,7 +1670,7 @@ test namespace-41.1 {Shadowing byte-compiled commands, Bug: 231259} { set res {} proc test {} { set ::g 0 - } + } lappend ::res [test] proc set {a b} { ::set a [incr b] @@ -2797,9 +2797,9 @@ test namespace-51.15 {namespace resolution path control} -body { namespace delete ::test_ns_2 } test namespace-51.16 {Bug 1566526} { - interp create slave - slave eval namespace eval demo namespace path :: - interp delete slave + interp create child + child eval namespace eval demo namespace path :: + interp delete child } {} test namespace-51.17 {resolution epoch handling: Bug 2898722} -setup { set result {} @@ -3000,19 +3000,19 @@ test namespace-52.11 {unknown: with TCL_EVAL_INVOKE} -setup { } } catch {rename ::noSuchCommand {}} - set ::slave [interp create] + set ::child [interp create] } -body { - $::slave alias bar noSuchCommand + $::child alias bar noSuchCommand namespace eval test_ns_1 { namespace unknown unknown proc unknown args { return FAIL } - $::slave eval bar + $::child eval bar } } -cleanup { - interp delete $::slave - unset ::slave + interp delete $::child + unset ::child namespace delete test_ns_1 rename ::unknown {} rename unknown.save ::unknown @@ -3373,7 +3373,7 @@ test namespace-57.0 { rename ns2::p2 {} return $res } -cleanup { - unset res + unset res namespace delete ns2 namespace delete ns3 } -result success diff --git a/tests/oo.test b/tests/oo.test index e917bc9..612fb9b 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -142,7 +142,7 @@ test oo-1.4 {basic test of OO functionality} -body { oo::object create {} } -returnCodes 1 -result {object name must not be empty} test oo-1.4.1 {fully-qualified nested name} -body { - oo::object create ::one::two::three + oo::object create ::one::two::three } -result {::one::two::three} test oo-1.4.2 {automatic command name has same name as namespace} -body { set obj [oo::object new] @@ -306,19 +306,19 @@ test oo-1.18.2 {Bug 75b8433707: memory leak in oo-1.18} -setup { rename test-oo-1.18 {} } -result 0 test oo-1.18.3 {Bug 21c144f0f5} -setup { - interp create slave + interp create child } -body { - slave eval { + child eval { oo::define [oo::class create foo] superclass oo::class oo::class destroy } } -cleanup { - interp delete slave + interp delete child } test oo-1.18.4 {correct handling of cleanup in superclass set error} -setup { - interp create slave + interp create child } -body { - slave eval { + child eval { oo::class create A oo::class create B { superclass oo::class @@ -330,12 +330,12 @@ test oo-1.18.4 {correct handling of cleanup in superclass set error} -setup { [B create C] create d } } -returnCodes error -cleanup { - interp delete slave + interp delete child } -result {class should only be a direct superclass once} test oo-1.18.5 {correct handling of cleanup in superclass set error} -setup { - interp create slave + interp create child } -body { - slave eval { + child eval { oo::class create A oo::class create B { superclass oo::class @@ -347,7 +347,7 @@ test oo-1.18.5 {correct handling of cleanup in superclass set error} -setup { [B create C {B C}] create d } } -returnCodes error -cleanup { - interp delete slave + interp delete child } -result {attempt to form circular dependency graph} test oo-1.19 {basic test of OO functionality: teardown order} -body { oo::object create o @@ -2291,7 +2291,7 @@ test oo-15.10 {variable binding must not bleed through oo::copy} -setup { } -body { set obj1 [FooClass new] oo::objdefine $obj1 { - variable var + variable var method m {} { set var foo } @@ -2340,7 +2340,7 @@ test oo-15.13.1 { } -cleanup { Cls destroy Cls2 destroy -} -result done +} -result done test oo-15.13.2 {OO: object cloning with target NS} -setup { oo::class create Super oo::class create Cls {superclass Super} @@ -2368,7 +2368,7 @@ test oo-15.15 {method cloning must ensure that there is a string representation } -body { cls create foo oo::objdefine foo { - method m1 {} [string map {a b} {return hello}] + method m1 {} [string map {a b} {return hello}] } [oo::copy foo] m1 } -cleanup { @@ -3029,7 +3029,7 @@ test oo-20.10 {OO: variable and varname methods refer to same things} -setup { test oo-20.11 {OO: variable mustn't crash when recursing} -body { oo::class create A { constructor {name} { - my variable np_name + my variable np_name set np_name $name } method copy {nm} { @@ -3044,7 +3044,7 @@ test oo-20.11 {OO: variable mustn't crash when recursing} -body { lappend objs [$ref copy {}] } $cpy prop $var $objs - } else { + } else { $cpy prop $var $val } } @@ -4181,7 +4181,7 @@ test oo-35.6 { return done } -cleanup { rename obj {} -} -result done +} -result done diff --git a/tests/parse.test b/tests/parse.test index d73c725..9980015 100644 --- a/tests/parse.test +++ b/tests/parse.test @@ -369,7 +369,7 @@ test parse-8.8 {Tcl_EvalObjv procedure, async handlers} -constraints { variable ::aresult variable ::acode proc async1 {result code} { - variable ::aresult + variable ::aresult variable ::acode set aresult $result set acode $code @@ -405,14 +405,14 @@ test parse-8.11 {Tcl_EvalObjv procedure, TCL_EVAL_INVOKE} testevalobjv { proc ::unknown args {lappend ::info [info level]; uplevel 1 foo} proc ::foo args {lappend ::info global} catch {rename ::noSuchCommand {}} - set ::slave [interp create] - $::slave alias bar noSuchCommand + set ::child [interp create] + $::child alias bar noSuchCommand set ::info {} namespace eval test_ns_1 { proc foo args {lappend ::info namespace} - $::slave eval bar - testevalobjv 1 [list $::slave eval bar] - uplevel #0 [list $::slave eval bar] + $::child eval bar + testevalobjv 1 [list $::child eval bar] + uplevel #0 [list $::child eval bar] } namespace delete test_ns_1 rename ::foo {} @@ -429,14 +429,14 @@ test parse-8.12 {Tcl_EvalObjv procedure, TCL_EVAL_INVOKE} { lappend ::info ns }] catch {rename ::noSuchCommand {}} - set ::slave [interp create] - $::slave alias bar noSuchCommand + set ::child [interp create] + $::child alias bar noSuchCommand set ::info {} namespace eval test_ns_1 { - $::slave eval bar + $::child eval bar } namespace delete test_ns_1 - interp delete $::slave + interp delete $::child catch {rename ::noSuchCommand {}} set ::info } global diff --git a/tests/pkgMkIndex.test b/tests/pkgMkIndex.test index 84c82ce..37afafa 100644 --- a/tests/pkgMkIndex.test +++ b/tests/pkgMkIndex.test @@ -72,11 +72,11 @@ proc pkgtest::parseArgs { args } { # of the command line. proc pkgtest::parseIndex { filePath } { - # create a slave interpreter, where we override "package ifneeded" + # create a child interpreter, where we override "package ifneeded" - set slave [interp create] + set child [interp create] if {[catch { - $slave eval { + $child eval { rename package package_original proc package { args } { if {[lindex $args 0] eq "ifneeded"} { @@ -91,17 +91,17 @@ proc pkgtest::parseIndex { filePath } { } set dir [file dirname $filePath] - $slave eval {set curdir [pwd]} - $slave eval [list cd $dir] - $slave eval [list set dir $dir] - $slave eval [list source [file tail $filePath]] - $slave eval {cd $curdir} + $child eval {set curdir [pwd]} + $child eval [list cd $dir] + $child eval [list set dir $dir] + $child eval [list source [file tail $filePath]] + $child eval {cd $curdir} # Create the list in sorted order, so that we don't get spurious # errors because the order has changed. array set P {} - foreach {k v} [$slave eval {array get ::PKGS}] { + foreach {k v} [$child eval {array get ::PKGS}] { set P($k) $v } @@ -113,12 +113,12 @@ proc pkgtest::parseIndex { filePath } { set ei [dict get $opts -errorinfo] set ec [dict get $opts -errorcode] - catch {interp delete $slave} + catch {interp delete $child} error $ei $ec } - interp delete $slave + interp delete $child return $PKGS } @@ -231,7 +231,7 @@ proc pkgtest::runCreatedIndex {rv args} { set result [list 0 [makePkgList [parseIndex $idxFile]]] } err]} { set result [list 1 $err] - } + } file delete $idxFile } else { set result $rv diff --git a/tests/proc.test b/tests/proc.test index 9be056f..585efa5 100644 --- a/tests/proc.test +++ b/tests/proc.test @@ -99,7 +99,7 @@ test proc-1.6 {Tcl_ProcObjCmd, namespace code ignores single ":"s in middle or e test proc-1.7 {Tcl_ProcObjCmd, check that formal parameter names are not array elements} -setup { catch {rename p ""} } -returnCodes error -body { - proc p {a(1) a(2)} { + proc p {a(1) a(2)} { set z [expr $a(1)+$a(2)] puts "$z=z, $a(1)=$a(1)" } @@ -107,7 +107,7 @@ test proc-1.7 {Tcl_ProcObjCmd, check that formal parameter names are not array e test proc-1.8 {Tcl_ProcObjCmd, check that formal parameter names are simple names} -setup { catch {rename p ""} } -body { - proc p {b:a b::a} { + proc p {b:a b::a} { } } -returnCodes error -result {formal parameter "b::a" is not a simple name} test proc-1.9 {Tcl_ProcObjCmd, arguments via canonical list (string-representation bug [631b4c45df])} -body { @@ -340,7 +340,7 @@ test proc-5.1 {Bytecompiling noop; test for correct argument substitution} -body } -cleanup { catch {rename p ""} catch {rename t ""} -} -result {aba} +} -result {aba} test proc-6.1 {ProcessProcResultCode: Bug 647307 (negative return code)} -body { proc a {} {return -code -5} @@ -389,9 +389,9 @@ test proc-7.3 {Returning loop exception from redefined cmd: Bug 729692} -body { test proc-7.4 {Proc struct outlives its interp: Bug 3532959} { set lambda x lappend lambda {set a 1} - interp create slave - slave eval [list apply $lambda foo] - interp delete slave + interp create child + child eval [list apply $lambda foo] + interp delete child unset lambda } {} diff --git a/tests/resolver.test b/tests/resolver.test index b0b395d..db524a0 100644 --- a/tests/resolver.test +++ b/tests/resolver.test @@ -203,7 +203,7 @@ test resolver-2.1 {compiled var resolver: Bug #3383616} -setup { # resolver-agnostic). # # In order to make the test cases for the per-interpreter cmd literal pool -# reproducable and to minimize interactions between test cases, we use a slave +# reproducable and to minimize interactions between test cases, we use a child # interpreter per test-case. # # diff --git a/tests/safe-stock86.test b/tests/safe-stock86.test index 3f20d77..337527c 100644 --- a/tests/safe-stock86.test +++ b/tests/safe-stock86.test @@ -56,7 +56,7 @@ test safe-stock86-7.1 {tests that everything works at high level, uses http 2} - set i [safe::interpCreate] # no error shall occur: # (because the default access_path shall include 1st level sub dirs so - # package require in a slave works like in the parent) + # package require in a child works like in the parent) set v [interp eval $i {package require http 2}] # no error shall occur: interp eval $i {http::config} diff --git a/tests/subst.test b/tests/subst.test index 189dfe8..21aecc5 100644 --- a/tests/subst.test +++ b/tests/subst.test @@ -166,7 +166,7 @@ test subst-8.6 {return in a subst} -returnCodes error -body { subst "foo \[return {x}; bogus code bar" } -result {missing close-bracket} test subst-8.7 {return in a subst, parse error} -body { - subst {foo [return {x} ; set a {}"" ; stuff] bar} + subst {foo [return {x} ; set a {}"" ; stuff] bar} } -returnCodes error -result {extra characters after close-brace} test subst-8.8 {return in a subst, parse error} -body { subst {foo [return {x} ; set bar baz ; set a {}"" ; stuff] bar} @@ -282,18 +282,18 @@ test subst-13.1 {Bug 3081065} -setup { demo name2 } subst13.tcl] } -body { - interp create slave - slave eval [list source $script] - interp delete slave - interp create slave - slave eval { + interp create child + child eval [list source $script] + interp delete child + interp create child + child eval { set count 400 while {[incr count -1]} { lappend bloat [expr {rand()}] } } - slave eval [list source $script] - interp delete slave + child eval [list source $script] + interp delete child } -cleanup { removeFile subst13.tcl } diff --git a/tests/tcltest.test b/tests/tcltest.test index c856209..b02c18d 100644 --- a/tests/tcltest.test +++ b/tests/tcltest.test @@ -13,7 +13,7 @@ # testing to run the test itself. Ditto on things like [verbose]. # # It would be better to have the -body of the tests run the tcltest -# commands in a slave interp so the [test] being tested would not +# commands in a child interp so the [test] being tested would not # interfere with the [test] doing the testing. # @@ -63,11 +63,11 @@ test tcltest-1.3 {tcltest -h} {exec} { } {1 0} # -verbose, implicit & explicit testing of [verbose] -proc slave {msgVar args} { +proc child {msgVar args} { upvar 1 $msgVar msg interp create [namespace current]::i - # Fake the slave interp into dumping output to a file + # Fake the child interp into dumping output to a file i eval {namespace eval ::tcltest {}} i eval "set tcltest::outputChannel\ \[[list open [set of [makeFile {} output]] w]]" @@ -99,44 +99,44 @@ proc slave {msgVar args} { return $code } test tcltest-2.0 {tcltest (verbose default - 'b')} {unixOrWin} { - set result [slave msg test.tcl] + set result [child msg test.tcl] list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \ [regexp c-1.0 $msg] \ [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg] } {0 1 0 0 1} test tcltest-2.1 {tcltest -verbose 'b'} {unixOrWin} { - set result [slave msg test.tcl -verbose 'b'] + set result [child msg test.tcl -verbose 'b'] list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \ [regexp c-1.0 $msg] \ [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg] } {0 1 0 0 1} test tcltest-2.2 {tcltest -verbose 'p'} {unixOrWin} { - set result [slave msg test.tcl -verbose 'p'] + set result [child msg test.tcl -verbose 'p'] list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \ [regexp c-1.0 $msg] \ [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg] } {0 0 1 0 1} test tcltest-2.3 {tcltest -verbose 's'} {unixOrWin} { - set result [slave msg test.tcl -verbose 's'] + set result [child msg test.tcl -verbose 's'] list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \ [regexp c-1.0 $msg] \ [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg] } {0 0 0 1 1} test tcltest-2.4 {tcltest -verbose 'ps'} {unixOrWin} { - set result [slave msg test.tcl -verbose 'ps'] + set result [child msg test.tcl -verbose 'ps'] list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \ [regexp c-1.0 $msg] \ [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg] } {0 0 1 1 1} test tcltest-2.5 {tcltest -verbose 'psb'} {unixOrWin} { - set result [slave msg test.tcl -verbose 'psb'] + set result [child msg test.tcl -verbose 'psb'] list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \ [regexp c-1.0 $msg] \ [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg] } {0 1 1 1 1} test tcltest-2.5a {tcltest -verbose 'pass skip body'} {unixOrWin} { - set result [slave msg test.tcl -verbose "pass skip body"] + set result [child msg test.tcl -verbose "pass skip body"] list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \ [regexp c-1.0 $msg] \ [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg] @@ -145,7 +145,7 @@ test tcltest-2.5a {tcltest -verbose 'pass skip body'} {unixOrWin} { test tcltest-2.6 {tcltest -verbose 't'} { -constraints {unixOrWin} -body { - set result [slave msg test.tcl -verbose 't'] + set result [child msg test.tcl -verbose 't'] list $result $msg } -result {^0 .*a-1.0 start.*b-1.0 start} @@ -155,7 +155,7 @@ test tcltest-2.6 {tcltest -verbose 't'} { test tcltest-2.6a {tcltest -verbose 'start'} { -constraints {unixOrWin} -body { - set result [slave msg test.tcl -verbose start] + set result [child msg test.tcl -verbose start] list $result $msg } -result {^0 .*a-1.0 start.*b-1.0 start} @@ -178,7 +178,7 @@ test tcltest-2.7 {tcltest::verbose} { test tcltest-2.8 {tcltest -verbose 'error'} { -constraints {unixOrWin} -body { - set result [slave msg test.tcl -verbose error] + set result [child msg test.tcl -verbose error] list $result $msg } -result {errorInfo: foo.*errorCode: 9} @@ -186,22 +186,22 @@ test tcltest-2.8 {tcltest -verbose 'error'} { } # -match, [match] test tcltest-3.1 {tcltest -match 'a*'} {unixOrWin} { - set result [slave msg test.tcl -match a* -verbose 'ps'] + set result [child msg test.tcl -match a* -verbose 'ps'] list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \ [regexp "Total.+4.+Passed.+1.+Skipped.+3.+Failed.+0" $msg] } {0 1 0 0 1} test tcltest-3.2 {tcltest -match 'b*'} {unixOrWin} { - set result [slave msg test.tcl -match b* -verbose 'ps'] + set result [child msg test.tcl -match b* -verbose 'ps'] list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \ [regexp "Total.+4.+Passed.+0.+Skipped.+3.+Failed.+1" $msg] } {0 0 1 0 1} test tcltest-3.3 {tcltest -match 'c*'} {unixOrWin} { - set result [slave msg test.tcl -match c* -verbose 'ps'] + set result [child msg test.tcl -match c* -verbose 'ps'] list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \ [regexp "Total.+4.+Passed.+0.+Skipped.+4.+Failed.+0" $msg] } {0 0 0 1 1} test tcltest-3.4 {tcltest -match 'a* b*'} {unixOrWin} { - set result [slave msg test.tcl -match {a* b*} -verbose 'ps'] + set result [child msg test.tcl -match {a* b*} -verbose 'ps'] list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \ [regexp "Total.+4.+Passed.+1.+Skipped.+2.+Failed.+1" $msg] } {0 1 1 0 1} @@ -221,27 +221,27 @@ test tcltest-3.5 {tcltest::match} { # -skip, [skip] test tcltest-4.1 {tcltest -skip 'a*'} {unixOrWin} { - set result [slave msg test.tcl -skip a* -verbose 'ps'] + set result [child msg test.tcl -skip a* -verbose 'ps'] list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \ [regexp "Total.+4.+Passed.+0.+Skipped.+2.+Failed.+1" $msg] } {0 0 1 1 1} test tcltest-4.2 {tcltest -skip 'b*'} {unixOrWin} { - set result [slave msg test.tcl -skip b* -verbose 'ps'] + set result [child msg test.tcl -skip b* -verbose 'ps'] list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \ [regexp "Total.+4.+Passed.+1.+Skipped.+2.+Failed.+1" $msg] } {0 1 0 1 1} test tcltest-4.3 {tcltest -skip 'c*'} {unixOrWin} { - set result [slave msg test.tcl -skip c* -verbose 'ps'] + set result [child msg test.tcl -skip c* -verbose 'ps'] list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \ [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg] } {0 1 1 0 1} test tcltest-4.4 {tcltest -skip 'a* b*'} {unixOrWin} { - set result [slave msg test.tcl -skip {a* b*} -verbose 'ps'] + set result [child msg test.tcl -skip {a* b*} -verbose 'ps'] list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \ [regexp "Total.+4.+Passed.+0.+Skipped.+3.+Failed.+1" $msg] } {0 0 0 1 1} test tcltest-4.5 {tcltest -match 'a* b*' -skip 'b*'} {unixOrWin} { - set result [slave msg test.tcl -match {a* b*} -skip b* -verbose 'ps'] + set result [child msg test.tcl -match {a* b*} -skip b* -verbose 'ps'] list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \ [regexp "Total.+4.+Passed.+1.+Skipped.+3.+Failed.+0" $msg] } {0 1 0 0 1} @@ -262,12 +262,12 @@ test tcltest-4.6 {tcltest::skip} { # -constraints, -limitconstraints, [testConstraint], # $constraintsSpecified, [limitConstraints] test tcltest-5.1 {tcltest -constraints 'knownBug'} {unixOrWin} { - set result [slave msg test.tcl -constraints knownBug -verbose 'ps'] + set result [child msg test.tcl -constraints knownBug -verbose 'ps'] list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \ [regexp "Total.+4.+Passed.+2.+Skipped.+0.+Failed.+2" $msg] } {0 1 1 1 1} test tcltest-5.2 {tcltest -constraints 'knownBug' -limitconstraints 1} {unixOrWin} { - set result [slave msg test.tcl -constraints knownBug -verbose 'p' -limitconstraints 1] + set result [child msg test.tcl -constraints knownBug -verbose 'p' -limitconstraints 1] list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \ [regexp "Total.+4.+Passed.+1.+Skipped.+3.+Failed.+0" $msg] } {0 0 0 1 1} @@ -357,28 +357,28 @@ set printerror [makeFile { test tcltest-6.1 {tcltest -outfile, -errfile defaults} { -constraints unixOrWin -body { - slave msg $printerror + child msg $printerror return $msg } -result {a test.*a really} -match regexp } test tcltest-6.2 {tcltest -outfile a.tmp} {unixOrWin unixExecs} { - slave msg $printerror -outfile a.tmp + child msg $printerror -outfile a.tmp set result1 [catch {exec grep "a test" a.tmp}] set result2 [catch {exec grep "a really" a.tmp}] list [regexp "a test" $msg] [regexp "a really" $msg] \ $result1 $result2 [file exists a.tmp] [file delete a.tmp] } {0 1 0 1 1 {}} test tcltest-6.3 {tcltest -errfile a.tmp} {unixOrWin unixExecs} { - slave msg $printerror -errfile a.tmp + child msg $printerror -errfile a.tmp set result1 [catch {exec grep "a test" a.tmp}] set result2 [catch {exec grep "a really" a.tmp}] list [regexp "a test" $msg] [regexp "a really" $msg] \ $result1 $result2 [file exists a.tmp] [file delete a.tmp] } {1 0 1 0 1 {}} test tcltest-6.4 {tcltest -outfile a.tmp -errfile b.tmp} {unixOrWin unixExecs} { - slave msg $printerror -outfile a.tmp -errfile b.tmp + child msg $printerror -outfile a.tmp -errfile b.tmp set result1 [catch {exec grep "a test" a.tmp}] set result2 [catch {exec grep "a really" b.tmp}] list [regexp "a test" $msg] [regexp "a really" $msg] \ @@ -463,7 +463,7 @@ test tcltest-6.8 {tcltest::outputFile (implicit outputFile)} { # -debug, [debug] # Must use child processes to test -debug because it always writes # messages to stdout, and we have no way to capture stdout of a -# slave interp +# child interp test tcltest-7.1 {tcltest test.tcl -debug 0} {unixOrWin} { catch {exec [interpreter] test.tcl -debug 0} msg regexp "Flags passed into tcltest" $msg @@ -525,7 +525,7 @@ normalizePath normaldirectory test tcltest-8.1 {tcltest a.tcl -tmpdir a} -constraints unixOrWin -setup { file delete -force thisdirectorydoesnotexist } -body { - slave msg $a -tmpdir thisdirectorydoesnotexist + child msg $a -tmpdir thisdirectorydoesnotexist file exists [file join thisdirectorydoesnotexist a.tmp] } -cleanup { file delete -force thisdirectorydoesnotexist @@ -533,7 +533,7 @@ test tcltest-8.1 {tcltest a.tcl -tmpdir a} -constraints unixOrWin -setup { test tcltest-8.2 {tcltest a.tcl -tmpdir thisdirectoryisafile} { -constraints unixOrWin -body { - slave msg $a -tmpdir $tdiaf + child msg $a -tmpdir $tdiaf return $msg } -result {*not a directory*} @@ -558,7 +558,7 @@ switch -- $::tcl_platform(platform) { test tcltest-8.3 {tcltest a.tcl -tmpdir notReadableDir} { -constraints {unix notRoot} -body { - slave msg $a -tmpdir $notReadableDir + child msg $a -tmpdir $notReadableDir return $msg } -result {*not readable*} @@ -574,7 +574,7 @@ testConstraint notFAT [expr { test tcltest-8.4 {tcltest a.tcl -tmpdir notWriteableDir} { -constraints {unixOrWin notRoot notFAT} -body { - slave msg $a -tmpdir $notWriteableDir + child msg $a -tmpdir $notWriteableDir return $msg } -result {*not writeable*} @@ -583,7 +583,7 @@ test tcltest-8.4 {tcltest a.tcl -tmpdir notWriteableDir} { test tcltest-8.5 {tcltest a.tcl -tmpdir normaldirectory} { -constraints unixOrWin -body { - slave msg $a -tmpdir $normaldirectory + child msg $a -tmpdir $normaldirectory # The join is necessary because the message can be split on multiple # lines file exists [file join $normaldirectory a.tmp] @@ -629,7 +629,7 @@ test tcltest-8.10 {tcltest a.tcl -testdir thisdirectorydoesnotexist} { file delete -force thisdirectorydoesnotexist } -body { - slave msg $a -testdir thisdirectorydoesnotexist + child msg $a -testdir thisdirectorydoesnotexist return $msg } -match glob @@ -638,7 +638,7 @@ test tcltest-8.10 {tcltest a.tcl -testdir thisdirectorydoesnotexist} { test tcltest-8.11 {tcltest a.tcl -testdir thisdirectoryisafile} { -constraints unixOrWin -body { - slave msg $a -testdir $tdiaf + child msg $a -testdir $tdiaf return $msg } -match glob @@ -647,7 +647,7 @@ test tcltest-8.11 {tcltest a.tcl -testdir thisdirectoryisafile} { test tcltest-8.12 {tcltest a.tcl -testdir notReadableDir} { -constraints {unix notRoot} -body { - slave msg $a -testdir $notReadableDir + child msg $a -testdir $notReadableDir return $msg } -match glob @@ -656,7 +656,7 @@ test tcltest-8.12 {tcltest a.tcl -testdir notReadableDir} { test tcltest-8.13 {tcltest a.tcl -testdir normaldirectory} { -constraints unixOrWin -body { - slave msg $a -testdir $normaldirectory + child msg $a -testdir $normaldirectory # The join is necessary because the message can be split on multiple # lines list [string first "testdir: $normaldirectory" [join $msg]] \ @@ -735,7 +735,7 @@ test tcltest-9.1 {-file d*.tcl} -constraints {unixOrWin} -setup { set old [testsDirectory] testsDirectory [file dirname [info script]] } -body { - slave msg [file join [testsDirectory] all.tcl] -file d*.test + child msg [file join [testsDirectory] all.tcl] -file d*.test return $msg } -cleanup { testsDirectory $old @@ -745,7 +745,7 @@ test tcltest-9.2 {-file d*.tcl} -constraints {unixOrWin} -setup { set old [testsDirectory] testsDirectory [file dirname [info script]] } -body { - slave msg [file join [testsDirectory] all.tcl] \ + child msg [file join [testsDirectory] all.tcl] \ -file d*.test -notfile dstring* regexp {dstring\.test} $msg } -cleanup { @@ -784,7 +784,7 @@ test tcltest-9.5 {GetMatchingFiles: Bug 1119798} -setup { makeFile {} fee $d file copy [file join [file dirname [info script]] all.tcl] $d } -body { - slave msg [file join [temporaryDirectory] all.tcl] -file f* + child msg [file join [temporaryDirectory] all.tcl] -file f* regexp {exiting with errors:} $msg } -cleanup { file delete [file join $d all.tcl] @@ -807,23 +807,23 @@ set mc [makeFile { cd [temporaryDirectory] test tcltest-10.1 {-preservecore 0} {unixOrWin} { - slave msg $mc -preservecore 0 + child msg $mc -preservecore 0 file delete core regexp "Core file produced" $msg } {0} test tcltest-10.2 {-preservecore 1} {unixOrWin} { - slave msg $mc -preservecore 1 + child msg $mc -preservecore 1 file delete core regexp "Core file produced" $msg } {1} test tcltest-10.3 {-preservecore 2} {unixOrWin} { - slave msg $mc -preservecore 2 + child msg $mc -preservecore 2 file delete core list [regexp "Core file produced" $msg] [regexp "Moving file to" $msg] \ [regexp "core-" $msg] [file delete core-makecore] } {1 1 1 {}} test tcltest-10.4 {-preservecore 3} {unixOrWin} { - slave msg $mc -preservecore 3 + child msg $mc -preservecore 3 file delete core list [regexp "Core file produced" $msg] [regexp "Moving file to" $msg] \ [regexp "core-" $msg] [file delete core-makecore] @@ -854,7 +854,7 @@ set contents { set loadfile [makeFile $contents load.tcl] test tcltest-12.1 {-load xxx} {unixOrWin} { - slave msg $loadfile -load xxx + child msg $loadfile -load xxx return $msg } {xxx} @@ -952,7 +952,7 @@ cd [workingDirectory] test tcltest-14.1 {-singleproc - single process} { -constraints {unixOrWin} -body { - slave msg $allfile -singleproc 0 -tmpdir [temporaryDirectory] + child msg $allfile -singleproc 0 -tmpdir [temporaryDirectory] return $msg } -result {Test file error: can't unset .foo.: no such variable} @@ -962,7 +962,7 @@ test tcltest-14.1 {-singleproc - single process} { test tcltest-14.2 {-singleproc - multiple process} { -constraints {unixOrWin} -body { - slave msg $allfile -singleproc 1 -tmpdir [temporaryDirectory] + child msg $allfile -singleproc 1 -tmpdir [temporaryDirectory] return $msg } -result {single1.test.*single2.test.*all\-single.tcl:.*Total.*0.*Passed.*0.*Skipped.*0.*Failed.*0} @@ -1026,7 +1026,7 @@ makeFile { test tcltest-15.1 {basic directory walking} { -constraints {unixOrWin} -body { - if {[slave msg \ + if {[child msg \ [file join $dtd all.tcl] \ -tmpdir [temporaryDirectory]] == 1} { error $msg @@ -1040,7 +1040,7 @@ test tcltest-15.1 {basic directory walking} { test tcltest-15.2 {-asidefromdir} { -constraints {unixOrWin} -body { - if {[slave msg \ + if {[child msg \ [file join $dtd all.tcl] \ -asidefromdir dirtestdir2.3 \ -tmpdir [temporaryDirectory]] == 1} { @@ -1058,7 +1058,7 @@ Error: No test files remain after applying your match and skip patterns!$} test tcltest-15.3 {-relateddir, non-existent dir} { -constraints {unixOrWin} -body { - if {[slave msg \ + if {[child msg \ [file join $dtd all.tcl] \ -relateddir [file join [temporaryDirectory] dirtestdir0] \ -tmpdir [temporaryDirectory]] == 1} { @@ -1073,7 +1073,7 @@ test tcltest-15.3 {-relateddir, non-existent dir} { test tcltest-15.4 {-relateddir, subdir} { -constraints {unixOrWin} -body { - if {[slave msg \ + if {[child msg \ [file join $dtd all.tcl] \ -relateddir dirtestdir2.1 -tmpdir [temporaryDirectory]] == 1} { error $msg @@ -1086,7 +1086,7 @@ test tcltest-15.4 {-relateddir, subdir} { test tcltest-15.5 {-relateddir, -asidefromdir} { -constraints {unixOrWin} -body { - if {[slave msg \ + if {[child msg \ [file join $dtd all.tcl] \ -relateddir "dirtestdir2.1 dirtestdir2.2" \ -asidefromdir dirtestdir2.2 \ @@ -1147,25 +1147,25 @@ test tcltest-19.1 {TCLTEST_OPTIONS default} -setup { # set this to { } instead of just {} to get around quirk in # Windows env handling that removes empty elements from env array. set ::env(TCLTEST_OPTIONS) { } - interp create slave1 - slave1 eval [list set argv {-debug 2}] - slave1 alias puts puts - interp create slave2 - slave2 alias puts puts + interp create child1 + child1 eval [list set argv {-debug 2}] + child1 alias puts puts + interp create child2 + child2 alias puts puts } -cleanup { - interp delete slave2 - interp delete slave1 + interp delete child2 + interp delete child1 if {$oldoptions eq "none"} { unset ::env(TCLTEST_OPTIONS) } else { set ::env(TCLTEST_OPTIONS) $oldoptions } } -body { - slave1 eval [package ifneeded tcltest [package provide tcltest]] - slave1 eval tcltest::debug + child1 eval [package ifneeded tcltest [package provide tcltest]] + child1 eval tcltest::debug set ::env(TCLTEST_OPTIONS) "-debug 3" - slave2 eval [package ifneeded tcltest [package provide tcltest]] - slave2 eval tcltest::debug + child2 eval [package ifneeded tcltest [package provide tcltest]] + child2 eval tcltest::debug } -result {^3$} -match regexp -output\ {tcltest::debug\s+= 2.*tcltest::debug\s+= 3} @@ -1174,7 +1174,7 @@ test tcltest-19.1 {TCLTEST_OPTIONS default} -setup { cd [temporaryDirectory] # PrintError test tcltest-20.1 {PrintError} {unixOrWin} { - set result [slave msg $printerror] + set result [child msg $printerror] list $result [regexp "Error: a really short string" $msg] \ [regexp " \"quotes\"" $msg] [regexp " \"Path" $msg] \ [regexp " \"Really" $msg] [regexp Problem $msg] @@ -1407,7 +1407,7 @@ makeFile { } test.test $atd # Must use a child process because stdout/stderr parsing can't be -# duplicated in slave interp. +# duplicated in child interp. test tcltest-22.1 {runAllTests} { -constraints {unixOrWin} -body { @@ -1806,7 +1806,7 @@ test tcltest-26.1 {Bug/RFE 1017151} -setup { tcltest::cleanupTests } test.tcl } -body { - slave msg [file join [temporaryDirectory] test.tcl] + child msg [file join [temporaryDirectory] test.tcl] return $msg } -cleanup { removeFile test.tcl @@ -1826,7 +1826,7 @@ test tcltest-26.2 {Bug/RFE 1017151} -setup { tcltest::cleanupTests } test.tcl } -body { - slave msg [file join [temporaryDirectory] test.tcl] + child msg [file join [temporaryDirectory] test.tcl] return $msg } -cleanup { removeFile test.tcl diff --git a/tests/thread.test b/tests/thread.test index eaaaa41..9f14470 100644 --- a/tests/thread.test +++ b/tests/thread.test @@ -802,7 +802,7 @@ test thread-7.21 {cancel: subst -unwind} -constraints {thread drainEventQueue} - } -cleanup { unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted } -result {{} 1 1 {eval unwound}} -test thread-7.22 {cancel: slave interp} -constraints {thread drainEventQueue} -setup { +test thread-7.22 {cancel: child interp} -constraints {thread drainEventQueue} -setup { unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted } -body { set serverthread [thread::create -joinable \ @@ -832,7 +832,7 @@ test thread-7.22 {cancel: slave interp} -constraints {thread drainEventQueue} -s } -cleanup { unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted } -result {{} 1 1 {eval canceled}} -test thread-7.23 {cancel: slave interp -unwind} -constraints {thread drainEventQueue} -setup { +test thread-7.23 {cancel: child interp -unwind} -constraints {thread drainEventQueue} -setup { unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted } -body { set serverthread [thread::create -joinable \ diff --git a/tests/timer.test b/tests/timer.test index 740d05e..b422f35 100644 --- a/tests/timer.test +++ b/tests/timer.test @@ -568,15 +568,15 @@ test timer-9.1 {AfterCleanupProc procedure} -setup { } -result {before after2 after4} test timer-10.1 {Bug 1016167: [after] overwrites imports} -setup { - interp create slave - slave eval namespace export after - slave eval namespace eval foo namespace import ::after + interp create child + child eval namespace export after + child eval namespace eval foo namespace import ::after } -body { - slave eval foo::after 1 - slave eval namespace origin foo::after + child eval foo::after 1 + child eval namespace origin foo::after } -cleanup { # Bug will cause crash here; would cause failure otherwise - interp delete slave + interp delete child } -result ::after test timer-11.1 {Bug 1350291: [after] overflowing 32-bit field} -body { diff --git a/tests/trace.test b/tests/trace.test index d830f3c..c54efff 100644 --- a/tests/trace.test +++ b/tests/trace.test @@ -2197,11 +2197,11 @@ foo {if {[catch {bar}]} { }} 2 error leavestep foo foo 0 error leave}} -test trace-28.4 {exec traces in slave with 'return -code error'} { - interp create slave - interp alias slave traceExecute {} traceExecute +test trace-28.4 {exec traces in child with 'return -code error'} { + interp create child + interp alias child traceExecute {} traceExecute set info {} - set res [interp eval slave { + set res [interp eval child { set info {} set res {} @@ -2229,7 +2229,7 @@ test trace-28.4 {exec traces in slave with 'return -code error'} { list $res }] - interp delete slave + interp delete child lappend res [join $info \n] } {{error error} {foo foo enter foo {if {[catch {bar}]} { diff --git a/tests/var.test b/tests/var.test index 32388a2..202b66c 100644 --- a/tests/var.test +++ b/tests/var.test @@ -53,7 +53,7 @@ catch {unset arr} test var-1.1 {TclLookupVar, Array handling} -setup { catch {unset a} } -body { - set x "incr" ;# force no compilation and runtime call to Tcl_IncrCmd + set x "incr" ;# force no compilation and runtime call to Tcl_IncrCmd set i 10 set arr(foo) 37 list [$x i] $i [$x arr(foo)] $arr(foo) @@ -256,7 +256,7 @@ test var-3.3 {MakeUpvar, my var has TCL_GLOBAL_ONLY specified} -setup { set a 123321 proc p {} { # create global xx linked to global a - testupvar 1 a {} xx global + testupvar 1 a {} xx global } list [p] $xx [set xx 789] $a } -result {{} 123321 789 789} @@ -268,7 +268,7 @@ test var-3.4 {MakeUpvar, my var has TCL_NAMESPACE_ONLY specified} -setup { catch {unset ::test_ns_var::vv} proc p {} { # create namespace var vv linked to global a - testupvar 1 a {} vv namespace + testupvar 1 a {} vv namespace } p } @@ -570,11 +570,11 @@ test var-7.14 {Tcl_VariableObjCmd, array element parameter} -body { namespace eval test_ns_var { variable arrayvar(1) } } -returnCodes error -result "can't define \"arrayvar(1)\": name refers to an element in an array" test var-7.15 {Tcl_VariableObjCmd, array element parameter} -body { - namespace eval test_ns_var { + namespace eval test_ns_var { variable arrayvar set arrayvar(1) x variable arrayvar(1) y - } + } } -returnCodes error -result "can't define \"arrayvar(1)\": name refers to an element in an array" test var-7.16 {Tcl_VariableObjCmd, no args (TIP 323)} { variable @@ -828,7 +828,7 @@ test var-15.1 {segfault in [unset], [Bug 735335]} { set var $name } # - # Note that the variable name has to be + # Note that the variable name has to be # unused previously for the segfault to # be triggered. # @@ -1046,15 +1046,15 @@ test var-22.1 {leak in localVarName intrep: Bug 80304238ac} -setup { lindex [split [memory info] \n] 3 3 } proc doit {} { - interp create slave - slave eval { + interp create child + child eval { proc doit script { eval $script set foo bar } doit {foreach foo baz {}} } - interp delete slave + interp delete child } } -constraints memory -body { set end [getbytes] diff --git a/tools/tcltk-man2html.tcl b/tools/tcltk-man2html.tcl index a7231f7..a9327b8 100755 --- a/tools/tcltk-man2html.tcl +++ b/tools/tcltk-man2html.tcl @@ -587,6 +587,7 @@ array set exclude_refs_map { scrollbar.n {set} selection.n {string} tcltest.n {error} + text.n {bind image lower raise} tkvars.n {tk} tkwait.n {variable} tm.n {exec} diff --git a/unix/Makefile.in b/unix/Makefile.in index 87f0844..670e76c 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -2027,9 +2027,9 @@ rpm: all rm -rf RPMS THIS.TCL.SPEC # -# Target to create a proper Tcl distribution from information in the master -# source directory. DISTDIR must be defined to indicate where to put the -# distribution. DISTDIR must be an absolute path name. +# Target to create a proper Tcl distribution from information in the +# source directory. DISTDIR must be defined to indicate where to put +# the distribution. DISTDIR must be an absolute path name. # DISTROOT = /tmp/dist diff --git a/win/rules.vc b/win/rules.vc index d4765b9..6dca6d9 100644 --- a/win/rules.vc +++ b/win/rules.vc @@ -514,7 +514,7 @@ CFG_ENCODING = \"cp1252\" # information about supported compiler options etc. # # Tcl itself will always use the nmakehlp.c program which is -# in its own source. This is the "master" copy and kept updated. +# in its own source. It will be kept updated there. # # Extensions built against an installed Tcl will use the installed # copy of Tcl's nmakehlp.c if there is one and their own version @@ -1669,7 +1669,7 @@ default-shell: default-setup $(PROJECT) !ifdef RCFILE # Note: don't use $** in below rule because there may be other dependencies -# and only the "master" rc must be passed to the resource compiler +# and only the "main" rc must be passed to the resource compiler $(TMP_DIR)\$(PROJECT).res: $(RCDIR)\$(PROJECT).rc $(RESCMD) $(RCDIR)\$(PROJECT).rc @@ -1723,7 +1723,7 @@ DISABLE_IMPLICIT_RULES = 0 !if !$(DISABLE_IMPLICIT_RULES) # Implicit rule definitions - only for building library objects. For stubs and -# main application, the master makefile should define explicit rules. +# main application, the makefile should define explicit rules. {$(ROOT)}.c{$(TMP_DIR)}.obj:: $(CCPKGCMD) @<< -- cgit v0.12 From 264c84606b485bb031fbd8ac6b3eba23938b0d7f Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 2 Sep 2020 11:46:35 +0000 Subject: Upgrade Travis build from xcode 11.5 to 11.7 --- .travis.yml | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/.travis.yml b/.travis.yml index ad3f03a..7f93fa0 100644 --- a/.travis.yml +++ b/.travis.yml @@ -126,9 +126,9 @@ jobs: - BUILD_DIR=unix - CFGOPT="--enable-symbols=mem" # Testing on Mac, various styles - - name: "macOS/Xcode 11.5/Shared" + - name: "macOS/Xcode 11.7/Shared" os: osx - osx_image: xcode11.5 + osx_image: xcode11.7 env: - BUILD_DIR=macosx install: [] @@ -136,9 +136,9 @@ jobs: - make all # The styles=develop avoids some weird problems on OSX - make test styles=develop - - name: "macOS/Xcode 11.5/Shared/Unix-like" + - name: "macOS/Xcode 11.7/Shared/Unix-like" os: osx - osx_image: xcode11.5 + osx_image: xcode11.7 env: - BUILD_DIR=unix # Older MacOS versions -- cgit v0.12 From a4abf50c23f2a2b458181704617172b1de3e772a Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 4 Sep 2020 07:28:20 +0000 Subject: TIP #581: Mainly documentation and some testcases --- doc/CrtAlias.3 | 34 ++++---- doc/FileSystem.3 | 4 +- doc/Limit.3 | 2 +- doc/interp.n | 240 ++++++++++++++++++++++++++-------------------------- doc/library.n | 2 +- doc/pkgMkIndex.n | 4 +- doc/safe.n | 104 +++++++++++------------ generic/tcl.decls | 14 +-- generic/tclDecls.h | 35 ++++---- generic/tclEvent.c | 4 +- generic/tclIOUtil.c | 2 +- tests/winDde.test | 178 +++++++++++++++++++------------------- 12 files changed, 311 insertions(+), 312 deletions(-) diff --git a/doc/CrtAlias.3 b/doc/CrtAlias.3 index a0041af..2934fc3 100644 --- a/doc/CrtAlias.3 +++ b/doc/CrtAlias.3 @@ -44,22 +44,22 @@ Tcl_Interp * \fBTcl_GetMaster\fR(\fIinterp\fR) .sp int -\fBTcl_GetInterpPath\fR(\fIinterp, slaveInterp\fR) +\fBTcl_GetInterpPath\fR(\fIinterp, childInterp\fR) .sp int -\fBTcl_CreateAlias\fR(\fIslaveInterp, slaveCmd, targetInterp, targetCmd, +\fBTcl_CreateAlias\fR(\fIchildInterp, childCmd, targetInterp, targetCmd, argc, argv\fR) .sp int -\fBTcl_CreateAliasObj\fR(\fIslaveInterp, slaveCmd, targetInterp, targetCmd, +\fBTcl_CreateAliasObj\fR(\fIchildInterp, childCmd, targetInterp, targetCmd, objc, objv\fR) .sp int -\fBTcl_GetAlias\fR(\fIinterp, slaveCmd, targetInterpPtr, targetCmdPtr, +\fBTcl_GetAlias\fR(\fIinterp, childCmd, targetInterpPtr, targetCmdPtr, argcPtr, argvPtr\fR) .sp int -\fBTcl_GetAliasObj\fR(\fIinterp, slaveCmd, targetInterpPtr, targetCmdPtr, +\fBTcl_GetAliasObj\fR(\fIinterp, childCmd, targetInterpPtr, targetCmdPtr, objcPtr, objvPtr\fR) .sp int @@ -72,16 +72,16 @@ int .AP Tcl_Interp *interp in Interpreter in which to execute the specified command. .AP "const char" *name in -Name of slave interpreter to create or manipulate. +Name of child interpreter to create or manipulate. .AP int isSafe in If non-zero, a .QW safe -slave that is suitable for running untrusted code -is created, otherwise a trusted slave is created. -.AP Tcl_Interp *slaveInterp in +child that is suitable for running untrusted code +is created, otherwise a trusted child is created. +.AP Tcl_Interp *childInterp in Interpreter to use for creating the source command for an alias (see below). -.AP "const char" *slaveCmd in +.AP "const char" *childCmd in Name of source command for alias. .AP Tcl_Interp *targetInterp in Interpreter that contains the target command for an alias. @@ -186,22 +186,22 @@ top-level interpreter) then \fBNULL\fR is returned. .VE "TIP 581" .PP \fBTcl_GetInterpPath\fR stores in the result of \fIinterp\fR -the relative path between \fIinterp\fR and \fIslaveInterp\fR; -\fIslaveInterp\fR must be a slave of \fIinterp\fR. If the computation +the relative path between \fIinterp\fR and \fIchildInterp\fR; +\fIchildInterp\fR must be a slave of \fIinterp\fR. If the computation of the relative path succeeds, \fBTCL_OK\fR is returned, else \fBTCL_ERROR\fR is returned and an error message is stored as the result of \fIinterp\fR. .PP -\fBTcl_CreateAlias\fR creates a command named \fIslaveCmd\fR in -\fIslaveInterp\fR that when invoked, will cause the command \fItargetCmd\fR +\fBTcl_CreateAlias\fR creates a command named \fIchildCmd\fR in +\fIchildInterp\fR that when invoked, will cause the command \fItargetCmd\fR to be invoked in \fItargetInterp\fR. The arguments specified by the strings contained in \fIargv\fR are always prepended to any arguments supplied in the -invocation of \fIslaveCmd\fR and passed to \fItargetCmd\fR. +invocation of \fIchildCmd\fR and passed to \fItargetCmd\fR. This operation returns \fBTCL_OK\fR if it succeeds, or \fBTCL_ERROR\fR if it fails; in that case, an error message is left in the value result -of \fIslaveInterp\fR. +of \fIchildInterp\fR. Note that there are no restrictions on the ancestry relationship (as -created by \fBTcl_CreateSlave\fR) between \fIslaveInterp\fR and +created by \fBTcl_CreateSlave\fR) between \fIchildInterp\fR and \fItargetInterp\fR. Any two interpreters can be used, without any restrictions on how they are related. .PP diff --git a/doc/FileSystem.3 b/doc/FileSystem.3 index 28ee8f0..4a57743 100644 --- a/doc/FileSystem.3 +++ b/doc/FileSystem.3 @@ -1350,11 +1350,11 @@ is considered to be owned by the filesystem (not by Tcl's core), but should be given a reference count for Tcl. Tcl will use the contents of the list and then decrement that reference count. This allows filesystems to choose whether they actually want to retain a -.QW "master list" +.QW "global list" of volumes or not (if not, they generate the list on the fly and pass it to Tcl with a reference count of 1 and then forget about the list, if yes, then -they simply increment the reference count of their master list and pass it +they simply increment the reference count of their global list and pass it to Tcl which will copy the contents and then decrement the count back to where it was). .PP diff --git a/doc/Limit.3 b/doc/Limit.3 index 5939a80..3d202fc 100644 --- a/doc/Limit.3 +++ b/doc/Limit.3 @@ -116,7 +116,7 @@ execution of the callbacks is unspecified) execution in the limited interpreter is stopped by raising an error and setting a flag that prevents the \fBcatch\fR command in that interpreter from trapping that error. It is up to the context that started execution in that -interpreter (typically a master interpreter) to handle the error. +interpreter (typically the main interpreter) to handle the error. .SH "LIMIT CHECKING API" .PP To check the resource limits for an interpreter, call diff --git a/doc/interp.n b/doc/interp.n index 9f975d0..61aa151 100644 --- a/doc/interp.n +++ b/doc/interp.n @@ -19,18 +19,18 @@ interp \- Create and manipulate Tcl interpreters .PP This command makes it possible to create one or more new Tcl interpreters that co-exist with the creating interpreter in the -same application. The creating interpreter is called the \fImaster\fR -and the new interpreter is called a \fIslave\fR. -A master can create any number of slaves, and each slave can -itself create additional slaves for which it is master, resulting +same application. The creating interpreter is called the \fIparent\fR +and the new interpreter is called a \fIchild\fR. +A parent can create any number of children, and each child can +itself create additional children for which it is parent, resulting in a hierarchy of interpreters. .PP Each interpreter is independent from the others: it has its own name space for commands, procedures, and global variables. -A master interpreter may create connections between its slaves and +A parent interpreter may create connections between its children and itself using a mechanism called an \fIalias\fR. An \fIalias\fR is -a command in a slave interpreter which, when invoked, causes a -command to be invoked in its master interpreter or in another slave +a command in a child interpreter which, when invoked, causes a +command to be invoked in its parent interpreter or in another child interpreter. The only other connections between interpreters are through environment variables (the \fBenv\fR variable), which are normally shared among all interpreters in the application, @@ -41,7 +41,7 @@ share files and to transfer references to open files from one interpreter to another. .PP The \fBinterp\fR command also provides support for \fIsafe\fR -interpreters. A safe interpreter is a slave whose functions have +interpreters. A safe interpreter is a child whose functions have been greatly restricted, so that it is safe to execute untrusted scripts without fear of them damaging other interpreters or the application's environment. For example, all IO channel creation @@ -54,18 +54,18 @@ instead, it is \fIhidden\fR, so that only trusted interpreters can obtain access to it. For a detailed explanation of hidden commands, see \fBHIDDEN COMMANDS\fR, below. The alias mechanism can be used for protected communication (analogous to a -kernel call) between a slave interpreter and its master. +kernel call) between a child interpreter and its parent. See \fBALIAS INVOCATION\fR, below, for more details on how the alias mechanism works. .PP A qualified interpreter name is a proper Tcl lists containing a subset of its ancestors in the interpreter hierarchy, terminated by the string naming the -interpreter in its immediate master. Interpreter names are relative to the +interpreter in its immediate parent. Interpreter names are relative to the interpreter in which they are used. For example, if .QW \fBa\fR -is a slave of the current interpreter and it has a slave +is a child of the current interpreter and it has a child .QW \fBa1\fR , -which in turn has a slave +which in turn has a child .QW \fBa11\fR , the qualified name of .QW \fBa11\fR @@ -77,14 +77,14 @@ is the list The \fBinterp\fR command, described below, accepts qualified interpreter names as arguments; the interpreter in which the command is being evaluated can always be referred to as \fB{}\fR (the empty list or string). Note that -it is impossible to refer to a master (ancestor) interpreter by name in a -slave interpreter except through aliases. Also, there is no global name by +it is impossible to refer to a parent (ancestor) interpreter by name in a +child interpreter except through aliases. Also, there is no global name by which one can refer to the first interpreter created in an application. Both restrictions are motivated by safety concerns. .SH "THE INTERP COMMAND" .PP The \fBinterp\fR command is used to create, delete, and manipulate -slave interpreters, and to share or transfer +child interpreters, and to share or transfer channels between interpreters. It can have any of several forms, depending on the \fIsubcommand\fR argument: .TP @@ -94,11 +94,11 @@ Returns a Tcl list whose elements are the \fItargetCmd\fR and \fIarg\fRs associated with the alias represented by \fIsrcToken\fR (this is the value returned when the alias was created; it is possible that the name of the source command in the -slave is different from \fIsrcToken\fR). +child is different from \fIsrcToken\fR). .TP \fBinterp\fR \fBalias\fR \fIsrcPath\fR \fIsrcToken\fR \fB{}\fR . -Deletes the alias for \fIsrcToken\fR in the slave interpreter identified by +Deletes the alias for \fIsrcToken\fR in the child interpreter identified by \fIsrcPath\fR. \fIsrcToken\fR refers to the value returned when the alias was created; if the source command has been renamed, the renamed @@ -106,9 +106,9 @@ command will be deleted. .TP \fBinterp\fR \fBalias\fR \fIsrcPath\fR \fIsrcCmd\fR \fItargetPath\fR \fItargetCmd \fR?\fIarg arg ...\fR? . -This command creates an alias between one slave and another (see the -\fBalias\fR slave command below for creating aliases between a slave -and its master). In this command, either of the slave interpreters +This command creates an alias between one child and another (see the +\fBalias\fR child command below for creating aliases between a child +and its parent). In this command, either of the child interpreters may be anywhere in the hierarchy of interpreters under the interpreter invoking the command. \fISrcPath\fR and \fIsrcCmd\fR identify the source of the alias. @@ -117,9 +117,9 @@ interpreter. For example, .QW "\fBa b\fR" identifies an interpreter .QW \fBb\fR , -which is a slave of interpreter +which is a child of interpreter .QW \fBa\fR , -which is a slave of the invoking interpreter. An empty list specifies +which is a child of the invoking interpreter. An empty list specifies the interpreter invoking the command. \fIsrcCmd\fR gives the name of a new command, which will be created in the source interpreter. \fITargetPath\fR and \fItargetCmd\fR specify a target interpreter @@ -171,33 +171,33 @@ used. .TP \fBinterp\fR \fBcreate \fR?\fB\-safe\fR? ?\fB\-\|\-\fR? ?\fIpath\fR? . -Creates a slave interpreter identified by \fIpath\fR and a new command, -called a \fIslave command\fR. The name of the slave command is the last -component of \fIpath\fR. The new slave interpreter and the slave command +Creates a child interpreter identified by \fIpath\fR and a new command, +called a \fIchild command\fR. The name of the child command is the last +component of \fIpath\fR. The new child interpreter and the child command are created in the interpreter identified by the path obtained by removing the last component from \fIpath\fR. For example, if \fIpath\fR is \fBa b -c\fR then a new slave interpreter and slave command named \fBc\fR are +c\fR then a new child interpreter and child command named \fBc\fR are created in the interpreter identified by the path \fBa b\fR. -The slave command may be used to manipulate the new interpreter as +The child command may be used to manipulate the new interpreter as described below. If \fIpath\fR is omitted, Tcl creates a unique name of the form \fBinterp\fIx\fR, where \fIx\fR is an integer, and uses it for the -interpreter and the slave command. If the \fB\-safe\fR switch is specified -(or if the master interpreter is a safe interpreter), the new slave +interpreter and the child command. If the \fB\-safe\fR switch is specified +(or if the parent interpreter is a safe interpreter), the new child interpreter will be created as a safe interpreter with limited -functionality; otherwise the slave will include the full set of Tcl +functionality; otherwise the child will include the full set of Tcl built-in commands and variables. The \fB\-\|\-\fR switch can be used to mark the end of switches; it may be needed if \fIpath\fR is an unusual value such as \fB\-safe\fR. The result of the command is the name of the -new interpreter. The name of a slave interpreter must be unique among all -the slaves for its master; an error occurs if a slave interpreter by the -given name already exists in this master. -The initial recursion limit of the slave interpreter is set to the +new interpreter. The name of a child interpreter must be unique among all +the children for its parent; an error occurs if a child interpreter by the +given name already exists in this parent. +The initial recursion limit of the child interpreter is set to the current recursion limit of its parent interpreter. .TP \fBinterp\fR \fBdebug \fIpath\fR ?\fB\-frame\fR ?\fIbool\fR?? . Controls whether frame-level stack information is captured in the -slave interpreter identified by \fIpath\fR. If no arguments are +child interpreter identified by \fIpath\fR. If no arguments are given, option and current setting are returned. If \fB\-frame\fR is given, the debug setting is set to the given boolean if provided and the current setting is returned. @@ -239,8 +239,8 @@ consistency of the underlying interpreter's state. \fBinterp\fR \fBdelete \fR?\fIpath ...?\fR . Deletes zero or more interpreters given by the optional \fIpath\fR -arguments, and for each interpreter, it also deletes its slaves. The -command also deletes the slave command for each interpreter deleted. +arguments, and for each interpreter, it also deletes its children. The +command also deletes the child command for each interpreter deleted. For each \fIpath\fR argument, if no interpreter by that name exists, the command raises an error. .TP @@ -248,20 +248,20 @@ exists, the command raises an error. . This command concatenates all of the \fIarg\fR arguments in the same fashion as the \fBconcat\fR command, then evaluates the resulting string as -a Tcl script in the slave interpreter identified by \fIpath\fR. The result +a Tcl script in the child interpreter identified by \fIpath\fR. The result of this evaluation (including all \fBreturn\fR options, such as \fB\-errorinfo\fR and \fB\-errorcode\fR information, if an error occurs) is returned to the invoking interpreter. Note that the script will be executed in the current context stack frame of the -\fIpath\fR interpreter; this is so that the implementations (in a master -interpreter) of aliases in a slave interpreter can execute scripts in -the slave that find out information about the slave's current state +\fIpath\fR interpreter; this is so that the implementations (in a parent +interpreter) of aliases in a child interpreter can execute scripts in +the child that find out information about the child's current state and stack frame. .TP \fBinterp exists \fIpath\fR . -Returns \fB1\fR if a slave interpreter by the specified \fIpath\fR -exists in this master, \fB0\fR otherwise. If \fIpath\fR is omitted, the +Returns \fB1\fR if a child interpreter by the specified \fIpath\fR +exists in this parent, \fB0\fR otherwise. If \fIpath\fR is omitted, the invoking interpreter is used. .TP \fBinterp expose \fIpath\fR \fIhiddenName\fR ?\fIexposedCmdName\fR? @@ -287,7 +287,7 @@ Currently both \fIexposedCmdName\fR and \fIhiddenCmdName\fR can not contain namespace qualifiers, or an error is raised. Commands to be hidden by \fBinterp hide\fR are looked up in the global namespace even if the current namespace is not the global one. This -prevents slaves from fooling a master interpreter into hiding the wrong +prevents children from fooling a parent interpreter into hiding the wrong command, by making the current namespace be different from the global one. Hidden commands are explained in more detail in \fBHIDDEN COMMANDS\fR, below. .TP @@ -373,7 +373,7 @@ interpreter is destroyed. .TP \fBinterp\fR \fBslaves\fR ?\fIpath\fR? . -Returns a Tcl list of the names of all the slave interpreters associated +Returns a Tcl list of the names of all the child interpreters associated with the interpreter identified by \fIpath\fR. If \fIpath\fR is omitted, the invoking interpreter is used. .TP @@ -399,48 +399,48 @@ The target command does not have to be defined at the time of this invocation. Causes the IO channel identified by \fIchannelId\fR to become available in the interpreter identified by \fIdestPath\fR and unavailable in the interpreter identified by \fIsrcPath\fR. -.SH "SLAVE COMMAND" +.SH "child COMMAND" .PP -For each slave interpreter created with the \fBinterp\fR command, a -new Tcl command is created in the master interpreter with the same +For each child interpreter created with the \fBinterp\fR command, a +new Tcl command is created in the parent interpreter with the same name as the new interpreter. This command may be used to invoke various operations on the interpreter. It has the following general form: .PP .CS -\fIslave command \fR?\fIarg arg ...\fR? +\fIchild command \fR?\fIarg arg ...\fR? .CE .PP -\fISlave\fR is the name of the interpreter, and \fIcommand\fR +\fIchild\fR is the name of the interpreter, and \fIcommand\fR and the \fIarg\fRs determine the exact behavior of the command. The valid forms of this command are: .TP -\fIslave \fBaliases\fR +\fIchild \fBaliases\fR . Returns a Tcl list whose elements are the tokens of all the -aliases in \fIslave\fR. The tokens correspond to the values returned when +aliases in \fIchild\fR. The tokens correspond to the values returned when the aliases were created (which may not be the same as the current names of the commands). .TP -\fIslave \fBalias \fIsrcToken\fR +\fIchild \fBalias \fIsrcToken\fR . Returns a Tcl list whose elements are the \fItargetCmd\fR and \fIarg\fRs associated with the alias represented by \fIsrcToken\fR (this is the value returned when the alias was created; it is possible that the actual source command in the -slave is different from \fIsrcToken\fR). +child is different from \fIsrcToken\fR). .TP -\fIslave \fBalias \fIsrcToken \fB{}\fR +\fIchild \fBalias \fIsrcToken \fB{}\fR . -Deletes the alias for \fIsrcToken\fR in the slave interpreter. +Deletes the alias for \fIsrcToken\fR in the child interpreter. \fIsrcToken\fR refers to the value returned when the alias was created; if the source command has been renamed, the renamed command will be deleted. .TP -\fIslave \fBalias \fIsrcCmd targetCmd \fR?\fIarg ..\fR? +\fIchild \fBalias \fIsrcCmd targetCmd \fR?\fIarg ..\fR? . Creates an alias such that whenever \fIsrcCmd\fR is invoked -in \fIslave\fR, \fItargetCmd\fR is invoked in the master. +in \fIchild\fR, \fItargetCmd\fR is invoked in the parent. The \fIarg\fR arguments will be passed to \fItargetCmd\fR as additional arguments, prepended before any arguments passed in the invocation of \fIsrcCmd\fR. @@ -449,69 +449,69 @@ The command returns a token that uniquely identifies the command created \fIsrcCmd\fR, even if the command is renamed afterwards. The token may but does not have to be equal to \fIsrcCmd\fR. .TP -\fIslave \fBbgerror\fR ?\fIcmdPrefix\fR? +\fIchild \fBbgerror\fR ?\fIcmdPrefix\fR? . This command either gets or sets the current background exception handler -for the \fIslave\fR interpreter. If \fIcmdPrefix\fR is +for the \fIchild\fR interpreter. If \fIcmdPrefix\fR is absent, the current background exception handler is returned, and if it is present, it is a list of words (of minimum length one) that describes what to set the interpreter's background exception handler to. See the \fBBACKGROUND EXCEPTION HANDLING\fR section for more details. .TP -\fIslave \fBeval \fIarg \fR?\fIarg ..\fR? +\fIchild \fBeval \fIarg \fR?\fIarg ..\fR? . This command concatenates all of the \fIarg\fR arguments in the same fashion as the \fBconcat\fR command, then evaluates -the resulting string as a Tcl script in \fIslave\fR. +the resulting string as a Tcl script in \fIchild\fR. The result of this evaluation (including all \fBreturn\fR options, such as \fB\-errorinfo\fR and \fB\-errorcode\fR information, if an error occurs) is returned to the invoking interpreter. Note that the script will be executed in the current context stack frame -of \fIslave\fR; this is so that the implementations (in a master -interpreter) of aliases in a slave interpreter can execute scripts in -the slave that find out information about the slave's current state +of \fIchild\fR; this is so that the implementations (in a parent +interpreter) of aliases in a child interpreter can execute scripts in +the child that find out information about the child's current state and stack frame. .TP -\fIslave \fBexpose \fIhiddenName \fR?\fIexposedCmdName\fR? +\fIchild \fBexpose \fIhiddenName \fR?\fIexposedCmdName\fR? . This command exposes the hidden command \fIhiddenName\fR, eventually bringing it back under a new \fIexposedCmdName\fR name (this name is currently accepted only if it is a valid global name space name without any ::), -in \fIslave\fR. +in \fIchild\fR. If an exposed command with the targeted name already exists, this command fails. For more details on hidden commands, see \fBHIDDEN COMMANDS\fR, below. .TP -\fIslave \fBhide \fIexposedCmdName\fR ?\fIhiddenCmdName\fR? +\fIchild \fBhide \fIexposedCmdName\fR ?\fIhiddenCmdName\fR? . This command hides the exposed command \fIexposedCmdName\fR, renaming it to the hidden command \fIhiddenCmdName\fR, or keeping the same name if the -argument is not given, in the \fIslave\fR interpreter. +argument is not given, in the \fIchild\fR interpreter. If a hidden command with the targeted name already exists, this command fails. Currently both \fIexposedCmdName\fR and \fIhiddenCmdName\fR can not contain namespace qualifiers, or an error is raised. Commands to be hidden are looked up in the global namespace even if the current namespace is not the global one. This -prevents slaves from fooling a master interpreter into hiding the wrong +prevents children from fooling a parent interpreter into hiding the wrong command, by making the current namespace be different from the global one. For more details on hidden commands, see \fBHIDDEN COMMANDS\fR, below. .TP -\fIslave \fBhidden\fR +\fIchild \fBhidden\fR . -Returns a list of the names of all hidden commands in \fIslave\fR. +Returns a list of the names of all hidden commands in \fIchild\fR. .TP -\fIslave \fBinvokehidden\fR ?\fI\-option ...\fR? \fIhiddenName \fR?\fIarg ..\fR? +\fIchild \fBinvokehidden\fR ?\fI\-option ...\fR? \fIhiddenName \fR?\fIarg ..\fR? . This command invokes the hidden command \fIhiddenName\fR with the -supplied arguments, in \fIslave\fR. No substitutions or evaluations are +supplied arguments, in \fIchild\fR. No substitutions or evaluations are applied to the arguments. Three \fI\-option\fRs are supported, all of which start with \fB\-\fR: \fB\-namespace\fR (which takes a single argument afterwards, \fInsName\fR), \fB\-global\fR, and \fB\-\|\-\fR. If the \fB\-namespace\fR flag is given, the hidden command is invoked in -the specified namespace in the slave. +the specified namespace in the child. If the \fB\-global\fR flag is given, the command is invoked at the global -level in the slave; otherwise it is invoked at the current call frame and +level in the child; otherwise it is invoked at the current call frame and can access local variables in that or outer call frames. The \fB\-\|\-\fR flag allows the \fIhiddenCmdName\fR argument to start with a .QW \- @@ -519,37 +519,37 @@ character, and is otherwise unnecessary. If both the \fB\-namespace\fR and \fB\-global\fR flags are given, the \fB\-namespace\fR flag is ignored. Note that the hidden command will be executed (by default) in the -current context stack frame of \fIslave\fR. +current context stack frame of \fIchild\fR. For more details on hidden commands, see \fBHIDDEN COMMANDS\fR, below. .TP -\fIslave \fBissafe\fR +\fIchild \fBissafe\fR . -Returns \fB1\fR if the slave interpreter is safe, \fB0\fR otherwise. +Returns \fB1\fR if the child interpreter is safe, \fB0\fR otherwise. .TP -\fIslave \fBlimit\fR \fIlimitType\fR ?\fI\-option\fR? ?\fIvalue\fR \fI...\fR? +\fIchild \fBlimit\fR \fIlimitType\fR ?\fI\-option\fR? ?\fIvalue\fR \fI...\fR? . Sets up, manipulates and queries the configuration of the resource -limit \fIlimitType\fR for the slave interpreter. If no \fI\-option\fR +limit \fIlimitType\fR for the child interpreter. If no \fI\-option\fR is specified, return the current configuration of the limit. If \fI\-option\fR is the sole argument, return the value of that option. Otherwise, a list of \fI\-option\fR/\fIvalue\fR argument pairs must supplied. See \fBRESOURCE LIMITS\fR below for a more detailed explanation of what limits and options are supported. .TP -\fIslave \fBmarktrusted\fR +\fIchild \fBmarktrusted\fR . -Marks the slave interpreter as trusted. Can only be invoked by a +Marks the child interpreter as trusted. Can only be invoked by a trusted interpreter. This command does not expose any hidden -commands in the slave interpreter. The command has no effect if the slave +commands in the child interpreter. The command has no effect if the child is already trusted. .TP -\fIslave\fR \fBrecursionlimit\fR ?\fInewlimit\fR? +\fIchild\fR \fBrecursionlimit\fR ?\fInewlimit\fR? . -Returns the maximum allowable nesting depth for the \fIslave\fR interpreter. -If \fInewlimit\fR is specified, the recursion limit in \fIslave\fR will be +Returns the maximum allowable nesting depth for the \fIchild\fR interpreter. +If \fInewlimit\fR is specified, the recursion limit in \fIchild\fR will be set so that nesting of more than \fInewlimit\fR calls to \fBTcl_Eval()\fR -and related procedures in \fIslave\fR will return an error. +and related procedures in \fIchild\fR will return an error. The \fInewlimit\fR value is also returned. The \fInewlimit\fR value must be a positive integer between 1 and the maximum value of a non-long integer on the platform. @@ -573,14 +573,14 @@ For example, commands to create files on disk are removed, and the \fBexec\fR command is removed, since it could be used to cause damage through subprocesses. Limited access to these facilities can be provided, by creating -aliases to the master interpreter which check their arguments carefully +aliases to the parent interpreter which check their arguments carefully and provide restricted access to a safe subset of facilities. For example, file creation might be allowed in a particular subdirectory and subprocess invocation might be allowed for a carefully selected and fixed set of programs. .PP A safe interpreter is created by specifying the \fB\-safe\fR switch -to the \fBinterp create\fR command. Furthermore, any slave created +to the \fBinterp create\fR command. Furthermore, any child created by a safe interpreter will also be safe. .PP A safe interpreter is created with exactly the following set of @@ -668,14 +668,14 @@ including itself. .PP The alias mechanism has been carefully designed so that it can be used safely when an untrusted script is executing -in a safe slave and the target of the alias is a trusted -master. The most important thing in guaranteeing safety is to -ensure that information passed from the slave to the master is -never evaluated or substituted in the master; if this were to -occur, it would enable an evil script in the slave to invoke -arbitrary functions in the master, which would compromise security. -.PP -When the source for an alias is invoked in the slave interpreter, the +in a safe child and the target of the alias is a trusted +parent. The most important thing in guaranteeing safety is to +ensure that information passed from the child to the parent is +never evaluated or substituted in the parent; if this were to +occur, it would enable an evil script in the child to invoke +arbitrary functions in the parent, which would compromise security. +.PP +When the source for an alias is invoked in the child interpreter, the usual Tcl substitutions are performed when parsing that command. These substitutions are carried out in the source interpreter just as they would be for any other command invoked in that interpreter. @@ -702,8 +702,8 @@ the alias's source command is parsed in the source interpreter. When writing the \fItargetCmd\fRs for aliases in safe interpreters, it is very important that the arguments to that command never be evaluated or substituted, since this would provide an escape -mechanism whereby the slave interpreter could execute arbitrary -code in the master. This in turn would compromise the security +mechanism whereby the child interpreter could execute arbitrary +code in the parent. This in turn would compromise the security of the system. .SH "HIDDEN COMMANDS" .PP @@ -730,28 +730,28 @@ invoke\fR. Hidden commands and exposed commands reside in separate name spaces. It is possible to define a hidden command and an exposed command by the same name within one interpreter. .PP -Hidden commands in a slave interpreter can be invoked in the body of -procedures called in the master during alias invocation. For example, an -alias for \fBsource\fR could be created in a slave interpreter. When it is -invoked in the slave interpreter, a procedure is called in the master +Hidden commands in a child interpreter can be invoked in the body of +procedures called in the parent during alias invocation. For example, an +alias for \fBsource\fR could be created in a child interpreter. When it is +invoked in the child interpreter, a procedure is called in the parent interpreter to check that the operation is allowable (e.g. it asks to -source a file that the slave interpreter is allowed to access). The -procedure then it invokes the hidden \fBsource\fR command in the slave +source a file that the child interpreter is allowed to access). The +procedure then it invokes the hidden \fBsource\fR command in the child interpreter to actually source in the contents of the file. Note that two -commands named \fBsource\fR exist in the slave interpreter: the alias, and +commands named \fBsource\fR exist in the child interpreter: the alias, and the hidden command. .PP -Because a master interpreter may invoke a hidden command as part of +Because a parent interpreter may invoke a hidden command as part of handling an alias invocation, great care must be taken to avoid evaluating any arguments passed in through the alias invocation. -Otherwise, malicious slave interpreters could cause a trusted master +Otherwise, malicious child interpreters could cause a trusted parent interpreter to execute dangerous commands on their behalf. See the section on \fBALIAS INVOCATION\fR for a more complete discussion of this topic. To help avoid this problem, no substitutions or evaluations are applied to arguments of \fBinterp invokehidden\fR. .PP Safe interpreters are not allowed to invoke hidden commands in themselves -or in their descendants. This prevents safe slaves from gaining access to +or in their descendants. This prevents safe children from gaining access to hidden functionality in themselves or their descendants. .PP The set of hidden commands in an interpreter can be manipulated by a trusted @@ -770,12 +770,12 @@ qualifiers, and you must first rename a command in a namespace to the global namespace before you can hide it. Commands to be hidden by \fBinterp hide\fR are looked up in the global namespace even if the current namespace is not the global one. This -prevents slaves from fooling a master interpreter into hiding the wrong +prevents children from fooling a parent interpreter into hiding the wrong command, by making the current namespace be different from the global one. .SH "RESOURCE LIMITS" .PP Every interpreter has two kinds of resource limits that may be imposed by any -master interpreter upon its slaves. Command limits (of type \fBcommand\fR) +parent interpreter upon its children. Command limits (of type \fBcommand\fR) restrict the total number of Tcl commands that may be executed by an interpreter (as can be inspected via the \fBinfo cmdcount\fR command), and time limits (of type \fBtime\fR) place a limit by which execution within the @@ -784,7 +784,7 @@ interpreter must complete. Note that time limits are expressed as \fBafter\fR) because they may be modified after creation. .PP When a limit is exceeded for an interpreter, first any handler callbacks -defined by master interpreters are called. If those callbacks increase or +defined by parent interpreters are called. If those callbacks increase or remove the limit, execution within the (previously) limited interpreter continues. If the limit is still in force, an error is generated at that point and normal processing of errors within the interpreter (by the \fBcatch\fR @@ -841,13 +841,13 @@ This option specifies the number of commands that the interpreter may execute before triggering the command limit. This option may be the empty string, which indicates that a command limit is not set for the interpreter. .PP -Where an interpreter with a resource limit set on it creates a slave -interpreter, that slave interpreter will have resource limits imposed on it -that are at least as restrictive as the limits on the creating master -interpreter. If the master interpreter of the limited master wishes to relax +Where an interpreter with a resource limit set on it creates a child +interpreter, that child interpreter will have resource limits imposed on it +that are at least as restrictive as the limits on the creating parent +interpreter. If the parent interpreter of the limited parent wishes to relax these conditions, it should hide the \fBinterp\fR command in the child and then use aliases and the \fBinterp invokehidden\fR subcommand to provide such -access as it chooses to the \fBinterp\fR command to the limited master as +access as it chooses to the \fBinterp\fR command to the limited parent as necessary. .SH "BACKGROUND EXCEPTION HANDLING" .PP @@ -908,9 +908,9 @@ set i [\fBinterp create\fR] } .CE .SH "SEE ALSO" -bgerror(n), load(n), safe(n), Tcl_CreateSlave(3), Tcl_Eval(3), Tcl_BackgroundException(3) +bgerror(n), load(n), safe(n), Tcl_CreateChild(3), Tcl_Eval(3), Tcl_BackgroundException(3) .SH KEYWORDS -alias, master interpreter, safe interpreter, slave interpreter +alias, parent interpreter, safe interpreter, child interpreter '\"Local Variables: '\"mode: nroff '\"End: diff --git a/doc/library.n b/doc/library.n index 6f8f265..87f13bd 100644 --- a/doc/library.n +++ b/doc/library.n @@ -124,7 +124,7 @@ will read all the \fB.tcl\fR files in subdirectory \fBfoo\fR and generate a new index file \fBfoo/tclIndex\fR. .PP \fBAuto_mkindex\fR parses the Tcl scripts by sourcing them into a -slave interpreter and monitoring the proc and namespace commands that +child interpreter and monitoring the proc and namespace commands that are executed. Extensions can use the (undocumented) auto_mkindex_parser package to register other commands that can contribute to the auto_load index. You will have to read through diff --git a/doc/pkgMkIndex.n b/doc/pkgMkIndex.n index ec39be9..5a6b905 100644 --- a/doc/pkgMkIndex.n +++ b/doc/pkgMkIndex.n @@ -42,7 +42,7 @@ The default pattern is \fB*.tcl\fR and \fB*.[info sharedlibextension]\fR. \fBPkg_mkIndex\fR will create a file \fBpkgIndex.tcl\fR in \fIdir\fR with package information about all the files given by the \fIpattern\fR arguments. -It does this by loading each file into a slave +It does this by loading each file into a child interpreter and seeing what packages and new commands appear (this is why it is essential to have \fBpackage provide\fR commands or \fBTcl_PkgProvide\fR calls @@ -109,7 +109,7 @@ the use of \fIauto_reset\fR, and therefore its use is discouraged. .TP 15 \fB\-load \fIpkgPat\fR The index process will pre-load any packages that exist in the -current interpreter and match \fIpkgPat\fR into the slave interpreter used to +current interpreter and match \fIpkgPat\fR into the child interpreter used to generate the index. The pattern match uses string match rules, but without making case distinctions. See \fBCOMPLEX CASES\fR below. diff --git a/doc/safe.n b/doc/safe.n index 7ddb182..819287d 100644 --- a/doc/safe.n +++ b/doc/safe.n @@ -11,17 +11,17 @@ .SH NAME safe \- Creating and manipulating safe interpreters .SH SYNOPSIS -\fB::safe::interpCreate\fR ?\fIslave\fR? ?\fIoptions...\fR? +\fB::safe::interpCreate\fR ?\fIchild\fR? ?\fIoptions...\fR? .sp -\fB::safe::interpInit\fR \fIslave\fR ?\fIoptions...\fR? +\fB::safe::interpInit\fR \fIchild\fR ?\fIoptions...\fR? .sp -\fB::safe::interpConfigure\fR \fIslave\fR ?\fIoptions...\fR? +\fB::safe::interpConfigure\fR \fIchild\fR ?\fIoptions...\fR? .sp -\fB::safe::interpDelete\fR \fIslave\fR +\fB::safe::interpDelete\fR \fIchild\fR .sp -\fB::safe::interpAddToAccessPath\fR \fIslave\fR \fIdirectory\fR +\fB::safe::interpAddToAccessPath\fR \fIchild\fR \fIdirectory\fR .sp -\fB::safe::interpFindInAccessPath\fR \fIslave\fR \fIdirectory\fR +\fB::safe::interpFindInAccessPath\fR \fIchild\fR \fIdirectory\fR .sp \fB::safe::setLogCmd\fR ?\fIcmd arg...\fR? .SS OPTIONS @@ -44,7 +44,7 @@ application or computer. Untrusted scripts are also prevented from disclosing information stored on the hosting computer or in the hosting application to any party. .PP -Safe Tcl allows a master interpreter to create safe, restricted +Safe Tcl allows a parent interpreter to create safe, restricted interpreters that contain a set of predefined aliases for the \fBsource\fR, \fBload\fR, \fBfile\fR, \fBencoding\fR, and \fBexit\fR commands and are able to use the auto-loading and package mechanisms. @@ -53,47 +53,47 @@ No knowledge of the file system structure is leaked to the safe interpreter, because it has access only to a virtualized path containing tokens. When the safe interpreter requests to source a file, it uses the token in the virtual path as part of the file name to source; the -master interpreter transparently +parent interpreter transparently translates the token into a real directory name and executes the requested operation (see the section \fBSECURITY\fR below for details). Different levels of security can be selected by using the optional flags of the commands described below. .PP -All commands provided in the master interpreter by Safe Tcl reside in +All commands provided in the parent interpreter by Safe Tcl reside in the \fBsafe\fR namespace. .SH COMMANDS -The following commands are provided in the master interpreter: +The following commands are provided in the parent interpreter: .TP -\fB::safe::interpCreate\fR ?\fIslave\fR? ?\fIoptions...\fR? +\fB::safe::interpCreate\fR ?\fIchild\fR? ?\fIoptions...\fR? Creates a safe interpreter, installs the aliases described in the section \fBALIASES\fR and initializes the auto-loading and package mechanism as specified by the supplied \fIoptions\fR. See the \fBOPTIONS\fR section below for a description of the optional arguments. -If the \fIslave\fR argument is omitted, a name will be generated. +If the \fIchild\fR argument is omitted, a name will be generated. \fB::safe::interpCreate\fR always returns the interpreter name. .sp -The interpreter name \fIslave\fR may include namespace separators, +The interpreter name \fIchild\fR may include namespace separators, but may not have leading or trailing namespace separators, or excess colon characters in namespace separators. The interpreter name is qualified relative to the global namespace ::, not the namespace in which the \fB::safe::interpCreate\fR command is evaluated. .TP -\fB::safe::interpInit\fR \fIslave\fR ?\fIoptions...\fR? +\fB::safe::interpInit\fR \fIchild\fR ?\fIoptions...\fR? This command is similar to \fBinterpCreate\fR except it that does not -create the safe interpreter. \fIslave\fR must have been created by some +create the safe interpreter. \fIchild\fR must have been created by some other means, like \fBinterp create\fR \fB\-safe\fR. The interpreter -name \fIslave\fR may include namespace separators, subject to the same +name \fIchild\fR may include namespace separators, subject to the same restrictions as for \fBinterpCreate\fR. .TP -\fB::safe::interpConfigure\fR \fIslave\fR ?\fIoptions...\fR? +\fB::safe::interpConfigure\fR \fIchild\fR ?\fIoptions...\fR? If no \fIoptions\fR are given, returns the settings for all options for the named safe interpreter as a list of options and their current values -for that \fIslave\fR. +for that \fIchild\fR. If a single additional argument is provided, it will return a list of 2 elements \fIname\fR and \fIvalue\fR where \fIname\fR is the full name of that option and \fIvalue\fR the current value -for that option and the \fIslave\fR. +for that option and the \fIchild\fR. If more than two additional arguments are provided, it will reconfigure the safe interpreter and change each and only the provided options. See the section on \fBOPTIONS\fR below for options description. @@ -113,14 +113,14 @@ safe::interpConfigure $i0 \-delete {foo bar} \-statics 0 .CE .RE .TP -\fB::safe::interpDelete\fR \fIslave\fR +\fB::safe::interpDelete\fR \fIchild\fR Deletes the safe interpreter and cleans up the corresponding -master interpreter data structures. +parent interpreter data structures. If a \fIdeleteHook\fR script was specified for this interpreter it is evaluated before the interpreter is deleted, with the name of the interpreter as an additional argument. .TP -\fB::safe::interpFindInAccessPath\fR \fIslave\fR \fIdirectory\fR +\fB::safe::interpFindInAccessPath\fR \fIchild\fR \fIdirectory\fR This command finds and returns the token for the real directory \fIdirectory\fR in the safe interpreter's current virtual access path. It generates an error if the directory is not found. @@ -128,14 +128,14 @@ Example of use: .RS .PP .CS -$slave eval [list set tk_library \e +$child eval [list set tk_library \e [::safe::interpFindInAccessPath $name $tk_library]] .CE .RE .TP -\fB::safe::interpAddToAccessPath\fR \fIslave\fR \fIdirectory\fR +\fB::safe::interpAddToAccessPath\fR \fIchild\fR \fIdirectory\fR This command adds \fIdirectory\fR to the virtual path maintained for the -safe interpreter in the master, and returns the token that can be used in +safe interpreter in the parent, and returns the token that can be used in the safe interpreter to obtain access to files in that directory. If the directory is already in the virtual path, it only returns the token without adding the directory to the virtual path again. @@ -143,7 +143,7 @@ Example of use: .RS .PP .CS -$slave eval [list set tk_library \e +$child eval [list set tk_library \e [::safe::interpAddToAccessPath $name $tk_library]] .CE .RE @@ -176,10 +176,10 @@ Note that the safe interpreter only received an error message saying that the file was not found: .PP .CS -NOTICE for slave interp10 : Created -NOTICE for slave interp10 : Setting accessPath=(/foo/bar) staticsok=1 nestedok=0 deletehook=() -NOTICE for slave interp10 : auto_path in interp10 has been set to {$p(:0:)} -ERROR for slave interp10 : /foo/bar/init.tcl: no such file or directory +NOTICE for child interp10 : Created +NOTICE for child interp10 : Setting accessPath=(/foo/bar) staticsok=1 nestedok=0 deletehook=() +NOTICE for child interp10 : auto_path in interp10 has been set to {$p(:0:)} +ERROR for child interp10 : /foo/bar/init.tcl: no such file or directory .CE .RE .SS OPTIONS @@ -195,7 +195,7 @@ This option sets the list of directories from which the safe interpreter can \fBsource\fR and \fBload\fR files. If this option is not specified, or if it is given as the empty list, the safe interpreter will use the same directories as its -master for auto-loading. +parent for auto-loading. See the section \fBSECURITY\fR below for more detail about virtual paths, tokens and access control. .TP @@ -224,7 +224,7 @@ to load packages into its own sub-interpreters. .TP \fB\-deleteHook\fR \fIscript\fR When this option is given a non-empty \fIscript\fR, it will be -evaluated in the master with the name of +evaluated in the parent with the name of the safe interpreter as an additional argument just before actually deleting the safe interpreter. Giving an empty value removes any currently installed deletion hook @@ -289,8 +289,8 @@ potential for information leakage about its directory structure. To prevent this, commands that take file names as arguments in a safe interpreter use tokens instead of the real directory names. These tokens are translated to the real directory name while a request to, -e.g., source a file is mediated by the master interpreter. -This virtual path system is maintained in the master interpreter for each safe +e.g., source a file is mediated by the parent interpreter. +This virtual path system is maintained in the parent interpreter for each safe interpreter created by \fB::safe::interpCreate\fR or initialized by \fB::safe::interpInit\fR and the path maps tokens accessible in the safe interpreter into real path @@ -299,7 +299,7 @@ from gaining knowledge about the structure of the file system of the host on which the interpreter is executing. The only valid file names arguments -for the \fBsource\fR and \fBload\fR aliases provided to the slave +for the \fBsource\fR and \fBload\fR aliases provided to the child are path in the form of \fB[file join \fItoken filename\fB]\fR (i.e. when using the native file path formats: \fItoken\fB/\fIfilename\fR @@ -328,26 +328,26 @@ or be called .PP Each element of the initial access path list will be assigned a token that will be set in -the slave \fBauto_path\fR and the first element of that list will be set as -the \fBtcl_library\fR for that slave. +the child \fBauto_path\fR and the first element of that list will be set as +the \fBtcl_library\fR for that child. .PP If the access path argument is not given or is the empty list, -the default behavior is to let the slave access the same packages -as the master has access to (Or to be more precise: +the default behavior is to let the child access the same packages +as the parent has access to (Or to be more precise: only packages written in Tcl (which by definition cannot be dangerous -as they run in the slave interpreter) and C extensions that -provides a _SafeInit entry point). For that purpose, the master's -\fBauto_path\fR will be used to construct the slave access path. -In order that the slave successfully loads the Tcl library files +as they run in the child interpreter) and C extensions that +provides a _SafeInit entry point). For that purpose, the parent's +\fBauto_path\fR will be used to construct the child access path. +In order that the child successfully loads the Tcl library files (which includes the auto-loading mechanism itself) the \fBtcl_library\fR will be added or moved to the first position if necessary, in the -slave access path, so the slave -\fBtcl_library\fR will be the same as the master's (its real -path will still be invisible to the slave though). -In order that auto-loading works the same for the slave and -the master in this by default case, the first-level -sub directories of each directory in the master \fBauto_path\fR will -also be added (if not already included) to the slave access path. +child access path, so the child +\fBtcl_library\fR will be the same as the parent's (its real +path will still be invisible to the child though). +In order that auto-loading works the same for the child and +the parent in this by default case, the first-level +sub directories of each directory in the parent \fBauto_path\fR will +also be added (if not already included) to the child access path. You can always specify a more restrictive path for which sub directories will never be searched by explicitly specifying your directory list with the \fB\-accessPath\fR flag @@ -360,8 +360,8 @@ to synchronize its \fBauto_index\fR with the new token list. .SH "SEE ALSO" interp(n), library(n), load(n), package(n), source(n), unknown(n) .SH KEYWORDS -alias, auto\-loading, auto_mkindex, load, master interpreter, safe -interpreter, slave interpreter, source +alias, auto\-loading, auto_mkindex, load, parent interpreter, safe +interpreter, child interpreter, source '\" Local Variables: '\" mode: nroff '\" End: diff --git a/generic/tcl.decls b/generic/tcl.decls index 6f35631..23e8f6a 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -316,12 +316,12 @@ declare 85 { int flags) } declare 86 { - int Tcl_CreateAlias(Tcl_Interp *slave, const char *slaveCmd, + int Tcl_CreateAlias(Tcl_Interp *childInterp, const char *childCmd, Tcl_Interp *target, const char *targetCmd, int argc, CONST84 char *const *argv) } declare 87 { - int Tcl_CreateAliasObj(Tcl_Interp *slave, const char *slaveCmd, + int Tcl_CreateAliasObj(Tcl_Interp *childInterp, const char *childCmd, Tcl_Interp *target, const char *targetCmd, int objc, Tcl_Obj *const objv[]) } @@ -364,7 +364,7 @@ declare 96 { Tcl_CmdDeleteProc *deleteProc) } declare 97 { - Tcl_Interp *Tcl_CreateSlave(Tcl_Interp *interp, const char *slaveName, + Tcl_Interp *Tcl_CreateSlave(Tcl_Interp *interp, const char *name, int isSafe) } declare 98 { @@ -527,12 +527,12 @@ declare 147 { void Tcl_FreeResult(Tcl_Interp *interp) } declare 148 { - int Tcl_GetAlias(Tcl_Interp *interp, const char *slaveCmd, + int Tcl_GetAlias(Tcl_Interp *interp, const char *childCmd, Tcl_Interp **targetInterpPtr, CONST84 char **targetCmdPtr, int *argcPtr, CONST84 char ***argvPtr) } declare 149 { - int Tcl_GetAliasObj(Tcl_Interp *interp, const char *slaveCmd, + int Tcl_GetAliasObj(Tcl_Interp *interp, const char *childCmd, Tcl_Interp **targetInterpPtr, CONST84 char **targetCmdPtr, int *objcPtr, Tcl_Obj ***objv) } @@ -582,7 +582,7 @@ declare 162 { CONST84_RETURN char *Tcl_GetHostName(void) } declare 163 { - int Tcl_GetInterpPath(Tcl_Interp *interp, Tcl_Interp *slaveInterp) + int Tcl_GetInterpPath(Tcl_Interp *interp, Tcl_Interp *childInterp) } declare 164 { Tcl_Interp *Tcl_GetMaster(Tcl_Interp *interp) @@ -616,7 +616,7 @@ declare 171 { int Tcl_GetServiceMode(void) } declare 172 { - Tcl_Interp *Tcl_GetSlave(Tcl_Interp *interp, const char *slaveName) + Tcl_Interp *Tcl_GetSlave(Tcl_Interp *interp, const char *name) } declare 173 { Tcl_Channel Tcl_GetStdChannel(int type) diff --git a/generic/tclDecls.h b/generic/tclDecls.h index e0854d6..0f18dd4 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -279,13 +279,13 @@ EXTERN int Tcl_ConvertElement(const char *src, char *dst, EXTERN int Tcl_ConvertCountedElement(const char *src, int length, char *dst, int flags); /* 86 */ -EXTERN int Tcl_CreateAlias(Tcl_Interp *slave, - const char *slaveCmd, Tcl_Interp *target, +EXTERN int Tcl_CreateAlias(Tcl_Interp *childInterp, + const char *childCmd, Tcl_Interp *target, const char *targetCmd, int argc, CONST84 char *const *argv); /* 87 */ -EXTERN int Tcl_CreateAliasObj(Tcl_Interp *slave, - const char *slaveCmd, Tcl_Interp *target, +EXTERN int Tcl_CreateAliasObj(Tcl_Interp *childInterp, + const char *childCmd, Tcl_Interp *target, const char *targetCmd, int objc, Tcl_Obj *const objv[]); /* 88 */ @@ -323,8 +323,8 @@ EXTERN Tcl_Command Tcl_CreateObjCommand(Tcl_Interp *interp, ClientData clientData, Tcl_CmdDeleteProc *deleteProc); /* 97 */ -EXTERN Tcl_Interp * Tcl_CreateSlave(Tcl_Interp *interp, - const char *slaveName, int isSafe); +EXTERN Tcl_Interp * Tcl_CreateSlave(Tcl_Interp *interp, const char *name, + int isSafe); /* 98 */ EXTERN Tcl_TimerToken Tcl_CreateTimerHandler(int milliseconds, Tcl_TimerProc *proc, ClientData clientData); @@ -458,13 +458,13 @@ EXTERN int Tcl_Flush(Tcl_Channel chan); EXTERN void Tcl_FreeResult(Tcl_Interp *interp); /* 148 */ EXTERN int Tcl_GetAlias(Tcl_Interp *interp, - const char *slaveCmd, + const char *childCmd, Tcl_Interp **targetInterpPtr, CONST84 char **targetCmdPtr, int *argcPtr, CONST84 char ***argvPtr); /* 149 */ EXTERN int Tcl_GetAliasObj(Tcl_Interp *interp, - const char *slaveCmd, + const char *childCmd, Tcl_Interp **targetInterpPtr, CONST84 char **targetCmdPtr, int *objcPtr, Tcl_Obj ***objv); @@ -504,7 +504,7 @@ EXTERN int Tcl_GetErrno(void); EXTERN CONST84_RETURN char * Tcl_GetHostName(void); /* 163 */ EXTERN int Tcl_GetInterpPath(Tcl_Interp *interp, - Tcl_Interp *slaveInterp); + Tcl_Interp *childInterp); /* 164 */ EXTERN Tcl_Interp * Tcl_GetMaster(Tcl_Interp *interp); /* 165 */ @@ -532,8 +532,7 @@ EXTERN int Tcl_GetsObj(Tcl_Channel chan, Tcl_Obj *objPtr); /* 171 */ EXTERN int Tcl_GetServiceMode(void); /* 172 */ -EXTERN Tcl_Interp * Tcl_GetSlave(Tcl_Interp *interp, - const char *slaveName); +EXTERN Tcl_Interp * Tcl_GetSlave(Tcl_Interp *interp, const char *name); /* 173 */ EXTERN Tcl_Channel Tcl_GetStdChannel(int type); /* 174 */ @@ -1949,8 +1948,8 @@ typedef struct TclStubs { char * (*tcl_Concat) (int argc, CONST84 char *const *argv); /* 83 */ int (*tcl_ConvertElement) (const char *src, char *dst, int flags); /* 84 */ int (*tcl_ConvertCountedElement) (const char *src, int length, char *dst, int flags); /* 85 */ - int (*tcl_CreateAlias) (Tcl_Interp *slave, const char *slaveCmd, Tcl_Interp *target, const char *targetCmd, int argc, CONST84 char *const *argv); /* 86 */ - int (*tcl_CreateAliasObj) (Tcl_Interp *slave, const char *slaveCmd, Tcl_Interp *target, const char *targetCmd, int objc, Tcl_Obj *const objv[]); /* 87 */ + int (*tcl_CreateAlias) (Tcl_Interp *childInterp, const char *childCmd, Tcl_Interp *target, const char *targetCmd, int argc, CONST84 char *const *argv); /* 86 */ + int (*tcl_CreateAliasObj) (Tcl_Interp *childInterp, const char *childCmd, Tcl_Interp *target, const char *targetCmd, int objc, Tcl_Obj *const objv[]); /* 87 */ Tcl_Channel (*tcl_CreateChannel) (const Tcl_ChannelType *typePtr, const char *chanName, ClientData instanceData, int mask); /* 88 */ void (*tcl_CreateChannelHandler) (Tcl_Channel chan, int mask, Tcl_ChannelProc *proc, ClientData clientData); /* 89 */ void (*tcl_CreateCloseHandler) (Tcl_Channel chan, Tcl_CloseProc *proc, ClientData clientData); /* 90 */ @@ -1960,7 +1959,7 @@ typedef struct TclStubs { Tcl_Interp * (*tcl_CreateInterp) (void); /* 94 */ void (*tcl_CreateMathFunc) (Tcl_Interp *interp, const char *name, int numArgs, Tcl_ValueType *argTypes, Tcl_MathProc *proc, ClientData clientData); /* 95 */ Tcl_Command (*tcl_CreateObjCommand) (Tcl_Interp *interp, const char *cmdName, Tcl_ObjCmdProc *proc, ClientData clientData, Tcl_CmdDeleteProc *deleteProc); /* 96 */ - Tcl_Interp * (*tcl_CreateSlave) (Tcl_Interp *interp, const char *slaveName, int isSafe); /* 97 */ + Tcl_Interp * (*tcl_CreateSlave) (Tcl_Interp *interp, const char *name, int isSafe); /* 97 */ Tcl_TimerToken (*tcl_CreateTimerHandler) (int milliseconds, Tcl_TimerProc *proc, ClientData clientData); /* 98 */ Tcl_Trace (*tcl_CreateTrace) (Tcl_Interp *interp, int level, Tcl_CmdTraceProc *proc, ClientData clientData); /* 99 */ void (*tcl_DeleteAssocData) (Tcl_Interp *interp, const char *name); /* 100 */ @@ -2011,8 +2010,8 @@ typedef struct TclStubs { Tcl_HashEntry * (*tcl_FirstHashEntry) (Tcl_HashTable *tablePtr, Tcl_HashSearch *searchPtr); /* 145 */ int (*tcl_Flush) (Tcl_Channel chan); /* 146 */ void (*tcl_FreeResult) (Tcl_Interp *interp); /* 147 */ - int (*tcl_GetAlias) (Tcl_Interp *interp, const char *slaveCmd, Tcl_Interp **targetInterpPtr, CONST84 char **targetCmdPtr, int *argcPtr, CONST84 char ***argvPtr); /* 148 */ - int (*tcl_GetAliasObj) (Tcl_Interp *interp, const char *slaveCmd, Tcl_Interp **targetInterpPtr, CONST84 char **targetCmdPtr, int *objcPtr, Tcl_Obj ***objv); /* 149 */ + int (*tcl_GetAlias) (Tcl_Interp *interp, const char *childCmd, Tcl_Interp **targetInterpPtr, CONST84 char **targetCmdPtr, int *argcPtr, CONST84 char ***argvPtr); /* 148 */ + int (*tcl_GetAliasObj) (Tcl_Interp *interp, const char *childCmd, Tcl_Interp **targetInterpPtr, CONST84 char **targetCmdPtr, int *objcPtr, Tcl_Obj ***objv); /* 149 */ ClientData (*tcl_GetAssocData) (Tcl_Interp *interp, const char *name, Tcl_InterpDeleteProc **procPtr); /* 150 */ Tcl_Channel (*tcl_GetChannel) (Tcl_Interp *interp, const char *chanName, int *modePtr); /* 151 */ int (*tcl_GetChannelBufferSize) (Tcl_Channel chan); /* 152 */ @@ -2026,7 +2025,7 @@ typedef struct TclStubs { CONST84_RETURN char * (*tcl_GetCommandName) (Tcl_Interp *interp, Tcl_Command command); /* 160 */ int (*tcl_GetErrno) (void); /* 161 */ CONST84_RETURN char * (*tcl_GetHostName) (void); /* 162 */ - int (*tcl_GetInterpPath) (Tcl_Interp *interp, Tcl_Interp *slaveInterp); /* 163 */ + int (*tcl_GetInterpPath) (Tcl_Interp *interp, Tcl_Interp *childInterp); /* 163 */ Tcl_Interp * (*tcl_GetMaster) (Tcl_Interp *interp); /* 164 */ const char * (*tcl_GetNameOfExecutable) (void); /* 165 */ Tcl_Obj * (*tcl_GetObjResult) (Tcl_Interp *interp); /* 166 */ @@ -2043,7 +2042,7 @@ typedef struct TclStubs { int (*tcl_Gets) (Tcl_Channel chan, Tcl_DString *dsPtr); /* 169 */ int (*tcl_GetsObj) (Tcl_Channel chan, Tcl_Obj *objPtr); /* 170 */ int (*tcl_GetServiceMode) (void); /* 171 */ - Tcl_Interp * (*tcl_GetSlave) (Tcl_Interp *interp, const char *slaveName); /* 172 */ + Tcl_Interp * (*tcl_GetSlave) (Tcl_Interp *interp, const char *name); /* 172 */ Tcl_Channel (*tcl_GetStdChannel) (int type); /* 173 */ CONST84_RETURN char * (*tcl_GetStringResult) (Tcl_Interp *interp); /* 174 */ CONST84_RETURN char * (*tcl_GetVar) (Tcl_Interp *interp, const char *varName, int flags); /* 175 */ diff --git a/generic/tclEvent.c b/generic/tclEvent.c index e56c21b..ae40850 100644 --- a/generic/tclEvent.c +++ b/generic/tclEvent.c @@ -1043,7 +1043,7 @@ TclInitSubsystems(void) * implementation of self-initializing locks. */ - TclInitThreadStorage(); /* Creates master hash table for + TclInitThreadStorage(); /* Creates hash table for * thread local storage */ #if USE_TCLALLOC TclInitAlloc(); /* Process wide mutex init */ @@ -1157,7 +1157,7 @@ Tcl_Finalize(void) TclFinalizeFilesystem(); /* - * Undo all Tcl_ObjType registrations, and reset the master list of free + * Undo all Tcl_ObjType registrations, and reset the global list of free * Tcl_Obj's. After this returns, no more Tcl_Obj's should be allocated or * freed. * diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c index e67da14..6e1cb1f 100644 --- a/generic/tclIOUtil.c +++ b/generic/tclIOUtil.c @@ -4619,7 +4619,7 @@ Tcl_FSGetFileSystemForPath( /* * Check if the filesystem has changed in some way since this object's * internal representation was calculated. Before doing that, assure we - * have the most up-to-date copy of the master filesystem. This is + * have the most up-to-date copy of the first filesystem. This is * accomplished by the FsGetFirstFilesystem() call. */ diff --git a/tests/winDde.test b/tests/winDde.test index acba304..6ba2ba1 100644 --- a/tests/winDde.test +++ b/tests/winDde.test @@ -279,19 +279,19 @@ test winDde-6.6 {DDE remote servername collision force} -constraints {dde stdio} # ------------------------------------------------------------------------- -test winDde-7.1 {Load DDE in slave interpreter} -constraints dde -setup { - interp create slave +test winDde-7.1 {Load DDE in child interpreter} -constraints dde -setup { + interp create child } -body { - slave eval [list load $::ddelib Dde] - slave eval [list dde servername -- dde-interp-7.1] + child eval [list load $::ddelib Dde] + child eval [list dde servername -- dde-interp-7.1] } -cleanup { - interp delete slave + interp delete child } -result {dde-interp-7.1} -test winDde-7.2 {DDE slave cleanup} -constraints dde -setup { - interp create slave - slave eval [list load $::ddelib Dde] - slave eval [list dde servername -- dde-interp-7.5] - interp delete slave +test winDde-7.2 {DDE child cleanup} -constraints dde -setup { + interp create child + child eval [list load $::ddelib Dde] + child eval [list dde servername -- dde-interp-7.5] + interp delete child } -body { dde services TclEval {} set s [dde services TclEval {}] @@ -300,128 +300,128 @@ test winDde-7.2 {DDE slave cleanup} -constraints dde -setup { set s } } -result {} -test winDde-7.3 {DDE present in slave interp} -constraints dde -setup { - interp create slave - slave eval [list load $::ddelib Dde] - slave eval [list dde servername -- dde-interp-7.3] +test winDde-7.3 {DDE present in child interp} -constraints dde -setup { + interp create child + child eval [list load $::ddelib Dde] + child eval [list dde servername -- dde-interp-7.3] } -body { dde services TclEval dde-interp-7.3 } -cleanup { - interp delete slave + interp delete child } -result {{TclEval dde-interp-7.3}} test winDde-7.4 {interp name collision with -force} -constraints dde -setup { - interp create slave - slave eval [list load $::ddelib Dde] - slave eval [list dde servername -- dde-interp-7.4] + interp create child + child eval [list load $::ddelib Dde] + child eval [list dde servername -- dde-interp-7.4] } -body { dde servername -force -- dde-interp-7.4 } -cleanup { - interp delete slave + interp delete child } -result {dde-interp-7.4} test winDde-7.5 {interp name collision without -force} -constraints dde -setup { - interp create slave - slave eval [list load $::ddelib Dde] - slave eval [list dde servername -- dde-interp-7.5] + interp create child + child eval [list load $::ddelib Dde] + child eval [list dde servername -- dde-interp-7.5] } -body { dde servername -- dde-interp-7.5 } -cleanup { - interp delete slave + interp delete child } -result "dde-interp-7.5 #2" # ------------------------------------------------------------------------- test winDde-8.1 {Safe DDE load} -constraints dde -setup { - interp create -safe slave - slave invokehidden load $::ddelib Dde + interp create -safe child + child invokehidden load $::ddelib Dde } -body { - slave eval dde servername slave + child eval dde servername child } -cleanup { - interp delete slave + interp delete child } -returnCodes error -result {invalid command name "dde"} test winDde-8.2 {Safe DDE set servername} -constraints dde -setup { - interp create -safe slave - slave invokehidden load $::ddelib Dde + interp create -safe child + child invokehidden load $::ddelib Dde } -body { - slave invokehidden dde servername slave -} -cleanup {interp delete slave} -result {slave} + child invokehidden dde servername child +} -cleanup {interp delete child} -result {child} test winDde-8.3 {Safe DDE check handler required for eval} -constraints dde -setup { - interp create -safe slave - slave invokehidden load $::ddelib Dde - slave invokehidden dde servername slave + interp create -safe child + child invokehidden load $::ddelib Dde + child invokehidden dde servername child } -body { - catch {dde eval slave set a 1} msg -} -cleanup {interp delete slave} -result {1} + catch {dde eval child set a 1} msg +} -cleanup {interp delete child} -result {1} test winDde-8.4 {Safe DDE check that execute is denied} -constraints dde -setup { - interp create -safe slave - slave invokehidden load $::ddelib Dde - slave invokehidden dde servername slave + interp create -safe child + child invokehidden load $::ddelib Dde + child invokehidden dde servername child } -body { - slave eval set a 1 - dde execute TclEval slave {set a 2} - slave eval set a -} -cleanup {interp delete slave} -result 1 + child eval set a 1 + dde execute TclEval child {set a 2} + child eval set a +} -cleanup {interp delete child} -result 1 test winDde-8.5 {Safe DDE check that request is denied} -constraints dde -setup { - interp create -safe slave - slave invokehidden load $::ddelib Dde - slave invokehidden dde servername slave + interp create -safe child + child invokehidden load $::ddelib Dde + child invokehidden dde servername child } -body { - slave eval set a 1 - dde request TclEval slave a + child eval set a 1 + dde request TclEval child a } -cleanup { - interp delete slave + interp delete child } -returnCodes error -result {remote server cannot handle this command} test winDde-8.6 {Safe DDE assign handler procedure} -constraints dde -setup { - interp create -safe slave - slave invokehidden load $::ddelib Dde - slave eval {proc DDEACCEPT {cmd} {set ::DDECMD $cmd}} + interp create -safe child + child invokehidden load $::ddelib Dde + child eval {proc DDEACCEPT {cmd} {set ::DDECMD $cmd}} } -body { - slave invokehidden dde servername -handler DDEACCEPT slave -} -cleanup {interp delete slave} -result slave + child invokehidden dde servername -handler DDEACCEPT child +} -cleanup {interp delete child} -result child test winDde-8.7 {Safe DDE check simple command} -constraints dde -setup { - interp create -safe slave - slave invokehidden load $::ddelib Dde - slave eval {proc DDEACCEPT {cmd} {set ::DDECMD $cmd}} - slave invokehidden dde servername -handler DDEACCEPT slave + interp create -safe child + child invokehidden load $::ddelib Dde + child eval {proc DDEACCEPT {cmd} {set ::DDECMD $cmd}} + child invokehidden dde servername -handler DDEACCEPT child } -body { - dde eval slave set x 1 -} -cleanup {interp delete slave} -result {set x 1} + dde eval child set x 1 +} -cleanup {interp delete child} -result {set x 1} test winDde-8.8 {Safe DDE check non-list command} -constraints dde -setup { - interp create -safe slave - slave invokehidden load $::ddelib Dde - slave eval {proc DDEACCEPT {cmd} {set ::DDECMD $cmd}} - slave invokehidden dde servername -handler DDEACCEPT slave + interp create -safe child + child invokehidden load $::ddelib Dde + child eval {proc DDEACCEPT {cmd} {set ::DDECMD $cmd}} + child invokehidden dde servername -handler DDEACCEPT child } -body { set s "c:\\Program Files\\Microsoft Visual Studio\\" - dde eval slave $s - string equal [slave eval set DDECMD] $s -} -cleanup {interp delete slave} -result 1 + dde eval child $s + string equal [child eval set DDECMD] $s +} -cleanup {interp delete child} -result 1 test winDde-8.9 {Safe DDE check command evaluation} -constraints dde -setup { - interp create -safe slave - slave invokehidden load $::ddelib Dde - slave eval {proc DDEACCEPT {cmd} {set ::DDECMD [uplevel \#0 $cmd]}} - slave invokehidden dde servername -handler DDEACCEPT slave + interp create -safe child + child invokehidden load $::ddelib Dde + child eval {proc DDEACCEPT {cmd} {set ::DDECMD [uplevel \#0 $cmd]}} + child invokehidden dde servername -handler DDEACCEPT child } -body { - dde eval slave set \xe1 1 - slave eval set \xe1 -} -cleanup {interp delete slave} -result 1 + dde eval child set \xe1 1 + child eval set \xe1 +} -cleanup {interp delete child} -result 1 test winDde-8.10 {Safe DDE check command evaluation (2)} -constraints dde -setup { - interp create -safe slave - slave invokehidden load $::ddelib Dde - slave eval {proc DDEACCEPT {cmd} {set ::DDECMD [uplevel \#0 $cmd]}} - slave invokehidden dde servername -handler DDEACCEPT slave + interp create -safe child + child invokehidden load $::ddelib Dde + child eval {proc DDEACCEPT {cmd} {set ::DDECMD [uplevel \#0 $cmd]}} + child invokehidden dde servername -handler DDEACCEPT child } -body { - dde eval slave [list set x 1] - slave eval set x -} -cleanup {interp delete slave} -result 1 + dde eval child [list set x 1] + child eval set x +} -cleanup {interp delete child} -result 1 test winDde-8.11 {Safe DDE check command evaluation (3)} -constraints dde -setup { - interp create -safe slave - slave invokehidden load $::ddelib Dde - slave eval {proc DDEACCEPT {cmd} {set ::DDECMD [uplevel \#0 $cmd]}} - slave invokehidden dde servername -handler DDEACCEPT slave + interp create -safe child + child invokehidden load $::ddelib Dde + child eval {proc DDEACCEPT {cmd} {set ::DDECMD [uplevel \#0 $cmd]}} + child invokehidden dde servername -handler DDEACCEPT child } -body { - dde eval slave [list [list set x 1]] - slave eval set x -} -cleanup {interp delete slave} -returnCodes error -result {invalid command name "set x 1"} + dde eval child [list [list set x 1]] + child eval set x +} -cleanup {interp delete child} -returnCodes error -result {invalid command name "set x 1"} # ------------------------------------------------------------------------- @@ -481,7 +481,7 @@ test winDde-9.4 {External safe DDE check null data passing} -constraints {dde st # ------------------------------------------------------------------------- #cleanup -#catch {interp delete $slave}; # ensure we clean up the slave. +#catch {interp delete $child}; # ensure we clean up the child. file delete -force $::scriptName ::tcltest::cleanupTests return -- cgit v0.12 From f2963d15d036e305300773f74a602c9c0a8c9229 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 4 Sep 2020 15:48:08 +0000 Subject: Let all test-cases load the "tcltest" package the same way. Depend on tcltest 2.5, since we never test with earlier tcltest versions --- doc/Tcl_Main.3 | 12 ++++++------ doc/tcltest.n | 22 +++++++++++----------- macosx/Tcl.xcode/project.pbxproj | 2 +- macosx/Tcl.xcodeproj/project.pbxproj | 2 +- pkgs/README | 2 +- tests/aaa_exit.test | 4 ++-- tests/append.test | 4 ++-- tests/appendComp.test | 4 ++-- tests/apply.test | 4 ++-- tests/assemble.test | 2 +- tests/assocd.test | 2 +- tests/async.test | 4 ++-- tests/autoMkindex.test | 2 +- tests/basic.test | 6 ++++-- tests/binary.test | 4 ++-- tests/case.test | 4 ++-- tests/chan.test | 4 ++-- tests/chanio.test | 5 ++--- tests/clock.test | 4 ++-- tests/cmdIL.test | 4 ++-- tests/cmdInfo.test | 6 ++++-- tests/compExpr-old.test | 4 ++-- tests/compExpr.test | 2 +- tests/compile.test | 6 ++++-- tests/concat.test | 2 +- tests/config.test | 4 ++-- tests/coroutine.test | 4 ++-- tests/dcall.test | 6 ++++-- tests/dict.test | 4 ++-- tests/dstring.test | 2 +- tests/encoding.test | 7 ++++--- tests/env.test | 4 ++-- tests/error.test | 4 ++-- tests/eval.test | 2 +- tests/event.test | 6 ++++-- tests/exec.test | 6 ++++-- tests/execute.test | 6 +++--- tests/expr.test | 4 ++-- tests/fCmd.test | 2 +- tests/fileName.test | 2 +- tests/fileSystem.test | 6 +++++- tests/fileSystemEncoding.test | 7 +++++-- tests/for-old.test | 4 ++-- tests/for.test | 4 ++-- tests/foreach.test | 4 ++-- tests/format.test | 4 ++-- tests/get.test | 4 ++-- tests/history.test | 2 +- tests/http.test | 6 ++++-- tests/http11.test | 6 ++++-- tests/httpPipeline.test | 6 ++++-- tests/httpold.test | 4 ++-- tests/if-old.test | 4 ++-- tests/if.test | 4 ++-- tests/incr-old.test | 4 ++-- tests/incr.test | 2 +- tests/indexObj.test | 4 ++-- tests/info.test | 2 +- tests/io.test | 10 +++++----- tests/ioCmd.test | 4 ++-- tests/ioTrans.test | 8 ++++---- tests/join.test | 4 ++-- tests/lindex.test | 4 ++-- tests/link.test | 2 +- tests/linsert.test | 4 ++-- tests/list.test | 4 ++-- tests/listObj.test | 4 ++-- tests/llength.test | 4 ++-- tests/lmap.test | 2 +- tests/load.test | 4 ++-- tests/lrange.test | 4 ++-- tests/lrepeat.test | 4 ++-- tests/lreplace.test | 4 ++-- tests/lsearch.test | 2 +- tests/lset.test | 4 ++-- tests/lsetComp.test | 4 ++-- tests/macOSXFCmd.test | 4 ++-- tests/macOSXLoad.test | 5 +++-- tests/mathop.test | 2 +- tests/misc.test | 4 ++-- tests/msgcat.test | 8 ++++---- tests/namespace.test | 6 ++++-- tests/notify.test | 4 ++-- tests/nre.test | 4 ++-- tests/obj.test | 4 ++-- tests/oo.test | 4 ++-- tests/ooNext2.test | 4 ++-- tests/opt.test | 4 ++-- tests/parseExpr.test | 6 ++++-- tests/parseOld.test | 6 ++++-- tests/pid.test | 4 ++-- tests/pkgMkIndex.test | 6 ++++-- tests/platform.test | 2 +- tests/proc-old.test | 4 ++-- tests/proc.test | 2 +- tests/pwd.test | 4 ++-- tests/reg.test | 4 ++-- tests/regexp.test | 2 +- tests/regexpComp.test | 4 ++-- tests/registry.test | 4 ++-- tests/rename.test | 4 ++-- tests/resolver.test | 4 ++-- tests/result.test | 6 ++++-- tests/safe-stock86.test | 6 ++---- tests/safe.test | 6 ++---- tests/scan.test | 2 +- tests/security.test | 2 +- tests/set-old.test | 4 ++-- tests/set.test | 4 ++-- tests/socket.test | 7 +++++-- tests/split.test | 4 ++-- tests/stack.test | 6 ++++-- tests/string.test | 4 ++-- tests/stringComp.test | 4 ++-- tests/stringObj.test | 4 ++-- tests/subst.test | 2 +- tests/switch.test | 2 +- tests/tailcall.test | 4 ++-- tests/tcltest.test | 28 ++++++++++++++-------------- tests/tcltests.tcl | 2 +- tests/timer.test | 4 ++-- tests/tm.test | 2 +- tests/trace.test | 6 ++++-- tests/unixFCmd.test | 4 ++-- tests/unixFile.test | 4 ++-- tests/unixForkEvent.test | 2 +- tests/unixInit.test | 2 +- tests/unixNotfy.test | 4 ++-- tests/unknown.test | 2 +- tests/unload.test | 4 ++-- tests/uplevel.test | 4 ++-- tests/upvar.test | 4 ++-- tests/utf.test | 4 ++-- tests/util.test | 4 ++-- tests/var.test | 2 +- tests/while-old.test | 4 ++-- tests/while.test | 2 +- tests/winConsole.test | 4 ++-- tests/winDde.test | 4 ++-- tests/winFCmd.test | 4 ++-- tests/winFile.test | 4 ++-- tests/winNotify.test | 4 ++-- tests/winPipe.test | 2 +- tests/winTime.test | 4 ++-- tests/zlib.test | 2 +- 145 files changed, 332 insertions(+), 293 deletions(-) diff --git a/doc/Tcl_Main.3 b/doc/Tcl_Main.3 index 3ec33d1..2eae4b8 100644 --- a/doc/Tcl_Main.3 +++ b/doc/Tcl_Main.3 @@ -79,7 +79,7 @@ against the standard Tcl library. Extensions (stub-enabled or not) are not intended to call \fBTcl_Main\fR. .PP \fBTcl_Main\fR is not thread-safe. It should only be called by -a single master thread of a multi-threaded application. This +a single main thread of a multi-threaded application. This restriction is not a problem with normal use described above. .PP \fBTcl_Main\fR and therefore all applications based upon it, like @@ -112,7 +112,7 @@ The file name and encoding values managed by the routines \fBTcl_SetStartupScript\fR and \fBTcl_GetStartupScript\fR are stored per-thread. Although the storage and retrieval functions of these routines work in any thread, only those -calls in the same master thread as \fBTcl_Main\fR can have +calls in the same main thread as \fBTcl_Main\fR can have any influence on it. .PP The caller of \fBTcl_Main\fR may call \fBTcl_SetStartupScript\fR @@ -126,7 +126,7 @@ a \fIstartup script\fR, and \fIname\fR is taken to be the name of the encoding of the contents of that file. \fBTcl_Main\fR then calls \fBTcl_SetStartupScript\fR with these values. .PP -\fBTcl_Main\fR then defines in its master interpreter +\fBTcl_Main\fR then defines in its main interpreter the Tcl variables \fIargc\fR, \fIargv\fR, \fIargv0\fR, and \fItcl_interactive\fR, as described in the documentation for \fBtclsh\fR. .PP @@ -154,9 +154,9 @@ When the \fIappInitProc\fR is finished, \fBTcl_Main\fR calls been requested, if any. If a startup script has been provided, \fBTcl_Main\fR attempts to evaluate it. Otherwise, interactive mode begins with examination of the variable \fItcl_rcFileName\fR -in the master interpreter. If that variable exists and holds the +in the main interpreter. If that variable exists and holds the name of a readable file, the contents of that file are evaluated -in the master interpreter. Then interactive operations begin, +in the main interpreter. Then interactive operations begin, with prompts and command evaluation results written to the standard output channel, and commands read from the standard input channel and then evaluated. The prompts written to the standard output @@ -164,7 +164,7 @@ channel may be customized by defining the Tcl variables \fItcl_prompt1\fR and \fItcl_prompt2\fR as described in the documentation for \fBtclsh\fR. The prompts and command evaluation results are written to the standard output channel only if the Tcl variable \fItcl_interactive\fR in the -master interpreter holds a non-zero integer value. +main interpreter holds a non-zero integer value. .PP \fBTcl_SetMainLoop\fR allows setting an event loop procedure to be run. This allows, for example, Tk to be dynamically loaded and set its event diff --git a/doc/tcltest.n b/doc/tcltest.n index b161a2b..25e5e5e 100644 --- a/doc/tcltest.n +++ b/doc/tcltest.n @@ -203,7 +203,7 @@ array. Returns an empty string. .TP \fBrunAllTests\fR . -This is a master command meant to run an entire suite of tests, +This is a main command meant to run an entire suite of tests, spanning multiple files and/or directories, as governed by the configurable options of \fBtcltest\fR. See \fBRUNNING ALL TESTS\fR below for a complete description of the many variations possible @@ -804,17 +804,17 @@ then a copy of \fBinterpreter\fR will be \fBexec\fR'd to evaluate each file. The multi-process operation is useful when testing can cause errors so severe that a process terminates. Although such an error may terminate a child -process evaluating one file, the master process can continue +process evaluating one file, the main process can continue with the rest of the test suite. In multi-process operation, -the configuration of \fBtcltest\fR in the master process is +the configuration of \fBtcltest\fR in the main process is passed to the child processes as command line arguments, with the exception of \fBconfigure \-outfile\fR. The \fBrunAllTests\fR command in the -master process collects all output from the child processes -and collates their results into one master report. Any +main process collects all output from the child processes +and collates their results into one main report. Any reports of individual test failures, or messages requested by a \fBconfigure \-verbose\fR setting are passed directly -on to \fBoutputChannel\fR by the master process. +on to \fBoutputChannel\fR by the main process. .PP After evaluating all selected test files, a summary of the results is printed to \fBoutputChannel\fR. The summary @@ -1134,7 +1134,7 @@ A good namespace to use is a child namespace \fBtest\fR of the namespace of the module you are testing. .PP A test file should also be able to be evaluated directly as a script, -not depending on being called by a master \fBrunAllTests\fR. This +not depending on being called by a main \fBrunAllTests\fR. This means that each test file should process command line arguments to give the tester all the configuration control that \fBtcltest\fR provides. .PP @@ -1145,7 +1145,7 @@ Here is a sketch of a sample test file illustrating those points: .RS .PP .CS -package require tcltest 2.2 +package require tcltest 2.5 eval \fB::tcltest::configure\fR $argv package require example namespace eval ::example::test { @@ -1175,12 +1175,12 @@ doing any necessary setup. This script is usually named \fBall.tcl\fR because that is the default name used by \fBrunAllTests\fR when combining multiple test suites into one testing run. .IP [8] -Here is a sketch of a sample test suite master script: +Here is a sketch of a sample test suite main script: .RS .PP .CS -package require Tcl 8.4 -package require tcltest 2.2 +package require Tcl 8.6 +package require tcltest 2.5 package require example \fB::tcltest::configure\fR -testdir \e [file dirname [file normalize [info script]]] diff --git a/macosx/Tcl.xcode/project.pbxproj b/macosx/Tcl.xcode/project.pbxproj index 06c7fa0..aceb929 100644 --- a/macosx/Tcl.xcode/project.pbxproj +++ b/macosx/Tcl.xcode/project.pbxproj @@ -1909,7 +1909,7 @@ ); runOnlyForDeploymentPostprocessing = 0; shellPath = /bin/bash; - shellScript = "if [ \"${ACTION:-build}\" == \"build\" ]; then\nif [ -z \"${HOME}\" ]; then export HOME=\"$(echo ~)\"; fi\ncd \"${TARGET_TEMP_DIR}\"; rm -rf \"${DERIVED_FILE_DIR}\"; mkdir -p \"${DERIVED_FILE_DIR}\"\nprintf '%s%s%s%s%s' '\npackage require tcltest 2.2\nnamespace import tcltest::*\nconfigure -testdir [file normalize {' \"${TCL_SRCROOT}\" '/tests}]\nconfigure -tmpdir [file normalize {' \"${DERIVED_FILE_DIR}\" '}]\nconfigure -verbose [concat [configure -verbose] line]\nrunAllTests\n' | \"${TEST_RIG}\"; TEST_RIG_RESULT=$?\n[ ${TEST_RIG_RESULT} -ne 0 ] && echo \"tcltest:0: error: tcltest exited abnormally with code ${TEST_RIG_RESULT}.\"\nexit ${TEST_RIG_RESULT}\nfi"; + shellScript = "if [ \"${ACTION:-build}\" == \"build\" ]; then\nif [ -z \"${HOME}\" ]; then export HOME=\"$(echo ~)\"; fi\ncd \"${TARGET_TEMP_DIR}\"; rm -rf \"${DERIVED_FILE_DIR}\"; mkdir -p \"${DERIVED_FILE_DIR}\"\nprintf '%s%s%s%s%s' '\npackage require tcltest 2.5\nnamespace import tcltest::*\nconfigure -testdir [file normalize {' \"${TCL_SRCROOT}\" '/tests}]\nconfigure -tmpdir [file normalize {' \"${DERIVED_FILE_DIR}\" '}]\nconfigure -verbose [concat [configure -verbose] line]\nrunAllTests\n' | \"${TEST_RIG}\"; TEST_RIG_RESULT=$?\n[ ${TEST_RIG_RESULT} -ne 0 ] && echo \"tcltest:0: error: tcltest exited abnormally with code ${TEST_RIG_RESULT}.\"\nexit ${TEST_RIG_RESULT}\nfi"; showEnvVarsInLog = 0; }; F97AF02F0B665DA900310EA2 /* Build Tcl */ = { diff --git a/macosx/Tcl.xcodeproj/project.pbxproj b/macosx/Tcl.xcodeproj/project.pbxproj index a0d4f2a..da16424 100644 --- a/macosx/Tcl.xcodeproj/project.pbxproj +++ b/macosx/Tcl.xcodeproj/project.pbxproj @@ -1909,7 +1909,7 @@ ); runOnlyForDeploymentPostprocessing = 0; shellPath = /bin/bash; - shellScript = "if [ \"${ACTION:-build}\" == \"build\" ]; then\nif [ -z \"${HOME}\" ]; then export HOME=\"$(echo ~)\"; fi\ncd \"${TARGET_TEMP_DIR}\"; rm -rf \"${DERIVED_FILE_DIR}\"; mkdir -p \"${DERIVED_FILE_DIR}\"\nprintf '%s%s%s%s%s' '\npackage require tcltest 2.2\nnamespace import tcltest::*\nconfigure -testdir [file normalize {' \"${TCL_SRCROOT}\" '/tests}]\nconfigure -tmpdir [file normalize {' \"${DERIVED_FILE_DIR}\" '}]\nconfigure -verbose [concat [configure -verbose] line]\nrunAllTests\n' | \"${TEST_RIG}\"; TEST_RIG_RESULT=$?\n[ ${TEST_RIG_RESULT} -ne 0 ] && echo \"tcltest:0: error: tcltest exited abnormally with code ${TEST_RIG_RESULT}.\"\nexit ${TEST_RIG_RESULT}\nfi"; + shellScript = "if [ \"${ACTION:-build}\" == \"build\" ]; then\nif [ -z \"${HOME}\" ]; then export HOME=\"$(echo ~)\"; fi\ncd \"${TARGET_TEMP_DIR}\"; rm -rf \"${DERIVED_FILE_DIR}\"; mkdir -p \"${DERIVED_FILE_DIR}\"\nprintf '%s%s%s%s%s' '\npackage require tcltest 2.5\nnamespace import tcltest::*\nconfigure -testdir [file normalize {' \"${TCL_SRCROOT}\" '/tests}]\nconfigure -tmpdir [file normalize {' \"${DERIVED_FILE_DIR}\" '}]\nconfigure -verbose [concat [configure -verbose] line]\nrunAllTests\n' | \"${TEST_RIG}\"; TEST_RIG_RESULT=$?\n[ ${TEST_RIG_RESULT} -ne 0 ] && echo \"tcltest:0: error: tcltest exited abnormally with code ${TEST_RIG_RESULT}.\"\nexit ${TEST_RIG_RESULT}\nfi"; showEnvVarsInLog = 0; }; F97AF02F0B665DA900310EA2 /* Build Tcl */ = { diff --git a/pkgs/README b/pkgs/README index 159a237..4633e0b 100644 --- a/pkgs/README +++ b/pkgs/README @@ -17,7 +17,7 @@ needs to conform to the following conventions. "configure". When the program "configure" is run, it should generate a file "Makefile" in the current working directory. The "configure" program should be able to accept as command line arguments all the - arguments that can be passed to the master unix/configure program. It + arguments that can be passed to the top unix/configure program. It should also accept the --with-tcl= and --with-tclinclude= options in the conventional way. diff --git a/tests/aaa_exit.test b/tests/aaa_exit.test index 3ba5167..d4d2a7c 100644 --- a/tests/aaa_exit.test +++ b/tests/aaa_exit.test @@ -11,8 +11,8 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/append.test b/tests/append.test index 8fa4e61..ef4a194 100644 --- a/tests/append.test +++ b/tests/append.test @@ -11,8 +11,8 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } unset -nocomplain x diff --git a/tests/appendComp.test b/tests/appendComp.test index a0069ac..66941a9 100644 --- a/tests/appendComp.test +++ b/tests/appendComp.test @@ -11,8 +11,8 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } catch {unset x} diff --git a/tests/apply.test b/tests/apply.test index ba19b81..5fed6ec 100644 --- a/tests/apply.test +++ b/tests/apply.test @@ -12,8 +12,8 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2.2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/assemble.test b/tests/assemble.test index 45368de..d2e626b 100644 --- a/tests/assemble.test +++ b/tests/assemble.test @@ -12,7 +12,7 @@ # Commands covered: assemble if {"::tcltest" ni [namespace children]} { - package require tcltest 2.2 + package require tcltest 2.5 namespace import -force ::tcltest::* } namespace eval tcl::unsupported {namespace export assemble} diff --git a/tests/assocd.test b/tests/assocd.test index edf55c4..863bf78 100644 --- a/tests/assocd.test +++ b/tests/assocd.test @@ -11,7 +11,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcltest 2 +package require tcltest 2.5 namespace import ::tcltest::* ::tcltest::loadTestedCommands diff --git a/tests/async.test b/tests/async.test index 4e7eadf..1aef907 100644 --- a/tests/async.test +++ b/tests/async.test @@ -11,8 +11,8 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/autoMkindex.test b/tests/autoMkindex.test index 6768772..6c57de0 100644 --- a/tests/autoMkindex.test +++ b/tests/autoMkindex.test @@ -10,7 +10,7 @@ # this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/basic.test b/tests/basic.test index bea5870..6f8d350 100644 --- a/tests/basic.test +++ b/tests/basic.test @@ -15,8 +15,10 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcltest 2 -namespace import ::tcltest::* +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] diff --git a/tests/binary.test b/tests/binary.test index c2c5eb4..07ecf6f 100644 --- a/tests/binary.test +++ b/tests/binary.test @@ -10,8 +10,8 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } testConstraint bigEndian [expr {$tcl_platform(byteOrder) eq "bigEndian"}] diff --git a/tests/case.test b/tests/case.test index 6d63cea..d32d7d3 100644 --- a/tests/case.test +++ b/tests/case.test @@ -11,8 +11,8 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/chan.test b/tests/chan.test index d8390e2..4efec11 100644 --- a/tests/chan.test +++ b/tests/chan.test @@ -7,8 +7,8 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/chanio.test b/tests/chanio.test index c4c88a0..c811b00 100644 --- a/tests/chanio.test +++ b/tests/chanio.test @@ -13,9 +13,8 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -# TODO: This test is likely worthless. Confirm and remove -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 } namespace eval ::tcl::test::io { diff --git a/tests/clock.test b/tests/clock.test index 0dc5caf..6d502d4 100644 --- a/tests/clock.test +++ b/tests/clock.test @@ -11,8 +11,8 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/cmdIL.test b/tests/cmdIL.test index 0bf34a2..27f1df1 100644 --- a/tests/cmdIL.test +++ b/tests/cmdIL.test @@ -8,8 +8,8 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/cmdInfo.test b/tests/cmdInfo.test index 0a587e8..e690002 100644 --- a/tests/cmdInfo.test +++ b/tests/cmdInfo.test @@ -13,8 +13,10 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcltest 2 -namespace import ::tcltest::* +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] diff --git a/tests/compExpr-old.test b/tests/compExpr-old.test index bae26a0..d4525e6 100644 --- a/tests/compExpr-old.test +++ b/tests/compExpr-old.test @@ -12,8 +12,8 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/compExpr.test b/tests/compExpr.test index d1739de..677266c 100644 --- a/tests/compExpr.test +++ b/tests/compExpr.test @@ -9,7 +9,7 @@ # this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/compile.test b/tests/compile.test index cb41063..0663270 100644 --- a/tests/compile.test +++ b/tests/compile.test @@ -11,8 +11,10 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcltest 2 -namespace import -force ::tcltest::* +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] diff --git a/tests/concat.test b/tests/concat.test index eeb11ca..8ff5500 100644 --- a/tests/concat.test +++ b/tests/concat.test @@ -12,7 +12,7 @@ # this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/config.test b/tests/config.test index d14837e..15be790 100644 --- a/tests/config.test +++ b/tests/config.test @@ -12,8 +12,8 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/coroutine.test b/tests/coroutine.test index 4c35460..c60b568 100644 --- a/tests/coroutine.test +++ b/tests/coroutine.test @@ -9,8 +9,8 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/dcall.test b/tests/dcall.test index 41dd777..7d86135 100644 --- a/tests/dcall.test +++ b/tests/dcall.test @@ -11,8 +11,10 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcltest 2 -namespace import ::tcltest::* +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] diff --git a/tests/dict.test b/tests/dict.test index a6b0cb4..6ede398 100644 --- a/tests/dict.test +++ b/tests/dict.test @@ -9,8 +9,8 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/dstring.test b/tests/dstring.test index 5feb355..8a24ebe 100644 --- a/tests/dstring.test +++ b/tests/dstring.test @@ -12,7 +12,7 @@ # this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/encoding.test b/tests/encoding.test index 935bef8..72d218b 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -8,13 +8,14 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} namespace eval ::tcl::test::encoding { variable x -namespace import -force ::tcltest::* - catch { ::tcltest::loadTestedCommands package require -exact Tcltest [info patchlevel] diff --git a/tests/env.test b/tests/env.test index 9b8016c..8cc57d2 100644 --- a/tests/env.test +++ b/tests/env.test @@ -11,8 +11,8 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/error.test b/tests/error.test index af07ed7..a111c80 100644 --- a/tests/error.test +++ b/tests/error.test @@ -11,8 +11,8 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/eval.test b/tests/eval.test index 70ceac8..d473fdf 100644 --- a/tests/eval.test +++ b/tests/eval.test @@ -12,7 +12,7 @@ # this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/event.test b/tests/event.test index 70d4cff..77f13d3 100644 --- a/tests/event.test +++ b/tests/event.test @@ -9,8 +9,10 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcltest 2 -namespace import -force ::tcltest::* +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} catch { ::tcltest::loadTestedCommands diff --git a/tests/exec.test b/tests/exec.test index 62133e8..3aaec6e 100644 --- a/tests/exec.test +++ b/tests/exec.test @@ -14,8 +14,10 @@ # There is no point in running Valgrind on cases where [exec] forks but then # fails and the child process doesn't go through full cleanup. -package require tcltest 2 -namespace import -force ::tcltest::* +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} package require tcltests diff --git a/tests/execute.test b/tests/execute.test index da3e2d4..14c2f76 100644 --- a/tests/execute.test +++ b/tests/execute.test @@ -15,7 +15,7 @@ # this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } @@ -984,7 +984,7 @@ test execute-8.5 {Bug 2038069} -setup { test execute-8.6 {Compile epoch bump in global level (bug [fa6bf38d07])} -setup { interp create child child eval { - package require tcltest + package require tcltest 2.5 catch [list package require -exact Tcltest [info patchlevel]] ::tcltest::loadTestedCommands if {[namespace which -command testbumpinterpepoch] eq ""} { @@ -1017,7 +1017,7 @@ test execute-8.6 {Compile epoch bump in global level (bug [fa6bf38d07])} -setup test execute-8.7 {Compile epoch bump in global level (bug [fa6bf38d07]), exception case} -setup { interp create child child eval { - package require tcltest + package require tcltest 2.5 catch [list package require -exact Tcltest [info patchlevel]] ::tcltest::loadTestedCommands if {[namespace which -command testbumpinterpepoch] eq ""} { diff --git a/tests/expr.test b/tests/expr.test index 0e3bd61..d2f767d 100644 --- a/tests/expr.test +++ b/tests/expr.test @@ -10,8 +10,8 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2.1 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/fCmd.test b/tests/fCmd.test index 260fde9..bb8fb4a 100644 --- a/tests/fCmd.test +++ b/tests/fCmd.test @@ -11,7 +11,7 @@ # this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/fileName.test b/tests/fileName.test index 0e4cb9e..725c1dd 100644 --- a/tests/fileName.test +++ b/tests/fileName.test @@ -11,7 +11,7 @@ # this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/fileSystem.test b/tests/fileSystem.test index d9264ee..c1deb1b 100644 --- a/tests/fileSystem.test +++ b/tests/fileSystem.test @@ -9,7 +9,11 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} + namespace eval ::tcl::test::fileSystem { namespace import ::tcltest::* diff --git a/tests/fileSystemEncoding.test b/tests/fileSystemEncoding.test index da301ce..40a0090 100644 --- a/tests/fileSystemEncoding.test +++ b/tests/fileSystemEncoding.test @@ -7,8 +7,11 @@ if {[string equal $::tcl_platform(os) "Windows NT"]} { } namespace eval ::tcl::test::fileSystemEncoding { - package require tcltest 2 - namespace import ::tcltest::* + + if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* + } variable fname1 \u767b\u9e1b\u9d72\u6a13 diff --git a/tests/for-old.test b/tests/for-old.test index a11a791..d00a4ee 100644 --- a/tests/for-old.test +++ b/tests/for-old.test @@ -12,8 +12,8 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/for.test b/tests/for.test index 1a65274..65d8fc8 100644 --- a/tests/for.test +++ b/tests/for.test @@ -9,8 +9,8 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/foreach.test b/tests/foreach.test index 84af4bd..cdbfc85 100644 --- a/tests/foreach.test +++ b/tests/foreach.test @@ -10,8 +10,8 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/format.test b/tests/format.test index c26bbe9..ea0e929 100644 --- a/tests/format.test +++ b/tests/format.test @@ -10,8 +10,8 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/get.test b/tests/get.test index 7aa06c1..b9a83ac 100644 --- a/tests/get.test +++ b/tests/get.test @@ -10,8 +10,8 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/history.test b/tests/history.test index 3201ad7..76ce54e 100644 --- a/tests/history.test +++ b/tests/history.test @@ -12,7 +12,7 @@ # this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/http.test b/tests/http.test index e6255bf..636a651 100644 --- a/tests/http.test +++ b/tests/http.test @@ -11,8 +11,10 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcltest 2 -namespace import -force ::tcltest::* +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} if {[catch {package require http 2} version]} { if {[info exists http2]} { diff --git a/tests/http11.test b/tests/http11.test index 989b00f..7ca57f4 100644 --- a/tests/http11.test +++ b/tests/http11.test @@ -7,8 +7,10 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcltest 2 -namespace import -force ::tcltest::* +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} package require http 2.9 diff --git a/tests/httpPipeline.test b/tests/httpPipeline.test index de1a7d8..4306149 100644 --- a/tests/httpPipeline.test +++ b/tests/httpPipeline.test @@ -8,8 +8,10 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcltest 2 -namespace import -force ::tcltest::* +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} package require http 2.9 diff --git a/tests/httpold.test b/tests/httpold.test index acc5a6e..dec4697 100644 --- a/tests/httpold.test +++ b/tests/httpold.test @@ -11,8 +11,8 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/if-old.test b/tests/if-old.test index fbcf56c..e537fea 100644 --- a/tests/if-old.test +++ b/tests/if-old.test @@ -13,8 +13,8 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/if.test b/tests/if.test index 040364a..f5acf60 100644 --- a/tests/if.test +++ b/tests/if.test @@ -10,8 +10,8 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/incr-old.test b/tests/incr-old.test index ed457cf..5d792e1 100644 --- a/tests/incr-old.test +++ b/tests/incr-old.test @@ -13,8 +13,8 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/incr.test b/tests/incr.test index 9243be0..af15f5e 100644 --- a/tests/incr.test +++ b/tests/incr.test @@ -11,7 +11,7 @@ # this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/indexObj.test b/tests/indexObj.test index 646cb02..60ee61a 100644 --- a/tests/indexObj.test +++ b/tests/indexObj.test @@ -8,8 +8,8 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/info.test b/tests/info.test index 5fe2240..3f42d93 100644 --- a/tests/info.test +++ b/tests/info.test @@ -16,7 +16,7 @@ # DO NOT DELETE THIS LINE if {{::tcltest} ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/io.test b/tests/io.test index 1df017a..5f668e6 100644 --- a/tests/io.test +++ b/tests/io.test @@ -13,12 +13,12 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 -} - namespace eval ::tcl::test::io { - namespace import ::tcltest::* + + if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* + } variable umaskValue variable path diff --git a/tests/ioCmd.test b/tests/ioCmd.test index 18b228e..8d961ae 100644 --- a/tests/ioCmd.test +++ b/tests/ioCmd.test @@ -13,8 +13,8 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/ioTrans.test b/tests/ioTrans.test index 867362a..2872fbb 100644 --- a/tests/ioTrans.test +++ b/tests/ioTrans.test @@ -11,8 +11,8 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } @@ -36,8 +36,8 @@ testConstraint thread [expr {0 == [catch {package require Thread 2.7-}]}] # can access this variable. set helperscript { - if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 + if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/join.test b/tests/join.test index 4aeb093..9ea554d 100644 --- a/tests/join.test +++ b/tests/join.test @@ -11,8 +11,8 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/lindex.test b/tests/lindex.test index e513b62..dadf275 100644 --- a/tests/lindex.test +++ b/tests/lindex.test @@ -12,8 +12,8 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2.2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/link.test b/tests/link.test index 189762e..d37f08a 100644 --- a/tests/link.test +++ b/tests/link.test @@ -12,7 +12,7 @@ # this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/linsert.test b/tests/linsert.test index 4939e5c..ddc56a9 100644 --- a/tests/linsert.test +++ b/tests/linsert.test @@ -11,8 +11,8 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/list.test b/tests/list.test index 2686bd7..edb572c 100644 --- a/tests/list.test +++ b/tests/list.test @@ -11,8 +11,8 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/listObj.test b/tests/listObj.test index d7fb46c..ce6c978 100644 --- a/tests/listObj.test +++ b/tests/listObj.test @@ -11,8 +11,8 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/llength.test b/tests/llength.test index 169c7ca..a2770c0 100644 --- a/tests/llength.test +++ b/tests/llength.test @@ -11,8 +11,8 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/lmap.test b/tests/lmap.test index 08035d9..432e195 100644 --- a/tests/lmap.test +++ b/tests/lmap.test @@ -14,7 +14,7 @@ # RCS: @(#) $Id: $ if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/load.test b/tests/load.test index 7d2e5df..9fdf1cf 100644 --- a/tests/load.test +++ b/tests/load.test @@ -10,8 +10,8 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/lrange.test b/tests/lrange.test index d5676ad..4bce1b3 100644 --- a/tests/lrange.test +++ b/tests/lrange.test @@ -11,8 +11,8 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/lrepeat.test b/tests/lrepeat.test index 788bb9b..61f2b62 100644 --- a/tests/lrepeat.test +++ b/tests/lrepeat.test @@ -9,8 +9,8 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/lreplace.test b/tests/lreplace.test index fd2f7f8..b7caf47 100644 --- a/tests/lreplace.test +++ b/tests/lreplace.test @@ -11,8 +11,8 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/lsearch.test b/tests/lsearch.test index 7e6a345..aa43862 100644 --- a/tests/lsearch.test +++ b/tests/lsearch.test @@ -12,7 +12,7 @@ # this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/lset.test b/tests/lset.test index 1c1300b..a130fe9 100644 --- a/tests/lset.test +++ b/tests/lset.test @@ -11,8 +11,8 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/lsetComp.test b/tests/lsetComp.test index 6846cbf..d8ad246 100644 --- a/tests/lsetComp.test +++ b/tests/lsetComp.test @@ -11,8 +11,8 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/macOSXFCmd.test b/tests/macOSXFCmd.test index f1758f5..0a147f0 100644 --- a/tests/macOSXFCmd.test +++ b/tests/macOSXFCmd.test @@ -9,8 +9,8 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/macOSXLoad.test b/tests/macOSXLoad.test index 12c77e0..e68c4bb 100644 --- a/tests/macOSXLoad.test +++ b/tests/macOSXLoad.test @@ -10,10 +10,11 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } + set oldTSF $::tcltest::testSingleFile set ::tcltest::testSingleFile false diff --git a/tests/mathop.test b/tests/mathop.test index a1a3f80..f6d0c00 100644 --- a/tests/mathop.test +++ b/tests/mathop.test @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2.1 namespace import -force ::tcltest::* } diff --git a/tests/misc.test b/tests/misc.test index d4ece74..8b6e1b7 100644 --- a/tests/misc.test +++ b/tests/misc.test @@ -12,8 +12,8 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/msgcat.test b/tests/msgcat.test index 1c3ce58..9a6eac0 100644 --- a/tests/msgcat.test +++ b/tests/msgcat.test @@ -12,11 +12,11 @@ # Note that after running these tests, entries will be left behind in the # message catalogs for locales foo, foo_BAR, and foo_BAR_baz. -package require Tcl 8.5- -if {[catch {package require tcltest 2}]} { - puts stderr "Skipping tests in [info script]. tcltest 2 required." - return +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* } + if {[catch {package require msgcat 1.6}]} { puts stderr "Skipping tests in [info script]. No msgcat 1.6 found to test." return diff --git a/tests/namespace.test b/tests/namespace.test index 2b25803..8209cf3 100644 --- a/tests/namespace.test +++ b/tests/namespace.test @@ -12,8 +12,10 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcltest 2 -namespace import -force ::tcltest::* +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} testConstraint memory [llength [info commands memory]] ::tcltest::loadTestedCommands diff --git a/tests/notify.test b/tests/notify.test index d2b9123..7375f83 100644 --- a/tests/notify.test +++ b/tests/notify.test @@ -13,8 +13,8 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/nre.test b/tests/nre.test index 09061d2..e420b06 100644 --- a/tests/nre.test +++ b/tests/nre.test @@ -9,8 +9,8 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/obj.test b/tests/obj.test index 7273b40..b6b6eb8 100644 --- a/tests/obj.test +++ b/tests/obj.test @@ -11,8 +11,8 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/oo.test b/tests/oo.test index 612fb9b..94537b7 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -8,8 +8,8 @@ # this file, and for a DISCLAIMER OF ALL WARRANTIES. package require TclOO 1.0.3 -package require tcltest 2 -if {"::tcltest" in [namespace children]} { +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/ooNext2.test b/tests/ooNext2.test index 6a48d28..84a2bdd 100644 --- a/tests/ooNext2.test +++ b/tests/ooNext2.test @@ -8,8 +8,8 @@ # this file, and for a DISCLAIMER OF ALL WARRANTIES. package require TclOO 1.0.3 -package require tcltest 2 -if {"::tcltest" in [namespace children]} { +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/opt.test b/tests/opt.test index 7ed25b5..0af4488 100644 --- a/tests/opt.test +++ b/tests/opt.test @@ -11,8 +11,8 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/parseExpr.test b/tests/parseExpr.test index ef05454..bb0920e 100644 --- a/tests/parseExpr.test +++ b/tests/parseExpr.test @@ -8,8 +8,10 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcltest 2 -namespace import ::tcltest::* +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] diff --git a/tests/parseOld.test b/tests/parseOld.test index 504d063..134a3c2 100644 --- a/tests/parseOld.test +++ b/tests/parseOld.test @@ -13,8 +13,10 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcltest 2 -namespace import ::tcltest::* +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] diff --git a/tests/pid.test b/tests/pid.test index af21f30..47f753b 100644 --- a/tests/pid.test +++ b/tests/pid.test @@ -11,8 +11,8 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/pkgMkIndex.test b/tests/pkgMkIndex.test index 37afafa..8121377 100644 --- a/tests/pkgMkIndex.test +++ b/tests/pkgMkIndex.test @@ -8,8 +8,10 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. -package require tcltest 2 -namespace import ::tcltest::* +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} set fullPkgPath [makeDirectory pkg] diff --git a/tests/platform.test b/tests/platform.test index e5a4c90..e40ff39 100644 --- a/tests/platform.test +++ b/tests/platform.test @@ -9,7 +9,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcltest 2 +package require tcltest 2.5 package require tcltests namespace eval ::tcl::test::platform { diff --git a/tests/proc-old.test b/tests/proc-old.test index e45cf5c..79ee1fa 100644 --- a/tests/proc-old.test +++ b/tests/proc-old.test @@ -14,8 +14,8 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/proc.test b/tests/proc.test index 585efa5..7039dbb 100644 --- a/tests/proc.test +++ b/tests/proc.test @@ -14,7 +14,7 @@ # this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/pwd.test b/tests/pwd.test index 175c852..3486e70 100644 --- a/tests/pwd.test +++ b/tests/pwd.test @@ -11,8 +11,8 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/reg.test b/tests/reg.test index a95d1e2..02677c7 100644 --- a/tests/reg.test +++ b/tests/reg.test @@ -9,8 +9,8 @@ # # Copyright (c) 1998, 1999 Henry Spencer. All rights reserved. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 } ::tcltest::loadTestedCommands diff --git a/tests/regexp.test b/tests/regexp.test index 6be902b..563a5ee 100644 --- a/tests/regexp.test +++ b/tests/regexp.test @@ -12,7 +12,7 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/regexpComp.test b/tests/regexpComp.test index 01ef06d..2fd7f88 100644 --- a/tests/regexpComp.test +++ b/tests/regexpComp.test @@ -11,8 +11,8 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/registry.test b/tests/registry.test index 8cfd5be..53e48fe 100644 --- a/tests/registry.test +++ b/tests/registry.test @@ -10,8 +10,8 @@ # Copyright (c) 1997 by Sun Microsystems, Inc. All rights reserved. # Copyright (c) 1998-1999 by Scriptics Corporation. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/rename.test b/tests/rename.test index ebf5425..ddda909 100644 --- a/tests/rename.test +++ b/tests/rename.test @@ -11,8 +11,8 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/resolver.test b/tests/resolver.test index db524a0..9916529 100644 --- a/tests/resolver.test +++ b/tests/resolver.test @@ -10,8 +10,8 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcltest 2 -if {"::tcltest" in [namespace children]} { +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/result.test b/tests/result.test index 9e8a66b..6e51e4e 100644 --- a/tests/result.test +++ b/tests/result.test @@ -10,8 +10,10 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcltest 2 -namespace import ::tcltest::* +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] diff --git a/tests/safe-stock86.test b/tests/safe-stock86.test index 337527c..402ea31 100644 --- a/tests/safe-stock86.test +++ b/tests/safe-stock86.test @@ -18,10 +18,8 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require Tcl 8.5- - -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/safe.test b/tests/safe.test index 217200c..eb4bfaf 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -21,10 +21,8 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require Tcl 8.5- - -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/scan.test b/tests/scan.test index 98c581b..e3fab05 100644 --- a/tests/scan.test +++ b/tests/scan.test @@ -12,7 +12,7 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/security.test b/tests/security.test index eeabc9c..3235a1f 100644 --- a/tests/security.test +++ b/tests/security.test @@ -11,7 +11,7 @@ # All rights reserved. if {"::tcltest" ni [namespace children]} { - package require tcltest + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/set-old.test b/tests/set-old.test index 309abaf..68e0497 100644 --- a/tests/set-old.test +++ b/tests/set-old.test @@ -13,8 +13,8 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/set.test b/tests/set.test index 3c87000..303c2d7 100644 --- a/tests/set.test +++ b/tests/set.test @@ -10,8 +10,8 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/socket.test b/tests/socket.test index 87169ae..4f1a198 100644 --- a/tests/socket.test +++ b/tests/socket.test @@ -60,8 +60,11 @@ # listening at port 2048. If all fails, a message is printed and the tests # using the remote server are not performed. -package require tcltest 2 -namespace import -force ::tcltest::* +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} + ::tcltest::loadTestedCommands if {[expr {[info exists ::env(TRAVIS_OSX_IMAGE)] && [string match xcode* $::env(TRAVIS_OSX_IMAGE)]}]} { diff --git a/tests/split.test b/tests/split.test index 18055b3..8e82367 100644 --- a/tests/split.test +++ b/tests/split.test @@ -11,8 +11,8 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/stack.test b/tests/stack.test index 13bc524..44417df 100644 --- a/tests/stack.test +++ b/tests/stack.test @@ -9,8 +9,10 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcltest 2 -namespace import ::tcltest::* +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} # Note that a failure in this test may result in a crash of the executable. diff --git a/tests/string.test b/tests/string.test index 124bda7..dabe3a4 100644 --- a/tests/string.test +++ b/tests/string.test @@ -12,8 +12,8 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/stringComp.test b/tests/stringComp.test index 2aeb08e..1cd0193 100644 --- a/tests/stringComp.test +++ b/tests/stringComp.test @@ -15,8 +15,8 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/stringObj.test b/tests/stringObj.test index 49f268e..ce19e96 100644 --- a/tests/stringObj.test +++ b/tests/stringObj.test @@ -12,8 +12,8 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/subst.test b/tests/subst.test index 21aecc5..e203ad2 100644 --- a/tests/subst.test +++ b/tests/subst.test @@ -11,7 +11,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2.1 namespace import -force ::tcltest::* } diff --git a/tests/switch.test b/tests/switch.test index 4d204bb..8ca049c 100644 --- a/tests/switch.test +++ b/tests/switch.test @@ -12,7 +12,7 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/tailcall.test b/tests/tailcall.test index 3751c35..c664455 100644 --- a/tests/tailcall.test +++ b/tests/tailcall.test @@ -9,8 +9,8 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/tcltest.test b/tests/tcltest.test index b02c18d..fc6b183 100644 --- a/tests/tcltest.test +++ b/tests/tcltest.test @@ -27,7 +27,7 @@ namespace eval ::tcltest::test { namespace import ::tcltest::* makeFile { - package require tcltest + package require tcltest 2.5 namespace import ::tcltest::test test a-1.0 {test a} { list 0 @@ -340,7 +340,7 @@ test tcltest-5.5 {InitConstraints: list of built-in constraints} \ # -outfile, -errfile, [outputChannel], [outputFile], [errorChannel], [errorFile] set printerror [makeFile { - package require tcltest + package require tcltest 2.5 namespace import ::tcltest::* puts [outputChannel] "a test" ::tcltest::PrintError "a really short string" @@ -510,7 +510,7 @@ removeFile test.tcl # directory tests set a [makeFile { - package require tcltest + package require tcltest 2.5 tcltest::makeFile {} a.tmp puts [tcltest::outputChannel] "testdir: [tcltest::testsDirectory]" exit @@ -795,7 +795,7 @@ test tcltest-9.5 {GetMatchingFiles: Bug 1119798} -setup { # -preservecore, [preserveCore] set mc [makeFile { - package require tcltest + package require tcltest 2.5 namespace import ::tcltest::test test makecore {make a core file} { set f [open core w] @@ -846,7 +846,7 @@ removeFile makecore.tcl # -load, -loadfile, [loadScript], [loadFile] set contents { - package require tcltest + package require tcltest 2.5 namespace import tcltest::* puts [outputChannel] $::tcltest::loadScript exit @@ -942,7 +942,7 @@ makeFile { } single2.test $spd set allfile [makeFile { - package require tcltest + package require tcltest 2.5 namespace import tcltest::* testsDirectory [file join [temporaryDirectory] singleprocdir] runAllTests @@ -999,25 +999,25 @@ set dtd1 [makeDirectory dirtestdir2.1 $dtd] set dtd2 [makeDirectory dirtestdir2.2 $dtd] set dtd3 [makeDirectory dirtestdir2.3 $dtd] makeFile { - package require tcltest + package require tcltest 2.5 namespace import -force tcltest::* testsDirectory [file join [temporaryDirectory] dirtestdir] runAllTests } all.tcl $dtd makeFile { - package require tcltest + package require tcltest 2.5 namespace import -force tcltest::* testsDirectory [file join [temporaryDirectory] dirtestdir dirtestdir2.1] runAllTests } all.tcl $dtd1 makeFile { - package require tcltest + package require tcltest 2.5 namespace import -force tcltest::* testsDirectory [file join [temporaryDirectory] dirtestdir dirtestdir2.2] runAllTests } all.tcl $dtd2 makeFile { - package require tcltest + package require tcltest 2.5 namespace import -force tcltest::* testsDirectory [file join [temporaryDirectory] dirtestdir dirtestdir2.3] runAllTests @@ -1385,7 +1385,7 @@ test tcltest-21.12 { set atd [makeDirectory alltestdir] makeFile { - package require tcltest + package require tcltest 2.5 namespace import -force tcltest::* testsDirectory [file join [temporaryDirectory] alltestdir] runAllTests @@ -1397,7 +1397,7 @@ makeFile { error "throw an error" } error.test $atd makeFile { - package require tcltest + package require tcltest 2.5 namespace import -force tcltest::* test foo-1.1 {foo} { -body { return 1 } @@ -1796,7 +1796,7 @@ test tcltest-25.3 { test tcltest-26.1 {Bug/RFE 1017151} -setup { makeFile { - package require tcltest + package require tcltest 2.5 set ::errorInfo "Should never see this" tcltest::test tcltest-26.1.0 { no errorInfo when only return code mismatch @@ -1816,7 +1816,7 @@ test tcltest-26.1 {Bug/RFE 1017151} -setup { test tcltest-26.2 {Bug/RFE 1017151} -setup { makeFile { - package require tcltest + package require tcltest 2.5 set ::errorInfo "Should never see this" tcltest::test tcltest-26.2.0 {do not mask body errorInfo} -body { error "body error" diff --git a/tests/tcltests.tcl b/tests/tcltests.tcl index a1fdb3d..58e6bfb 100644 --- a/tests/tcltests.tcl +++ b/tests/tcltests.tcl @@ -1,6 +1,6 @@ #! /usr/bin/env tclsh -package require tcltest 2.2 +package require tcltest 2.5 namespace import ::tcltest::* testConstraint exec [llength [info commands exec]] diff --git a/tests/timer.test b/tests/timer.test index b422f35..48d88b6 100644 --- a/tests/timer.test +++ b/tests/timer.test @@ -13,8 +13,8 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/tm.test b/tests/tm.test index 001b73e..ed14567 100644 --- a/tests/tm.test +++ b/tests/tm.test @@ -8,7 +8,7 @@ package require Tcl 8.5- if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/trace.test b/tests/trace.test index c54efff..726590f 100644 --- a/tests/trace.test +++ b/tests/trace.test @@ -11,8 +11,10 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcltest -namespace import ::tcltest::* +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] diff --git a/tests/unixFCmd.test b/tests/unixFCmd.test index 183c145..c98e3f0 100644 --- a/tests/unixFCmd.test +++ b/tests/unixFCmd.test @@ -9,8 +9,8 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/unixFile.test b/tests/unixFile.test index 8147f48..492e5d0 100644 --- a/tests/unixFile.test +++ b/tests/unixFile.test @@ -9,8 +9,8 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/unixForkEvent.test b/tests/unixForkEvent.test index 120f362..4a0ac15 100644 --- a/tests/unixForkEvent.test +++ b/tests/unixForkEvent.test @@ -8,7 +8,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcltest 2 +package require tcltest 2.5 namespace import -force ::tcltest::* testConstraint testfork [llength [info commands testfork]] diff --git a/tests/unixInit.test b/tests/unixInit.test index 681a931..51ecafe 100644 --- a/tests/unixInit.test +++ b/tests/unixInit.test @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcltest 2.2 +package require tcltest 2.5 namespace import ::tcltest::* unset -nocomplain path catch {set oldlang $env(LANG)} diff --git a/tests/unixNotfy.test b/tests/unixNotfy.test index 2f03529..df95c46 100644 --- a/tests/unixNotfy.test +++ b/tests/unixNotfy.test @@ -10,8 +10,8 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/unknown.test b/tests/unknown.test index 6c31c3d..7600cba 100644 --- a/tests/unknown.test +++ b/tests/unknown.test @@ -11,7 +11,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcltest 2 +package require tcltest 2.5 namespace import ::tcltest::* unset -nocomplain x diff --git a/tests/unload.test b/tests/unload.test index 73f1091..05a0104 100644 --- a/tests/unload.test +++ b/tests/unload.test @@ -11,8 +11,8 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/uplevel.test b/tests/uplevel.test index 9fe1645..f44cedc 100644 --- a/tests/uplevel.test +++ b/tests/uplevel.test @@ -11,8 +11,8 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/upvar.test b/tests/upvar.test index aea9333..10e0e9f 100644 --- a/tests/upvar.test +++ b/tests/upvar.test @@ -11,8 +11,8 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/utf.test b/tests/utf.test index b1fafb6..6839860 100644 --- a/tests/utf.test +++ b/tests/utf.test @@ -8,8 +8,8 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/util.test b/tests/util.test index f5a59ee..a7d21f1 100644 --- a/tests/util.test +++ b/tests/util.test @@ -7,8 +7,8 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/var.test b/tests/var.test index 202b66c..4c6664d 100644 --- a/tests/var.test +++ b/tests/var.test @@ -15,7 +15,7 @@ # this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2.2 + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/while-old.test b/tests/while-old.test index ee17d0b..eddc025 100644 --- a/tests/while-old.test +++ b/tests/while-old.test @@ -13,8 +13,8 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/while.test b/tests/while.test index 642ec93..30aff4b 100644 --- a/tests/while.test +++ b/tests/while.test @@ -11,7 +11,7 @@ # this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/winConsole.test b/tests/winConsole.test index fdde41c..9075ff3 100644 --- a/tests/winConsole.test +++ b/tests/winConsole.test @@ -9,8 +9,8 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/winDde.test b/tests/winDde.test index 6ba2ba1..1c3daa5 100644 --- a/tests/winDde.test +++ b/tests/winDde.test @@ -10,7 +10,7 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 #tcltest::configure -verbose {pass start} namespace import -force ::tcltest::* } @@ -43,7 +43,7 @@ proc createChildProcess {ddeServerName args} { # DDE child server - # if {"::tcltest" ni [namespace children]} { - package require tcltest + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/winFCmd.test b/tests/winFCmd.test index 2ce4916..6d87319 100644 --- a/tests/winFCmd.test +++ b/tests/winFCmd.test @@ -10,8 +10,8 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/winFile.test b/tests/winFile.test index eb6addd..3737d9f 100644 --- a/tests/winFile.test +++ b/tests/winFile.test @@ -10,8 +10,8 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[catch {package require tcltest 2.0.2}]} { - puts stderr "Skipping tests in [info script]. tcltest 2.0.2 required." +if {[catch {package require tcltest 2.5}]} { + puts stderr "Skipping tests in [info script]. tcltest 2.5 required." return } namespace import -force ::tcltest::* diff --git a/tests/winNotify.test b/tests/winNotify.test index 3e9aa29..0433b4a 100644 --- a/tests/winNotify.test +++ b/tests/winNotify.test @@ -10,8 +10,8 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/winPipe.test b/tests/winPipe.test index 06bd67e..d3a580c 100644 --- a/tests/winPipe.test +++ b/tests/winPipe.test @@ -12,7 +12,7 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcltest +package require tcltest 2.5 namespace import -force ::tcltest::* unset -nocomplain path diff --git a/tests/winTime.test b/tests/winTime.test index dbaa14c..19e4c58 100644 --- a/tests/winTime.test +++ b/tests/winTime.test @@ -10,8 +10,8 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/zlib.test b/tests/zlib.test index d3a6dff..7809482 100644 --- a/tests/zlib.test +++ b/tests/zlib.test @@ -11,7 +11,7 @@ # this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2.1 + package require tcltest 2.5 namespace import -force ::tcltest::* } -- cgit v0.12 From 66dd14a48053da5e5f4463d0d83b9e5480a9bd5e Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sat, 5 Sep 2020 20:45:04 +0000 Subject: TIP #581: Last possible master/slave -> parent/child changes, without affecting anything serious --- doc/CrtAlias.3 | 22 ++-- library/safe.tcl | 338 ++++++++++++++++++++++++++--------------------------- tests/ioCmd.test | 6 +- tests/ioTrans.test | 16 +-- tests/oo.test | 136 ++++++++++----------- tests/ooNext2.test | 8 +- tests/safe.test | 2 +- tests/socket.test | 30 ++--- 8 files changed, 279 insertions(+), 279 deletions(-) diff --git a/doc/CrtAlias.3 b/doc/CrtAlias.3 index 2934fc3..a642d08 100644 --- a/doc/CrtAlias.3 +++ b/doc/CrtAlias.3 @@ -136,17 +136,17 @@ interpreter. The return value for those procedures that return an \fBint\fR is either \fBTCL_OK\fR or \fBTCL_ERROR\fR. If \fBTCL_ERROR\fR is returned then the interpreter's result contains an error message. .PP -\fBTcl_CreateSlave\fR creates a new interpreter as a slave of \fIinterp\fR. -It also creates a slave command named \fIslaveName\fR in \fIinterp\fR which -allows \fIinterp\fR to manipulate the new slave. -If \fIisSafe\fR is zero, the command creates a trusted slave in which Tcl +\fBTcl_CreateSlave\fR creates a new interpreter as a child of \fIinterp\fR. +It also creates a child command named \fIchildName\fR in \fIinterp\fR which +allows \fIinterp\fR to manipulate the new child. +If \fIisSafe\fR is zero, the command creates a trusted child in which Tcl code has access to all the Tcl commands. If it is \fB1\fR, the command creates a .QW safe -slave in which Tcl code has access only to set of Tcl commands defined as +child in which Tcl code has access only to set of Tcl commands defined as .QW "Safe Tcl" ; see the manual entry for the Tcl \fBinterp\fR command for details. -If the creation of the new slave interpreter failed, \fBNULL\fR is returned. +If the creation of the new child interpreter failed, \fBNULL\fR is returned. .PP .VS "TIP 581" \fBTcl_CreateChild\fR is a synonym for \fBTcl_CreateSlave\fR. @@ -169,9 +169,9 @@ Callers will want to take care with their use of \fBTcl_MakeSafe\fR to avoid false claims of safety. For many situations, \fBTcl_CreateSlave\fR may be a better choice, since it creates interpreters in a known-safe state. .PP -\fBTcl_GetSlave\fR returns a pointer to a slave interpreter of -\fIinterp\fR. The slave interpreter is identified by \fIslaveName\fR. -If no such slave interpreter exists, \fBNULL\fR is returned. +\fBTcl_GetSlave\fR returns a pointer to a child interpreter of +\fIinterp\fR. The child interpreter is identified by \fIchildName\fR. +If no such child interpreter exists, \fBNULL\fR is returned. .PP .VS "TIP 581" \fBTcl_GetChild\fR is a synonym for \fBTcl_GetSlave\fR. @@ -187,7 +187,7 @@ top-level interpreter) then \fBNULL\fR is returned. .PP \fBTcl_GetInterpPath\fR stores in the result of \fIinterp\fR the relative path between \fIinterp\fR and \fIchildInterp\fR; -\fIchildInterp\fR must be a slave of \fIinterp\fR. If the computation +\fIchildInterp\fR must be a child of \fIinterp\fR. If the computation of the relative path succeeds, \fBTCL_OK\fR is returned, else \fBTCL_ERROR\fR is returned and an error message is stored as the result of \fIinterp\fR. @@ -260,4 +260,4 @@ interp .SH KEYWORDS alias, command, exposed commands, hidden commands, interpreter, invoke, -master, slave +parent, child diff --git a/library/safe.tcl b/library/safe.tcl index 96177d5..48cb0de 100644 --- a/library/safe.tcl +++ b/library/safe.tcl @@ -1,9 +1,9 @@ # safe.tcl -- # # This file provide a safe loading/sourcing mechanism for safe interpreters. -# It implements a virtual path mecanism to hide the real pathnames from the -# slave. It runs in a parent interpreter and sets up data structure and -# aliases that will be invoked when used from a slave interpreter. +# It implements a virtual path mechanism to hide the real pathnames from the +# child. It runs in a parent interpreter and sets up data structure and +# aliases that will be invoked when used from a child interpreter. # # See the safe.n man page for details. # @@ -94,12 +94,12 @@ proc ::safe::interpInit {args} { [InterpStatics] [InterpNested] $deleteHook } -# Check that the given slave is "one of us" -proc ::safe::CheckInterp {slave} { - namespace upvar ::safe [VarName $slave] state - if {![info exists state] || ![::interp exists $slave]} { +# Check that the given child is "one of us" +proc ::safe::CheckInterp {child} { + namespace upvar ::safe [VarName $child] state + if {![info exists state] || ![::interp exists $child]} { return -code error \ - "\"$slave\" is not an interpreter managed by ::safe::" + "\"$child\" is not an interpreter managed by ::safe::" } } @@ -121,7 +121,7 @@ proc ::safe::interpConfigure {args} { 1 { # If we have exactly 1 argument the semantic is to return all # the current configuration. We still call OptKeyParse though - # we know that "slave" is our given argument because it also + # we know that "child" is our given argument because it also # checks for the "-help" option. set Args [::tcl::OptKeyParse ::safe::interpIC $args] CheckInterp $slave @@ -220,7 +220,7 @@ proc ::safe::interpConfigure {args} { } # we can now reconfigure : InterpSetConfig $slave $accessPath $statics $nested $deleteHook - # auto_reset the slave (to completly synch the new access_path) + # auto_reset the child (to completly synch the new access_path) if {$doreset} { if {[catch {::interp eval $slave {auto_reset}} msg]} { Log $slave "auto_reset failed: $msg" @@ -260,15 +260,15 @@ proc ::safe::interpConfigure {args} { # # safe::InterpCreate : doing the real job # -# This procedure creates a safe slave and initializes it with the safe +# This procedure creates a safe child and initializes it with the safe # base aliases. -# NB: slave name must be simple alphanumeric string, no spaces, no (), no +# NB: child name must be simple alphanumeric string, no spaces, no (), no # {},... {because the state array is stored as part of the name} # -# Returns the slave name. +# Returns the child name. # # Optional Arguments : -# + slave name : if empty, generated name will be used +# + child name : if empty, generated name will be used # + access_path: path list controlling where load/source can occur, # if empty: the parent auto_path will be used. # + staticsok : flag, if 0 :no static package can be loaded (load {} Xxx) @@ -278,37 +278,37 @@ proc ::safe::interpConfigure {args} { # use the full name and no indent so auto_mkIndex can find us proc ::safe::InterpCreate { - slave + child access_path staticsok nestedok deletehook } { - # Create the slave. + # Create the child. # If evaluated in ::safe, the interpreter command for foo is ::foo; # but for foo::bar is safe::foo::bar. So evaluate in :: instead. - if {$slave ne ""} { - namespace eval :: [list ::interp create -safe $slave] + if {$child ne ""} { + namespace eval :: [list ::interp create -safe $child] } else { - # empty argument: generate slave name - set slave [::interp create -safe] + # empty argument: generate child name + set child [::interp create -safe] } - Log $slave "Created" NOTICE + Log $child "Created" NOTICE - # Initialize it. (returns slave name) - InterpInit $slave $access_path $staticsok $nestedok $deletehook + # Initialize it. (returns child name) + InterpInit $child $access_path $staticsok $nestedok $deletehook } # # InterpSetConfig (was setAccessPath) : -# Sets up slave virtual auto_path and corresponding structure within -# the parent. Also sets the tcl_library in the slave to be the first +# Sets up child virtual auto_path and corresponding structure within +# the parent. Also sets the tcl_library in the child to be the first # directory in the path. -# NB: If you change the path after the slave has been initialized you -# probably need to call "auto_reset" in the slave in order that it gets +# NB: If you change the path after the child has been initialized you +# probably need to call "auto_reset" in the child in order that it gets # the right auto_index() array values. -proc ::safe::InterpSetConfig {slave access_path staticsok nestedok deletehook} { +proc ::safe::InterpSetConfig {child access_path staticsok nestedok deletehook} { global auto_path # determine and store the access path if empty @@ -321,33 +321,33 @@ proc ::safe::InterpSetConfig {slave access_path staticsok nestedok deletehook} { if {$where == -1} { # not found, add it. set access_path [linsert $access_path 0 [info library]] - Log $slave "tcl_library was not in auto_path,\ + Log $child "tcl_library was not in auto_path,\ added it to slave's access_path" NOTICE } elseif {$where != 0} { # not first, move it first set access_path [linsert \ [lreplace $access_path $where $where] \ 0 [info library]] - Log $slave "tcl_libray was not in first in auto_path,\ + Log $child "tcl_libray was not in first in auto_path,\ moved it to front of slave's access_path" NOTICE } # Add 1st level sub dirs (will searched by auto loading from tcl - # code in the slave using glob and thus fail, so we add them here + # code in the child using glob and thus fail, so we add them here # so by default it works the same). set access_path [AddSubDirs $access_path] } - Log $slave "Setting accessPath=($access_path) staticsok=$staticsok\ + Log $child "Setting accessPath=($access_path) staticsok=$staticsok\ nestedok=$nestedok deletehook=($deletehook)" NOTICE - namespace upvar ::safe [VarName $slave] state + namespace upvar ::safe [VarName $child] state # clear old autopath if it existed # build new one # Extend the access list with the paths used to look for Tcl Modules. # We save the virtual form separately as well, as syncing it with the - # slave has to be defered until the necessary commands are present for + # child has to be deferred until the necessary commands are present for # setup. set norm_access_path {} @@ -420,7 +420,7 @@ proc ::safe::InterpSetConfig {slave access_path staticsok nestedok deletehook} { set state(nestedok) $nestedok set state(cleanupHook) $deletehook - SyncAccessPath $slave + SyncAccessPath $child return } @@ -429,9 +429,9 @@ proc ::safe::InterpSetConfig {slave access_path staticsok nestedok deletehook} { # FindInAccessPath: # Search for a real directory and returns its virtual Id (including the # "$") -proc ::safe::interpFindInAccessPath {slave path} { - CheckInterp $slave - namespace upvar ::safe [VarName $slave] state +proc ::safe::interpFindInAccessPath {child path} { + CheckInterp $child + namespace upvar ::safe [VarName $child] state if {![dict exists $state(access_path,remap) $path]} { return -code error "$path not found in access path" @@ -444,11 +444,11 @@ proc ::safe::interpFindInAccessPath {slave path} { # addToAccessPath: # add (if needed) a real directory to access path and return its # virtual token (including the "$"). -proc ::safe::interpAddToAccessPath {slave path} { +proc ::safe::interpAddToAccessPath {child path} { # first check if the directory is already in there # (inlined interpFindInAccessPath). - CheckInterp $slave - namespace upvar ::safe [VarName $slave] state + CheckInterp $child + namespace upvar ::safe [VarName $child] state if {[dict exists $state(access_path,remap) $path]} { return [dict get $state(access_path,remap) $path] @@ -463,7 +463,7 @@ proc ::safe::interpAddToAccessPath {slave path} { lappend state(access_path,remap) $path $token lappend state(access_path,norm) [file normalize $path] - SyncAccessPath $slave + SyncAccessPath $child return $token } @@ -471,25 +471,25 @@ proc ::safe::interpAddToAccessPath {slave path} { # interpreter. It is useful when you want to install the safe base aliases # into a preexisting safe interpreter. proc ::safe::InterpInit { - slave + child access_path staticsok nestedok deletehook } { # Configure will generate an access_path when access_path is empty. - InterpSetConfig $slave $access_path $staticsok $nestedok $deletehook + InterpSetConfig $child $access_path $staticsok $nestedok $deletehook # NB we need to add [namespace current], aliases are always absolute # paths. - # These aliases let the slave load files to define new commands - # This alias lets the slave use the encoding names, convertfrom, + # These aliases let the child load files to define new commands + # This alias lets the child use the encoding names, convertfrom, # convertto, and system, but not "encoding system " to set the # system encoding. # Handling Tcl Modules, we need a restricted form of Glob. # This alias interposes on the 'exit' command and cleanly terminates - # the slave. + # the child. foreach {command alias} { source AliasSource @@ -498,61 +498,61 @@ proc ::safe::InterpInit { exit interpDelete glob AliasGlob } { - ::interp alias $slave $command {} [namespace current]::$alias $slave + ::interp alias $child $command {} [namespace current]::$alias $child } - # This alias lets the slave have access to a subset of the 'file' + # This alias lets the child have access to a subset of the 'file' # command functionality. - ::interp expose $slave file + ::interp expose $child file foreach subcommand {dirname extension rootname tail} { - ::interp alias $slave ::tcl::file::$subcommand {} \ - ::safe::AliasFileSubcommand $slave $subcommand + ::interp alias $child ::tcl::file::$subcommand {} \ + ::safe::AliasFileSubcommand $child $subcommand } foreach subcommand { atime attributes copy delete executable exists isdirectory isfile link lstat mtime mkdir nativename normalize owned readable readlink rename size stat tempfile type volumes writable } { - ::interp alias $slave ::tcl::file::$subcommand {} \ - ::safe::BadSubcommand $slave file $subcommand + ::interp alias $child ::tcl::file::$subcommand {} \ + ::safe::BadSubcommand $child file $subcommand } # Subcommands of info foreach {subcommand alias} { nameofexecutable AliasExeName } { - ::interp alias $slave ::tcl::info::$subcommand \ - {} [namespace current]::$alias $slave + ::interp alias $child ::tcl::info::$subcommand \ + {} [namespace current]::$alias $child } - # The allowed slave variables already have been set by Tcl_MakeSafe(3) + # The allowed child variables already have been set by Tcl_MakeSafe(3) - # Source init.tcl and tm.tcl into the slave, to get auto_load and + # Source init.tcl and tm.tcl into the child, to get auto_load and # other procedures defined: - if {[catch {::interp eval $slave { + if {[catch {::interp eval $child { source [file join $tcl_library init.tcl] }} msg opt]} { - Log $slave "can't source init.tcl ($msg)" - return -options $opt "can't source init.tcl into slave $slave ($msg)" + Log $child "can't source init.tcl ($msg)" + return -options $opt "can't source init.tcl into slave $child ($msg)" } - if {[catch {::interp eval $slave { + if {[catch {::interp eval $child { source [file join $tcl_library tm.tcl] }} msg opt]} { - Log $slave "can't source tm.tcl ($msg)" - return -options $opt "can't source tm.tcl into slave $slave ($msg)" + Log $child "can't source tm.tcl ($msg)" + return -options $opt "can't source tm.tcl into slave $child ($msg)" } # Sync the paths used to search for Tcl modules. This can be done only # now, after tm.tcl was loaded. - namespace upvar ::safe [VarName $slave] state + namespace upvar ::safe [VarName $child] state if {[llength $state(tm_path_slave)] > 0} { - ::interp eval $slave [list \ + ::interp eval $child [list \ ::tcl::tm::add {*}[lreverse $state(tm_path_slave)]] } - return $slave + return $child } # Add (only if needed, avoid duplicates) 1 level of sub directories to an @@ -578,30 +578,30 @@ proc ::safe::AddSubDirs {pathList} { return $res } -# This procedure deletes a safe slave managed by Safe Tcl and cleans up +# This procedure deletes a safe child managed by Safe Tcl and cleans up # associated state. # - The command will also delete non-Safe-Base interpreters. # - This is regrettable, but to avoid breaking existing code this should be # amended at the next major revision by uncommenting "CheckInterp". -proc ::safe::interpDelete {slave} { - Log $slave "About to delete" NOTICE +proc ::safe::interpDelete {child} { + Log $child "About to delete" NOTICE - # CheckInterp $slave - namespace upvar ::safe [VarName $slave] state + # CheckInterp $child + namespace upvar ::safe [VarName $child] state # When an interpreter is deleted with [interp delete], any sub-interpreters # are deleted automatically, but this leaves behind their data in the Safe # Base. To clean up properly, we call safe::interpDelete recursively on each # Safe Base sub-interpreter, so each one is deleted cleanly and not by # the automatic mechanism built into [interp delete]. - foreach sub [interp children $slave] { - if {[info exists ::safe::[VarName [list $slave $sub]]]} { - ::safe::interpDelete [list $slave $sub] + foreach sub [interp children $child] { + if {[info exists ::safe::[VarName [list $child $sub]]]} { + ::safe::interpDelete [list $child $sub] } } - # If the slave has a cleanup hook registered, call it. Check the + # If the child has a cleanup hook registered, call it. Check the # existance because we might be called to delete an interp which has # not been registered with us at all @@ -612,14 +612,14 @@ proc ::safe::interpDelete {slave} { # we'll loop unset state(cleanupHook) try { - {*}$hook $slave + {*}$hook $child } on error err { - Log $slave "Delete hook error ($err)" + Log $child "Delete hook error ($err)" } } } - # Discard the global array of state associated with the slave, and + # Discard the global array of state associated with the child, and # delete the interpreter. if {[info exists state]} { @@ -628,9 +628,9 @@ proc ::safe::interpDelete {slave} { # if we have been called twice, the interp might have been deleted # already - if {[::interp exists $slave]} { - ::interp delete $slave - Log $slave "Deleted" NOTICE + if {[::interp exists $child]} { + ::interp delete $child + Log $child "Deleted" NOTICE } return @@ -656,9 +656,9 @@ proc ::safe::setLogCmd {args} { } else { # Activate logging, define proper command. - proc ::safe::Log {slave msg {type ERROR}} { + proc ::safe::Log {child msg {type ERROR}} { variable Log - {*}$Log "$type for slave $slave : $msg" + {*}$Log "$type for slave $child : $msg" return } } @@ -667,23 +667,23 @@ proc ::safe::setLogCmd {args} { # ------------------- END OF PUBLIC METHODS ------------ # -# Sets the slave auto_path to the parent recorded value. Also sets +# Sets the child auto_path to the parent recorded value. Also sets # tcl_library to the first token of the virtual path. # -proc ::safe::SyncAccessPath {slave} { - namespace upvar ::safe [VarName $slave] state +proc ::safe::SyncAccessPath {child} { + namespace upvar ::safe [VarName $child] state set slave_access_path $state(access_path,slave) - ::interp eval $slave [list set auto_path $slave_access_path] + ::interp eval $child [list set auto_path $slave_access_path] - Log $slave "auto_path in $slave has been set to $slave_access_path"\ + Log $child "auto_path in $child has been set to $slave_access_path"\ NOTICE # This code assumes that info library is the first element in the # list of auto_path's. See -> InterpSetConfig for the code which # ensures this condition. - ::interp eval $slave [list \ + ::interp eval $child [list \ set tcl_library [lindex $slave_access_path 0]] } @@ -697,8 +697,8 @@ proc ::safe::PathToken {n} { # # translate virtual path into real path # -proc ::safe::TranslatePath {slave path} { - namespace upvar ::safe [VarName $slave] state +proc ::safe::TranslatePath {child path} { + namespace upvar ::safe [VarName $child] state # somehow strip the namespaces 'functionality' out (the danger is that # we would strip valid macintosh "../" queries... : @@ -713,7 +713,7 @@ proc ::safe::TranslatePath {slave path} { # file name control (limit access to files/resources that should be a # valid tcl source file) -proc ::safe::CheckFileName {slave file} { +proc ::safe::CheckFileName {child file} { # This used to limit what can be sourced to ".tcl" and forbid files # with more than 1 dot and longer than 14 chars, but I changed that # for 8.4 as a safe interp has enough internal protection already to @@ -734,17 +734,17 @@ proc ::safe::CheckFileName {slave file} { # interpreters that are *almost* safe. In particular, it just acts to # prevent discovery of what home directories exist. -proc ::safe::AliasFileSubcommand {slave subcommand name} { +proc ::safe::AliasFileSubcommand {child subcommand name} { if {[string match ~* $name]} { set name ./$name } - tailcall ::interp invokehidden $slave tcl:file:$subcommand $name + tailcall ::interp invokehidden $child tcl:file:$subcommand $name } # AliasGlob is the target of the "glob" alias in safe interpreters. -proc ::safe::AliasGlob {slave args} { - Log $slave "GLOB ! $args" NOTICE +proc ::safe::AliasGlob {child args} { + Log $child "GLOB ! $args" NOTICE set cmd {} set at 0 array set got { @@ -789,7 +789,7 @@ proc ::safe::AliasGlob {slave args} { incr at } -* { - Log $slave "Safe base rejecting glob option '$opt'" + Log $child "Safe base rejecting glob option '$opt'" return -code error "Safe base rejecting glob option '$opt'" } default { @@ -800,14 +800,14 @@ proc ::safe::AliasGlob {slave args} { } # Get the real path from the virtual one and check that the path is in the - # access path of that slave. Done after basic argument processing so that + # access path of that child. Done after basic argument processing so that # we know if -nocomplain is set. if {$got(-directory)} { try { - set dir [TranslatePath $slave $virtualdir] - DirInAccessPath $slave $dir + set dir [TranslatePath $child $virtualdir] + DirInAccessPath $child $dir } on error msg { - Log $slave $msg + Log $child $msg if {$got(-nocomplain)} return return -code error "permission denied" } @@ -820,7 +820,7 @@ proc ::safe::AliasGlob {slave args} { # The code after this "if ... else" block would conspire to return with # no results in this case, if it were allowed to proceed. Instead, # return now and reduce the number of cases to be considered later. - Log $slave {option -directory must be supplied} + Log $child {option -directory must be supplied} if {$got(-nocomplain)} return return -code error "permission denied" } @@ -846,11 +846,11 @@ proc ::safe::AliasGlob {slave args} { # after removing any subdir that are not in the access path. if {($thedir eq "*") && ($thefile eq "pkgIndex.tcl")} { set mapped 0 - foreach d [glob -directory [TranslatePath $slave $virtualdir] \ + foreach d [glob -directory [TranslatePath $child $virtualdir] \ -types d -tails *] { catch { - DirInAccessPath $slave \ - [TranslatePath $slave [file join $virtualdir $d]] + DirInAccessPath $child \ + [TranslatePath $child [file join $virtualdir $d]] lappend cmd [file join $d $thefile] set mapped 1 } @@ -876,17 +876,17 @@ proc ::safe::AliasGlob {slave args} { # - Bug [3529949] relates to unwanted expansion of ~${foo} and this is # how the present code avoids the bug. All tests safe-16.* relate. try { - DirInAccessPath $slave [TranslatePath $slave \ + DirInAccessPath $child [TranslatePath $child \ [file join $virtualdir $thedir]] } on error msg { - Log $slave $msg + Log $child $msg if {$got(-nocomplain)} continue return -code error "permission denied" } lappend cmd $opt } - Log $slave "GLOB = $cmd" NOTICE + Log $child "GLOB = $cmd" NOTICE if {$got(-nocomplain) && [llength $cmd] eq $firstPattern} { return @@ -899,17 +899,17 @@ proc ::safe::AliasGlob {slave args} { # which are a list of names each with tail pkgIndex.tcl. The purpose # of the call to glob is to remove the names for which the file does # not exist. - set entries [::interp invokehidden $slave glob {*}$cmd] + set entries [::interp invokehidden $child glob {*}$cmd] } on error msg { # This is the only place that a call with -nocomplain and no invalid # "dash-options" can return an error. - Log $slave $msg + Log $child $msg return -code error "script error" } - Log $slave "GLOB < $entries" NOTICE + Log $child "GLOB < $entries" NOTICE - # Translate path back to what the slave should see. + # Translate path back to what the child should see. set res {} set l [string length $dir] foreach p $entries { @@ -919,13 +919,13 @@ proc ::safe::AliasGlob {slave args} { lappend res $p } - Log $slave "GLOB > $res" NOTICE + Log $child "GLOB > $res" NOTICE return $res } # AliasSource is the target of the "source" alias in safe interpreters. -proc ::safe::AliasSource {slave args} { +proc ::safe::AliasSource {child args} { set argc [llength $args] # Extended for handling of Tcl Modules to allow not only "source # filename", but "source -encoding E filename" as well. @@ -934,7 +934,7 @@ proc ::safe::AliasSource {slave args} { set encoding [lindex $args 1] set at 2 if {$encoding eq "identity"} { - Log $slave "attempt to use the identity encoding" + Log $child "attempt to use the identity encoding" return -code error "permission denied" } } else { @@ -943,24 +943,24 @@ proc ::safe::AliasSource {slave args} { } if {$argc != 1} { set msg "wrong # args: should be \"source ?-encoding E? fileName\"" - Log $slave "$msg ($args)" + Log $child "$msg ($args)" return -code error $msg } set file [lindex $args $at] # get the real path from the virtual one. if {[catch { - set realfile [TranslatePath $slave $file] + set realfile [TranslatePath $child $file] } msg]} { - Log $slave $msg + Log $child $msg return -code error "permission denied" } - # check that the path is in the access path of that slave + # check that the path is in the access path of that child if {[catch { - FileInAccessPath $slave $realfile + FileInAccessPath $child $realfile } msg]} { - Log $slave $msg + Log $child $msg return -code error "permission denied" } @@ -969,16 +969,16 @@ proc ::safe::AliasSource {slave args} { # to tclLog. Has no effect on other callers of ::source, which are in # "package ifneeded" scripts. if {[catch { - CheckFileName $slave $realfile + CheckFileName $child $realfile } msg]} { - Log $slave "$realfile:$msg" + Log $child "$realfile:$msg" return -code error -errorcode {POSIX EACCES} $msg } # Passed all the tests, lets source it. Note that we do this all manually - # because we want to control [info script] in the slave so information + # because we want to control [info script] in the child so information # doesn't leak so much. [Bug 2913625] - set old [::interp eval $slave {info script}] + set old [::interp eval $child {info script}] set replacementMsg "script error" set code [catch { set f [open $realfile] @@ -988,17 +988,17 @@ proc ::safe::AliasSource {slave args} { } set contents [read $f] close $f - ::interp eval $slave [list info script $file] + ::interp eval $child [list info script $file] } msg opt] if {$code == 0} { - set code [catch {::interp eval $slave $contents} msg opt] + set code [catch {::interp eval $child $contents} msg opt] set replacementMsg $msg } - catch {interp eval $slave [list info script $old]} + catch {interp eval $child [list info script $old]} # Note that all non-errors are fine result codes from [source], so we must # take a little care to do it properly. [Bug 2923613] if {$code == 1} { - Log $slave $msg + Log $child $msg return -code error $replacementMsg } return -code $code -options $opt $msg @@ -1006,18 +1006,18 @@ proc ::safe::AliasSource {slave args} { # AliasLoad is the target of the "load" alias in safe interpreters. -proc ::safe::AliasLoad {slave file args} { +proc ::safe::AliasLoad {child file args} { set argc [llength $args] if {$argc > 2} { set msg "load error: too many arguments" - Log $slave "$msg ($argc) {$file $args}" + Log $child "$msg ($argc) {$file $args}" return -code error $msg } # package name (can be empty if file is not). set package [lindex $args 0] - namespace upvar ::safe [VarName $slave] state + namespace upvar ::safe [VarName $child] state # Determine where to load. load use a relative interp path and {} # means self, so we can directly and safely use passed arg. @@ -1026,7 +1026,7 @@ proc ::safe::AliasLoad {slave file args} { # we will try to load into a sub sub interp; check that we want to # authorize that. if {!$state(nestedok)} { - Log $slave "loading to a sub interp (nestedok)\ + Log $child "loading to a sub interp (nestedok)\ disabled (trying to load $package to $target)" return -code error "permission denied (nested load)" } @@ -1037,11 +1037,11 @@ proc ::safe::AliasLoad {slave file args} { # static package loading if {$package eq ""} { set msg "load error: empty filename and no package name" - Log $slave $msg + Log $child $msg return -code error $msg } if {!$state(staticsok)} { - Log $slave "static packages loading disabled\ + Log $child "static packages loading disabled\ (trying to load $package to $target)" return -code error "permission denied (static package)" } @@ -1050,23 +1050,23 @@ proc ::safe::AliasLoad {slave file args} { # get the real path from the virtual one. try { - set file [TranslatePath $slave $file] + set file [TranslatePath $child $file] } on error msg { - Log $slave $msg + Log $child $msg return -code error "permission denied" } # check the translated path try { - FileInAccessPath $slave $file + FileInAccessPath $child $file } on error msg { - Log $slave $msg + Log $child $msg return -code error "permission denied (path)" } } try { - return [::interp invokehidden $slave load $file $package $target] + return [::interp invokehidden $child load $file $package $target] } on error msg { # Some packages return no error message. set msg0 "load of binary library for package $package failed" @@ -1075,18 +1075,18 @@ proc ::safe::AliasLoad {slave file args} { } else { set msg "$msg0: $msg" } - Log $slave $msg + Log $child $msg return -code error $msg } } # FileInAccessPath raises an error if the file is not found in the list of -# directories contained in the (parent side recorded) slave's access path. +# directories contained in the (parent side recorded) child's access path. # the security here relies on "file dirname" answering the proper # result... needs checking ? -proc ::safe::FileInAccessPath {slave file} { - namespace upvar ::safe [VarName $slave] state +proc ::safe::FileInAccessPath {child file} { + namespace upvar ::safe [VarName $child] state set access_path $state(access_path) if {[file isdirectory $file]} { @@ -1098,14 +1098,14 @@ proc ::safe::FileInAccessPath {slave file} { # potential pathname anomalies. set norm_parent [file normalize $parent] - namespace upvar ::safe [VarName $slave] state + namespace upvar ::safe [VarName $child] state if {$norm_parent ni $state(access_path,norm)} { return -code error "\"$file\": not in access_path" } } -proc ::safe::DirInAccessPath {slave dir} { - namespace upvar ::safe [VarName $slave] state +proc ::safe::DirInAccessPath {child dir} { + namespace upvar ::safe [VarName $child] state set access_path $state(access_path) if {[file isfile $dir]} { @@ -1116,7 +1116,7 @@ proc ::safe::DirInAccessPath {slave dir} { # potential pathname anomalies. set norm_dir [file normalize $dir] - namespace upvar ::safe [VarName $slave] state + namespace upvar ::safe [VarName $child] state if {$norm_dir ni $state(access_path,norm)} { return -code error "\"$dir\": not in access_path" } @@ -1125,16 +1125,16 @@ proc ::safe::DirInAccessPath {slave dir} { # This procedure is used to report an attempt to use an unsafe member of an # ensemble command. -proc ::safe::BadSubcommand {slave command subcommand args} { +proc ::safe::BadSubcommand {child command subcommand args} { set msg "not allowed to invoke subcommand $subcommand of $command" - Log $slave $msg + Log $child $msg return -code error -errorcode {TCL SAFE SUBCOMMAND} $msg } # AliasEncoding is the target of the "encoding" alias in safe interpreters. -proc ::safe::AliasEncoding {slave option args} { - # Note that [encoding dirs] is not supported in safe slaves at all +proc ::safe::AliasEncoding {child option args} { + # Note that [encoding dirs] is not supported in safe children at all set subcommands {convertfrom convertto names system} try { set option [tcl::prefix match -error [list -level 1 -errorcode \ @@ -1145,15 +1145,15 @@ proc ::safe::AliasEncoding {slave option args} { "wrong # args: should be \"encoding system\"" } } on error {msg options} { - Log $slave $msg + Log $child $msg return -options $options $msg } - tailcall ::interp invokehidden $slave encoding $option {*}$args + tailcall ::interp invokehidden $child encoding $option {*}$args } # Various minor hiding of platform features. [Bug 2913625] -proc ::safe::AliasExeName {slave} { +proc ::safe::AliasExeName {child} { return "" } @@ -1184,17 +1184,17 @@ proc ::safe::AliasExeName {slave} { # fails. # So we choose (a). # (7) The command -# namespace upvar ::safe S$slave state +# namespace upvar ::safe S$child state # becomes -# namespace upvar ::safe [VarName $slave] state +# namespace upvar ::safe [VarName $child] state # ------------------------------------------------------------------------------ -proc ::safe::RejectExcessColons {slave} { - set stripped [regsub -all -- {:::*} $slave ::] +proc ::safe::RejectExcessColons {child} { + set stripped [regsub -all -- {:::*} $child ::] if {[string range $stripped end-1 end] eq {::}} { return -code error {interpreter name must not end in "::"} } - if {$stripped ne $slave} { + if {$stripped ne $child} { set msg {interpreter name has excess colons in namespace separators} return -code error $msg } @@ -1204,9 +1204,9 @@ proc ::safe::RejectExcessColons {slave} { return } -proc ::safe::VarName {slave} { - # return S$slave - return S[string map {:: @N @ @A} $slave] +proc ::safe::VarName {child} { + # return S$child + return S[string map {:: @N @ @A} $child] } proc ::safe::Setup {} { @@ -1267,20 +1267,20 @@ namespace eval ::safe { # Log command, set via 'setLogCmd'. Logging is disabled when empty. variable Log {} - # The package maintains a state array per slave interp under its + # The package maintains a state array per child interp under its # control. The name of this array is S. This array is # brought into scope where needed, using 'namespace upvar'. The S - # prefix is used to avoid that a slave interp called "Log" smashes + # prefix is used to avoid that a child interp called "Log" smashes # the "Log" variable. # # The array's elements are: # - # access_path : List of paths accessible to the slave. + # access_path : List of paths accessible to the child. # access_path,norm : Ditto, in normalized form. - # access_path,slave : Ditto, as the path tokens as seen by the slave. + # access_path,slave : Ditto, as the path tokens as seen by the child. # access_path,map : dict ( token -> path ) # access_path,remap : dict ( path -> token ) - # tm_path_slave : List of TM root directories, as tokens seen by the slave. + # tm_path_slave : List of TM root directories, as tokens seen by the child. # staticsok : Value of option -statics # nestedok : Value of option -nested # cleanupHook : Value of option -deleteHook diff --git a/tests/ioCmd.test b/tests/ioCmd.test index 8d961ae..898d076 100644 --- a/tests/ioCmd.test +++ b/tests/ioCmd.test @@ -2109,13 +2109,13 @@ test iocmd-32.2 {delete interp of reflected chan} { # Bug 3034840 # Run this test in an interp with memory debugging to panic # on the double free - interp create slave - slave eval { + interp create child + child eval { proc no-op args {} proc driver {sub args} {return {initialize finalize watch read}} chan event [chan create read driver] readable no-op } - interp delete slave + interp delete child } {} # ### ### ### ######### ######### ######### diff --git a/tests/ioTrans.test b/tests/ioTrans.test index 2872fbb..f185117 100644 --- a/tests/ioTrans.test +++ b/tests/ioTrans.test @@ -1244,16 +1244,16 @@ test iortrans-11.1 {origin interpreter of moved transform destroyed during acces tempdone } -result {Owner lost} test iortrans-11.2 {delete interp of reflected transform} -setup { - interp create slave - # Magic to get the test* commands into the slave - load {} Tcltest slave + interp create child + # Magic to get the test* commands into the child + load {} Tcltest child } -constraints {testchannel} -body { - # Get base channel into the slave + # Get base channel into the child set c [tempchan] testchannel cut $c - interp eval slave [list testchannel splice $c] - interp eval slave [list set c $c] - slave eval { + interp eval child [list testchannel splice $c] + interp eval child [list set c $c] + child eval { proc no-op args {} proc driver {c sub args} { return {initialize finalize read write} @@ -1261,7 +1261,7 @@ test iortrans-11.2 {delete interp of reflected transform} -setup { set t [chan push $c [list driver $c]] chan event $c readable no-op } - interp delete slave + interp delete child } -cleanup { tempdone } -result {} diff --git a/tests/oo.test b/tests/oo.test index 94537b7..43aa608 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -1370,16 +1370,16 @@ test oo-7.8 {OO: next at the end of the method chain} -setup { } -result {foo2 foo 1 {no next method implementation}} test oo-7.9 {OO: defining inheritance in namespaces} -setup { set ::result {} - oo::class create ::master + oo::class create ::parent namespace eval ::foo { - oo::class create mixin {superclass ::master} + oo::class create mixin {superclass ::parent} } } -cleanup { - ::master destroy + ::parent destroy namespace delete ::foo } -body { namespace eval ::foo { - oo::class create bar {superclass master} + oo::class create bar {superclass parent} oo::class create boo oo::define boo {superclass bar} oo::define boo {mixin mixin} @@ -2066,18 +2066,18 @@ test oo-14.5 {OO and mixins and filters - advanced case} -setup { mix destroy } -result >>foobar<< test oo-14.6 {OO and mixins of mixins - Bug 1960703} -setup { - oo::class create master + oo::class create parent } -cleanup { - master destroy + parent destroy } -body { oo::class create A { - superclass master + superclass parent method egg {} { return chicken } } oo::class create B { - superclass master + superclass parent mixin A method bar {} { # mixin from A @@ -2085,7 +2085,7 @@ test oo-14.6 {OO and mixins of mixins - Bug 1960703} -setup { } } oo::class create C { - superclass master + superclass parent mixin B method foo {} { # mixin from B @@ -2095,12 +2095,12 @@ test oo-14.6 {OO and mixins of mixins - Bug 1960703} -setup { [C new] foo } -result chicken test oo-14.7 {OO and filters from mixins of mixins} -setup { - oo::class create master + oo::class create parent } -cleanup { - master destroy + parent destroy } -body { oo::class create A { - superclass master + superclass parent method egg {} { return chicken } @@ -2111,7 +2111,7 @@ test oo-14.7 {OO and filters from mixins of mixins} -setup { } } oo::class create B { - superclass master + superclass parent mixin A filter f method bar {} { @@ -2120,7 +2120,7 @@ test oo-14.7 {OO and filters from mixins of mixins} -setup { } } oo::class create C { - superclass master + superclass parent mixin B filter f method foo {} { @@ -2132,18 +2132,18 @@ test oo-14.7 {OO and filters from mixins of mixins} -setup { } -result {(foo) (bar) (egg) chicken (egg) (bar) (foo)} test oo-14.8 {OO: class mixin order - Bug 1998221} -setup { set ::result {} - oo::class create master { + oo::class create parent { method test {} {} } } -cleanup { - master destroy + parent destroy } -body { oo::class create mix { - superclass master + superclass parent method test {} {lappend ::result mix; next; return $::result} } oo::class create cls { - superclass master + superclass parent mixin mix method test {} {lappend ::result cls; next; return $::result} } @@ -2778,13 +2778,13 @@ test oo-18.7 {OO: objdefine command support} -setup { invoked from within "oo::objdefine inst {rename ::inst ::INST;error foo}"}} test oo-18.8 {OO: define/self command support} -setup { - oo::class create master - oo::class create ::foo {superclass master} + oo::class create parent + oo::class create ::foo {superclass parent} } -body { catch {oo::define foo {rename ::foo ::bar; self {error foobar}}} msg opt dict get $opt -errorinfo } -cleanup { - master destroy + parent destroy } -result {foobar while executing "error foobar" @@ -2795,15 +2795,15 @@ test oo-18.8 {OO: define/self command support} -setup { invoked from within "oo::define foo {rename ::foo ::bar; self {error foobar}}"} test oo-18.9 {OO: define/self command support} -setup { - oo::class create master + oo::class create parent set c [oo::class create now_this_is_a_very_very_long_class_name_indeed { - superclass master + superclass parent }] } -body { catch {oo::define $c {error err}} msg opt dict get $opt -errorinfo } -cleanup { - master destroy + parent destroy } -result {err while executing "error err" @@ -2811,13 +2811,13 @@ test oo-18.9 {OO: define/self command support} -setup { invoked from within "oo::define $c {error err}"} test oo-18.10 {OO: define/self command support} -setup { - oo::class create master - oo::class create ::foo {superclass master} + oo::class create parent + oo::class create ::foo {superclass parent} } -body { catch {oo::define foo {self {rename ::foo {}; error foobar}}} msg opt dict get $opt -errorinfo } -cleanup { - master destroy + parent destroy } -result {foobar while executing "error foobar" @@ -2828,13 +2828,13 @@ test oo-18.10 {OO: define/self command support} -setup { invoked from within "oo::define foo {self {rename ::foo {}; error foobar}}"} test oo-18.11 {OO: define/self command support} -setup { - oo::class create master - oo::class create ::foo {superclass master} + oo::class create parent + oo::class create ::foo {superclass parent} } -body { catch {oo::define foo {rename ::foo {}; self {error foobar}}} msg opt dict get $opt -errorinfo } -cleanup { - master destroy + parent destroy } -result {this command cannot be called when the object has been deleted while executing "self {error foobar}" @@ -3457,12 +3457,12 @@ test oo-27.2 {variables declaration - object introspection} -setup { info object variables foo } -result {a b c} test oo-27.3 {variables declaration - basic behaviour} -setup { - oo::class create master + oo::class create parent } -cleanup { - master destroy + parent destroy } -body { oo::class create foo { - superclass master + superclass parent variable x! constructor {} {set x! 1} method y {} {incr x!} @@ -3472,13 +3472,13 @@ test oo-27.3 {variables declaration - basic behaviour} -setup { bar y } -result 3 test oo-27.4 {variables declaration - destructors too} -setup { - oo::class create master + oo::class create parent set result bad! } -cleanup { - master destroy + parent destroy } -body { oo::class create foo { - superclass master + superclass parent variable x! constructor {} {set x! 1} method y {} {incr x!} @@ -3503,12 +3503,12 @@ test oo-27.5 {variables declaration - object-bound variables} -setup { foo y } -result 2 test oo-27.6 {variables declaration - non-interference of levels} -setup { - oo::class create master + oo::class create parent } -cleanup { - master destroy + parent destroy } -body { oo::class create foo { - superclass master + superclass parent variable x! constructor {} {set x! 1} method y {} {incr x!} @@ -3523,12 +3523,12 @@ test oo-27.6 {variables declaration - non-interference of levels} -setup { list [bar y] [lsort [info object vars bar]] [bar eval {info vars *!}] } -result {{3 2 y! {}} {x! y!} {x! y!}} test oo-27.7 {variables declaration - one underlying variable space} -setup { - oo::class create master + oo::class create parent } -cleanup { - master destroy + parent destroy } -body { oo::class create foo { - superclass master + superclass parent variable x! constructor {} {set x! 1} method y {} {incr x!} @@ -3555,12 +3555,12 @@ test oo-27.9 {variables declaration - error cases - arrays} -body { oo::define oo::object variable bad(var) } -returnCodes error -result {invalid declared variable name "bad(var)": must not refer to an array element} test oo-27.10 {variables declaration - no instance var leaks with class resolvers} -setup { - oo::class create master + oo::class create parent } -cleanup { - master destroy + parent destroy } -body { oo::class create foo { - superclass master + superclass parent variable clsvar constructor {} { set clsvar 0 @@ -3583,12 +3583,12 @@ test oo-27.10 {variables declaration - no instance var leaks with class resolver list [inst1 value] [inst2 value] } -result {3 2} test oo-27.11 {variables declaration - no instance var leaks with class resolvers} -setup { - oo::class create master + oo::class create parent } -cleanup { - master destroy + parent destroy } -body { oo::class create foo { - superclass master + superclass parent variable clsvar constructor {} { set clsvar 0 @@ -3656,12 +3656,12 @@ test oo-27.13 {variables declaration: Bug 3185009: require refcount management} foo destroy } -result {0 7 1 7 {} 0 1 {can't read "x": no such variable}} test oo-27.14 {variables declaration - multiple use} -setup { - oo::class create master + oo::class create parent } -cleanup { - master destroy + parent destroy } -body { oo::class create foo { - superclass master + superclass parent variable x variable y method boo {} { @@ -3672,12 +3672,12 @@ test oo-27.14 {variables declaration - multiple use} -setup { list [bar boo] [bar boo] } -result {1,1 2,2} test oo-27.15 {variables declaration - multiple use} -setup { - oo::class create master + oo::class create parent } -cleanup { - master destroy + parent destroy } -body { oo::class create foo { - superclass master + superclass parent variable variable x y method boo {} { @@ -3688,12 +3688,12 @@ test oo-27.15 {variables declaration - multiple use} -setup { list [bar boo] [bar boo] } -result {1,1 2,2} test oo-27.16 {variables declaration - multiple use} -setup { - oo::class create master + oo::class create parent } -cleanup { - master destroy + parent destroy } -body { oo::class create foo { - superclass master + superclass parent variable x variable -clear variable y @@ -3705,12 +3705,12 @@ test oo-27.16 {variables declaration - multiple use} -setup { list [bar boo] [bar boo] } -result {1,1 1,2} test oo-27.17 {variables declaration - multiple use} -setup { - oo::class create master + oo::class create parent } -cleanup { - master destroy + parent destroy } -body { oo::class create foo { - superclass master + superclass parent variable x variable -set y method boo {} { @@ -3721,12 +3721,12 @@ test oo-27.17 {variables declaration - multiple use} -setup { list [bar boo] [bar boo] } -result {1,1 1,2} test oo-27.18 {variables declaration - multiple use} -setup { - oo::class create master + oo::class create parent } -cleanup { - master destroy + parent destroy } -body { oo::class create foo { - superclass master + superclass parent variable x variable -? y method boo {} { @@ -3824,12 +3824,12 @@ test oo-27.22 {variables declaration uniqueifies: Bug 3396896} -setup { } -result {v t} test oo-27.23 {variable resolver leakage: Bug 1493a43044} -setup { oo::class create Super - oo::class create Master { + oo::class create parent { superclass Super variable member1 member2 constructor {} { - set member1 master1 - set member2 master2 + set member1 parent1 + set member2 parent2 } method getChild {} { Child new [self] @@ -3850,10 +3850,10 @@ test oo-27.23 {variable resolver leakage: Bug 1493a43044} -setup { method result {} {return $result} } } -body { - [[Master new] getChild] result + [[parent new] getChild] result } -cleanup { Super destroy -} -result {master1 master2 master1 master2 master1 master2 master1 master2} +} -result {parent1 parent2 parent1 parent2 parent1 parent2 parent1 parent2} # A feature that's not supported because the mechanism may change without # warning, but is supposed to work... diff --git a/tests/ooNext2.test b/tests/ooNext2.test index 84a2bdd..0ec7cdd 100644 --- a/tests/ooNext2.test +++ b/tests/ooNext2.test @@ -882,9 +882,9 @@ test oo-call-3.4 {current call introspection: in destructors} -setup { # caller set testopts { -setup { - oo::class create Master + oo::class create Parent oo::class create Foo { - superclass Master + superclass Parent method bar {} { puts abc tailcall puts hi @@ -892,11 +892,11 @@ set testopts { } } oo::class create Foo2 { - superclass Master + superclass Parent } } -cleanup { - Master destroy + Parent destroy } } diff --git a/tests/safe.test b/tests/safe.test index eb4bfaf..b91da86 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -901,7 +901,7 @@ test safe-9.20 {check module loading} -setup { {TCLLIB TESTSDIR/auto0/modules TESTSDIR/auto0/modules/mod1\ TESTSDIR/auto0/modules/mod2} -- res0 res1 res2} # - The command safe::InterpSetConfig adds the parent's [tcl::tm::list] in -# tokenized form to the slave's access path, and then adds all the +# tokenized form to the child's access path, and then adds all the # descendants, discovered recursively by using glob. # - The order of the directories in the list returned by glob is system-dependent, # and therefore this is true also for (a) the order of token assignment to diff --git a/tests/socket.test b/tests/socket.test index 4f1a198..5198f4f 100644 --- a/tests/socket.test +++ b/tests/socket.test @@ -1838,12 +1838,12 @@ proc transf_test {{testmode transfer} {maxIter 1000} {maxTime 10000}} { } } tcltest::DebugPuts 1 "== test \[$::localhost\]:$port $testmode ==" - set ::master [thread::id] - # helper thread creating async connection and initiating transfer (detach) to master: + set ::parent [thread::id] + # helper thread creating async connection and initiating transfer (detach) to parent: set ::helper [thread::create] thread::send -async $::helper [list \ - lassign [list $::master $::localhost $port $testmode] \ - ::master ::localhost ::port ::testmode + lassign [list $::parent $::localhost $port $testmode] \ + ::parent ::localhost ::port ::testmode ] thread::send -async $::helper { set ::helper [thread::id] @@ -1852,29 +1852,29 @@ proc transf_test {{testmode transfer} {maxIter 1000} {maxTime 10000}} { if {"helper-writable" in $::testmode} {;# to test both sides during connect fileevent $fd writable [list apply {{fd} { if {[thread::id] ne $::helper} { - thread::send -async $::master {set ::count "ERROR: invalid thread, $::helper is expecting"} + thread::send -async $::parent {set ::count "ERROR: invalid thread, $::helper is expecting"} close $fd return } }} $fd] };# thread::detach $fd - thread::send -async $::master [list transf_master $fd {*}$args] + thread::send -async $::parent [list transf_parent $fd {*}$args] } iteration first } - # master proc commiting transfer attempt (attach) and checking acquire was successful: - proc transf_master {fd args} { + # parent proc commiting transfer attempt (attach) and checking acquire was successful: + proc transf_parent {fd args} { tcltest::DebugPuts 1 "** trma / $::count ** $args **" thread::attach $fd - if {"master-close" in $::testmode} {;# to test close during connect + if {"parent-close" in $::testmode} {;# to test close during connect set ::count $::count close $fd return };# fileevent $fd writable [list apply {{fd} { - if {[thread::id] ne $::master} { - thread::send -async $::master {set ::count "ERROR: invalid thread, $::master is expecting"} + if {[thread::id] ne $::parent} { + thread::send -async $::parent {set ::count "ERROR: invalid thread, $::parent is expecting"} close $fd return } @@ -1902,7 +1902,7 @@ proc transf_test {{testmode transfer} {maxIter 1000} {maxTime 10000}} { if {$srvsock ne {}} {close $srvsock} if {[info exists ::helper]} {thread::release -wait $::helper} tcltest::DebugPuts 1 "== stop / $::count ==" - unset -nocomplain ::count ::testmode ::master ::helper + unset -nocomplain ::count ::testmode ::parent ::helper } } test socket_$af-13.2.tr1 {Testing socket transfer between threads during async connect} -body { @@ -1912,12 +1912,12 @@ test socket_$af-13.2.tr2 {Testing socket transfer between threads during async c transf_test {transfer helper-writable} 100 } -result 100 -constraints [list socket supported_$af thread] test socket_$af-13.2.cl1 {Testing socket transfer between threads during async connect} -body { - transf_test {master-close} 100 + transf_test {parent-close} 100 } -result 100 -constraints [list socket supported_$af thread] test socket_$af-13.2.cl2 {Testing socket transfer between threads during async connect} -body { - transf_test {master-close helper-writable} 100 + transf_test {parent-close helper-writable} 100 } -result 100 -constraints [list socket supported_$af thread] -catch {rename transf_master {}} +catch {rename transf_parent {}} rename transf_test {} # ---------------------------------------------------------------------- -- cgit v0.12 From a7f1b76ad23c4ab5075e330f0034ecfe928fc006 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 7 Sep 2020 11:56:51 +0000 Subject: Backport genStubs.tcl from 8.7. This adds support for MP_WUR, not actually used by Tcl. But could be used in (libtommath-related) extensions --- tools/genStubs.tcl | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/tools/genStubs.tcl b/tools/genStubs.tcl index 4516010..a4a73ba 100644 --- a/tools/genStubs.tcl +++ b/tools/genStubs.tcl @@ -479,6 +479,8 @@ proc genStubs::makeDecl {name decl index} { if {[info exists stubs($name,deprecated,$index)]} { append text "[string toupper $libraryName]_DEPRECATED(\"$stubs($name,deprecated,$index)\")\n" set line "$rtype" + } elseif {[string range $rtype end-5 end] eq "MP_WUR"} { + set line "$scspec [string trim [string range $rtype 0 end-6]]" } else { set line "$scspec $rtype" } @@ -550,6 +552,9 @@ proc genStubs::makeDecl {name decl index} { append line ")" } } + if {[string range $rtype end-5 end] eq "MP_WUR"} { + append line " MP_WUR" + } return "$text$line;\n" } @@ -613,6 +618,8 @@ proc genStubs::makeSlot {name decl index} { append text [string trim [string range $rtype 0 end-9]] " (__stdcall *" $lfname ") " } elseif {[string range $rtype 0 11] eq "TCL_NORETURN"} { append text "TCL_NORETURN1 " [string trim [string range $rtype 12 end]] " (*" $lfname ") " + } elseif {[string range $rtype end-5 end] eq "MP_WUR"} { + append text [string trim [string range $rtype 0 end-6]] " (*" $lfname ") " } else { append text $rtype " (*" $lfname ") " } @@ -650,6 +657,9 @@ proc genStubs::makeSlot {name decl index} { } } + if {[string range $rtype end-5 end] eq "MP_WUR"} { + append text " MP_WUR" + } append text "; /* $index */\n" return $text } -- cgit v0.12 From 60fde1d90fb5711ebedac2d1429649235c62c844 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 7 Sep 2020 15:11:19 +0000 Subject: Fix "make install" on MacOSX: interp: make-manpage-section: ignoring .VS "TIP 581" after .TP --- doc/interp.n | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/interp.n b/doc/interp.n index 61aa151..f0a6c5e 100644 --- a/doc/interp.n +++ b/doc/interp.n @@ -376,8 +376,8 @@ interpreter is destroyed. Returns a Tcl list of the names of all the child interpreters associated with the interpreter identified by \fIpath\fR. If \fIpath\fR is omitted, the invoking interpreter is used. -.TP .VS "TIP 581" +.TP \fBinterp\fR \fBchildren\fR ?\fIpath\fR? . Synonym for . \fBinterp\fR \fBslaves\fR ?\fIpath\fR? -- cgit v0.12 From f4d0f6366c3f05177907320d459e4df57a3bbe04 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 9 Sep 2020 06:37:45 +0000 Subject: Rename safe-stock86.test to safe-stock.test --- tests/safe-stock.test | 109 +++++++++++++++++++++++++++++++++++++++++++++ tests/safe-stock86.test | 114 ------------------------------------------------ 2 files changed, 109 insertions(+), 114 deletions(-) create mode 100644 tests/safe-stock.test delete mode 100644 tests/safe-stock86.test diff --git a/tests/safe-stock.test b/tests/safe-stock.test new file mode 100644 index 0000000..7be483e --- /dev/null +++ b/tests/safe-stock.test @@ -0,0 +1,109 @@ +# safe-stock.test -- +# +# This file contains tests for safe Tcl that were previously in the file +# safe.test, and use files and packages of stock Tcl 8.6 to perform the tests. +# These files may be changed or disappear in future revisions of Tcl, +# for example package http 1.0 will be removed from Tcl 8.7. +# +# The tests are replaced in safe.tcl with tests that use files provided in the +# tests directory. Test numbering is for comparison with similar tests in +# safe.test. +# +# Sourcing this file into tcl runs the tests and generates output for errors. +# No output means no errors were found. +# +# Copyright (c) 1995-1996 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# +# See the file "license.terms" for information on usage and redistribution of +# this file, and for a DISCLAIMER OF ALL WARRANTIES. + +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} + +foreach i [interp children] { + interp delete $i +} + +set SaveAutoPath $::auto_path +set ::auto_path [info library] +set TestsDir [file normalize [file dirname [info script]]] +set PathMapp [list $tcl_library TCLLIB $TestsDir TESTSDIR] + +proc mapList {map listIn} { + set listOut {} + foreach element $listIn { + lappend listOut [string map $map $element] + } + return $listOut +} + +# Force actual loading of the safe package because we use un-exported (and +# thus un-autoindexed) APIs in this test result arguments: +catch {safe::interpConfigure} + +# high level general test +test safe-stock-7.1 {tests that everything works at high level, uses http 2} -body { + set i [safe::interpCreate] + # no error shall occur: + # (because the default access_path shall include 1st level sub dirs so + # package require in a child works like in the parent) + set v [interp eval $i {package require http 2}] + # no error shall occur: + interp eval $i {http::config} + safe::interpDelete $i + set v +} -match glob -result 2.* +test safe-stock-7.2 {tests specific path and interpFind/AddToAccessPath, uses http1.0} -body { + set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]] + # should not add anything (p0) + set token1 [safe::interpAddToAccessPath $i [info library]] + # should add as p1 + set token2 [safe::interpAddToAccessPath $i "/dummy/unixlike/test/path"] + set confA [safe::interpConfigure $i] + set mappA [mapList $PathMapp [dict get $confA -accessPath]] + # an error shall occur (http is not anymore in the secure 0-level + # provided deep path) + list $token1 $token2 -- \ + [catch {interp eval $i {package require http 1}} msg] $msg -- \ + $mappA -- [safe::interpDelete $i] +} -match glob -result {{$p(:0:)} {$p(:*:)} -- 1 {can't find package http 1} --\ + {TCLLIB */dummy/unixlike/test/path} -- {}} +test safe-stock-7.4 {tests specific path and positive search, uses http1.0} -body { + set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]] + # should not add anything (p0) + set token1 [safe::interpAddToAccessPath $i [info library]] + # should add as p1 + set token2 [safe::interpAddToAccessPath $i [file join [info library] http1.0]] + set confA [safe::interpConfigure $i] + set mappA [mapList $PathMapp [dict get $confA -accessPath]] + # this time, unlike test safe-stock-7.2, http should be found + list $token1 $token2 -- \ + [catch {interp eval $i {package require http 1}} msg] $msg -- \ + $mappA -- [safe::interpDelete $i] +} -match glob -result {{$p(:0:)} {$p(:*:)} -- 0 1.0 -- {TCLLIB *TCLLIB/http1.0} -- {}} + +# The following test checks whether the definition of tcl_endOfWord can be +# obtained from auto_loading. It was previously test "safe-5.1". +test safe-stock-9.8 {test auto-loading in safe interpreters, was test 5.1} -setup { + catch {safe::interpDelete a} + safe::interpCreate a +} -body { + interp eval a {tcl_endOfWord "" 0} +} -cleanup { + safe::interpDelete a +} -result -1 + +set ::auto_path $SaveAutoPath +unset SaveAutoPath TestsDir PathMapp +rename mapList {} + +# cleanup +::tcltest::cleanupTests +return + +# Local Variables: +# mode: tcl +# End: diff --git a/tests/safe-stock86.test b/tests/safe-stock86.test deleted file mode 100644 index 402ea31..0000000 --- a/tests/safe-stock86.test +++ /dev/null @@ -1,114 +0,0 @@ -# safe-stock86.test -- -# -# This file contains tests for safe Tcl that were previously in the file -# safe.test, and use files and packages of stock Tcl 8.6 to perform the tests. -# These files may be changed or disappear in future revisions of Tcl, -# for example package http 1.0 will be removed from Tcl 8.7. -# -# The tests are replaced in safe.tcl with tests that use files provided in the -# tests directory. Test numbering is for comparison with similar tests in -# safe.test. -# -# Sourcing this file into tcl runs the tests and generates output for errors. -# No output means no errors were found. -# -# Copyright (c) 1995-1996 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. -# -# See the file "license.terms" for information on usage and redistribution of -# this file, and for a DISCLAIMER OF ALL WARRANTIES. - -if {"::tcltest" ni [namespace children]} { - package require tcltest 2.5 - namespace import -force ::tcltest::* -} - -foreach i [interp children] { - interp delete $i -} - -set SaveAutoPath $::auto_path -set ::auto_path [info library] -set TestsDir [file normalize [file dirname [info script]]] -set PathMapp [list $tcl_library TCLLIB $TestsDir TESTSDIR] - -proc mapList {map listIn} { - set listOut {} - foreach element $listIn { - lappend listOut [string map $map $element] - } - return $listOut -} - -# Force actual loading of the safe package because we use un-exported (and -# thus un-autoindexed) APIs in this test result arguments: -catch {safe::interpConfigure} - -# testing that nested and statics do what is advertised (we use a static -# package - Tcltest - but it might be absent if we're in standard tclsh) - -testConstraint TcltestPackage [expr {![catch {package require Tcltest}]}] - -# high level general test -test safe-stock86-7.1 {tests that everything works at high level, uses http 2} -body { - set i [safe::interpCreate] - # no error shall occur: - # (because the default access_path shall include 1st level sub dirs so - # package require in a child works like in the parent) - set v [interp eval $i {package require http 2}] - # no error shall occur: - interp eval $i {http::config} - safe::interpDelete $i - set v -} -match glob -result 2.* -test safe-stock86-7.2 {tests specific path and interpFind/AddToAccessPath, uses http1.0} -body { - set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]] - # should not add anything (p0) - set token1 [safe::interpAddToAccessPath $i [info library]] - # should add as p1 - set token2 [safe::interpAddToAccessPath $i "/dummy/unixlike/test/path"] - set confA [safe::interpConfigure $i] - set mappA [mapList $PathMapp [dict get $confA -accessPath]] - # an error shall occur (http is not anymore in the secure 0-level - # provided deep path) - list $token1 $token2 -- \ - [catch {interp eval $i {package require http 1}} msg] $msg -- \ - $mappA -- [safe::interpDelete $i] -} -match glob -result {{$p(:0:)} {$p(:*:)} -- 1 {can't find package http 1} --\ - {TCLLIB */dummy/unixlike/test/path} -- {}} -test safe-stock86-7.4 {tests specific path and positive search, uses http1.0} -body { - set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]] - # should not add anything (p0) - set token1 [safe::interpAddToAccessPath $i [info library]] - # should add as p1 - set token2 [safe::interpAddToAccessPath $i [file join [info library] http1.0]] - set confA [safe::interpConfigure $i] - set mappA [mapList $PathMapp [dict get $confA -accessPath]] - # this time, unlike test safe-stock86-7.2, http should be found - list $token1 $token2 -- \ - [catch {interp eval $i {package require http 1}} msg] $msg -- \ - $mappA -- [safe::interpDelete $i] -} -match glob -result {{$p(:0:)} {$p(:*:)} -- 0 1.0 -- {TCLLIB *TCLLIB/http1.0} -- {}} - -# The following test checks whether the definition of tcl_endOfWord can be -# obtained from auto_loading. It was previously test "safe-5.1". -test safe-stock86-9.8 {test auto-loading in safe interpreters, was test 5.1} -setup { - catch {safe::interpDelete a} - safe::interpCreate a -} -body { - interp eval a {tcl_endOfWord "" 0} -} -cleanup { - safe::interpDelete a -} -result -1 - -set ::auto_path $SaveAutoPath -unset SaveAutoPath TestsDir PathMapp -rename mapList {} - -# cleanup -::tcltest::cleanupTests -return - -# Local Variables: -# mode: tcl -# End: -- cgit v0.12 From 2592b1e93b713440a2fab51b01df4ad31bb21f7d Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 10 Sep 2020 10:28:46 +0000 Subject: Don't use sizeof() for structs containing a flexible array as last element. Lesson from [https://core.tcl-lang.org/tk/info/3bc0f44ef3|3bc0f44ef3]. Use TclOffset in stead. --- generic/tclCompCmds.c | 20 ++++++++++---------- generic/tclEncoding.c | 2 +- generic/tclStringRep.h | 4 ++-- 3 files changed, 13 insertions(+), 13 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 607521d..c8970ce 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -403,9 +403,9 @@ TclCompileArraySetCmd( keyVar = AnonymousLocal(envPtr); valVar = AnonymousLocal(envPtr); - infoPtr = ckalloc(sizeof(ForeachInfo)); + infoPtr = ckalloc(TclOffset(ForeachInfo, varLists) + sizeof(ForeachVarList *)); infoPtr->numLists = 1; - infoPtr->varLists[0] = ckalloc(sizeof(ForeachVarList) + sizeof(int)); + infoPtr->varLists[0] = ckalloc(TclOffset(ForeachVarList, varIndexes) + 2 * sizeof(int)); infoPtr->varLists[0]->numVars = 2; infoPtr->varLists[0]->varIndexes[0] = keyVar; infoPtr->varLists[0]->varIndexes[1] = valVar; @@ -1776,7 +1776,7 @@ TclCompileDictUpdateCmd( * that are to be used. */ - duiPtr = ckalloc(sizeof(DictUpdateInfo) + sizeof(int) * (numVars - 1)); + duiPtr = ckalloc(TclOffset(DictUpdateInfo, varIndices) + sizeof(int) * numVars); duiPtr->length = numVars; keyTokenPtrs = TclStackAlloc(interp, sizeof(Tcl_Token *) * numVars); tokenPtr = TokenAfter(dictVarTokenPtr); @@ -2258,7 +2258,7 @@ DupDictUpdateInfo( unsigned len; dui1Ptr = clientData; - len = sizeof(DictUpdateInfo) + sizeof(int) * (dui1Ptr->length - 1); + len = TclOffset(DictUpdateInfo, varIndices) + sizeof(int) * dui1Ptr->length; dui2Ptr = ckalloc(len); memcpy(dui2Ptr, dui1Ptr, len); return dui2Ptr; @@ -2712,8 +2712,8 @@ CompileEachloopCmd( */ numLists = (numWords - 2)/2; - infoPtr = ckalloc(sizeof(ForeachInfo) - + (numLists - 1) * sizeof(ForeachVarList *)); + infoPtr = ckalloc(TclOffset(ForeachInfo, varLists) + + numLists * sizeof(ForeachVarList *)); infoPtr->numLists = 0; /* Count this up as we go */ /* @@ -2746,8 +2746,8 @@ CompileEachloopCmd( goto done; } - varListPtr = ckalloc(sizeof(ForeachVarList) - + (numVars - 1) * sizeof(int)); + varListPtr = ckalloc(TclOffset(ForeachVarList, varIndexes) + + numVars * sizeof(int)); varListPtr->numVars = numVars; infoPtr->varLists[i/2] = varListPtr; infoPtr->numLists++; @@ -2882,7 +2882,7 @@ DupForeachInfo( ForeachVarList *srcListPtr, *dupListPtr; int numVars, i, j, numLists = srcPtr->numLists; - dupPtr = ckalloc(sizeof(ForeachInfo) + dupPtr = ckalloc(TclOffset(ForeachInfo, varLists) + numLists * sizeof(ForeachVarList *)); dupPtr->numLists = numLists; dupPtr->firstValueTemp = srcPtr->firstValueTemp; @@ -2891,7 +2891,7 @@ DupForeachInfo( for (i = 0; i < numLists; i++) { srcListPtr = srcPtr->varLists[i]; numVars = srcListPtr->numVars; - dupListPtr = ckalloc(sizeof(ForeachVarList) + dupListPtr = ckalloc(TclOffset(ForeachVarList, varIndexes) + numVars * sizeof(int)); dupListPtr->numVars = numVars; for (j = 0; j < numVars; j++) { diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index 5c7aab8..6377ad8 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -2039,7 +2039,7 @@ LoadEscapeEncoding( Tcl_DStringFree(&lineString); } - size = sizeof(EscapeEncodingData) - sizeof(EscapeSubTable) + size = TclOffset(EscapeEncodingData, subTables) + Tcl_DStringLength(&escapeData); dataPtr = (EscapeEncodingData *)ckalloc(size); dataPtr->initLen = strlen(init); diff --git a/generic/tclStringRep.h b/generic/tclStringRep.h index 227e6bc..6d179ba 100644 --- a/generic/tclStringRep.h +++ b/generic/tclStringRep.h @@ -65,9 +65,9 @@ typedef struct String { } String; #define STRING_MAXCHARS \ - (int)(((size_t)UINT_MAX - sizeof(String))/sizeof(Tcl_UniChar)) + (int)(((size_t)UINT_MAX - 1 - TclOffset(String, unicode))/sizeof(Tcl_UniChar)) #define STRING_SIZE(numChars) \ - (sizeof(String) + ((numChars) * sizeof(Tcl_UniChar))) + (TclOffset(String, unicode) + ((numChars + 1) * sizeof(Tcl_UniChar))) #define stringCheckLimits(numChars) \ do { \ if ((numChars) < 0 || (numChars) > STRING_MAXCHARS) { \ -- cgit v0.12 From 0715d88019e40aa514b3b2d3ba691ab7d0a96eb2 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 11 Sep 2020 08:09:20 +0000 Subject: Use $index<0 in stead of $index==-1 consistantly --- library/http/http.tcl | 2 +- library/init.tcl | 4 ++-- library/safe.tcl | 2 +- library/tcltest/tcltest.tcl | 6 +++--- 4 files changed, 7 insertions(+), 7 deletions(-) diff --git a/library/http/http.tcl b/library/http/http.tcl index 9d3e5ca..6ca3bad 100644 --- a/library/http/http.tcl +++ b/library/http/http.tcl @@ -531,7 +531,7 @@ proc http::CloseSocket {s {token {}}} { } else { set map [array get socketMapping] set ndx [lsearch -exact $map $s] - if {$ndx != -1} { + if {$ndx >= 0} { incr ndx -1 set connId [lindex $map $ndx] } diff --git a/library/init.tcl b/library/init.tcl index e6964e0..1028b9e 100644 --- a/library/init.tcl +++ b/library/init.tcl @@ -313,7 +313,7 @@ proc unknown args { set errInfo [string range $errInfo 0 $last-1] set tail "\"$cinfo\"" set last [string last $tail $errInfo] - if {$last + [string length $tail] != [string length $errInfo]} { + if {$last < 0 || $last + [string length $tail] != [string length $errInfo]} { return -code error -errorcode $errCode \ -errorinfo $errInfo $msg } @@ -797,7 +797,7 @@ proc tcl::CopyDirectory {action src dest} { } } } else { - if {[string first $nsrc $ndest] != -1} { + if {[string first $nsrc $ndest] >= 0} { set srclen [expr {[llength [file split $nsrc]] - 1}] set ndest [lindex [file split $ndest] $srclen] if {$ndest eq [file tail $nsrc]} { diff --git a/library/safe.tcl b/library/safe.tcl index 48cb0de..5e04453 100644 --- a/library/safe.tcl +++ b/library/safe.tcl @@ -318,7 +318,7 @@ proc ::safe::InterpSetConfig {child access_path staticsok nestedok deletehook} { # Make sure that tcl_library is in auto_path and at the first # position (needed by setAccessPath) set where [lsearch -exact $access_path [info library]] - if {$where == -1} { + if {$where < 0} { # not found, add it. set access_path [linsert $access_path 0 [info library]] Log $child "tcl_library was not in auto_path,\ diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl index c894ff1..2af79bc 100644 --- a/library/tcltest/tcltest.tcl +++ b/library/tcltest/tcltest.tcl @@ -640,7 +640,7 @@ namespace eval tcltest { proc IsVerbose {level} { variable Option - return [expr {[lsearch -exact $Option(-verbose) $level] != -1}] + return [expr {[lsearch -exact $Option(-verbose) $level] >= 0}] } # Default verbosity is to show bodies of failed tests @@ -3107,7 +3107,7 @@ proc tcltest::removeFile {name {directory ""}} { set fullName [file join $directory $name] DebugPuts 3 "[lindex [info level 0] 0]: removing $fullName" set idx [lsearch -exact $filesMade $fullName] - if {$idx == -1} { + if {$idx < 0} { DebugDo 1 { Warn "removeFile removing \"$fullName\":\n not created by makeFile" } @@ -3184,7 +3184,7 @@ proc tcltest::removeDirectory {name {directory ""}} { DebugPuts 3 "[lindex [info level 0] 0]: deleting $fullName" set idx [lsearch -exact $filesMade $fullName] set filesMade [lreplace $filesMade $idx $idx] - if {$idx == -1} { + if {$idx < 0} { DebugDo 1 { Warn "removeDirectory removing \"$fullName\":\n not created\ by makeDirectory" -- cgit v0.12 From 7f62b768876fc8b0779d10ae3fcba1fc7aeaba04 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 11 Sep 2020 12:31:48 +0000 Subject: Fix [https://core.tcl-lang.org/tk/tktview?name=3bc0f44ef3|3bc0f44ef3]: UBSan complains about body.chars[] usage. (Yes, I know, this one is for Tk, but Tcl was using the same construct too ....) --- generic/tclBinary.c | 10 ++++----- generic/tclCompile.h | 6 +++--- generic/tclEncoding.c | 2 +- generic/tclIO.h | 2 +- generic/tclInt.h | 10 +++++++-- generic/tclObj.c | 56 +++++++++++++++++++++++++------------------------- generic/tclProc.c | 10 ++++----- generic/tclStringRep.h | 2 +- 8 files changed, 52 insertions(+), 46 deletions(-) diff --git a/generic/tclBinary.c b/generic/tclBinary.c index f66aff7..78cdd42 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -199,7 +199,7 @@ typedef struct ByteArray { * array. */ int allocated; /* The amount of space actually allocated * minus 1 byte. */ - unsigned char bytes[1]; /* The array of bytes. The actual size of this + unsigned char bytes[TCLFLEXARRAY]; /* The array of bytes. The actual size of this * field depends on the 'allocated' field * above. */ } ByteArray; @@ -334,7 +334,7 @@ Tcl_SetByteArrayObj( if (length < 0) { length = 0; } - byteArrayPtr = ckalloc(BYTEARRAY_SIZE(length)); + byteArrayPtr = (ByteArray *)ckalloc(BYTEARRAY_SIZE(length)); byteArrayPtr->used = length; byteArrayPtr->allocated = length; @@ -460,7 +460,7 @@ SetByteArrayFromAny( src = TclGetStringFromObj(objPtr, &length); srcEnd = src + length; - byteArrayPtr = ckalloc(BYTEARRAY_SIZE(length)); + byteArrayPtr = (ByteArray *)ckalloc(BYTEARRAY_SIZE(length)); for (dst = byteArrayPtr->bytes; src < srcEnd; ) { src += TclUtfToUniChar(src, &ch); *dst++ = UCHAR(ch); @@ -529,7 +529,7 @@ DupByteArrayInternalRep( srcArrayPtr = GET_BYTEARRAY(srcPtr); length = srcArrayPtr->used; - copyArrayPtr = ckalloc(BYTEARRAY_SIZE(length)); + copyArrayPtr = (ByteArray *)ckalloc(BYTEARRAY_SIZE(length)); copyArrayPtr->used = length; copyArrayPtr->allocated = length; memcpy(copyArrayPtr->bytes, srcArrayPtr->bytes, length); @@ -588,7 +588,7 @@ UpdateStringOfByteArray( Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); } - dst = ckalloc(size + 1); + dst = (char *)ckalloc(size + 1); objPtr->bytes = dst; objPtr->length = size; diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 1d657a7..03b4a90 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -966,7 +966,7 @@ typedef struct JumpFixupArray { typedef struct ForeachVarList { int numVars; /* The number of variables in the list. */ - int varIndexes[1]; /* An array of the indexes ("slot numbers") + int varIndexes[TCLFLEXARRAY];/* An array of the indexes ("slot numbers") * for each variable in the procedure's array * of local variables. Only scalar variables * are supported. The actual size of this @@ -990,7 +990,7 @@ typedef struct ForeachInfo { * the loop's iteration count. Used to * determine next value list element to assign * each loop var. */ - ForeachVarList *varLists[1];/* An array of pointers to ForeachVarList + ForeachVarList *varLists[TCLFLEXARRAY];/* An array of pointers to ForeachVarList * structures describing each var list. The * actual size of this field will be large * enough to numVars indexes. THIS MUST BE THE @@ -1021,7 +1021,7 @@ MODULE_SCOPE const AuxDataType tclJumptableInfoType; typedef struct { int length; /* Size of array */ - int varIndices[1]; /* Array of variable indices to manage when + int varIndices[TCLFLEXARRAY]; /* Array of variable indices to manage when * processing the start and end of a [dict * update]. There is really more than one * entry, and the structure is allocated to diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index 6377ad8..557f241 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -116,7 +116,7 @@ typedef struct { * entry in this array is 1, otherwise it is * 0. */ int numSubTables; /* Length of following array. */ - EscapeSubTable subTables[1];/* Information about each EscapeSubTable used + EscapeSubTable subTables[TCLFLEXARRAY];/* Information about each EscapeSubTable used * by this encoding type. The actual size is * as large as necessary to hold all * EscapeSubTables. */ diff --git a/generic/tclIO.h b/generic/tclIO.h index ffbfa31..eccc7a9 100644 --- a/generic/tclIO.h +++ b/generic/tclIO.h @@ -44,7 +44,7 @@ typedef struct ChannelBuffer { int bufLength; /* How big is the buffer? */ struct ChannelBuffer *nextPtr; /* Next buffer in chain. */ - char buf[1]; /* Placeholder for real buffer. The real + char buf[TCLFLEXARRAY]; /* Placeholder for real buffer. The real * buffer occuppies this space + bufSize-1 * bytes. This must be the last field in the * structure. */ diff --git a/generic/tclInt.h b/generic/tclInt.h index 317ae1f..e145925 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -877,6 +877,12 @@ typedef struct VarInHash { *---------------------------------------------------------------- */ +#if defined(__GNUC__) && (__GNUC__ > 2) +# define TCLFLEXARRAY 0 +#else +# define TCLFLEXARRAY 1 +#endif + /* * Forward declaration to prevent an error when the forward reference to * Command is encountered in the Proc and ImportRef types declared below. @@ -920,7 +926,7 @@ typedef struct CompiledLocal { * is marked by a unique ClientData tag during * compilation, and that same tag is used to * find the variable at runtime. */ - char name[1]; /* Name of the local variable starts here. If + char name[TCLFLEXARRAY]; /* Name of the local variable starts here. If * the name is NULL, this will just be '\0'. * The actual size of this field will be large * enough to hold the name. MUST BE THE LAST @@ -1254,7 +1260,7 @@ typedef struct CFWordBC { typedef struct ContLineLoc { int num; /* Number of entries in loc, not counting the * final -1 marker entry. */ - int loc[1]; /* Table of locations, as character offsets. + int loc[TCLFLEXARRAY];/* Table of locations, as character offsets. * The table is allocated as part of the * structure, extending behind the nominal end * of the structure. An entry containing the diff --git a/generic/tclObj.c b/generic/tclObj.c index 28fb3da..a2544ad 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -145,12 +145,12 @@ typedef struct PendingObjData { #define ObjDeletionUnlock(contextPtr) ((contextPtr)->deletionCount--) #define ObjDeletePending(contextPtr) ((contextPtr)->deletionCount > 0) #define ObjOnStack(contextPtr) ((contextPtr)->deletionStack != NULL) -#define PushObjToDelete(contextPtr,objPtr) \ +#define PushObjToDelete(contextPtr,objPtr) \ /* The string rep is already invalidated so we can use the bytes value \ * for our pointer chain: push onto the head of the stack. */ \ (objPtr)->bytes = (char *) ((contextPtr)->deletionStack); \ (contextPtr)->deletionStack = (objPtr) -#define PopObjToDelete(contextPtr,objPtrVar) \ +#define PopObjToDelete(contextPtr,objPtrVar) \ (objPtrVar) = (contextPtr)->deletionStack; \ (contextPtr)->deletionStack = (Tcl_Obj *) (objPtrVar)->bytes @@ -168,7 +168,7 @@ static __thread PendingObjData pendingObjData; #else static Tcl_ThreadDataKey pendingObjDataKey; #define ObjInitDeletionContext(contextPtr) \ - PendingObjData *const contextPtr = \ + PendingObjData *const contextPtr = \ Tcl_GetThreadData(&pendingObjDataKey, sizeof(PendingObjData)) #endif @@ -177,27 +177,27 @@ static Tcl_ThreadDataKey pendingObjDataKey; */ #define PACK_BIGNUM(bignum, objPtr) \ - if ((bignum).used > 0x7FFF) { \ - mp_int *temp = (void *) ckalloc((unsigned) sizeof(mp_int)); \ + if ((bignum).used > 0x7FFF) { \ + mp_int *temp = (mp_int *)ckalloc(sizeof(mp_int)); \ *temp = bignum; \ - (objPtr)->internalRep.twoPtrValue.ptr1 = temp; \ - (objPtr)->internalRep.twoPtrValue.ptr2 = INT2PTR(-1); \ - } else { \ + (objPtr)->internalRep.twoPtrValue.ptr1 = temp; \ + (objPtr)->internalRep.twoPtrValue.ptr2 = INT2PTR(-1); \ + } else { \ if ((bignum).alloc > 0x7FFF) { \ mp_shrink(&(bignum)); \ } \ - (objPtr)->internalRep.twoPtrValue.ptr1 = (void *) (bignum).dp; \ - (objPtr)->internalRep.twoPtrValue.ptr2 = INT2PTR( ((bignum).sign << 30) \ - | ((bignum).alloc << 15) | ((bignum).used)); \ + (objPtr)->internalRep.twoPtrValue.ptr1 = (void *)(bignum).dp; \ + (objPtr)->internalRep.twoPtrValue.ptr2 = INT2PTR(((bignum).sign << 30) \ + | ((bignum).alloc << 15) | ((bignum).used)); \ } #define UNPACK_BIGNUM(objPtr, bignum) \ - if ((objPtr)->internalRep.twoPtrValue.ptr2 == INT2PTR(-1)) { \ - (bignum) = *((mp_int *) ((objPtr)->internalRep.twoPtrValue.ptr1)); \ + if ((objPtr)->internalRep.twoPtrValue.ptr2 == INT2PTR(-1)) { \ + (bignum) = *((mp_int *) ((objPtr)->internalRep.twoPtrValue.ptr1)); \ } else { \ - (bignum).dp = (objPtr)->internalRep.twoPtrValue.ptr1; \ + (bignum).dp = (objPtr)->internalRep.twoPtrValue.ptr1; \ (bignum).sign = PTR2INT((objPtr)->internalRep.twoPtrValue.ptr2) >> 30; \ - (bignum).alloc = \ + (bignum).alloc = \ (PTR2INT((objPtr)->internalRep.twoPtrValue.ptr2) >> 15) & 0x7FFF; \ (bignum).used = PTR2INT((objPtr)->internalRep.twoPtrValue.ptr2) & 0x7FFF; \ } @@ -541,7 +541,7 @@ TclGetContLineTable(void) ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); if (!tsdPtr->lineCLPtr) { - tsdPtr->lineCLPtr = ckalloc(sizeof(Tcl_HashTable)); + tsdPtr->lineCLPtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable)); Tcl_InitHashTable(tsdPtr->lineCLPtr, TCL_ONE_WORD_KEYS); Tcl_CreateThreadExitHandler(TclThreadFinalizeContLines,NULL); } @@ -576,7 +576,7 @@ TclContinuationsEnter( ThreadSpecificData *tsdPtr = TclGetContLineTable(); Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(tsdPtr->lineCLPtr, objPtr, &newEntry); - ContLineLoc *clLocPtr = ckalloc(sizeof(ContLineLoc) + num*sizeof(int)); + ContLineLoc *clLocPtr = (ContLineLoc *)ckalloc(TclOffset(ContLineLoc, loc) + (num + 1) *sizeof(int)); if (!newEntry) { /* @@ -1079,7 +1079,7 @@ TclDbInitNewObj( ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); if (tsdPtr->objThreadMap == NULL) { - tsdPtr->objThreadMap = ckalloc(sizeof(Tcl_HashTable)); + tsdPtr->objThreadMap = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable)); Tcl_InitHashTable(tsdPtr->objThreadMap, TCL_ONE_WORD_KEYS); } tablePtr = tsdPtr->objThreadMap; @@ -1092,7 +1092,7 @@ TclDbInitNewObj( * Record the debugging information. */ - objData = ckalloc(sizeof(ObjData)); + objData = (ObjData *)ckalloc(sizeof(ObjData)); objData->objPtr = objPtr; objData->file = file; objData->line = line; @@ -1251,7 +1251,7 @@ TclAllocateFreeObjects(void) * Purify apparently can't figure that out, and fires a false alarm. */ - basePtr = ckalloc(bytesToAlloc); + basePtr = (char *)ckalloc(bytesToAlloc); prevPtr = NULL; objPtr = (Tcl_Obj *) basePtr; @@ -2373,7 +2373,7 @@ UpdateStringOfDouble( Tcl_PrintDouble(NULL, objPtr->internalRep.doubleValue, buffer); len = strlen(buffer); - objPtr->bytes = ckalloc(len + 1); + objPtr->bytes = (char *)ckalloc(len + 1); memcpy(objPtr->bytes, buffer, (unsigned) len + 1); objPtr->length = len; } @@ -2573,7 +2573,7 @@ UpdateStringOfInt( len = TclFormatInt(buffer, objPtr->internalRep.longValue); - objPtr->bytes = ckalloc(len + 1); + objPtr->bytes = (char *)ckalloc(len + 1); memcpy(objPtr->bytes, buffer, (unsigned) len + 1); objPtr->length = len; } @@ -2877,7 +2877,7 @@ UpdateStringOfWideInt( sprintf(buffer, "%" TCL_LL_MODIFIER "d", wideVal); len = strlen(buffer); - objPtr->bytes = ckalloc(len + 1); + objPtr->bytes = (char *)ckalloc(len + 1); memcpy(objPtr->bytes, buffer, len + 1); objPtr->length = len; } @@ -3269,7 +3269,7 @@ UpdateStringOfBignum( Tcl_Panic("UpdateStringOfBignum: string length limit exceeded"); } - stringVal = ckalloc(size); + stringVal = (char *)ckalloc(size); status = mp_to_radix(&bignumVal, stringVal, size, NULL, 10); if (status != MP_OKAY) { Tcl_Panic("conversion failure in UpdateStringOfBignum"); @@ -3942,8 +3942,8 @@ AllocObjEntry( Tcl_HashTable *tablePtr, /* Hash table. */ void *keyPtr) /* Key to store in the hash table entry. */ { - Tcl_Obj *objPtr = keyPtr; - Tcl_HashEntry *hPtr = ckalloc(sizeof(Tcl_HashEntry)); + Tcl_Obj *objPtr = (Tcl_Obj *)keyPtr; + Tcl_HashEntry *hPtr = (Tcl_HashEntry *)ckalloc(sizeof(Tcl_HashEntry)); hPtr->key.objPtr = objPtr; Tcl_IncrRefCount(objPtr); @@ -4236,7 +4236,7 @@ TclSetCmdNameObj( } cmdPtr->refCount++; - resPtr = ckalloc(sizeof(ResolvedCmdName)); + resPtr = (ResolvedCmdName *)ckalloc(sizeof(ResolvedCmdName)); resPtr->cmdPtr = cmdPtr; resPtr->cmdEpoch = cmdPtr->cmdEpoch; resPtr->refCount = 1; @@ -4422,7 +4422,7 @@ SetCmdNameFromAny( } } else { TclFreeIntRep(objPtr); - resPtr = ckalloc(sizeof(ResolvedCmdName)); + resPtr = (ResolvedCmdName *)ckalloc(sizeof(ResolvedCmdName)); resPtr->refCount = 1; objPtr->internalRep.twoPtrValue.ptr1 = resPtr; objPtr->internalRep.twoPtrValue.ptr2 = NULL; diff --git a/generic/tclProc.c b/generic/tclProc.c index 4600382..a9134f2 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -600,7 +600,7 @@ TclCreateProc( */ localPtr = (CompiledLocal *)ckalloc( - TclOffset(CompiledLocal, name) + fieldValues[0]->length +1); + TclOffset(CompiledLocal, name) + fieldValues[0]->length + 1); if (procPtr->firstLocalPtr == NULL) { procPtr->firstLocalPtr = procPtr->lastLocalPtr = localPtr; } else { @@ -1305,8 +1305,8 @@ InitLocalCache( * for future calls. */ - localCachePtr = ckalloc(sizeof(LocalCache) - + (localCt - 1) * sizeof(Tcl_Obj *) + localCachePtr = (LocalCache *)ckalloc(TclOffset(LocalCache, varName0) + + localCt * sizeof(Tcl_Obj *) + numArgs * sizeof(Var)); namePtr = &localCachePtr->varName0; @@ -2499,12 +2499,12 @@ SetLambdaFromAny( * location (line of 2nd list element). */ - cfPtr = ckalloc(sizeof(CmdFrame)); + cfPtr = (CmdFrame *)ckalloc(sizeof(CmdFrame)); TclListLines(objPtr, contextPtr->line[1], 2, buf, NULL); cfPtr->level = -1; cfPtr->type = contextPtr->type; - cfPtr->line = ckalloc(sizeof(int)); + cfPtr->line = (int *)ckalloc(sizeof(int)); cfPtr->line[0] = buf[1]; cfPtr->nline = 1; cfPtr->framePtr = NULL; diff --git a/generic/tclStringRep.h b/generic/tclStringRep.h index 6d179ba..25b854e 100644 --- a/generic/tclStringRep.h +++ b/generic/tclStringRep.h @@ -59,7 +59,7 @@ typedef struct String { * space allocated for the unicode array. */ int hasUnicode; /* Boolean determining whether the string has * a Unicode representation. */ - Tcl_UniChar unicode[1]; /* The array of Unicode chars. The actual size + Tcl_UniChar unicode[TCLFLEXARRAY]; /* The array of Unicode chars. The actual size * of this field depends on the 'maxChars' * field above. */ } String; -- cgit v0.12 From 6e44927248852ae0356d9d3e1cfa3d69597a66b1 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 11 Sep 2020 13:43:49 +0000 Subject: Folow-up to previous commit: ExecStack is a FLEXARRAY too --- generic/tclExecute.c | 6 +++--- generic/tclInt.h | 2 +- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index aacf565..4d92468 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -914,8 +914,8 @@ TclCreateExecEnv( * [sizeof(Tcl_Obj*)] */ { ExecEnv *eePtr = ckalloc(sizeof(ExecEnv)); - ExecStack *esPtr = ckalloc(sizeof(ExecStack) - + (size_t) (size-1) * sizeof(Tcl_Obj *)); + ExecStack *esPtr = ckalloc(TclOffset(ExecStack, stackWords) + + size * sizeof(Tcl_Obj *)); eePtr->execStackPtr = esPtr; TclNewBooleanObj(eePtr->constants[0], 0); @@ -1180,7 +1180,7 @@ GrowEvaluationStack( newElems = needed; #endif - newBytes = sizeof(ExecStack) + (newElems-1) * sizeof(Tcl_Obj *); + newBytes = TclOffset(ExecStack, stackWords) + newElems * sizeof(Tcl_Obj *); oldPtr = esPtr; esPtr = ckalloc(newBytes); diff --git a/generic/tclInt.h b/generic/tclInt.h index e145925..fe69b26 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -1409,7 +1409,7 @@ typedef struct ExecStack { Tcl_Obj **markerPtr; Tcl_Obj **endPtr; Tcl_Obj **tosPtr; - Tcl_Obj *stackWords[1]; + Tcl_Obj *stackWords[TCLFLEXARRAY]; } ExecStack; /* -- cgit v0.12 From f0ec68f07293dac2b967d45a3697073b77688970 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 14 Sep 2020 09:22:18 +0000 Subject: Prevent the usage of the term safe/unsafe child. Suggested by Keith Nash. Thanks! More usage of $index<0 in stead of $index==-1 consistantly --- doc/interp.n | 8 ++++---- generic/tclInterp.c | 4 ++-- library/http/http.tcl | 2 +- library/safe.tcl | 4 ++-- tests/chan.test | 2 +- tests/http11.test | 2 +- tests/httpTest.tcl | 12 ++++++------ tests/httpd11.tcl | 2 +- tests/obj.test | 2 +- tests/reg.test | 8 ++++---- tests/socket.test | 2 +- tests/stringObj.test | 4 ++-- tests/thread.test | 4 ++-- tests/unload.test | 4 ++-- tools/mkdepend.tcl | 2 +- tools/uniParse.tcl | 4 ++-- 16 files changed, 33 insertions(+), 33 deletions(-) diff --git a/doc/interp.n b/doc/interp.n index f0a6c5e..bfbf9fd 100644 --- a/doc/interp.n +++ b/doc/interp.n @@ -667,9 +667,9 @@ including itself. .SH "ALIAS INVOCATION" .PP The alias mechanism has been carefully designed so that it can -be used safely when an untrusted script is executing -in a safe child and the target of the alias is a trusted -parent. The most important thing in guaranteeing safety is to +be used safely in an untrusted script which is being executed in a +safe interpreter even if the target of the alias is not a safe +interpreter. The most important thing in guaranteeing safety is to ensure that information passed from the child to the parent is never evaluated or substituted in the parent; if this were to occur, it would enable an evil script in the child to invoke @@ -751,7 +751,7 @@ To help avoid this problem, no substitutions or evaluations are applied to arguments of \fBinterp invokehidden\fR. .PP Safe interpreters are not allowed to invoke hidden commands in themselves -or in their descendants. This prevents safe children from gaining access to +or in their descendants. This prevents them from gaining access to hidden functionality in themselves or their descendants. .PP The set of hidden commands in an interpreter can be manipulated by a trusted diff --git a/generic/tclInterp.c b/generic/tclInterp.c index 80c2534..e1a6d20 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -123,7 +123,7 @@ typedef struct Target { * * NB: the flags field in the interp structure, used with SAFE_INTERP mask * denotes whether the interpreter is safe or not. Safe interpreters have - * restricted functionality, can only create safe child interpreters and can + * restricted functionality, can only create safe interpreters and can * only load safe extensions. */ @@ -3209,7 +3209,7 @@ Tcl_MakeSafe( */ /* - * No env array in a safe child. + * No env array in a safe interpreter. */ Tcl_UnsetVar(interp, "env", TCL_GLOBAL_ONLY); diff --git a/library/http/http.tcl b/library/http/http.tcl index 6ca3bad..cce1828 100644 --- a/library/http/http.tcl +++ b/library/http/http.tcl @@ -2754,7 +2754,7 @@ proc http::Event {sock token} { # scan any list for "close". if {$tmpHeader in {close keep-alive}} { # The common cases, continue. - } elseif {[string first , $tmpHeader] == -1} { + } elseif {[string first , $tmpHeader] < 0} { # Not a comma-separated list, not "close", # therefore "keep-alive". set tmpHeader keep-alive diff --git a/library/safe.tcl b/library/safe.tcl index 5e04453..b9dd18d 100644 --- a/library/safe.tcl +++ b/library/safe.tcl @@ -260,7 +260,7 @@ proc ::safe::interpConfigure {args} { # # safe::InterpCreate : doing the real job # -# This procedure creates a safe child and initializes it with the safe +# This procedure creates a safe interpreter and initializes it with the safe # base aliases. # NB: child name must be simple alphanumeric string, no spaces, no (), no # {},... {because the state array is stored as part of the name} @@ -578,7 +578,7 @@ proc ::safe::AddSubDirs {pathList} { return $res } -# This procedure deletes a safe child managed by Safe Tcl and cleans up +# This procedure deletes a safe interpreter managed by Safe Tcl and cleans up # associated state. # - The command will also delete non-Safe-Base interpreters. # - This is regrettable, but to avoid breaking existing code this should be diff --git a/tests/chan.test b/tests/chan.test index 4efec11..49afdc6 100644 --- a/tests/chan.test +++ b/tests/chan.test @@ -173,7 +173,7 @@ test chan-16.9 {chan command: pending input subcommand} -setup { lappend ::chan-16.9-data $r $l $e $b $i - if {$r != -1 || $e || $l || !$b || $i > 128} { + if {$r >= 0 || $e || $l || !$b || $i > 128} { set data [read $sock $i] lappend ::chan-16.9-data [string range $data 0 2] lappend ::chan-16.9-data [string range $data end-2 end] diff --git a/tests/http11.test b/tests/http11.test index 7ca57f4..f243e56 100644 --- a/tests/http11.test +++ b/tests/http11.test @@ -19,7 +19,7 @@ variable httpd_output proc create_httpd {} { proc httpd_read {chan} { variable httpd_output - if {[gets $chan line] != -1} { + if {[gets $chan line] >= 0} { #puts stderr "read '$line'" set httpd_output $line } diff --git a/tests/httpTest.tcl b/tests/httpTest.tcl index 326b361..6a2226e 100644 --- a/tests/httpTest.tcl +++ b/tests/httpTest.tcl @@ -60,7 +60,7 @@ proc http::Log {args} { variable TestStartTimeInMs set time [expr {[clock milliseconds] - $TestStartTimeInMs}] set txt [list $time {*}$args] - if {[string first ^ $txt] != -1} { + if {[string first ^ $txt] >= 0} { ::httpTest::LogRecord $txt ::httpTest::Puts $txt } elseif {$::httpTest::testOptions(-verbose) > 1} { @@ -82,7 +82,7 @@ proc httpTest::LogRecord {txt} { puts stdout "Fix this call to Log in http-*.tm so it has ^ then\ a letter then a numeral." flush stdout - } elseif {$pos == -1} { + } elseif {$pos < 0} { # Called by mistake. } else { set letter [string index $txt [incr pos]] @@ -149,7 +149,7 @@ proc httpTest::TestOverlaps {someResults n term msg badTrans notPiped} { set myStart [lsearch -exact $someResults [list B $i]] set myEnd [lsearch -exact $someResults [list $term $i]] - if {($myStart == -1 || $myEnd == -1)} { + if {($myStart < 0 || $myEnd < 0)} { set res "Cannot find positions of transaction $i" append msg $res \n Puts $res @@ -370,7 +370,7 @@ proc httpTest::ProcessRetries {someResults n msg skipOverlaps notIncluded notPip variable testOptions set nextRetry [lsearch -glob -index 0 $someResults {[PQR]}] - if {$nextRetry == -1} { + if {$nextRetry < 0} { return [MostAnalysis $someResults $n $msg $skipOverlaps $notIncluded $notPiped] } set badTrans $notIncluded @@ -387,7 +387,7 @@ proc httpTest::ProcessRetries {someResults n msg skipOverlaps notIncluded notPip for {set i 1} {$i <= $n} {incr i} { set first [lsearch -exact $beforeTry [list A $i]] set last [lsearch -exact $beforeTry [list F $i]] - if {$first == -1} { + if {$first < 0} { set res "Transaction $i was not started in connection number $tryCount" # So lappend it to badTrans and don't include it in the call below of MostAnalysis. # append msg $res \n @@ -396,7 +396,7 @@ proc httpTest::ProcessRetries {someResults n msg skipOverlaps notIncluded notPip lappend badTrans $i } else { } - } elseif {$last == -1} { + } elseif {$last < 0} { set res "Transaction $i was started but unfinished in connection number $tryCount" # So lappend it to badTrans and don't include it in the call below of MostAnalysis. # append msg $res \n diff --git a/tests/httpd11.tcl b/tests/httpd11.tcl index 0b02319..89590ec 100644 --- a/tests/httpd11.tcl +++ b/tests/httpd11.tcl @@ -237,7 +237,7 @@ proc Accept {chan addr port} { } proc Control {chan} { - if {[gets $chan line] != -1} { + if {[gets $chan line] >= 0} { if {[string trim $line] eq "quit"} { set ::forever 1 } diff --git a/tests/obj.test b/tests/obj.test index b6b6eb8..e5fec9a 100644 --- a/tests/obj.test +++ b/tests/obj.test @@ -36,7 +36,7 @@ test obj-1.1 {Tcl_AppendAllObjTypes, and InitTypeTable, Tcl_RegisterObjType} tes string } { set first [string first $t [testobj types]] - set r [expr {$r && ($first != -1)}] + set r [expr {$r && ($first >= 0)}] } set result $r } {1} diff --git a/tests/reg.test b/tests/reg.test index 02677c7..063b091 100644 --- a/tests/reg.test +++ b/tests/reg.test @@ -49,9 +49,9 @@ catch [list package require -exact Tcltest [info patchlevel]] # subexpressions, checking where empty substrings are located, # etc. should be done using expectIndices and expectPartial. -# The flag characters are complex and a bit eclectic. Generally speaking, +# The flag characters are complex and a bit eclectic. Generally speaking, # lowercase letters are compile options, uppercase are expected re_info -# bits, and nonalphabetics are match options, controls for how the test is +# bits, and nonalphabetics are match options, controls for how the test is # run, or testing options. The one small surprise is that AREs are the # default, and you must explicitly request lesser flavors of RE. The flags # are as follows. It is admitted that some are not very mnemonic. @@ -287,7 +287,7 @@ namespace eval RETest { set infoflags [TestInfoFlags $flags] set ccmd [list testregexp -about {*}$f $re] set nsub [expr {[llength $args] - 1}] - if {$nsub == -1} { + if {$nsub < 0} { # didn't tell us number of subexps set ccmd "lreplace \[$ccmd\] 0 0" set info [list $infoflags] @@ -311,7 +311,7 @@ namespace eval RETest { # match expected (full fanciness) # expectIndices testno flags re target mat submat ... proc expectIndices {args} { - MatchExpected -indices {*}$args + MatchExpected -indices {*}$args } # partial match expected diff --git a/tests/socket.test b/tests/socket.test index 5198f4f..ca60588 100644 --- a/tests/socket.test +++ b/tests/socket.test @@ -237,7 +237,7 @@ if {$doTestsWithRemoteServer} { # Some tests are run only if we are doing testing against a remote server. testConstraint doTestsWithRemoteServer $doTestsWithRemoteServer if {!$doTestsWithRemoteServer} { - if {[string first s $::tcltest::verbose] != -1} { + if {[string first s $::tcltest::verbose] >= 0} { puts "Skipping tests with remote server. See tests/socket.test for" puts "information on how to run remote server." puts "Reason for not doing remote tests: $noRemoteTestReason" diff --git a/tests/stringObj.test b/tests/stringObj.test index ce19e96..bfe9da1 100644 --- a/tests/stringObj.test +++ b/tests/stringObj.test @@ -27,8 +27,8 @@ testConstraint testdstring [llength [info commands testdstring]] test stringObj-1.1 {string type registration} testobj { set t [testobj types] set first [string first "string" $t] - set result [expr {$first != -1}] -} {1} + set result [expr {$first >= 0}] +} 1 test stringObj-2.1 {Tcl_NewStringObj} testobj { set result "" diff --git a/tests/thread.test b/tests/thread.test index 9f14470..7c7dc27 100644 --- a/tests/thread.test +++ b/tests/thread.test @@ -36,11 +36,11 @@ set threadSuperKillScript { proc getThreadErrorFromInfo { info } { set list [split $info \n] set idx [lsearch -glob $list "*eval*unwound*"] - if {$idx != -1} then { + if {$idx >= 0} then { return [lindex $list $idx] } set idx [lsearch -glob $list "*eval*canceled*"] - if {$idx != -1} then { + if {$idx >= 0} then { return [lindex $list $idx] } return ""; # some other error we do not care about. diff --git a/tests/unload.test b/tests/unload.test index 05a0104..815ff31 100644 --- a/tests/unload.test +++ b/tests/unload.test @@ -156,14 +156,14 @@ test unload-3.3 {unloading of a package that has never been loaded from a safe i unload [file join $testDir pkga$ext] {} child } -result {file "*" has never been loaded in this interpreter} test unload-3.4 {basic unloading of a non-unloadable package from a safe interpreter, with guess for package name} -setup { - if {[lsearch -index 1 [info loaded child] Pkgb] == -1} { + if {[lsearch -index 1 [info loaded child] Pkgb] < 0} { load [file join $testDir pkgb$ext] pKgB child } } -constraints [list $dll $loaded] -returnCodes error -match glob -body { unload [file join $testDir pkgb$ext] {} child } -result {file "*" cannot be unloaded under a safe interpreter} test unload-3.5 {basic unloading of an unloadable package from a safe interpreter, with guess for package name} -setup { - if {[lsearch -index 1 [info loaded child] Pkgua] == -1} { + if {[lsearch -index 1 [info loaded child] Pkgua] < 0} { load [file join $testDir pkgua$ext] pkgua child } } -constraints [list $dll $loaded] -body { diff --git a/tools/mkdepend.tcl b/tools/mkdepend.tcl index 3d96a5e..afe123a 100644 --- a/tools/mkdepend.tcl +++ b/tools/mkdepend.tcl @@ -88,7 +88,7 @@ proc readDepends {chan} { set line "" array set depends {} - while {[gets $chan line] != -1} { + while {[gets $chan line] < 0} { if {[regexp {^#line [0-9]+ \"(.*)\"$} $line dummy fname] != 0} { set fname [file normalize $fname] if {![info exists target]} { diff --git a/tools/uniParse.tcl b/tools/uniParse.tcl index a451096..545afc4 100644 --- a/tools/uniParse.tcl +++ b/tools/uniParse.tcl @@ -68,7 +68,7 @@ proc uni::getGroup {value} { variable groups set gIndex [lsearch -exact $groups $value] - if {$gIndex == -1} { + if {$gIndex < 0} { set gIndex [llength $groups] lappend groups $value } @@ -81,7 +81,7 @@ proc uni::addPage {info} { variable shift set pIndex [lsearch -exact $pages $info] - if {$pIndex == -1} { + if {$pIndex < 0} { set pIndex [llength $pages] lappend pages $info } -- cgit v0.12 From 262b6297ea2f920b93647282240008fb6b77b0e9 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 14 Sep 2020 12:31:56 +0000 Subject: Eliminate many "register" keywords (which do nothing with modern compilers) Eliminate many unnecessary type-casts to (unsigned) --- generic/tclAlloc.c | 22 +++--- generic/tclBasic.c | 44 +++++------ generic/tclCkalloc.c | 4 +- generic/tclCmdMZ.c | 18 ++--- generic/tclCompCmdsGR.c | 2 +- generic/tclCompile.c | 2 +- generic/tclInt.decls | 2 +- generic/tclInt.h | 4 +- generic/tclLiteral.c | 4 +- generic/tclNamesp.c | 74 +++++++++--------- generic/tclOOCall.c | 16 ++-- generic/tclObj.c | 194 ++++++++++++++++++++++++------------------------ generic/tclRegexp.c | 18 ++--- generic/tclResult.c | 28 +++---- generic/tclTest.c | 18 ++--- generic/tclTimer.c | 12 +-- generic/tclVar.c | 70 ++++++++--------- tests/winFCmd.test | 2 +- tools/mkdepend.tcl | 2 +- 19 files changed, 268 insertions(+), 268 deletions(-) diff --git a/generic/tclAlloc.c b/generic/tclAlloc.c index 39b9395..dd83385 100644 --- a/generic/tclAlloc.c +++ b/generic/tclAlloc.c @@ -253,9 +253,9 @@ char * TclpAlloc( unsigned int numBytes) /* Number of bytes to allocate. */ { - register union overhead *overPtr; - register long bucket; - register unsigned amount; + union overhead *overPtr; + long bucket; + unsigned amount; struct block *bigBlockPtr = NULL; if (!allocInit) { @@ -274,7 +274,7 @@ TclpAlloc( if (numBytes >= MAXMALLOC - OVERHEAD) { if (numBytes <= UINT_MAX - OVERHEAD -sizeof(struct block)) { - bigBlockPtr = (struct block *) TclpSysAlloc((unsigned) + bigBlockPtr = (struct block *) TclpSysAlloc( (sizeof(struct block) + OVERHEAD + numBytes), 0); } if (bigBlockPtr == NULL) { @@ -387,8 +387,8 @@ static void MoreCore( int bucket) /* What bucket to allocat to. */ { - register union overhead *overPtr; - register long size; /* size of desired block */ + union overhead *overPtr; + long size; /* size of desired block */ long amount; /* amount to allocate */ int numBlocks; /* how many blocks we get */ struct block *blockPtr; @@ -405,7 +405,7 @@ MoreCore( numBlocks = amount / size; ASSERT(numBlocks*size == amount); - blockPtr = (struct block *) TclpSysAlloc((unsigned) + blockPtr = (struct block *) TclpSysAlloc( (sizeof(struct block) + amount), 1); /* no more room! */ if (blockPtr == NULL) { @@ -448,8 +448,8 @@ void TclpFree( char *oldPtr) /* Pointer to memory to free. */ { - register long size; - register union overhead *overPtr; + long size; + union overhead *overPtr; struct block *bigBlockPtr; if (oldPtr == NULL) { @@ -645,8 +645,8 @@ void mstats( char *s) /* Where to write info. */ { - register int i, j; - register union overhead *overPtr; + int i, j; + union overhead *overPtr; int totalFree = 0, totalUsed = 0; Tcl_MutexLock(allocMutexPtr); diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 8b3a1b2..cca87ce 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -1036,7 +1036,7 @@ int TclHideUnsafeCommands( Tcl_Interp *interp) /* Hide commands in this interpreter. */ { - register const CmdInfo *cmdInfoPtr; + const CmdInfo *cmdInfoPtr; if (interp == NULL) { return TCL_ERROR; @@ -2485,7 +2485,7 @@ int TclInvokeStringCommand( ClientData clientData, /* Points to command's Command structure. */ Tcl_Interp *interp, /* Current interpreter. */ - register int objc, /* Number of arguments. */ + int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { Command *cmdPtr = clientData; @@ -2534,7 +2534,7 @@ TclInvokeObjectCommand( ClientData clientData, /* Points to command's Command structure. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ - register const char **argv) /* Argument strings. */ + const char **argv) /* Argument strings. */ { Command *cmdPtr = clientData; Tcl_Obj *objPtr; @@ -3025,7 +3025,7 @@ Tcl_GetCommandFullName( { Interp *iPtr = (Interp *) interp; - register Command *cmdPtr = (Command *) command; + Command *cmdPtr = (Command *) command; char *name; /* @@ -3302,7 +3302,7 @@ CallCommandTraces( * trigger, either TCL_TRACE_DELETE or * TCL_TRACE_RENAME. */ { - register CommandTrace *tracePtr; + CommandTrace *tracePtr; ActiveCommandTrace active; char *result; Tcl_Obj *oldNamePtr = NULL; @@ -3492,7 +3492,7 @@ CancelEvalProc( void TclCleanupCommand( - register Command *cmdPtr) /* Points to the Command structure to + Command *cmdPtr) /* Points to the Command structure to * be freed. */ { cmdPtr->refCount--; @@ -3877,7 +3877,7 @@ int TclInterpReady( Tcl_Interp *interp) { - register Interp *iPtr = (Interp *) interp; + Interp *iPtr = (Interp *) interp; /* * Reset both the interpreter's string and object results and clear out @@ -3949,7 +3949,7 @@ TclResetCancellation( Tcl_Interp *interp, int force) { - register Interp *iPtr = (Interp *) interp; + Interp *iPtr = (Interp *) interp; if (iPtr == NULL) { return TCL_ERROR; @@ -3991,7 +3991,7 @@ Tcl_Canceled( Tcl_Interp *interp, int flags) { - register Interp *iPtr = (Interp *) interp; + Interp *iPtr = (Interp *) interp; /* * Has the current script in progress for this interpreter been canceled @@ -4720,7 +4720,7 @@ TEOV_NotFound( newObjv[i] = handlerObjv[i]; Tcl_IncrRefCount(newObjv[i]); } - memcpy(newObjv+handlerObjc, objv, sizeof(Tcl_Obj *) * (unsigned)objc); + memcpy(newObjv+handlerObjc, objv, sizeof(Tcl_Obj *) * objc); /* * Look up and invoke the handler (by recursive call to this function). If @@ -5506,7 +5506,7 @@ TclAdvanceLines( const char *start, const char *end) { - register const char *p; + const char *p; for (p = start; p < end; p++) { if (*p == '\n') { @@ -6031,7 +6031,7 @@ int Tcl_EvalObjEx( Tcl_Interp *interp, /* Token for command interpreter (returned by * a previous call to Tcl_CreateInterp). */ - register Tcl_Obj *objPtr, /* Pointer to object containing commands to + Tcl_Obj *objPtr, /* Pointer to object containing commands to * execute. */ int flags) /* Collection of OR-ed bits that control the * evaluation of the script. Supported values @@ -6044,7 +6044,7 @@ int TclEvalObjEx( Tcl_Interp *interp, /* Token for command interpreter (returned by * a previous call to Tcl_CreateInterp). */ - register Tcl_Obj *objPtr, /* Pointer to object containing commands to + Tcl_Obj *objPtr, /* Pointer to object containing commands to * execute. */ int flags, /* Collection of OR-ed bits that control the * evaluation of the script. Supported values @@ -6063,7 +6063,7 @@ int TclNREvalObjEx( Tcl_Interp *interp, /* Token for command interpreter (returned by * a previous call to Tcl_CreateInterp). */ - register Tcl_Obj *objPtr, /* Pointer to object containing commands to + Tcl_Obj *objPtr, /* Pointer to object containing commands to * execute. */ int flags, /* Collection of OR-ed bits that control the * evaluation of the script. Supported values @@ -6371,7 +6371,7 @@ Tcl_ExprLong( const char *exprstring, /* Expression to evaluate. */ long *ptr) /* Where to store result. */ { - register Tcl_Obj *exprPtr; + Tcl_Obj *exprPtr; int result = TCL_OK; if (*exprstring == '\0') { /* @@ -6398,7 +6398,7 @@ Tcl_ExprDouble( const char *exprstring, /* Expression to evaluate. */ double *ptr) /* Where to store result. */ { - register Tcl_Obj *exprPtr; + Tcl_Obj *exprPtr; int result = TCL_OK; if (*exprstring == '\0') { @@ -6478,7 +6478,7 @@ int Tcl_ExprLongObj( Tcl_Interp *interp, /* Context in which to evaluate the * expression. */ - register Tcl_Obj *objPtr, /* Expression to evaluate. */ + Tcl_Obj *objPtr, /* Expression to evaluate. */ long *ptr) /* Where to store long result. */ { Tcl_Obj *resultPtr; @@ -6526,7 +6526,7 @@ int Tcl_ExprDoubleObj( Tcl_Interp *interp, /* Context in which to evaluate the * expression. */ - register Tcl_Obj *objPtr, /* Expression to evaluate. */ + Tcl_Obj *objPtr, /* Expression to evaluate. */ double *ptr) /* Where to store double result. */ { Tcl_Obj *resultPtr; @@ -6562,7 +6562,7 @@ int Tcl_ExprBooleanObj( Tcl_Interp *interp, /* Context in which to evaluate the * expression. */ - register Tcl_Obj *objPtr, /* Expression to evaluate. */ + Tcl_Obj *objPtr, /* Expression to evaluate. */ int *ptr) /* Where to store 0/1 result. */ { Tcl_Obj *resultPtr; @@ -6674,7 +6674,7 @@ TclNRInvoke( int objc, Tcl_Obj *const objv[]) { - register Interp *iPtr = (Interp *) interp; + Interp *iPtr = (Interp *) interp; Tcl_HashTable *hTblPtr; /* Table of hidden commands. */ const char *cmdName; /* Name of the command from objv[0]. */ Tcl_HashEntry *hPtr = NULL; @@ -6868,7 +6868,7 @@ Tcl_AddObjErrorInfo( int length) /* The number of bytes in the message. If < 0, * then append all bytes up to a NULL byte. */ { - register Interp *iPtr = (Interp *) interp; + Interp *iPtr = (Interp *) interp; /* * If we are just starting to log an error, errorInfo is initialized from @@ -7016,7 +7016,7 @@ Tcl_GlobalEval( * command. */ const char *command) /* Command to evaluate. */ { - register Interp *iPtr = (Interp *) interp; + Interp *iPtr = (Interp *) interp; int result; CallFrame *savedVarFramePtr; diff --git a/generic/tclCkalloc.c b/generic/tclCkalloc.c index 2730443..0dc1dca 100644 --- a/generic/tclCkalloc.c +++ b/generic/tclCkalloc.c @@ -406,7 +406,7 @@ Tcl_DbCkalloc( /* Don't let size argument to TclpAlloc overflow */ if (size <= UINT_MAX - HIGH_GUARD_SIZE -sizeof(struct mem_header)) { - result = (struct mem_header *) TclpAlloc((unsigned)size + + result = (struct mem_header *) TclpAlloc(size + sizeof(struct mem_header) + HIGH_GUARD_SIZE); } if (result == NULL) { @@ -496,7 +496,7 @@ Tcl_AttemptDbCkalloc( /* Don't let size argument to TclpAlloc overflow */ if (size <= UINT_MAX - HIGH_GUARD_SIZE - sizeof(struct mem_header)) { - result = (struct mem_header *) TclpAlloc((unsigned)size + + result = (struct mem_header *) TclpAlloc(size + sizeof(struct mem_header) + HIGH_GUARD_SIZE); } if (result == NULL) { diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index b9b6b6c..b24cb97 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -1231,7 +1231,7 @@ StringFirstCmd( */ if (needleLen > 0 && needleLen <= haystackLen) { - register Tcl_UniChar *p, *end; + Tcl_UniChar *p, *end; end = haystackStr + haystackLen - needleLen + 1; for (p = haystackStr; p < end; p++) { @@ -1712,7 +1712,7 @@ StringIsCmd( const char *elemStart, *nextElem; int lenRemain, elemSize; - register const char *p; + const char *p; string1 = TclGetStringFromObj(objPtr, &length1); end = string1 + length1; @@ -2035,7 +2035,7 @@ StringMapCmd( (Tcl_UniCharToLower(*ustring1) == u2lc[index/2]))) && /* Restrict max compare length. */ (end-ustring1 >= length2) && ((length2 == 1) || - !strCmpFn(ustring2, ustring1, (unsigned) length2))) { + !strCmpFn(ustring2, ustring1, length2))) { if (p != ustring1) { /* * Put the skipped chars onto the result first. @@ -2272,7 +2272,7 @@ StringReptCmd( * Include space for the NUL. */ - string2 = attemptckalloc((unsigned) length2 + 1); + string2 = attemptckalloc(length2 + 1); if (string2 == NULL) { /* * Alloc failed. Note that in this case we try to do an error message @@ -4185,9 +4185,9 @@ Tcl_TimeObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - register Tcl_Obj *objPtr; + Tcl_Obj *objPtr; Tcl_Obj *objs[4]; - register int i, result; + int i, result; int count; double totalMicroSec; #ifndef TCL_WIDE_CLICKS @@ -4286,8 +4286,8 @@ Tcl_TimeRateObjCmd( static double measureOverhead = 0; /* global measure-overhead */ double overhead = -1; /* given measure-overhead */ - register Tcl_Obj *objPtr; - register int result, i; + Tcl_Obj *objPtr; + int result, i; Tcl_Obj *calibrate = NULL, *direct = NULL; TclWideMUInt count = 0; /* Holds repetition count */ Tcl_WideInt maxms = WIDE_MIN; @@ -4301,7 +4301,7 @@ Tcl_TimeRateObjCmd( * zero (i.e., never < 1) */ unsigned short factor = 50; /* Factor (4..50) limiting threshold to avoid * growth of execution time. */ - register Tcl_WideInt start, middle, stop; + Tcl_WideInt start, middle, stop; #ifndef TCL_WIDE_CLICKS Tcl_Time now; #endif /* !TCL_WIDE_CLICKS */ diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index 4207df7..16fafad 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -2119,7 +2119,7 @@ TclCompileRegexpCmd( sawLast++; i++; break; - } else if ((len > 1) && (strncmp(str,"-nocase",(unsigned)len) == 0)) { + } else if ((len > 1) && (strncmp(str, "-nocase", len) == 0)) { nocase = 1; } else { /* diff --git a/generic/tclCompile.c b/generic/tclCompile.c index b79d504..6761c09 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -2996,7 +2996,7 @@ TclFindCompiledLocal( char *localName = localPtr->name; if ((nameBytes == localPtr->nameLength) && - (strncmp(name,localName,(unsigned)nameBytes) == 0)) { + (strncmp(name, localName, nameBytes) == 0)) { return i; } } diff --git a/generic/tclInt.decls b/generic/tclInt.decls index 46adc69..b858dfa 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -903,7 +903,7 @@ declare 227 { # Used to be needed for TclOO-extension; unneeded now that TclOO is in the # core and NRE-enabled # declare 228 { -# int TclObjInterpProcCore(register Tcl_Interp *interp, Tcl_Obj *procNameObj, +# int TclObjInterpProcCore(Tcl_Interp *interp, Tcl_Obj *procNameObj, # int skip, ProcErrorProc *errorProc) # } declare 229 { diff --git a/generic/tclInt.h b/generic/tclInt.h index fe69b26..46ba764 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -4315,8 +4315,8 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file, (objPtr)->bytes = tclEmptyStringRep; \ (objPtr)->length = 0; \ } else { \ - (objPtr)->bytes = (char *) ckalloc((unsigned) ((len) + 1)); \ - memcpy((objPtr)->bytes, (bytePtr), (unsigned) (len)); \ + (objPtr)->bytes = (char *) ckalloc((len) + 1); \ + memcpy((objPtr)->bytes, (bytePtr), (len)); \ (objPtr)->bytes[len] = '\0'; \ (objPtr)->length = (len); \ } diff --git a/generic/tclLiteral.c b/generic/tclLiteral.c index 55473c1..35c54be 100644 --- a/generic/tclLiteral.c +++ b/generic/tclLiteral.c @@ -213,7 +213,7 @@ TclCreateLiteral( if ((objLength == length) && ((length == 0) || ((objBytes[0] == bytes[0]) - && (memcmp(objBytes, bytes, (unsigned) length) == 0)))) { + && (memcmp(objBytes, bytes, length) == 0)))) { /* * A literal was found: return it */ @@ -418,7 +418,7 @@ TclRegisterLiteral( objPtr = localPtr->objPtr; if ((objPtr->length == length) && ((length == 0) || ((objPtr->bytes[0] == bytes[0]) - && (memcmp(objPtr->bytes, bytes, (unsigned) length) == 0)))) { + && (memcmp(objPtr->bytes, bytes, length) == 0)))) { if ((flags & LITERAL_ON_HEAP)) { ckfree(bytes); } diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index cf4ecc4..bfce6ee 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -225,7 +225,7 @@ TclInitNamespaceSubsystem(void) Tcl_Namespace * Tcl_GetCurrentNamespace( - register Tcl_Interp *interp)/* Interpreter whose current namespace is + Tcl_Interp *interp)/* Interpreter whose current namespace is * being queried. */ { return TclGetCurrentNamespace(interp); @@ -249,7 +249,7 @@ Tcl_GetCurrentNamespace( Tcl_Namespace * Tcl_GetGlobalNamespace( - register Tcl_Interp *interp)/* Interpreter whose global namespace should + Tcl_Interp *interp)/* Interpreter whose global namespace should * be returned. */ { return TclGetGlobalNamespace(interp); @@ -301,8 +301,8 @@ Tcl_PushCallFrame( * variables. */ { Interp *iPtr = (Interp *) interp; - register CallFrame *framePtr = (CallFrame *) callFramePtr; - register Namespace *nsPtr; + CallFrame *framePtr = (CallFrame *) callFramePtr; + Namespace *nsPtr; if (namespacePtr == NULL) { nsPtr = (Namespace *) TclGetCurrentNamespace(interp); @@ -378,8 +378,8 @@ void Tcl_PopCallFrame( Tcl_Interp *interp) /* Interpreter with call frame to pop. */ { - register Interp *iPtr = (Interp *) interp; - register CallFrame *framePtr = iPtr->framePtr; + Interp *iPtr = (Interp *) interp; + CallFrame *framePtr = iPtr->framePtr; Namespace *nsPtr; /* @@ -664,7 +664,7 @@ Tcl_CreateNamespace( * function should be called. */ { Interp *iPtr = (Interp *) interp; - register Namespace *nsPtr, *ancestorPtr; + Namespace *nsPtr, *ancestorPtr; Namespace *parentPtr, *dummy1Ptr, *dummy2Ptr; Namespace *globalNsPtr = iPtr->globalNsPtr; const char *simpleName; @@ -833,7 +833,7 @@ Tcl_CreateNamespace( for (ancestorPtr = nsPtr; ancestorPtr != NULL; ancestorPtr = ancestorPtr->parentPtr) { if (ancestorPtr != globalNsPtr) { - register Tcl_DString *tempPtr = namePtr; + Tcl_DString *tempPtr = namePtr; TclDStringAppendLiteral(buffPtr, "::"); Tcl_DStringAppend(buffPtr, ancestorPtr->name, -1); @@ -861,7 +861,7 @@ Tcl_CreateNamespace( name = Tcl_DStringValue(namePtr); nameLen = Tcl_DStringLength(namePtr); nsPtr->fullName = ckalloc(nameLen + 1); - memcpy(nsPtr->fullName, name, (unsigned) nameLen + 1); + memcpy(nsPtr->fullName, name, nameLen + 1); Tcl_DStringFree(&buffer1); Tcl_DStringFree(&buffer2); @@ -907,7 +907,7 @@ void Tcl_DeleteNamespace( Tcl_Namespace *namespacePtr)/* Points to the namespace to delete. */ { - register Namespace *nsPtr = (Namespace *) namespacePtr; + Namespace *nsPtr = (Namespace *) namespacePtr; Interp *iPtr = (Interp *) nsPtr->interp; Namespace *globalNsPtr = (Namespace *) TclGetGlobalNamespace((Tcl_Interp *) iPtr); @@ -1103,11 +1103,11 @@ TclNamespaceDeleted( void TclTeardownNamespace( - register Namespace *nsPtr) /* Points to the namespace to be dismantled + Namespace *nsPtr) /* Points to the namespace to be dismantled * and unlinked from its parent. */ { Interp *iPtr = (Interp *) nsPtr->interp; - register Tcl_HashEntry *entryPtr; + Tcl_HashEntry *entryPtr; Tcl_HashSearch search; int i; @@ -1296,7 +1296,7 @@ TclTeardownNamespace( static void NamespaceFree( - register Namespace *nsPtr) /* Points to the namespace to free. */ + Namespace *nsPtr) /* Points to the namespace to free. */ { /* * Most of the namespace's contents are freed when the namespace is @@ -1455,7 +1455,7 @@ Tcl_Export( len = strlen(pattern); patternCpy = ckalloc(len + 1); - memcpy(patternCpy, pattern, (unsigned) len + 1); + memcpy(patternCpy, pattern, len + 1); nsPtr->exportArrayPtr[nsPtr->numExportPatterns] = patternCpy; nsPtr->numExportPatterns++; @@ -1572,7 +1572,7 @@ Tcl_Import( { Namespace *nsPtr, *importNsPtr, *dummyPtr; const char *simplePattern; - register Tcl_HashEntry *hPtr; + Tcl_HashEntry *hPtr; Tcl_HashSearch search; /* @@ -1851,7 +1851,7 @@ Tcl_ForgetImport( Namespace *nsPtr, *sourceNsPtr, *dummyPtr; const char *simplePattern; char *cmdName; - register Tcl_HashEntry *hPtr; + Tcl_HashEntry *hPtr; Tcl_HashSearch search; /* @@ -1978,7 +1978,7 @@ TclGetOriginalCommand( Tcl_Command command) /* The imported command for which the original * command should be returned. */ { - register Command *cmdPtr = (Command *) command; + Command *cmdPtr = (Command *) command; ImportedCmdData *dataPtr; if (cmdPtr->deleteProc != DeleteImportedCmd) { @@ -2067,7 +2067,7 @@ DeleteImportedCmd( ImportedCmdData *dataPtr = clientData; Command *realCmdPtr = dataPtr->realCmdPtr; Command *selfPtr = dataPtr->selfPtr; - register ImportRef *refPtr, *prevPtr; + ImportRef *refPtr, *prevPtr; prevPtr = NULL; for (refPtr = realCmdPtr->importRefPtr; refPtr != NULL; @@ -2487,7 +2487,7 @@ Tcl_FindNamespace( * points to namespace in which to resolve * name; if NULL, look up name in the current * namespace. */ - register int flags) /* Flags controlling namespace lookup: an OR'd + int flags) /* Flags controlling namespace lookup: an OR'd * combination of TCL_GLOBAL_ONLY and * TCL_LEAVE_ERR_MSG flags. */ { @@ -2558,8 +2558,8 @@ Tcl_FindCommand( { Interp *iPtr = (Interp *) interp; Namespace *cxtNsPtr; - register Tcl_HashEntry *entryPtr; - register Command *cmdPtr; + Tcl_HashEntry *entryPtr; + Command *cmdPtr; const char *simpleName; int result; @@ -2670,7 +2670,7 @@ Tcl_FindCommand( } } else { Namespace *nsPtr[2]; - register int search; + int search; TclGetNamespaceForQualName(interp, name, cxtNsPtr, flags, &nsPtr[0], &nsPtr[1], &cxtNsPtr, &simpleName); @@ -2744,7 +2744,7 @@ TclResetShadowedCmdRefs( { char *cmdName; Tcl_HashEntry *hPtr; - register Namespace *nsPtr; + Namespace *nsPtr; Namespace *trailNsPtr, *shadowNsPtr; Namespace *globalNsPtr = (Namespace *) TclGetGlobalNamespace(interp); int found, i; @@ -2991,7 +2991,7 @@ NamespaceChildrenCmd( Namespace *globalNsPtr = (Namespace *) TclGetGlobalNamespace(interp); const char *pattern = NULL; Tcl_DString buffer; - register Tcl_HashEntry *entryPtr; + Tcl_HashEntry *entryPtr; Tcl_HashSearch search; Tcl_Obj *listPtr, *elemPtr; @@ -3117,7 +3117,7 @@ NamespaceCodeCmd( { Namespace *currNsPtr; Tcl_Obj *listPtr, *objPtr; - register const char *arg; + const char *arg; int length; if (objc != 2) { @@ -3196,7 +3196,7 @@ NamespaceCurrentCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - register Namespace *currNsPtr; + Namespace *currNsPtr; if (objc != 1) { Tcl_WrongNumArgs(interp, 1, objv, NULL); @@ -3261,7 +3261,7 @@ NamespaceDeleteCmd( { Tcl_Namespace *namespacePtr; const char *name; - register int i; + int i; if (objc < 1) { Tcl_WrongNumArgs(interp, 1, objv, "?name name...?"); @@ -3616,7 +3616,7 @@ NamespaceForgetCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { const char *pattern; - register int i, result; + int i, result; if (objc < 1) { Tcl_WrongNumArgs(interp, 1, objv, "?pattern pattern...?"); @@ -3682,7 +3682,7 @@ NamespaceImportCmd( { int allowOverwrite = 0; const char *string, *pattern; - register int i, result; + int i, result; int firstArg; if (objc < 1) { @@ -3835,7 +3835,7 @@ NRNamespaceInscopeCmd( cmdObjPtr = objv[2]; } else { Tcl_Obj *concatObjv[2]; - register Tcl_Obj *listPtr; + Tcl_Obj *listPtr; listPtr = Tcl_NewListObj(0, NULL); for (i = 3; i < objc; i++) { @@ -4236,7 +4236,7 @@ NamespaceQualifiersCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - register const char *name, *p; + const char *name, *p; int length; if (objc != 2) { @@ -4491,7 +4491,7 @@ NamespaceTailCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - register const char *name, *p; + const char *name, *p; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "string"); @@ -4694,7 +4694,7 @@ NamespaceWhichCmd( static void FreeNsNameInternalRep( - register Tcl_Obj *objPtr) /* nsName object with internal representation + Tcl_Obj *objPtr) /* nsName object with internal representation * to free. */ { ResolvedNsName *resNamePtr = objPtr->internalRep.twoPtrValue.ptr1; @@ -4740,7 +4740,7 @@ FreeNsNameInternalRep( static void DupNsNameInternalRep( Tcl_Obj *srcPtr, /* Object with internal rep to copy. */ - register Tcl_Obj *copyPtr) /* Object with internal rep to set. */ + Tcl_Obj *copyPtr) /* Object with internal rep to set. */ { ResolvedNsName *resNamePtr = srcPtr->internalRep.twoPtrValue.ptr1; @@ -4776,11 +4776,11 @@ SetNsNameFromAny( Tcl_Interp *interp, /* Points to the namespace in which to resolve * name. Also used for error reporting if not * NULL. */ - register Tcl_Obj *objPtr) /* The object to convert. */ + Tcl_Obj *objPtr) /* The object to convert. */ { const char *dummy; Namespace *nsPtr, *dummy1Ptr, *dummy2Ptr; - register ResolvedNsName *resNamePtr; + ResolvedNsName *resNamePtr; const char *name; if (interp == NULL) { @@ -4914,7 +4914,7 @@ TclLogCommandInfo( Tcl_Obj **tosPtr) /* Current stack of bytecode execution * context */ { - register const char *p; + const char *p; Interp *iPtr = (Interp *) interp; int overflow, limit = 150; Var *varPtr, *arrayPtr; diff --git a/generic/tclOOCall.c b/generic/tclOOCall.c index cc02c68..65b1e38 100644 --- a/generic/tclOOCall.c +++ b/generic/tclOOCall.c @@ -105,7 +105,7 @@ void TclOODeleteContext( CallContext *contextPtr) { - register Object *oPtr = contextPtr->oPtr; + Object *oPtr = contextPtr->oPtr; TclOODeleteChain(contextPtr->callPtr); if (oPtr != NULL) { @@ -215,7 +215,7 @@ DupMethodNameRep( Tcl_Obj *srcPtr, Tcl_Obj *dstPtr) { - register CallChain *callPtr = srcPtr->internalRep.twoPtrValue.ptr1; + CallChain *callPtr = srcPtr->internalRep.twoPtrValue.ptr1; dstPtr->typePtr = &methodNameType; dstPtr->internalRep.twoPtrValue.ptr1 = callPtr; @@ -226,7 +226,7 @@ static void FreeMethodNameRep( Tcl_Obj *objPtr) { - register CallChain *callPtr = objPtr->internalRep.twoPtrValue.ptr1; + CallChain *callPtr = objPtr->internalRep.twoPtrValue.ptr1; TclOODeleteChain(callPtr); objPtr->typePtr = NULL; @@ -255,7 +255,7 @@ TclOOInvokeContext( int objc, /* The number of arguments. */ Tcl_Obj *const objv[]) /* The arguments as actually seen. */ { - register CallContext *const contextPtr = clientData; + CallContext *const contextPtr = clientData; Method *const mPtr = contextPtr->callPtr->chain[contextPtr->index].mPtr; const int isFilter = contextPtr->callPtr->chain[contextPtr->index].isFilter; @@ -487,7 +487,7 @@ TclOOGetSortedMethodList( if (i > 0) { if (i > 1) { - qsort((void *) strings, (unsigned) i, sizeof(char *), CmpStr); + qsort((void *) strings, i, sizeof(char *), CmpStr); } *stringsPtr = strings; } else { @@ -560,7 +560,7 @@ TclOOGetSortedClassMethodList( if (i > 0) { if (i > 1) { - qsort((void *) strings, (unsigned) i, sizeof(char *), CmpStr); + qsort((void *) strings, i, sizeof(char *), CmpStr); } *stringsPtr = strings; } else { @@ -792,7 +792,7 @@ AddMethodToCallChain( * looking to add things from a mixin and have * not passed a mixin. */ { - register CallChain *callPtr = cbPtr->callChainPtr; + CallChain *callPtr = cbPtr->callChainPtr; int i; /* @@ -1463,7 +1463,7 @@ AddSimpleClassChainToCallContext( (char *) methodNameObj); if (hPtr != NULL) { - register Method *mPtr = Tcl_GetHashValue(hPtr); + Method *mPtr = Tcl_GetHashValue(hPtr); if (!(flags & KNOWN_STATE)) { if (flags & PUBLIC_METHOD) { diff --git a/generic/tclObj.c b/generic/tclObj.c index a2544ad..70b2b1e 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -876,7 +876,7 @@ Tcl_AppendAllObjTypes( * name of each registered type is appended as * a list element. */ { - register Tcl_HashEntry *hPtr; + Tcl_HashEntry *hPtr; Tcl_HashSearch search; int numElems; @@ -924,7 +924,7 @@ const Tcl_ObjType * Tcl_GetObjType( const char *typeName) /* Name of Tcl object type to look up. */ { - register Tcl_HashEntry *hPtr; + Tcl_HashEntry *hPtr; const Tcl_ObjType *typePtr = NULL; Tcl_MutexLock(&tableMutex); @@ -1054,10 +1054,10 @@ TclDbDumpActiveObjects( #ifdef TCL_MEM_DEBUG void TclDbInitNewObj( - register Tcl_Obj *objPtr, - register const char *file, /* The name of the source file calling this + Tcl_Obj *objPtr, + const char *file, /* The name of the source file calling this * function; used for debugging. */ - register int line) /* Line number in the source file; used for + int line) /* Line number in the source file; used for * debugging. */ { objPtr->refCount = 0; @@ -1142,7 +1142,7 @@ Tcl_NewObj(void) Tcl_Obj * Tcl_NewObj(void) { - register Tcl_Obj *objPtr; + Tcl_Obj *objPtr; /* * Use the macro defined in tclInt.h - it will use the correct allocator. @@ -1184,12 +1184,12 @@ Tcl_NewObj(void) Tcl_Obj * Tcl_DbNewObj( - register const char *file, /* The name of the source file calling this + const char *file, /* The name of the source file calling this * function; used for debugging. */ - register int line) /* Line number in the source file; used for + int line) /* Line number in the source file; used for * debugging. */ { - register Tcl_Obj *objPtr; + Tcl_Obj *objPtr; /* * Use the macro defined in tclInt.h - it will use the correct allocator. @@ -1239,8 +1239,8 @@ TclAllocateFreeObjects(void) { size_t bytesToAlloc = (OBJS_TO_ALLOC_EACH_TIME * sizeof(Tcl_Obj)); char *basePtr; - register Tcl_Obj *prevPtr, *objPtr; - register int i; + Tcl_Obj *prevPtr, *objPtr; + int i; /* * This has been noted by Purify to be a potential leak. The problem is @@ -1291,9 +1291,9 @@ TclAllocateFreeObjects(void) #ifdef TCL_MEM_DEBUG void TclFreeObj( - register Tcl_Obj *objPtr) /* The object to be freed. */ + Tcl_Obj *objPtr) /* The object to be freed. */ { - register const Tcl_ObjType *typePtr = objPtr->typePtr; + const Tcl_ObjType *typePtr = objPtr->typePtr; /* * This macro declares a variable, so must come here... @@ -1416,7 +1416,7 @@ TclFreeObj( void TclFreeObj( - register Tcl_Obj *objPtr) /* The object to be freed. */ + Tcl_Obj *objPtr) /* The object to be freed. */ { /* * Invalidate the string rep first so we can use the bytes value for our @@ -1625,7 +1625,7 @@ TclSetDuplicateObj( char * Tcl_GetString( - register Tcl_Obj *objPtr) /* Object whose string rep byte pointer should + Tcl_Obj *objPtr) /* Object whose string rep byte pointer should * be returned. */ { if (objPtr->bytes != NULL) { @@ -1683,9 +1683,9 @@ Tcl_GetString( char * Tcl_GetStringFromObj( - register Tcl_Obj *objPtr, /* Object whose string rep byte pointer should + Tcl_Obj *objPtr, /* Object whose string rep byte pointer should * be returned. */ - register int *lengthPtr) /* If non-NULL, the location where the string + int *lengthPtr) /* If non-NULL, the location where the string * rep's byte array length should * be stored. * If NULL, no length is stored. */ { @@ -1717,7 +1717,7 @@ Tcl_GetStringFromObj( void Tcl_InvalidateStringRep( - register Tcl_Obj *objPtr) /* Object whose string rep byte pointer should + Tcl_Obj *objPtr) /* Object whose string rep byte pointer should * be freed. */ { TclInvalidateStringRep(objPtr); @@ -1751,7 +1751,7 @@ Tcl_InvalidateStringRep( Tcl_Obj * Tcl_NewBooleanObj( - register int boolValue) /* Boolean used to initialize new object. */ + int boolValue) /* Boolean used to initialize new object. */ { return Tcl_DbNewBooleanObj(boolValue, "unknown", 0); } @@ -1760,9 +1760,9 @@ Tcl_NewBooleanObj( Tcl_Obj * Tcl_NewBooleanObj( - register int boolValue) /* Boolean used to initialize new object. */ + int boolValue) /* Boolean used to initialize new object. */ { - register Tcl_Obj *objPtr; + Tcl_Obj *objPtr; TclNewBooleanObj(objPtr, boolValue); return objPtr; @@ -1800,13 +1800,13 @@ Tcl_NewBooleanObj( Tcl_Obj * Tcl_DbNewBooleanObj( - register int boolValue, /* Boolean used to initialize new object. */ + int boolValue, /* Boolean used to initialize new object. */ const char *file, /* The name of the source file calling this * function; used for debugging. */ int line) /* Line number in the source file; used for * debugging. */ { - register Tcl_Obj *objPtr; + Tcl_Obj *objPtr; TclDbNewObj(objPtr, file, line); objPtr->bytes = NULL; @@ -1820,7 +1820,7 @@ Tcl_DbNewBooleanObj( Tcl_Obj * Tcl_DbNewBooleanObj( - register int boolValue, /* Boolean used to initialize new object. */ + int boolValue, /* Boolean used to initialize new object. */ const char *file, /* The name of the source file calling this * function; used for debugging. */ int line) /* Line number in the source file; used for @@ -1851,8 +1851,8 @@ Tcl_DbNewBooleanObj( #undef Tcl_SetBooleanObj void Tcl_SetBooleanObj( - register Tcl_Obj *objPtr, /* Object whose internal rep to init. */ - register int boolValue) /* Boolean used to set object's value. */ + Tcl_Obj *objPtr, /* Object whose internal rep to init. */ + int boolValue) /* Boolean used to set object's value. */ { if (Tcl_IsShared(objPtr)) { Tcl_Panic("%s called with shared object", "Tcl_SetBooleanObj"); @@ -1883,8 +1883,8 @@ Tcl_SetBooleanObj( int Tcl_GetBooleanFromObj( Tcl_Interp *interp, /* Used for error reporting if not NULL. */ - register Tcl_Obj *objPtr, /* The object from which to get boolean. */ - register int *boolPtr) /* Place to store resulting boolean. */ + Tcl_Obj *objPtr, /* The object from which to get boolean. */ + int *boolPtr) /* Place to store resulting boolean. */ { do { if (objPtr->typePtr == &tclIntType) { @@ -1950,7 +1950,7 @@ Tcl_GetBooleanFromObj( int TclSetBooleanFromAny( Tcl_Interp *interp, /* Used for error reporting if not NULL. */ - register Tcl_Obj *objPtr) /* The object to convert. */ + Tcl_Obj *objPtr) /* The object to convert. */ { /* * For some "pure" numeric Tcl_ObjTypes (no string rep), we can determine @@ -2003,7 +2003,7 @@ TclSetBooleanFromAny( static int ParseBoolean( - register Tcl_Obj *objPtr) /* The object to parse/convert. */ + Tcl_Obj *objPtr) /* The object to parse/convert. */ { int i, length, newBool; char lowerCase[6]; @@ -2144,7 +2144,7 @@ ParseBoolean( Tcl_Obj * Tcl_NewDoubleObj( - register double dblValue) /* Double used to initialize the object. */ + double dblValue) /* Double used to initialize the object. */ { return Tcl_DbNewDoubleObj(dblValue, "unknown", 0); } @@ -2153,9 +2153,9 @@ Tcl_NewDoubleObj( Tcl_Obj * Tcl_NewDoubleObj( - register double dblValue) /* Double used to initialize the object. */ + double dblValue) /* Double used to initialize the object. */ { - register Tcl_Obj *objPtr; + Tcl_Obj *objPtr; TclNewDoubleObj(objPtr, dblValue); return objPtr; @@ -2192,13 +2192,13 @@ Tcl_NewDoubleObj( Tcl_Obj * Tcl_DbNewDoubleObj( - register double dblValue, /* Double used to initialize the object. */ + double dblValue, /* Double used to initialize the object. */ const char *file, /* The name of the source file calling this * function; used for debugging. */ int line) /* Line number in the source file; used for * debugging. */ { - register Tcl_Obj *objPtr; + Tcl_Obj *objPtr; TclDbNewObj(objPtr, file, line); objPtr->bytes = NULL; @@ -2212,7 +2212,7 @@ Tcl_DbNewDoubleObj( Tcl_Obj * Tcl_DbNewDoubleObj( - register double dblValue, /* Double used to initialize the object. */ + double dblValue, /* Double used to initialize the object. */ const char *file, /* The name of the source file calling this * function; used for debugging. */ int line) /* Line number in the source file; used for @@ -2242,8 +2242,8 @@ Tcl_DbNewDoubleObj( void Tcl_SetDoubleObj( - register Tcl_Obj *objPtr, /* Object whose internal rep to init. */ - register double dblValue) /* Double used to set the object's value. */ + Tcl_Obj *objPtr, /* Object whose internal rep to init. */ + double dblValue) /* Double used to set the object's value. */ { if (Tcl_IsShared(objPtr)) { Tcl_Panic("%s called with shared object", "Tcl_SetDoubleObj"); @@ -2275,8 +2275,8 @@ Tcl_SetDoubleObj( int Tcl_GetDoubleFromObj( Tcl_Interp *interp, /* Used for error reporting if not NULL. */ - register Tcl_Obj *objPtr, /* The object from which to get a double. */ - register double *dblPtr) /* Place to store resulting double. */ + Tcl_Obj *objPtr, /* The object from which to get a double. */ + double *dblPtr) /* Place to store resulting double. */ { do { if (objPtr->typePtr == &tclDoubleType) { @@ -2336,7 +2336,7 @@ Tcl_GetDoubleFromObj( static int SetDoubleFromAny( Tcl_Interp *interp, /* Used for error reporting if not NULL. */ - register Tcl_Obj *objPtr) /* The object to convert. */ + Tcl_Obj *objPtr) /* The object to convert. */ { return TclParseNumber(interp, objPtr, "floating-point number", NULL, -1, NULL, 0); @@ -2365,16 +2365,16 @@ SetDoubleFromAny( static void UpdateStringOfDouble( - register Tcl_Obj *objPtr) /* Double obj with string rep to update. */ + Tcl_Obj *objPtr) /* Double obj with string rep to update. */ { char buffer[TCL_DOUBLE_SPACE]; - register int len; + int len; Tcl_PrintDouble(NULL, objPtr->internalRep.doubleValue, buffer); len = strlen(buffer); objPtr->bytes = (char *)ckalloc(len + 1); - memcpy(objPtr->bytes, buffer, (unsigned) len + 1); + memcpy(objPtr->bytes, buffer, len + 1); objPtr->length = len; } @@ -2413,7 +2413,7 @@ UpdateStringOfDouble( Tcl_Obj * Tcl_NewIntObj( - register int intValue) /* Int used to initialize the new object. */ + int intValue) /* Int used to initialize the new object. */ { return Tcl_DbNewLongObj((long)intValue, "unknown", 0); } @@ -2422,9 +2422,9 @@ Tcl_NewIntObj( Tcl_Obj * Tcl_NewIntObj( - register int intValue) /* Int used to initialize the new object. */ + int intValue) /* Int used to initialize the new object. */ { - register Tcl_Obj *objPtr; + Tcl_Obj *objPtr; TclNewIntObj(objPtr, intValue); return objPtr; @@ -2452,8 +2452,8 @@ Tcl_NewIntObj( #undef Tcl_SetIntObj void Tcl_SetIntObj( - register Tcl_Obj *objPtr, /* Object whose internal rep to init. */ - register int intValue) /* Integer used to set object's value. */ + Tcl_Obj *objPtr, /* Object whose internal rep to init. */ + int intValue) /* Integer used to set object's value. */ { if (Tcl_IsShared(objPtr)) { Tcl_Panic("%s called with shared object", "Tcl_SetIntObj"); @@ -2494,8 +2494,8 @@ Tcl_SetIntObj( int Tcl_GetIntFromObj( Tcl_Interp *interp, /* Used for error reporting if not NULL. */ - register Tcl_Obj *objPtr, /* The object from which to get a int. */ - register int *intPtr) /* Place to store resulting int. */ + Tcl_Obj *objPtr, /* The object from which to get a int. */ + int *intPtr) /* Place to store resulting int. */ { #if (LONG_MAX == INT_MAX) return TclGetLongFromObj(interp, objPtr, (long *) intPtr); @@ -2566,15 +2566,15 @@ SetIntFromAny( static void UpdateStringOfInt( - register Tcl_Obj *objPtr) /* Int object whose string rep to update. */ + Tcl_Obj *objPtr) /* Int object whose string rep to update. */ { char buffer[TCL_INTEGER_SPACE]; - register int len; + int len; len = TclFormatInt(buffer, objPtr->internalRep.longValue); objPtr->bytes = (char *)ckalloc(len + 1); - memcpy(objPtr->bytes, buffer, (unsigned) len + 1); + memcpy(objPtr->bytes, buffer, len + 1); objPtr->length = len; } @@ -2613,7 +2613,7 @@ UpdateStringOfInt( Tcl_Obj * Tcl_NewLongObj( - register long longValue) /* Long integer used to initialize the + long longValue) /* Long integer used to initialize the * new object. */ { return Tcl_DbNewLongObj(longValue, "unknown", 0); @@ -2623,10 +2623,10 @@ Tcl_NewLongObj( Tcl_Obj * Tcl_NewLongObj( - register long longValue) /* Long integer used to initialize the + long longValue) /* Long integer used to initialize the * new object. */ { - register Tcl_Obj *objPtr; + Tcl_Obj *objPtr; TclNewLongObj(objPtr, longValue); return objPtr; @@ -2669,14 +2669,14 @@ Tcl_NewLongObj( Tcl_Obj * Tcl_DbNewLongObj( - register long longValue, /* Long integer used to initialize the new + long longValue, /* Long integer used to initialize the new * object. */ const char *file, /* The name of the source file calling this * function; used for debugging. */ int line) /* Line number in the source file; used for * debugging. */ { - register Tcl_Obj *objPtr; + Tcl_Obj *objPtr; TclDbNewObj(objPtr, file, line); objPtr->bytes = NULL; @@ -2690,7 +2690,7 @@ Tcl_DbNewLongObj( Tcl_Obj * Tcl_DbNewLongObj( - register long longValue, /* Long integer used to initialize the new + long longValue, /* Long integer used to initialize the new * object. */ const char *file, /* The name of the source file calling this * function; used for debugging. */ @@ -2721,8 +2721,8 @@ Tcl_DbNewLongObj( void Tcl_SetLongObj( - register Tcl_Obj *objPtr, /* Object whose internal rep to init. */ - register long longValue) /* Long integer used to initialize the + Tcl_Obj *objPtr, /* Object whose internal rep to init. */ + long longValue) /* Long integer used to initialize the * object's value. */ { if (Tcl_IsShared(objPtr)) { @@ -2756,8 +2756,8 @@ Tcl_SetLongObj( int Tcl_GetLongFromObj( Tcl_Interp *interp, /* Used for error reporting if not NULL. */ - register Tcl_Obj *objPtr, /* The object from which to get a long. */ - register long *longPtr) /* Place to store resulting long. */ + Tcl_Obj *objPtr, /* The object from which to get a long. */ + long *longPtr) /* Place to store resulting long. */ { do { if (objPtr->typePtr == &tclIntType) { @@ -2862,11 +2862,11 @@ Tcl_GetLongFromObj( static void UpdateStringOfWideInt( - register Tcl_Obj *objPtr) /* Int object whose string rep to update. */ + Tcl_Obj *objPtr) /* Int object whose string rep to update. */ { char buffer[TCL_INTEGER_SPACE+2]; - register unsigned len; - register Tcl_WideInt wideVal = objPtr->internalRep.wideValue; + unsigned len; + Tcl_WideInt wideVal = objPtr->internalRep.wideValue; /* * Note that sprintf will generate a compiler warning under Mingw claiming @@ -2913,7 +2913,7 @@ UpdateStringOfWideInt( Tcl_Obj * Tcl_NewWideIntObj( - register Tcl_WideInt wideValue) + Tcl_WideInt wideValue) /* Wide integer used to initialize the new * object. */ { @@ -2924,11 +2924,11 @@ Tcl_NewWideIntObj( Tcl_Obj * Tcl_NewWideIntObj( - register Tcl_WideInt wideValue) + Tcl_WideInt wideValue) /* Wide integer used to initialize the new * object. */ { - register Tcl_Obj *objPtr; + Tcl_Obj *objPtr; TclNewObj(objPtr); Tcl_SetWideIntObj(objPtr, wideValue); @@ -2972,7 +2972,7 @@ Tcl_NewWideIntObj( Tcl_Obj * Tcl_DbNewWideIntObj( - register Tcl_WideInt wideValue, + Tcl_WideInt wideValue, /* Wide integer used to initialize the new * object. */ const char *file, /* The name of the source file calling this @@ -2980,7 +2980,7 @@ Tcl_DbNewWideIntObj( int line) /* Line number in the source file; used for * debugging. */ { - register Tcl_Obj *objPtr; + Tcl_Obj *objPtr; TclDbNewObj(objPtr, file, line); Tcl_SetWideIntObj(objPtr, wideValue); @@ -2991,7 +2991,7 @@ Tcl_DbNewWideIntObj( Tcl_Obj * Tcl_DbNewWideIntObj( - register Tcl_WideInt wideValue, + Tcl_WideInt wideValue, /* Long integer used to initialize the new * object. */ const char *file, /* The name of the source file calling this @@ -3023,8 +3023,8 @@ Tcl_DbNewWideIntObj( void Tcl_SetWideIntObj( - register Tcl_Obj *objPtr, /* Object w. internal rep to init. */ - register Tcl_WideInt wideValue) + Tcl_Obj *objPtr, /* Object w. internal rep to init. */ + Tcl_WideInt wideValue) /* Wide integer used to initialize the * object's value. */ { @@ -3071,8 +3071,8 @@ Tcl_SetWideIntObj( int Tcl_GetWideIntFromObj( Tcl_Interp *interp, /* Used for error reporting if not NULL. */ - register Tcl_Obj *objPtr, /* Object from which to get a wide int. */ - register Tcl_WideInt *wideIntPtr) + Tcl_Obj *objPtr, /* Object from which to get a wide int. */ + Tcl_WideInt *wideIntPtr) /* Place to store resulting long. */ { do { @@ -3712,7 +3712,7 @@ TclGetNumberFromObj( void Tcl_DbIncrRefCount( - register Tcl_Obj *objPtr, /* The object we are registering a reference + Tcl_Obj *objPtr, /* The object we are registering a reference * to. */ const char *file, /* The name of the source file calling this * function; used for debugging. */ @@ -3775,7 +3775,7 @@ Tcl_DbIncrRefCount( void Tcl_DbDecrRefCount( - register Tcl_Obj *objPtr, /* The object we are releasing a reference + Tcl_Obj *objPtr, /* The object we are releasing a reference * to. */ const char *file, /* The name of the source file calling this * function; used for debugging. */ @@ -3841,7 +3841,7 @@ Tcl_DbDecrRefCount( int Tcl_DbIsShared( - register Tcl_Obj *objPtr, /* The object to test for being shared. */ + Tcl_Obj *objPtr, /* The object to test for being shared. */ const char *file, /* The name of the source file calling this * function; used for debugging. */ int line) /* Line number in the source file; used for @@ -3913,7 +3913,7 @@ Tcl_DbIsShared( void Tcl_InitObjHashTable( - register Tcl_HashTable *tablePtr) + Tcl_HashTable *tablePtr) /* Pointer to table record, which is supplied * by the caller. */ { @@ -3976,8 +3976,8 @@ TclCompareObjKeys( { Tcl_Obj *objPtr1 = keyPtr; Tcl_Obj *objPtr2 = (Tcl_Obj *) hPtr->key.oneWordValue; - register const char *p1, *p2; - register size_t l1, l2; + const char *p1, *p2; + size_t l1, l2; /* * If the object pointers are the same then they match. @@ -4134,13 +4134,13 @@ Tcl_Command Tcl_GetCommandFromObj( Tcl_Interp *interp, /* The interpreter in which to resolve the * command and to report errors. */ - register Tcl_Obj *objPtr) /* The object containing the command's name. + Tcl_Obj *objPtr) /* The object containing the command's name. * If the name starts with "::", will be * looked up in global namespace. Else, looked * up first in the current namespace, then in * global namespace. */ { - register ResolvedCmdName *resPtr; + ResolvedCmdName *resPtr; /* * Get the internal representation, converting to a command type if @@ -4163,13 +4163,13 @@ Tcl_GetCommandFromObj( resPtr = objPtr->internalRep.twoPtrValue.ptr1; if ((objPtr->typePtr == &tclCmdNameType) && (resPtr != NULL)) { - register Command *cmdPtr = resPtr->cmdPtr; + Command *cmdPtr = resPtr->cmdPtr; if ((cmdPtr->cmdEpoch == resPtr->cmdEpoch) && !(cmdPtr->flags & CMD_IS_DELETED) && (interp == cmdPtr->nsPtr->interp) && !(cmdPtr->nsPtr->flags & NS_DYING)) { - register Namespace *refNsPtr = (Namespace *) + Namespace *refNsPtr = (Namespace *) TclGetCurrentNamespace(interp); if ((resPtr->refNsPtr == NULL) @@ -4218,14 +4218,14 @@ void TclSetCmdNameObj( Tcl_Interp *interp, /* Points to interpreter containing command * that should be cached in objPtr. */ - register Tcl_Obj *objPtr, /* Points to Tcl object to be changed to a + Tcl_Obj *objPtr, /* Points to Tcl object to be changed to a * CmdName object. */ Command *cmdPtr) /* Points to Command structure that the * CmdName object should refer to. */ { Interp *iPtr = (Interp *) interp; - register ResolvedCmdName *resPtr; - register Namespace *currNsPtr; + ResolvedCmdName *resPtr; + Namespace *currNsPtr; const char *name; if (objPtr->typePtr == &tclCmdNameType) { @@ -4290,10 +4290,10 @@ TclSetCmdNameObj( static void FreeCmdNameInternalRep( - register Tcl_Obj *objPtr) /* CmdName object with internal + Tcl_Obj *objPtr) /* CmdName object with internal * representation to free. */ { - register ResolvedCmdName *resPtr = objPtr->internalRep.twoPtrValue.ptr1; + ResolvedCmdName *resPtr = objPtr->internalRep.twoPtrValue.ptr1; if (resPtr != NULL) { /* @@ -4340,9 +4340,9 @@ FreeCmdNameInternalRep( static void DupCmdNameInternalRep( Tcl_Obj *srcPtr, /* Object with internal rep to copy. */ - register Tcl_Obj *copyPtr) /* Object with internal rep to set. */ + Tcl_Obj *copyPtr) /* Object with internal rep to set. */ { - register ResolvedCmdName *resPtr = srcPtr->internalRep.twoPtrValue.ptr1; + ResolvedCmdName *resPtr = srcPtr->internalRep.twoPtrValue.ptr1; copyPtr->internalRep.twoPtrValue.ptr1 = resPtr; copyPtr->internalRep.twoPtrValue.ptr2 = NULL; @@ -4376,13 +4376,13 @@ DupCmdNameInternalRep( static int SetCmdNameFromAny( Tcl_Interp *interp, /* Used for error reporting if not NULL. */ - register Tcl_Obj *objPtr) /* The object to convert. */ + Tcl_Obj *objPtr) /* The object to convert. */ { Interp *iPtr = (Interp *) interp; const char *name; - register Command *cmdPtr; + Command *cmdPtr; Namespace *currNsPtr; - register ResolvedCmdName *resPtr; + ResolvedCmdName *resPtr; if (interp == NULL) { return TCL_ERROR; diff --git a/generic/tclRegexp.c b/generic/tclRegexp.c index 19ff8fd..2070956 100644 --- a/generic/tclRegexp.c +++ b/generic/tclRegexp.c @@ -64,7 +64,7 @@ #define NUM_REGEXPS 30 -typedef struct ThreadSpecificData { +typedef struct { int initialized; /* Set to 1 when the module is initialized. */ char *patterns[NUM_REGEXPS];/* Strings corresponding to compiled regular * expression patterns. NULL means that this @@ -245,7 +245,7 @@ Tcl_RegExpRange( if ((size_t) index > regexpPtr->re.re_nsub) { *startPtr = *endPtr = NULL; - } else if (regexpPtr->matches[index].rm_so < 0) { + } else if (regexpPtr->matches[index].rm_so == -1) { *startPtr = *endPtr = NULL; } else { if (regexpPtr->objPtr) { @@ -355,7 +355,7 @@ TclRegExpRangeUniChar( { TclRegexp *regexpPtr = (TclRegexp *) re; - if ((regexpPtr->flags®_EXPECT) && index == -1) { + if ((regexpPtr->flags®_EXPECT) && (index == -1)) { *startPtr = regexpPtr->details.rm_extend.rm_so; *endPtr = regexpPtr->details.rm_extend.rm_eo; } else if ((size_t) index > regexpPtr->re.re_nsub) { @@ -510,9 +510,9 @@ Tcl_RegExpMatchObj( */ if (!(re = Tcl_GetRegExpFromObj(interp, patternObj, - TCL_REG_ADVANCED | TCL_REG_NOSUB)) + TCL_REG_ADVANCED | TCL_REG_NOSUB)) && !(re = Tcl_GetRegExpFromObj(interp, patternObj, TCL_REG_ADVANCED))) { - return -1; + return -1; } return Tcl_RegExpExecObj(interp, re, textObj, 0 /* offset */, 0 /* nmatches */, 0 /* flags */); @@ -912,7 +912,7 @@ CompileRegexp( * This is a new expression, so compile it and add it to the cache. */ - regexpPtr = ckalloc(sizeof(TclRegexp)); + regexpPtr = (TclRegexp*)ckalloc(sizeof(TclRegexp)); regexpPtr->objPtr = NULL; regexpPtr->string = NULL; regexpPtr->details.rm_extend.rm_so = -1; @@ -967,7 +967,7 @@ CompileRegexp( */ regexpPtr->matches = - ckalloc(sizeof(regmatch_t) * (regexpPtr->re.re_nsub + 1)); + (regmatch_t*)ckalloc(sizeof(regmatch_t) * (regexpPtr->re.re_nsub + 1)); /* * Initialize the refcount to one initially, since it is in the cache. @@ -993,8 +993,8 @@ CompileRegexp( tsdPtr->patLengths[i+1] = tsdPtr->patLengths[i]; tsdPtr->regexps[i+1] = tsdPtr->regexps[i]; } - tsdPtr->patterns[0] = ckalloc(length + 1); - memcpy(tsdPtr->patterns[0], string, (unsigned) length + 1); + tsdPtr->patterns[0] = (char *)ckalloc(length + 1); + memcpy(tsdPtr->patterns[0], string, length + 1); tsdPtr->patLengths[0] = length; tsdPtr->regexps[0] = regexpPtr; diff --git a/generic/tclResult.c b/generic/tclResult.c index caad71e..07d0e83 100644 --- a/generic/tclResult.c +++ b/generic/tclResult.c @@ -411,14 +411,14 @@ void Tcl_SetResult( Tcl_Interp *interp, /* Interpreter with which to associate the * return value. */ - register char *result, /* Value to be returned. If NULL, the result + char *result, /* Value to be returned. If NULL, the result * is set to an empty string. */ Tcl_FreeProc *freeProc) /* Gives information about the string: * TCL_STATIC, TCL_VOLATILE, or the address of * a Tcl_FreeProc such as free. */ { Interp *iPtr = (Interp *) interp; - register Tcl_FreeProc *oldFreeProc = iPtr->freeProc; + Tcl_FreeProc *oldFreeProc = iPtr->freeProc; char *oldResult = iPtr->result; if (result == NULL) { @@ -435,7 +435,7 @@ Tcl_SetResult( iPtr->result = iPtr->resultSpace; iPtr->freeProc = 0; } - memcpy(iPtr->result, result, (unsigned) length+1); + memcpy(iPtr->result, result, length+1); } else { iPtr->result = (char *) result; iPtr->freeProc = freeProc; @@ -481,7 +481,7 @@ Tcl_SetResult( const char * Tcl_GetStringResult( - register Tcl_Interp *interp)/* Interpreter whose result to return. */ + Tcl_Interp *interp)/* Interpreter whose result to return. */ { /* * If the string result is empty, move the object result to the string @@ -520,11 +520,11 @@ void Tcl_SetObjResult( Tcl_Interp *interp, /* Interpreter with which to associate the * return object value. */ - register Tcl_Obj *objPtr) /* Tcl object to be returned. If NULL, the obj + Tcl_Obj *objPtr) /* Tcl object to be returned. If NULL, the obj * result is made an empty string object. */ { - register Interp *iPtr = (Interp *) interp; - register Tcl_Obj *oldObjResult = iPtr->objResultPtr; + Interp *iPtr = (Interp *) interp; + Tcl_Obj *oldObjResult = iPtr->objResultPtr; iPtr->objResultPtr = objPtr; Tcl_IncrRefCount(objPtr); /* since interp result is a reference */ @@ -577,7 +577,7 @@ Tcl_Obj * Tcl_GetObjResult( Tcl_Interp *interp) /* Interpreter whose result to return. */ { - register Interp *iPtr = (Interp *) interp; + Interp *iPtr = (Interp *) interp; Tcl_Obj *objResultPtr; int length; @@ -880,9 +880,9 @@ SetupAppendBuffer( void Tcl_FreeResult( - register Tcl_Interp *interp)/* Interpreter for which to free result. */ + Tcl_Interp *interp)/* Interpreter for which to free result. */ { - register Interp *iPtr = (Interp *) interp; + Interp *iPtr = (Interp *) interp; if (iPtr->freeProc != NULL) { if (iPtr->freeProc == TCL_DYNAMIC) { @@ -917,9 +917,9 @@ Tcl_FreeResult( void Tcl_ResetResult( - register Tcl_Interp *interp)/* Interpreter for which to clear result. */ + Tcl_Interp *interp)/* Interpreter for which to clear result. */ { - register Interp *iPtr = (Interp *) interp; + Interp *iPtr = (Interp *) interp; ResetObjResult(iPtr); if (iPtr->freeProc != NULL) { @@ -980,10 +980,10 @@ Tcl_ResetResult( static void ResetObjResult( - register Interp *iPtr) /* Points to the interpreter whose result + Interp *iPtr) /* Points to the interpreter whose result * object should be reset. */ { - register Tcl_Obj *objResultPtr = iPtr->objResultPtr; + Tcl_Obj *objResultPtr = iPtr->objResultPtr; if (Tcl_IsShared(objResultPtr)) { TclDecrRefCount(objResultPtr); diff --git a/generic/tclTest.c b/generic/tclTest.c index 297cd11..03f40dd 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -1865,11 +1865,11 @@ TestencodingObjCmd( string = Tcl_GetStringFromObj(objv[3], &length); encodingPtr->toUtfCmd = (char *)ckalloc(length + 1); - memcpy(encodingPtr->toUtfCmd, string, (unsigned) length + 1); + memcpy(encodingPtr->toUtfCmd, string, length + 1); string = Tcl_GetStringFromObj(objv[4], &length); encodingPtr->fromUtfCmd = (char *)ckalloc(length + 1); - memcpy(encodingPtr->fromUtfCmd, string, (unsigned) (length + 1)); + memcpy(encodingPtr->fromUtfCmd, string, length + 1); string = Tcl_GetStringFromObj(objv[2], &length); @@ -1918,7 +1918,7 @@ EncodingToUtfProc( if (len > dstLen) { len = dstLen; } - memcpy(dst, Tcl_GetStringResult(encodingPtr->interp), (unsigned) len); + memcpy(dst, Tcl_GetStringResult(encodingPtr->interp), len); Tcl_ResetResult(encodingPtr->interp); *srcReadPtr = srcLen; @@ -1950,7 +1950,7 @@ EncodingFromUtfProc( if (len > dstLen) { len = dstLen; } - memcpy(dst, Tcl_GetStringResult(encodingPtr->interp), (unsigned) len); + memcpy(dst, Tcl_GetStringResult(encodingPtr->interp), len); Tcl_ResetResult(encodingPtr->interp); *srcReadPtr = srcLen; @@ -5879,7 +5879,7 @@ TestChannelEventCmd( cmd = argv[2]; len = strlen(cmd); - if ((cmd[0] == 'a') && (strncmp(cmd, "add", (unsigned) len) == 0)) { + if ((cmd[0] == 'a') && (strncmp(cmd, "add", len) == 0)) { if (argc != 5) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " channelName add eventSpec script\"", NULL); @@ -5914,7 +5914,7 @@ TestChannelEventCmd( return TCL_OK; } - if ((cmd[0] == 'd') && (strncmp(cmd, "delete", (unsigned) len) == 0)) { + if ((cmd[0] == 'd') && (strncmp(cmd, "delete", len) == 0)) { if (argc != 4) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " channelName delete index\"", NULL); @@ -5960,7 +5960,7 @@ TestChannelEventCmd( return TCL_OK; } - if ((cmd[0] == 'l') && (strncmp(cmd, "list", (unsigned) len) == 0)) { + if ((cmd[0] == 'l') && (strncmp(cmd, "list", len) == 0)) { if (argc != 3) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " channelName list\"", NULL); @@ -5983,7 +5983,7 @@ TestChannelEventCmd( return TCL_OK; } - if ((cmd[0] == 'r') && (strncmp(cmd, "removeall", (unsigned) len) == 0)) { + if ((cmd[0] == 'r') && (strncmp(cmd, "removeall", len) == 0)) { if (argc != 3) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " channelName removeall\"", NULL); @@ -6002,7 +6002,7 @@ TestChannelEventCmd( return TCL_OK; } - if ((cmd[0] == 's') && (strncmp(cmd, "set", (unsigned) len) == 0)) { + if ((cmd[0] == 's') && (strncmp(cmd, "set", len) == 0)) { if (argc != 5) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " channelName delete index event\"", NULL); diff --git a/generic/tclTimer.c b/generic/tclTimer.c index 106e2f7..d30879f 100644 --- a/generic/tclTimer.c +++ b/generic/tclTimer.c @@ -217,7 +217,7 @@ TimerExitProc( Tcl_DeleteEventSource(TimerSetupProc, TimerCheckProc, NULL); if (tsdPtr != NULL) { - register TimerHandler *timerHandlerPtr; + TimerHandler *timerHandlerPtr; timerHandlerPtr = tsdPtr->firstTimerHandlerPtr; while (timerHandlerPtr != NULL) { @@ -294,7 +294,7 @@ TclCreateAbsoluteTimerHandler( Tcl_TimerProc *proc, ClientData clientData) { - register TimerHandler *timerHandlerPtr, *tPtr2, *prevPtr; + TimerHandler *timerHandlerPtr, *tPtr2, *prevPtr; ThreadSpecificData *tsdPtr = InitTimer(); timerHandlerPtr = ckalloc(sizeof(TimerHandler)); @@ -355,7 +355,7 @@ Tcl_DeleteTimerHandler( Tcl_TimerToken token) /* Result previously returned by * Tcl_DeleteTimerHandler. */ { - register TimerHandler *timerHandlerPtr, *prevPtr; + TimerHandler *timerHandlerPtr, *prevPtr; ThreadSpecificData *tsdPtr = InitTimer(); if (token == NULL) { @@ -621,7 +621,7 @@ Tcl_DoWhenIdle( Tcl_IdleProc *proc, /* Function to invoke. */ ClientData clientData) /* Arbitrary value to pass to proc. */ { - register IdleHandler *idlePtr; + IdleHandler *idlePtr; Tcl_Time blockTime; ThreadSpecificData *tsdPtr = InitTimer(); @@ -665,7 +665,7 @@ Tcl_CancelIdleCall( Tcl_IdleProc *proc, /* Function that was previously registered. */ ClientData clientData) /* Arbitrary value to pass to proc. */ { - register IdleHandler *idlePtr, *prevPtr; + IdleHandler *idlePtr, *prevPtr; IdleHandler *nextPtr; ThreadSpecificData *tsdPtr = InitTimer(); @@ -906,7 +906,7 @@ Tcl_AfterObjCmd( tempCommand = Tcl_GetStringFromObj(afterPtr->commandPtr, &tempLength); if ((length == tempLength) - && !memcmp(command, tempCommand, (unsigned) length)) { + && !memcmp(command, tempCommand, length)) { break; } } diff --git a/generic/tclVar.c b/generic/tclVar.c index 7b3db7e..5d8d88c 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -489,7 +489,7 @@ TclLookupVar( Var * TclObjLookupVar( Tcl_Interp *interp, /* Interpreter to use for lookup. */ - register Tcl_Obj *part1Ptr, /* If part2 isn't NULL, this is the name of an + Tcl_Obj *part1Ptr, /* If part2 isn't NULL, this is the name of an * array. Otherwise, this is a full variable * name that could include a parenthesized * array element. */ @@ -561,7 +561,7 @@ TclObjLookupVarEx( * is set to NULL. */ { Interp *iPtr = (Interp *) interp; - register Var *varPtr; /* Points to the variable's in-frame Var + Var *varPtr; /* Points to the variable's in-frame Var * structure. */ const char *part1; int index, len1, len2; @@ -640,7 +640,7 @@ TclObjLookupVarEx( * part1Ptr is possibly an unparsed array element. */ - register int i; + int i; len2 = -1; for (i = 0; i < len1; i++) { @@ -665,7 +665,7 @@ TclObjLookupVarEx( len1 = i; newPart2 = ckalloc(len2 + 1); - memcpy(newPart2, part2, (unsigned) len2); + memcpy(newPart2, part2, len2); *(newPart2+len2) = '\0'; part2 = newPart2; part2Ptr = Tcl_NewStringObj(newPart2, -1); @@ -980,7 +980,7 @@ TclLookupSimpleVar( int localLen; for (i=0 ; iinternalRep.twoPtrValue.ptr1; - register char *elem = objPtr->internalRep.twoPtrValue.ptr2; + Tcl_Obj *arrayPtr = objPtr->internalRep.twoPtrValue.ptr1; + char *elem = objPtr->internalRep.twoPtrValue.ptr2; if (arrayPtr != NULL) { TclDecrRefCount(arrayPtr); @@ -5550,8 +5550,8 @@ DupParsedVarName( Tcl_Obj *srcPtr, Tcl_Obj *dupPtr) { - register Tcl_Obj *arrayPtr = srcPtr->internalRep.twoPtrValue.ptr1; - register char *elem = srcPtr->internalRep.twoPtrValue.ptr2; + Tcl_Obj *arrayPtr = srcPtr->internalRep.twoPtrValue.ptr1; + char *elem = srcPtr->internalRep.twoPtrValue.ptr2; char *elemCopy; unsigned elemLen; @@ -5595,10 +5595,10 @@ UpdateParsedVarName( objPtr->bytes = p; objPtr->length = totalLen; - memcpy(p, part1, (unsigned) len1); + memcpy(p, part1, len1); p += len1; *p++ = '('; - memcpy(p, part2, (unsigned) len2); + memcpy(p, part2, len2); p += len2; *p++ = ')'; *p = '\0'; @@ -5684,7 +5684,7 @@ ObjFindNamespaceVar( Namespace *nsPtr[2], *cxtNsPtr; const char *simpleName; Var *varPtr; - register int search; + int search; int result; Tcl_Var var; Tcl_Obj *simpleNamePtr; @@ -6311,8 +6311,8 @@ CompareVarKeys( { Tcl_Obj *objPtr1 = keyPtr; Tcl_Obj *objPtr2 = hPtr->key.objPtr; - register const char *p1, *p2; - register int l1, l2; + const char *p1, *p2; + int l1, l2; /* * If the object pointers are the same then they match. diff --git a/tests/winFCmd.test b/tests/winFCmd.test index 6d87319..517a56b 100644 --- a/tests/winFCmd.test +++ b/tests/winFCmd.test @@ -401,7 +401,7 @@ proc MakeFiles {dirname} { set f [open $filename w] close $f file stat $filename stat - if {[set n [lsearch -exact -integer $inodes $stat(ino)]] != -1} { + if {[set n [lsearch -exact -integer $inodes $stat(ino)]] < 0} { return [list [file join $dirname Test$n] $filename] } lappend inodes $stat(ino) diff --git a/tools/mkdepend.tcl b/tools/mkdepend.tcl index afe123a..b1ad076 100644 --- a/tools/mkdepend.tcl +++ b/tools/mkdepend.tcl @@ -88,7 +88,7 @@ proc readDepends {chan} { set line "" array set depends {} - while {[gets $chan line] < 0} { + while {[gets $chan line] >= 0} { if {[regexp {^#line [0-9]+ \"(.*)\"$} $line dummy fname] != 0} { set fname [file normalize $fname] if {![info exists target]} { -- cgit v0.12 From fa3cf75311fd2cf309675dacf20c723963b8fb19 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 14 Sep 2020 12:48:10 +0000 Subject: Add .bmp to .gitattributes. Simplify .fossil-settings/binary-glob --- .fossil-settings/binary-glob | 17 ++++++++++------- .gitattributes | 1 + 2 files changed, 11 insertions(+), 7 deletions(-) diff --git a/.fossil-settings/binary-glob b/.fossil-settings/binary-glob index ec574be..7e8f357 100644 --- a/.fossil-settings/binary-glob +++ b/.fossil-settings/binary-glob @@ -1,9 +1,12 @@ -compat/zlib/win32/zdll.lib -compat/zlib/win32/zlib1.dll -compat/zlib/win64/zdll.lib -compat/zlib/win64/zlib1.dll -compat/zlib/win64/libz.dll.a -compat/zlib/zlib.3.pdf +*.a *.bmp +*.dll +*.exe *.gif -*.png \ No newline at end of file +*.gz +*.jpg +*.lib +*.pdf +*.png +*.xlsx +*.zip diff --git a/.gitattributes b/.gitattributes index e9a67c8..8a49592 100644 --- a/.gitattributes +++ b/.gitattributes @@ -27,6 +27,7 @@ # Denote all files that are truly binary and should not be modified. *.a binary +*.bmp binary *.dll binary *.exe binary *.gif binary -- cgit v0.12 From 52f93c85fd4b12afc887e78f895f6dd7e33983db Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 14 Sep 2020 12:58:26 +0000 Subject: Unbreak winFCmd-1.38 testcase on Windows --- tests/winFCmd.test | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/winFCmd.test b/tests/winFCmd.test index 517a56b..7c81e81 100644 --- a/tests/winFCmd.test +++ b/tests/winFCmd.test @@ -401,7 +401,7 @@ proc MakeFiles {dirname} { set f [open $filename w] close $f file stat $filename stat - if {[set n [lsearch -exact -integer $inodes $stat(ino)]] < 0} { + if {[set n [lsearch -exact -integer $inodes $stat(ino)]] >= 0} { return [list [file join $dirname Test$n] $filename] } lappend inodes $stat(ino) -- cgit v0.12 From 1dc3124160fd7c59519c640c0704be7ba6bf7259 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 16 Sep 2020 12:17:54 +0000 Subject: Proposed solution for [835c93c000]: TIP #525 only implemented for non-singleproc case --- library/tcltest/tcltest.tcl | 19 ++++++++++++++----- 1 file changed, 14 insertions(+), 5 deletions(-) diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl index 2af79bc..e7f4288 100644 --- a/library/tcltest/tcltest.tcl +++ b/library/tcltest/tcltest.tcl @@ -2798,7 +2798,6 @@ proc tcltest::runAllTests { {shell ""} } { variable numTests variable failFiles variable DefaultValue - set failFilesAccum {} FillFilesExisted if {[llength [info level 0]] == 1} { @@ -2854,8 +2853,18 @@ proc tcltest::runAllTests { {shell ""} } { flush [outputChannel] if {[singleProcess]} { - incr numTestFiles - uplevel 1 [list ::source $file] + if {[catch { + incr numTestFiles + uplevel 1 [list ::source $file] + } msg]} { + puts [outputChannel] "Test file error: $msg" + # append the name of the test to a list to be reported + # later + lappend testFileFailures $file + } + if {$numTests(Failed) > 0} { + set failFilesSet 1 + } } else { # Pass along our configuration to the child processes. # EXCEPT for the -outfile, because the parent process @@ -2888,7 +2897,7 @@ proc tcltest::runAllTests { {shell ""} } { } if {$Failed > 0} { lappend failFiles $testFile - lappend failFilesAccum $testFile + set failFilesSet 1 } } elseif {[regexp [join { {^Number of tests skipped } @@ -2935,7 +2944,7 @@ proc tcltest::runAllTests { {shell ""} } { puts [outputChannel] "" puts [outputChannel] [string repeat ~ 44] } - return [expr {[info exists testFileFailures] || [llength $failFilesAccum]}] + return [expr {[info exists testFileFailures] || [info exists failFilesSet]}] } ##################################################################### -- cgit v0.12 From e14285c3a1d7dd2d7407fda5a5c841ccb5cae488 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 17 Sep 2020 08:37:09 +0000 Subject: Tcl 8.6 should not be tested with "package prefer latest" any more: All included packages are supposed to be stable. Not to be merged to 8.7 (which still contains unstable packages) --- tests/all.tcl | 1 - 1 file changed, 1 deletion(-) diff --git a/tests/all.tcl b/tests/all.tcl index 52c8763..5ac2abb 100644 --- a/tests/all.tcl +++ b/tests/all.tcl @@ -10,7 +10,6 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -package prefer latest package require Tcl 8.5- package require tcltest 2.5 namespace import ::tcltest::* -- cgit v0.12 From ac45c8d85147e6927979c08d95567504148b74cd Mon Sep 17 00:00:00 2001 From: pooryorick Date: Sat, 19 Sep 2020 14:33:24 +0000 Subject: Fix for [b9ecf3ce98], [uplevel] unnecessarily generates string representation. --- generic/tclProc.c | 45 ++++++++++++++++++++++++++++++++++----------- tests/uplevel.test | 17 +++++++++++++++++ 2 files changed, 51 insertions(+), 11 deletions(-) diff --git a/generic/tclProc.c b/generic/tclProc.c index a9134f2..0313b29 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -898,29 +898,52 @@ TclNRUplevelObjCmd( Interp *iPtr = (Interp *) interp; CmdFrame *invoker = NULL; int word = 0; + int havelevel = 0; int result; CallFrame *savedVarFramePtr, *framePtr; Tcl_Obj *objPtr; if (objc < 2) { + /* to do + * simplify things by interpreting the argument as a command when there + * is only one argument. This requires a TIP since currently a single + * argument is interpreted as a level indicator if possible. + */ uplevelSyntax: Tcl_WrongNumArgs(interp, 1, objv, "?level? command ?arg ...?"); return TCL_ERROR; + } else if (objc == 2) { + int status ,llength; + status = Tcl_ListObjLength(interp, objv[1], &llength); + if (status == TCL_OK && llength > 1) { + /* the first argument can't interpreted as a level. Avoid + * generating a string representation of the script. */ + result = TclGetFrame(interp, "1", &framePtr); + if (result == -1) { + return TCL_ERROR; + } + havelevel = 1; + objc -= 1; + objv += 1; + } } - /* - * Find the level to use for executing the command. - */ + if (!havelevel) { + /* + * Find the level to use for executing the command. + */ - result = TclObjGetFrame(interp, objv[1], &framePtr); - if (result == -1) { - return TCL_ERROR; - } - objc -= result + 1; - if (objc == 0) { - goto uplevelSyntax; + result = TclObjGetFrame(interp, objv[1], &framePtr); + if (result == -1) { + return TCL_ERROR; + } + objc -= result + 1; + if (objc == 0) { + goto uplevelSyntax; + } + objv += result + 1; } - objv += result + 1; + /* * Modify the interpreter state to execute in the given frame. diff --git a/tests/uplevel.test b/tests/uplevel.test index f44cedc..5f0dd5c 100644 --- a/tests/uplevel.test +++ b/tests/uplevel.test @@ -304,7 +304,24 @@ test uplevel-7.3 {var access, LVT in upper level} -setup { rename foo {} rename moo {} } -result {3 3 3} + + +test uplevel-8.0 { + string representation isn't generated when there is only one argument +} -body { + set res {} + set script [list lindex 5] + lappend res [apply {script { + uplevel $script + }} $script] + lappend res [string match {value is a list *no string representation*} [ + ::tcl::unsupported::representation $script]] +} -cleanup { + unset script + unset res +} -result {5 1} + # cleanup ::tcltest::cleanupTests return -- cgit v0.12 From 1a94f57ab672e62630b18fc4daa9a5a9c253bc6b Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 20 Sep 2020 10:14:44 +0000 Subject: Backport many (formatting) changes in tools/*. Nothing functional. testest.tcl: Use more uppercase hex. --- library/tcltest/tcltest.tcl | 4 +- tools/checkLibraryDoc.tcl | 31 +++++------ tools/eolFix.tcl | 18 +++--- tools/findBadExternals.tcl | 4 +- tools/genStubs.tcl | 12 ++-- tools/index.tcl | 10 ++-- tools/loadICU.tcl | 12 ++-- tools/makeTestCases.tcl | 132 ++++++++++++++++++++++---------------------- tools/man2help.tcl | 2 +- tools/man2help2.tcl | 40 ++++++++------ tools/man2html.tcl | 8 +-- tools/man2html1.tcl | 18 +++--- tools/man2html2.tcl | 22 ++++---- tools/mkdepend.tcl | 18 +++--- tools/regexpTestLib.tcl | 36 ++++++------ tools/tclZIC.tcl | 10 ++-- tools/tcltk-man2html.tcl | 2 +- tools/uniParse.tcl | 4 +- 18 files changed, 194 insertions(+), 189 deletions(-) diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl index e7f4288..4df25e4 100644 --- a/library/tcltest/tcltest.tcl +++ b/library/tcltest/tcltest.tcl @@ -3242,8 +3242,8 @@ proc tcltest::viewFile {name {directory ""}} { # procedures that are supposed to accept strings with embedded NULL # bytes. # 2. Confirm that a string result has a certain pattern of bytes, for -# instance to confirm that "\xe0\0" in a Tcl script is stored -# internally in UTF-8 as the sequence of bytes "\xc3\xa0\xc0\x80". +# instance to confirm that "\xE0\0" in a Tcl script is stored +# internally in UTF-8 as the sequence of bytes "\xC3\xA0\xC0\x80". # # Generally, it's a bad idea to examine the bytes in a Tcl string or to # construct improperly formed strings in this manner, because it involves diff --git a/tools/checkLibraryDoc.tcl b/tools/checkLibraryDoc.tcl index cd08c2a..224106e 100644 --- a/tools/checkLibraryDoc.tcl +++ b/tools/checkLibraryDoc.tcl @@ -1,9 +1,9 @@ # checkLibraryDoc.tcl -- # -# This script attempts to determine what APIs exist in the source base that -# have not been documented. By grepping through all of the doc/*.3 man +# This script attempts to determine what APIs exist in the source base that +# have not been documented. By grepping through all of the doc/*.3 man # pages, looking for "Pkg_*" (e.g., Tcl_ or Tk_), and comparing this list -# against the list of Pkg_ APIs found in the source (e.g., tcl8.2/*/*.[ch]) +# against the list of Pkg_ APIs found in the source (e.g., tcl8.5/*/*.[ch]) # we create six lists: # 1) APIs in Source not in Docs. # 2) APIs in Docs not in Source. @@ -11,10 +11,10 @@ # 4) Misc APIs and structs that we are not documenting. # 5) Command APIs (e.g., Tcl_ArrayObjCmd.) # 6) Proc pointers (e.g., Tcl_CloseProc.) -# +# # Note: Each list is "a best guess" approximation. If developers write # non-standard code, this script will produce erroneous results. Each -# list should be carefully checked for accuracy. +# list should be carefully checked for accuracy. # # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. @@ -86,7 +86,7 @@ set StructList { Tk_Window \ } -# Misc junk that appears in the comments of the source. This just +# Misc junk that appears in the comments of the source. This just # allows us to filter comments that "fool" the script. set CommentList { @@ -99,14 +99,13 @@ set CommentList { # Main entry point to this script. proc main {} { - global argv0 - global argv + global argv0 + global argv set len [llength $argv] if {($len != 2) && ($len != 3)} { puts "usage: $argv0 pkgName pkgDir \[outFile\]" puts " pkgName == Tcl,Tk" - puts " pkgDir == /home/surles/cvs/tcl8.2" exit 1 } @@ -121,12 +120,12 @@ proc main {} { foreach {c d} [compare [grepCode $dir $pkg] [grepDocs $dir $pkg]] {} filter $c $d $dir $pkg $file - if {$file != "stdout"} { + if {$file ne "stdout"} { close $file } return } - + # Intersect the two list and write out the sets of APIs in one # list that is not in the other. @@ -145,7 +144,7 @@ proc filter {code docs dir pkg {outFile stdout}} { # This list should just be verified for accuracy. set cmds {} - + # A list of proc pointer structs. These are not documented. # This list should just be verified for accuracy. @@ -162,7 +161,7 @@ proc filter {code docs dir pkg {outFile stdout}} { set misc [grepMisc $dir $pkg] set pat1 ".*(${pkg}_\[A-z0-9]+).*$" - + # A list of APIs in the source, not in the docs. # This list should just be verified for accuracy. @@ -196,7 +195,7 @@ proc filter {code docs dir pkg {outFile stdout}} { # Print the list of APIs if the list is not null. proc dump {list title file} { - if {$list != {}} { + if {$list ne ""} { puts $file "" puts $file $title puts $file "---------------------------------------------------------" @@ -240,7 +239,7 @@ proc grepDocs {dir pkg} { # (e.g., Tcl_Export). Return a list of APIs. proc grepDecl {dir pkg} { - set file [file join $dir generic "[string tolower $pkg]IntDecls.h"] + set file [file join $dir generic "[string tolower $pkg]IntDecls.h"] set apis [myGrep "^EXTERN.*\[ \t\]${pkg}_.*" $file] set pat1 ".*(${pkg}_\[A-z0-9]+).*$" @@ -258,7 +257,7 @@ proc grepDecl {dir pkg} { proc grepMisc {dir pkg} { global CommentList global StructList - + set apis [myGrep "^EXTERN.*\[ \t\]${pkg}_Db.*" "${dir}/\*/\*\.\[ch\]"] set pat1 ".*(${pkg}_\[A-z0-9]+).*$" diff --git a/tools/eolFix.tcl b/tools/eolFix.tcl index ed3ec7c..3f35ed4 100644 --- a/tools/eolFix.tcl +++ b/tools/eolFix.tcl @@ -13,16 +13,18 @@ namespace eval ::EOL { variable outMode crlf } -proc EOL::fix {filename {newfilename ""}} { +proc EOL::fix {filename {newfilename {}}} { variable outMode - if {![file exists $filename]} { return } + if {![file exists $filename]} { + return + } puts "EOL Fixing: $filename" file rename ${filename} ${filename}.o set fhnd [open ${filename}.o r] - if {$newfilename != ""} { + if {$newfilename ne ""} { set newfhnd [open ${newfilename} w] } else { set newfhnd [open ${filename} w] @@ -63,12 +65,12 @@ proc EOL::fixall {args} { } if {$tcl_interactive == 0 && $argc > 0} { - if {[string index [lindex $argv 0] 0] == "-"} { + if {[string index [lindex $argv 0] 0] eq "-"} { switch -- [lindex $argv 0] { - -cr { set ::EOL::outMode cr } - -crlf { set ::EOL::outMode crlf } - -lf { set ::EOL::outMode lf } - default { puts stderr "improper mode switch" ; exit 1 } + -cr {set ::EOL::outMode cr} + -crlf {set ::EOL::outMode crlf} + -lf {set ::EOL::outMode lf} + default {puts stderr "improper mode switch"; exit 1} } set argv [lrange $argv 1 end] } diff --git a/tools/findBadExternals.tcl b/tools/findBadExternals.tcl index 7592f17..2228357 100755 --- a/tools/findBadExternals.tcl +++ b/tools/findBadExternals.tcl @@ -1,5 +1,5 @@ # findBadExternals.tcl -- -# +# # This script scans the Tcl load library for exported symbols # that do not begin with 'Tcl' or 'tcl'. It reports them on the # standard output. It is used to make sure that the library does @@ -29,7 +29,7 @@ proc main {argc argv} { macosx { set status [catch { exec nm --extern-only --defined-only [lindex $argv 0] - } result] + } result] } windows { set status [catch { diff --git a/tools/genStubs.tcl b/tools/genStubs.tcl index 2eb6638..67b5112 100644 --- a/tools/genStubs.tcl +++ b/tools/genStubs.tcl @@ -382,7 +382,7 @@ proc genStubs::parseDecl {decl} { return } set rtype [string trim $rtype] - if {$args == ""} { + if {$args eq ""} { return [list $rtype $fname {}] } foreach arg [split $args ,] { @@ -430,14 +430,14 @@ proc genStubs::parseDecl {decl} { proc genStubs::parseArg {arg} { if {![regexp {^(.+[ ][*]*)([^][ *]+)(\[\])?$} $arg all type name array]} { - if {$arg == "void"} { + if {$arg eq "void"} { return $arg } else { return } } set result [list [string trim $type] $name] - if {$array != ""} { + if {$array ne ""} { lappend result $array } return $result @@ -460,7 +460,7 @@ proc genStubs::makeDecl {name decl index} { lassign $decl rtype fname args append text "/* $index */\n" - if {$rtype != "void"} { + if {$rtype ne "void"} { regsub -all void $rtype VOID rtype } set line "$scspec $rtype" @@ -640,7 +640,7 @@ proc genStubs::makeSlot {name decl index} { # Returns the formatted declaration string. proc genStubs::makeInit {name decl index} { - if {[lindex $decl 2] == ""} { + if {[lindex $decl 2] eq ""} { append text " &" [lindex $decl 1] ", /* " $index " */\n" } else { append text " " [lindex $decl 1] ", /* " $index " */\n" @@ -982,7 +982,7 @@ proc genStubs::emitHeader {name} { set capName [string toupper [string index $name 0]] append capName [string range $name 1 end] - if {$epoch != ""} { + if {$epoch ne ""} { set CAPName [string toupper $name] append text "\n" append text "#define ${CAPName}_STUBS_EPOCH $epoch\n" diff --git a/tools/index.tcl b/tools/index.tcl index 7b11e3f..71329c2 100644 --- a/tools/index.tcl +++ b/tools/index.tcl @@ -12,7 +12,7 @@ # Global variables used by these scripts: # # state - state variable that controls action of text proc. -# +# # topics - array indexed by (package,section,topic) with value # of topic ID. # @@ -135,7 +135,7 @@ proc macro {name args} { switch $args { NAME { - if {$state == "INIT" } { + if {$state eq "INIT" } { set state NAME } } @@ -144,7 +144,7 @@ proc macro {name args} { KEYWORDS {set state KEY} default {set state OFF} } - + } TH { global state curID curPkg curSect topics keywords @@ -176,7 +176,7 @@ proc macro {name args} { proc dash {} { global state - if {$state == "NAME"} { + if {$state eq "NAME"} { set state DASH } } @@ -185,7 +185,7 @@ proc dash {} { # initGlobals, tab, font, char, macro2 -- # -# These procedures do nothing during the first pass. +# These procedures do nothing during the first pass. # # Arguments: # None. diff --git a/tools/loadICU.tcl b/tools/loadICU.tcl index 1cdd12f..506b6e4 100755 --- a/tools/loadICU.tcl +++ b/tools/loadICU.tcl @@ -432,7 +432,7 @@ proc handleLocaleFile { localeName fileName msgFileName } { if { ![info exists format($localeName,TIME_FORMAT)] } { for { set i 3 } { $i >= 0 } { incr i -1 } { - if { [regexp H [lindex $items(DateTimePatterns) $i]] + if { [regexp H [lindex $items(DateTimePatterns) $i]] && [regexp s [lindex $items(DateTimePatterns) $i]] } { break } @@ -464,7 +464,7 @@ proc handleLocaleFile { localeName fileName msgFileName } { if { ![info exists format($localeName,TIME_FORMAT_12)] } { for { set i 3 } { $i >= 0 } { incr i -1 } { - if { [regexp h [lindex $items(DateTimePatterns) $i]] + if { [regexp h [lindex $items(DateTimePatterns) $i]] && [regexp s [lindex $items(DateTimePatterns) $i]] } { break } @@ -489,7 +489,7 @@ proc handleLocaleFile { localeName fileName msgFileName } { # Date and time... Prefer 24-hour format to 12-hour format. - if { ![info exists format($localeName,DATE_TIME_FORMAT)] + if { ![info exists format($localeName,DATE_TIME_FORMAT)] && [info exists format($localeName,DATE_FORMAT)] && [info exists format($localeName,TIME_FORMAT)]} { set format($localeName,DATE_TIME_FORMAT) \ @@ -497,7 +497,7 @@ proc handleLocaleFile { localeName fileName msgFileName } { append format($localeName,DATE_TIME_FORMAT) \ " " $format($localeName,TIME_FORMAT) " %z" } - if { ![info exists format($localeName,DATE_TIME_FORMAT)] + if { ![info exists format($localeName,DATE_TIME_FORMAT)] && [info exists format($localeName,DATE_FORMAT)] && [info exists format($localeName,TIME_FORMAT_12)]} { set format($localeName,DATE_TIME_FORMAT) \ @@ -517,7 +517,7 @@ proc handleLocaleFile { localeName fileName msgFileName } { # Write the string sets to the file. - foreach key { + foreach key { LOCALE_NUMERALS LOCALE_DATE_FORMAT LOCALE_TIME_FORMAT LOCALE_DATE_TIME_FORMAT LOCALE_ERAS LOCALE_YEAR_FORMAT } { @@ -588,7 +588,7 @@ proc backslashify { string } { set retval {} foreach char [split $string {}] { scan $char %c ccode - if { $ccode >= 0x0020 && $ccode < 0x007F && $char ne "\"" + if { $ccode >= 0x20 && $ccode < 0x7F && $char ne "\"" && $char ne "\{" && $char ne "\}" && $char ne "\[" && $char ne "\]" && $char ne "\\" && $char ne "\$" } { append retval $char diff --git a/tools/makeTestCases.tcl b/tools/makeTestCases.tcl index c230d57..70213e0 100755 --- a/tools/makeTestCases.tcl +++ b/tools/makeTestCases.tcl @@ -40,7 +40,7 @@ namespace eval ::tcl::clock { l li lii liii liv lv lvi lvii lviii lix lx lxi lxii lxiii lxiv lxv lxvi lxvii lxviii lxix lxx lxxi lxxii lxxiii lxxiv lxxv lxxvi lxxvii lxxviii lxxix - lxxx lxxxi lxxxii lxxxiii lxxxiv lxxxv lxxxvi lxxxvii lxxxviii + lxxx lxxxi lxxxii lxxxiii lxxxiv lxxxv lxxxvi lxxxvii lxxxviii lxxxix xc xci xcii xciii xciv xcv xcvi xcvii xcviii xcix c @@ -62,7 +62,7 @@ namespace eval ::tcl::clock { # # Parameters: # startOfYearArray - Name of an array in caller's scope that will -# be initialized as +# be initialized as # Results: # None # @@ -106,7 +106,7 @@ proc listYears { startOfYearArray } { set s $s2 incr y } - + # List years before 1970 set y 1970 @@ -138,7 +138,7 @@ proc listYears { startOfYearArray } { #---------------------------------------------------------------------- # -# processFile - +# processFile - # # Processes the 'clock.test' file, updating the test cases in it. # @@ -153,7 +153,7 @@ proc listYears { startOfYearArray } { proc processFile {d} { # Open two files - + set f1 [open [file join $d tests/clock.test] r] set f2 [open [file join $d tests/clock.new] w] @@ -164,7 +164,7 @@ proc processFile {d} { switch -exact -- $state { {} { puts $f2 $line - if { [regexp "^\# BEGIN (.*)" $line -> cases] + if { [regexp "^\# BEGIN (.*)" $line -> cases] && [string compare {} [info commands $cases]] } { set state inCaseSet $cases $f2 @@ -213,7 +213,7 @@ proc testcases2 { f2 } { listYears startOfYear # Define the roman numerals - + set roman { ? i ii iii iv v vi vii viii ix x xi xii xiii xiv xv xvi xvii xviii xix @@ -235,20 +235,20 @@ proc testcases2 { f2 } { } # Names of the months - + set short {{} Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec} set long { {} January February March April May June July August September October November December } - + # Put out a header describing the tests - + puts $f2 "" puts $f2 "\# Test formatting of Gregorian year, month, day, all formats" puts $f2 "\# Formats tested: %b %B %c %Ec %C %EC %d %Od %e %Oe %h %j %J %m %Om %N %x %Ex %y %Oy %Y %EY" puts $f2 "" - + # Generate the test cases for the first and last day of every month # from 1896 to 2045 @@ -262,7 +262,7 @@ proc testcases2 { f2 } { if { $m == 2 && ( $y%4 == 0 && $y%100 != 0 || $y%400 == 0 ) } { incr hath } - + set b [lindex $short $m] set B [lindex $long $m] set C [format %02d [expr { $y / 100 }]] @@ -271,9 +271,9 @@ proc testcases2 { f2 } { set mm [format %02d $m] set N [format %2d $m] set yy [format %02d [expr { $y % 100 }]] - + set J [expr { ( $s / 86400 ) + 2440588 }] - + set dt $y-$mm-01 set result "" append result $b " " $B " " \ @@ -296,17 +296,17 @@ proc testcases2 { f2 } { puts $f2 "\t-format {%b %B %c %Ec %C %EC %d %Od %e %Oe %h %j %J %m %Om %N %x %Ex %y %Oy %Y} \\" puts $f2 "\t-gmt true -locale en_US_roman" puts $f2 "} {$result}" - + set hm1 [expr { $hath - 1 }] incr s [expr { 86400 * ( $hath - 1 ) }] incr yd $hm1 - + set dd [format %02d $hath] set ee [format %2d $hath] set j [format %03d $yd] - + set J [expr { ( $s / 86400 ) + 2440588 }] - + set dt $y-$mm-$dd set result "" append result $b " " $B " " \ @@ -332,7 +332,7 @@ proc testcases2 { f2 } { puts $f2 "\t-format {%b %B %c %Ec %C %EC %d %Od %e %Oe %h %j %J %m %Om %N %x %Ex %y %Oy %Y} \\" puts $f2 "\t-gmt true -locale en_US_roman" puts $f2 "} {$result}" - + incr s 86400 incr yd } @@ -451,7 +451,7 @@ proc testcases3 { f2 } { testISO $f2 $ym1 52 1 [expr { $secs - 5*86400 }] testISO $f2 $ym1 52 6 $secs testISO $f2 $ym1 52 7 [expr { $secs + 86400 }] - } + } testISO $f2 $y 1 1 [expr { $secs + 2*86400 }] testISO $f2 $y 1 6 [expr { $secs + 7*86400 }] testISO $f2 $y 1 7 [expr { $secs + 8*86400 }] @@ -466,10 +466,10 @@ proc testcases3 { f2 } { proc testISO { f2 G V u secs } { upvar 1 case case - + set longdays {Sunday Monday Tuesday Wednesday Thursday Friday Saturday Sunday} set shortdays {Sun Mon Tue Wed Thu Fri Sat Sun} - + puts $f2 "test clock-3.[incr case] {ISO week-based calendar [format %04d-W%02d-%d $G $V $u]} {" puts $f2 " clock format $secs -format {%a %A %g %G %u %U %V %w %W} -gmt true; \# $G-W[format %02d $V]-$u" puts $f2 "} {[lindex $shortdays $u] [lindex $longdays $u]\ @@ -478,7 +478,7 @@ proc testISO { f2 G V u secs } { [clock format $secs -format %U -gmt true]\ [format %02d $V] [expr { $u % 7 }]\ [clock format $secs -format %W -gmt true]}" - + } #---------------------------------------------------------------------- @@ -504,15 +504,15 @@ proc testcases4 { f2 } { puts $f2 "\# Test formatting of time of day" puts $f2 "\# Format groups tested: %H %OH %I %OI %k %Ok %l %Ol %M %OM %p %P %r %R %S %OS %T %X %EX %+" puts $f2 {} - + set i 0 set fmt "%H %OH %I %OI %k %Ok %l %Ol %M %OM %p %P %r %R %S %OS %T %X %EX %+" - foreach { h romanH I romanI am } { - 0 ? 12 xii AM - 1 i 1 i AM - 11 xi 11 xi AM - 12 xii 12 xii PM - 13 xiii 1 i PM + foreach { h romanH I romanI am } { + 0 ? 12 xii AM + 1 i 1 i AM + 11 xi 11 xi AM + 12 xii 12 xii PM + 13 xiii 1 i PM 23 xxiii 11 xi PM } { set hh [format %02d $h] @@ -547,7 +547,7 @@ proc testcases4 { f2 } { puts "testcases4: $i test cases." } - + #---------------------------------------------------------------------- # # testcases5 -- @@ -572,9 +572,9 @@ proc testcases5 { f2 } { puts $f2 {} puts $f2 "\# Test formatting of Daylight Saving Time" puts $f2 {} - + set fmt {%H:%M:%S %z %Z} - + set i 0 puts $f2 "test clock-5.[incr i] {does Detroit exist} {" puts $f2 " clock format 0 -format {} -timezone :America/Detroit" @@ -587,7 +587,7 @@ proc testcases5 { f2 } { puts $f2 " concat {ok}" puts $f2 " }" puts $f2 "} ok" - + foreach row $TZData(:America/Detroit) { foreach { t offset isdst tzname } $row break if { $t > -4000000000000 } { @@ -648,12 +648,12 @@ proc testcases5 { f2 } { proc testcases8 { f2 } { # Put out a header describing the tests - + puts $f2 "" puts $f2 "\# Test parsing of ccyymmdd" puts $f2 "" - - set n 0 + + set n 0 foreach year {1970 1971 2000 2001} { foreach month {01 12} { foreach day {02 31} { @@ -670,7 +670,7 @@ proc testcases8 { f2 } { puts $f2 "} $scanned" } } - } + } foreach fmt {%x %D} { set string [clock format $scanned \ -format $fmt \ @@ -708,11 +708,11 @@ proc testcases8 { f2 } { proc testcases11 { f2 } { # Put out a header describing the tests - + puts $f2 "" puts $f2 "\# Test precedence among yyyymmdd and yyyyddd" puts $f2 "" - + array set v { Y 1970 m 01 @@ -771,12 +771,12 @@ proc testcases11 { f2 } { proc testcases12 { f2 } { # Put out a header describing the tests - + puts $f2 "" puts $f2 "\# Test parsing of ccyyWwwd" puts $f2 "" - - set n 0 + + set n 0 foreach year {1970 1971 2000 2001} { foreach month {01 12} { foreach day {02 31} { @@ -817,12 +817,12 @@ proc testcases12 { f2 } { proc testcases14 { f2 } { # Put out a header describing the tests - + puts $f2 "" puts $f2 "\# Test parsing of yymmdd" puts $f2 "" - - set n 0 + + set n 0 foreach year {1938 1970 2000 2037} { foreach month {01 12} { foreach day {02 31} { @@ -839,7 +839,7 @@ proc testcases14 { f2 } { puts $f2 "} $scanned" } } - } + } } } } @@ -868,12 +868,12 @@ proc testcases14 { f2 } { proc testcases17 { f2 } { # Put out a header describing the tests - + puts $f2 "" puts $f2 "\# Test parsing of yyWwwd" puts $f2 "" - - set n 0 + + set n 0 foreach year {1970 1971 2000 2001} { foreach month {01 12} { foreach day {02 31} { @@ -914,12 +914,12 @@ proc testcases17 { f2 } { proc testcases19 { f2 } { # Put out a header describing the tests - + puts $f2 "" puts $f2 "\# Test parsing of mmdd" puts $f2 "" - - set n 0 + + set n 0 foreach year {1938 1970 2000 2037} { set base [clock scan ${year}0101 -gmt true] foreach month {01 12} { @@ -935,7 +935,7 @@ proc testcases19 { f2 } { puts $f2 " [list clock scan $string -format [list $mm $dd] -locale en_US_roman -base $base -gmt 1]" puts $f2 "} $scanned" } - } + } } } } @@ -964,12 +964,12 @@ proc testcases19 { f2 } { proc testcases22 { f2 } { # Put out a header describing the tests - + puts $f2 "" puts $f2 "\# Test parsing of Wwwd" puts $f2 "" - - set n 0 + + set n 0 foreach year {1970 1971 2000 2001} { set base [clock scan ${year}0104 -gmt true] foreach month {03 10} { @@ -1011,12 +1011,12 @@ proc testcases22 { f2 } { proc testcases24 { f2 } { # Put out a header describing the tests - + puts $f2 "" puts $f2 "\# Test parsing of naked day-of-month" puts $f2 "" - - set n 0 + + set n 0 foreach year {1970 2000} { foreach month {01 12} { set base [clock scan ${year}${month}01 -gmt true] @@ -1030,7 +1030,7 @@ proc testcases24 { f2 } { puts $f2 "test clock-24.[incr n] {parse naked day of month} {" puts $f2 " [list clock scan $string -format $dd -locale en_US_roman -base $base -gmt 1]" puts $f2 "} $scanned" - } + } } } } @@ -1059,12 +1059,12 @@ proc testcases24 { f2 } { proc testcases26 { f2 } { # Put out a header describing the tests - + puts $f2 "" puts $f2 "\# Test parsing of naked day of week" puts $f2 "" - - set n 0 + + set n 0 foreach year {1970 2001} { foreach week {01 52} { set base [clock scan ${year}W${week}4 \ @@ -1108,7 +1108,7 @@ proc testcases26 { f2 } { proc testcases29 { f2 } { # Put out a header describing the tests - + puts $f2 "" puts $f2 "\# Test parsing of time of day" puts $f2 "" @@ -1172,7 +1172,7 @@ proc testcases29 { f2 } { } } } - + } puts "testcases29: $n test cases" } diff --git a/tools/man2help.tcl b/tools/man2help.tcl index 018fa84..ca29226 100644 --- a/tools/man2help.tcl +++ b/tools/man2help.tcl @@ -36,7 +36,7 @@ proc generateContents {basename version files} { set lastTopic {} foreach topic [getTopics $package $section] { if {[string compare $lastTopic $topic]} { - set id $topics($package,$section,$topic) + set id $topics($package,$section,$topic) puts $fd "2 $topic=$id" set lastTopic $topic } diff --git a/tools/man2help2.tcl b/tools/man2help2.tcl index 75f4249..91c81be 100644 --- a/tools/man2help2.tcl +++ b/tools/man2help2.tcl @@ -12,7 +12,7 @@ # Global variables used by these scripts: # # state - state variable that controls action of text proc. -# +# # topics - array indexed by (package,section,topic) with value # of topic ID. # @@ -157,7 +157,7 @@ proc text {string} { "\t" {\tab } \ '' "\\rdblquote " \ `` "\\ldblquote " \ - "\u00b7" "\\bullet " \ + "\xB7" "\\bullet " \ ] $string] # Check if this is the beginning of an international character string. @@ -176,12 +176,12 @@ proc text {string} { } switch $state(textState) { - REF { + REF { if {$state(inTP) == 0} { set string [insertRef $string] } } - SEE { + SEE { global topics curPkg curSect foreach i [split $string] { if {![regexp -nocase {^[a-z_0-9]+} [string trim $i] i ]} { @@ -231,7 +231,7 @@ proc insertRef {string} { } } - if {($ref != {}) && ($ref != $curID)} { + if {($ref != "") && ($ref != $curID)} { set string [link $string $ref] } return $string @@ -273,7 +273,7 @@ proc macro {name args} { # next page and previous page } br { - lineBreak + lineBreak } BS {} BE {} @@ -388,12 +388,12 @@ proc macro {name args} { set state(noFill) 1 } so { - if {$args != "man.macros"} { + if {$args ne "man.macros"} { puts stderr "Unknown macro: .$name [join $args " "]" } } sp { ;# needs work - if {$args == ""} { + if {$args eq ""} { set count 1 } else { set count [lindex $args 0] @@ -472,14 +472,14 @@ proc font {type} { P - R { endFont - if {$state(textState) == "REF"} { + if {$state(textState) eq "REF"} { set state(textState) INSERT } } C - B { beginFont Code - if {$state(textState) == "INSERT"} { + if {$state(textState) eq "INSERT"} { set state(textState) REF } } @@ -507,7 +507,7 @@ proc font {type} { proc formattedText {text} { global chars - while {$text != ""} { + while {$text ne ""} { set index [string first \\ $text] if {$index < 0} { text $text @@ -709,11 +709,15 @@ proc char {name} { textSetup puts -nonewline $file "\\'a9 " } + {\(mi} { + textSetup + puts -nonewline $file "-" + } {\(mu} { textSetup puts -nonewline $file "\\'d7 " } - {\(em} { + {\(em} - {\(en} { textSetup puts -nonewline $file "-" } @@ -760,7 +764,7 @@ proc SHmacro {argList {style section}} { } # control what the text proc does with text - + switch $args { NAME {set state(textState) NAME} DESCRIPTION {set state(textState) INSERT} @@ -820,10 +824,10 @@ proc IPmacro {argList} { set indent 5 } if {$text == {\(bu}} { - set text "\u00b7" + set text "\xB7" } - set tab [expr $indent * 0.1]i + set tab [expr {$indent * 0.1}]i newPara $tab -$tab set state(sb) 80 setTabs $tab @@ -885,7 +889,7 @@ proc THmacro {argList} { set curVer [lindex $argList 2] ;# 7.4 set curPkg [lindex $argList 3] ;# Tcl set curSect [lindex $argList 4] ;# {Tcl Library Procedures} - + regsub -all {\\ } $curSect { } curSect ;# Clean up for [incr\ Tcl] puts $file "#{\\footnote $curID}" ;# Context string @@ -950,7 +954,7 @@ proc newPara {leftIndent {firstIndent 0i}} { if $state(paragraph) { puts -nonewline $file "\\line\n" } - if {$leftIndent != ""} { + if {$leftIndent ne ""} { set state(leftIndent) [expr {$state(leftMargin) \ + ($state(offset) * $state(nestingLevel)) \ + [getTwips $leftIndent]}] @@ -1020,7 +1024,7 @@ proc incrNestingLevel {} { proc decrNestingLevel {} { global state - + if {$state(nestingLevel) == 0} { puts stderr "Nesting level decremented below 0" } else { diff --git a/tools/man2html.tcl b/tools/man2html.tcl index 444462b..2d03ab6 100644 --- a/tools/man2html.tcl +++ b/tools/man2html.tcl @@ -25,8 +25,8 @@ proc sarray {file args} { if {![array exists array]} { puts "sarray: \"$a\" isn't an array" break - } - + } + foreach name [lsort [array names array]] { regsub -all " " $name "\\ " name1 puts $file "set ${a}($name1) \{$array($name)\}" @@ -139,12 +139,12 @@ proc main {argv} { foreach package $packages { file mkdir $html_dir/$package - + # build hyperlink database arrays: NAME_file and KEY_file # puts "\nScanning man pages in $tcl_dir/$package/doc..." uplevel \#0 [list source $homeDir/man2html1.tcl] - + doDir $tcl_dir/$package/doc # clean up the NAME_file and KEY_file database arrays diff --git a/tools/man2html1.tcl b/tools/man2html1.tcl index a668e1b..64982ff 100644 --- a/tools/man2html1.tcl +++ b/tools/man2html1.tcl @@ -8,7 +8,7 @@ # Global variables used by these scripts: # # state - state variable that controls action of text proc. -# +# # curFile - tail of current man page. # # file - file pointer; for both xref.tcl and contents.html @@ -21,7 +21,7 @@ # # lib - contains package name. Used to label section in contents.html # -# inDT - in dictionary term. +# inDT - in dictionary term. # text -- @@ -30,7 +30,7 @@ # and KEY_file. # # DT: might do this: if first word of $dt matches $name and [llength $name==1] -# and [llength $dt > 1], then add to NAME_file. +# and [llength $dt > 1], then add to NAME_file. # # Arguments: # string - Text to index. @@ -84,7 +84,7 @@ proc macro {name args} { KEYWORDS {set state KEY} default {set state OFF} } - + } TP { global inDT @@ -136,7 +136,7 @@ proc newline {} { # initGlobals, tab, font, char, macro2 -- # -# These procedures do nothing during the first pass. +# These procedures do nothing during the first pass. # # Arguments: # None. @@ -212,9 +212,9 @@ proc doListing {file pattern} { proc doContents {file packageName} { global footer - + set file [open $file w] - + puts $file "$packageName Manual" puts $file "

$packageName

" doListing $file "*.1" @@ -235,8 +235,8 @@ proc doContents {file packageName} { # # This is the toplevel procedure that searches a man page # for hypertext links. It builds a data base consisting of -# two arrays: NAME_file and KEY file. It runs the man2tcl -# program to turn the man page into a script, then it evals +# two arrays: NAME_file and KEY file. It runs the man2tcl +# program to turn the man page into a script, then it evals # that script. # # Arguments: diff --git a/tools/man2html2.tcl b/tools/man2html2.tcl index e4ccedf..8483204 100644 --- a/tools/man2html2.tcl +++ b/tools/man2html2.tcl @@ -114,9 +114,9 @@ proc text string { set pos [string first "\t" $string] if {$pos >= 0} { - text [string range $string 0 [expr $pos-1]] + text [string range $string 0 [expr {$pos-1}]] tab - text [string range $string [expr $pos+1] end] + text [string range $string [expr {$pos+1}] end] return } if {$inTable} { @@ -471,27 +471,27 @@ proc formattedText text { text $text return } - text [string range $text 0 [expr $index-1]] - set c [string index $text [expr $index+1]] + text [string range $text 0 [expr {$index-1}]] + set c [string index $text [expr {$index+1}]] switch -- $c { f { - font [string index $text [expr $index+2]] - set text [string range $text [expr $index+3] end] + font [string index $text [expr {$index+2}]] + set text [string range $text [expr {$index+3}] end] } e { text \\ - set text [string range $text [expr $index+2] end] + set text [string range $text [expr {$index+2}] end] } - { dash - set text [string range $text [expr $index+2] end] + set text [string range $text [expr {$index+2}] end] } | { - set text [string range $text [expr $index+2] end] + set text [string range $text [expr {$index+2}] end] } default { puts stderr "Unknown sequence: \\$c" - set text [string range $text [expr $index+2] end] + set text [string range $text [expr {$index+2}] end] } } } @@ -527,7 +527,7 @@ proc tab {} { global inPRE charCnt tabString file # ? charCnt if {$inPRE == 1} { - set pos [expr $charCnt % [string length $tabString] ] + set pos [expr {$charCnt % [string length $tabString]}] set spaces [string first "1" [string range $tabString $pos end] ] text [format "%*s" [incr spaces] " "] } else { diff --git a/tools/mkdepend.tcl b/tools/mkdepend.tcl index de5fdba..b1ad076 100644 --- a/tools/mkdepend.tcl +++ b/tools/mkdepend.tcl @@ -10,20 +10,20 @@ # above copyright notice and the following two paragraphs appear in # all copies of this software. # -# IN NO EVENT SHALL THE AUTHOR BE LIABLE TO ANY PARTY FOR DIRECT, INDIRECT, -# SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OF -# THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE AUTHOR HAS BEEN ADVISED +# IN NO EVENT SHALL THE AUTHOR BE LIABLE TO ANY PARTY FOR DIRECT, INDIRECT, +# SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OF +# THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE AUTHOR HAS BEEN ADVISED # OF THE POSSIBILITY OF SUCH DAMAGE. # -# THE AUTHOR SPECIFICALLY DISCLAIMS ANY WARRANTIES, INCLUDING, BUT NOT -# LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A -# PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS ON AN "AS IS" +# THE AUTHOR SPECIFICALLY DISCLAIMS ANY WARRANTIES, INCLUDING, BUT NOT +# LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +# PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS ON AN "AS IS" # BASIS, AND THE AUTHOR HAS NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, # UPDATES, ENHANCEMENTS, OR MODIFICATIONS. #============================================================================== # # Modified heavily by David Gravereaux about 9/17/2006. -# Original can be found @ +# Original can be found @ # http://web.archive.org/web/20070616205924/http://www.doc.ic.ac.uk/~np2/software/mkdepend.html #============================================================================== @@ -88,7 +88,7 @@ proc readDepends {chan} { set line "" array set depends {} - while {[gets $chan line] != -1} { + while {[gets $chan line] >= 0} { if {[regexp {^#line [0-9]+ \"(.*)\"$} $line dummy fname] != 0} { set fname [file normalize $fname] if {![info exists target]} { @@ -98,7 +98,7 @@ proc readDepends {chan} { } else { # don't include ourselves as a dependency of ourself. if {![string compare $fname $target]} {continue} - # store in an array so multiple occurances are not counted. + # store in an array so multiple occurrences are not counted. set depends($target|$fname) "" } } diff --git a/tools/regexpTestLib.tcl b/tools/regexpTestLib.tcl index 86f2a3e..8379159 100644 --- a/tools/regexpTestLib.tcl +++ b/tools/regexpTestLib.tcl @@ -17,13 +17,13 @@ proc readInputFile {} { set len [string length $line] - if {($len > 0) && ([string index $line [expr $len - 1]] == "\\")} { + if {($len > 0) && ([string index $line [expr {$len - 1}]] == "\\")} { if {[info exists lineArray(c$i)] == 0} { set lineArray(c$i) 1 } else { incr lineArray(c$i) } - set line [string range $line 0 [expr $len - 2]] + set line [string range $line 0 [expr {$len - 2}]] append lineArray($i) $line continue } @@ -43,7 +43,7 @@ proc readInputFile {} { # # strings with embedded @'s are truncated # unpreceeded @'s are replaced by {} -# +# proc removeAts {ls} { set len [llength $ls] set newLs {} @@ -94,7 +94,7 @@ proc writeOutputFile {numLines fcn} { global outFileName global lineArray - # open output file and write file header info to it. + # open output file and write file header info to it. set fileId [open $outFileName w] @@ -133,7 +133,7 @@ proc writeOutputFile {numLines fcn} { puts $fileId $currentLine incr srcLineNum $lineArray(c$lineNum) incr lineNum - continue + continue } set len [llength $currentLine] @@ -144,7 +144,7 @@ proc writeOutputFile {numLines fcn} { puts $fileId "\n" incr srcLineNum $lineArray(c$lineNum) incr lineNum - continue + continue } if {($len < 3)} { puts "warning: test is too short --\n\t$currentLine" @@ -204,26 +204,26 @@ proc convertTestLine {currentLine len lineNum srcLineNum} { # find the test result - set numVars [expr $len - 3] + set numVars [expr {$len - 3}] set vars {} set vals {} set result 0 set v 0 - + if {[regsub {\*} "$flags" "" newFlags] == 1} { # an error is expected - + if {[string compare $str "EMPTY"] == 0} { # empty regexp is not an error # skip this test - + return "\# skipping the empty-re test from line $srcLineNum\n" } set flags $newFlags set result "\{1 \{[convertErrCode $str]\}\}" } elseif {$numVars > 0} { # at least 1 match is made - + if {[regexp {s} $flags] == 1} { set result "\{0 1\}" } else { @@ -240,7 +240,7 @@ proc convertTestLine {currentLine len lineNum srcLineNum} { } } else { # no match is made - + set result "\{0 0\}" } @@ -248,16 +248,16 @@ proc convertTestLine {currentLine len lineNum srcLineNum} { set cmd [prepareCmd $flags $re $str $vars $noBraces] if {$cmd == -1} { - return "\# skipping test with metasyntax from line $srcLineNum\n" + return "\# skipping test with metasyntax from line $srcLineNum\n" } set test "test regexp-1.$srcLineNum \{converted from line $srcLineNum\} \{\n" append test "\tcatch {unset var}\n" - append test "\tlist \[catch \{ \n" - append test "\t\tset match \[$cmd\] \n" - append test "\t\tlist \$match $vals \n" - append test "\t\} msg\] \$msg \n" - append test "\} $result \n" + append test "\tlist \[catch \{\n" + append test "\t\tset match \[$cmd\]\n" + append test "\t\tlist \$match $vals\n" + append test "\t\} msg\] \$msg\n" + append test "\} $result\n" return $test } diff --git a/tools/tclZIC.tcl b/tools/tclZIC.tcl index 1fa34be..85c9ba9 100755 --- a/tools/tclZIC.tcl +++ b/tools/tclZIC.tcl @@ -356,7 +356,7 @@ proc parseON {on} { # third possibility - lastWeekday - field 5 last([[:alpha:]]+) )$ - } $on -> dom1 wday2 dir2 num2 wday3]} then { + } $on -> dom1 wday2 dir2 num2 wday3]} { error "can't parse ON field \"$on\"" } if {$dom1 ne ""} { @@ -507,7 +507,7 @@ proc parseTOD {tod} { (?: ([wsugz]) # field 4 - type indicator )? - } $tod -> hour minute second ind]} then { + } $tod -> hour minute second ind]} { puts stderr "$fileName:$lno:can't parse time field \"$tod\"" incr errorCount } @@ -556,7 +556,7 @@ proc parseOffsetTime {offset} { :([[:digit:]]{2}) # field 4 - second )? )? - } $offset -> signum hour minute second]} then { + } $offset -> signum hour minute second]} { puts stderr "$fileName:$lno:can't parse offset time \"$offset\"" incr errorCount } @@ -938,7 +938,7 @@ proc applyRules {ruleSet year startSecs stdGMTOffset DSTOffset nextGMTOffset if { $earliestSecs > $startSecs && ($until eq "" || $earliestSecs < $untilSecs) - } then { + } { # Test if the initial transition has been done. # If not, do it now. @@ -987,7 +987,7 @@ proc applyRules {ruleSet year startSecs stdGMTOffset DSTOffset nextGMTOffset set date [::tcl::clock::GetJulianDayFromEraYearMonthDay \ [dict create era CE year $year month 1 dayOfMonth 1] 2361222] set startSecs [expr { - [dict get $date julianDay] * wide(86400) - 210866803200 + [dict get $date julianDay] * wide(86400) - 210866803200 - $stdGMTOffset - $DSTOffset }] diff --git a/tools/tcltk-man2html.tcl b/tools/tcltk-man2html.tcl index 04891eb..a09bf79 100755 --- a/tools/tcltk-man2html.tcl +++ b/tools/tcltk-man2html.tcl @@ -1427,7 +1427,7 @@ proc output-directive {line} { } ## ## merge copyright listings -## +## proc merge-copyrights {l1 l2} { set merge {} set re1 {^Copyright +(?:\(c\)|\\\(co|©) +(\w.*?)(?:all rights reserved)?(?:\. )*$} diff --git a/tools/uniParse.tcl b/tools/uniParse.tcl index a451096..545afc4 100644 --- a/tools/uniParse.tcl +++ b/tools/uniParse.tcl @@ -68,7 +68,7 @@ proc uni::getGroup {value} { variable groups set gIndex [lsearch -exact $groups $value] - if {$gIndex == -1} { + if {$gIndex < 0} { set gIndex [llength $groups] lappend groups $value } @@ -81,7 +81,7 @@ proc uni::addPage {info} { variable shift set pIndex [lsearch -exact $pages $info] - if {$pIndex == -1} { + if {$pIndex < 0} { set pIndex [llength $pages] lappend pages $info } -- cgit v0.12 From 107d130ce3db87a24b5136c006f32136b60d079c Mon Sep 17 00:00:00 2001 From: pooryorick Date: Sun, 20 Sep 2020 10:38:41 +0000 Subject: Make the check to avoid generating a string representation in [uplevel] a little less intrusive. --- generic/tclInt.h | 3 +++ generic/tclProc.c | 30 ++++++++++++++---------------- 2 files changed, 17 insertions(+), 16 deletions(-) diff --git a/generic/tclInt.h b/generic/tclInt.h index 46ba764..9629709 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -4376,6 +4376,9 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file, objPtr->bytes = NULL; \ } +#define TclHasStringRep(objPtr) \ + objPtr->bytes != NULL + /* *---------------------------------------------------------------- * Macros used by the Tcl core to grow Tcl_Token arrays. They use the same diff --git a/generic/tclProc.c b/generic/tclProc.c index 0313b29..56757ff 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -898,7 +898,6 @@ TclNRUplevelObjCmd( Interp *iPtr = (Interp *) interp; CmdFrame *invoker = NULL; int word = 0; - int havelevel = 0; int result; CallFrame *savedVarFramePtr, *framePtr; Tcl_Obj *objPtr; @@ -912,7 +911,7 @@ TclNRUplevelObjCmd( uplevelSyntax: Tcl_WrongNumArgs(interp, 1, objv, "?level? command ?arg ...?"); return TCL_ERROR; - } else if (objc == 2) { + } else if (!TclHasStringRep(objv[1]) && objc == 2) { int status ,llength; status = Tcl_ListObjLength(interp, objv[1], &llength); if (status == TCL_OK && llength > 1) { @@ -922,28 +921,27 @@ TclNRUplevelObjCmd( if (result == -1) { return TCL_ERROR; } - havelevel = 1; objc -= 1; objv += 1; + goto havelevel; } } - if (!havelevel) { - /* - * Find the level to use for executing the command. - */ + /* + * Find the level to use for executing the command. + */ - result = TclObjGetFrame(interp, objv[1], &framePtr); - if (result == -1) { - return TCL_ERROR; - } - objc -= result + 1; - if (objc == 0) { - goto uplevelSyntax; - } - objv += result + 1; + result = TclObjGetFrame(interp, objv[1], &framePtr); + if (result == -1) { + return TCL_ERROR; + } + objc -= result + 1; + if (objc == 0) { + goto uplevelSyntax; } + objv += result + 1; + havelevel: /* * Modify the interpreter state to execute in the given frame. -- cgit v0.12 From 7a56ff406f3244d777f60d9a5e0da1e5e08f3ef9 Mon Sep 17 00:00:00 2001 From: dgp Date: Sun, 20 Sep 2020 15:53:37 +0000 Subject: Silence compiler warning -- fix safety of macro. --- generic/tclInt.h | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclInt.h b/generic/tclInt.h index 9629709..3dbffeb 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -4377,7 +4377,7 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file, } #define TclHasStringRep(objPtr) \ - objPtr->bytes != NULL + (objPtr->bytes != NULL) /* *---------------------------------------------------------------- -- cgit v0.12 From 9e43cbb9739ecfd05d38ff31a49050a0eb04505b Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 20 Sep 2020 21:32:35 +0000 Subject: Improve TclInvalidateStringRep() macro such that (objPtr) is only evaluated once. Addation brackets in TclHasStringRep() macro --- generic/tcl.h | 2 +- generic/tclInt.h | 15 +++++++++------ 2 files changed, 10 insertions(+), 7 deletions(-) diff --git a/generic/tcl.h b/generic/tcl.h index 458072a..914f62b 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -2517,7 +2517,7 @@ EXTERN void Tcl_GetMemoryInfo(Tcl_DString *dsPtr); # define Tcl_DecrRefCount(objPtr) \ do { \ Tcl_Obj *_objPtr = (objPtr); \ - if ((_objPtr)->refCount-- <= 1) { \ + if (_objPtr->refCount-- <= 1) { \ TclFreeObj(_objPtr); \ } \ } while(0) diff --git a/generic/tclInt.h b/generic/tclInt.h index 3dbffeb..f2f097c 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -4369,15 +4369,18 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file, */ #define TclInvalidateStringRep(objPtr) \ - if (objPtr->bytes != NULL) { \ - if (objPtr->bytes != tclEmptyStringRep) { \ - ckfree((char *) objPtr->bytes); \ + do { \ + Tcl_Obj *_isobjPtr = (Tcl_Obj *)(objPtr); \ + if (_isobjPtr->bytes != NULL) { \ + if (_isobjPtr->bytes != tclEmptyStringRep) { \ + ckfree((char *)_isobjPtr->bytes); \ + } \ + _isobjPtr->bytes = NULL; \ } \ - objPtr->bytes = NULL; \ - } + } while (0) #define TclHasStringRep(objPtr) \ - (objPtr->bytes != NULL) + ((objPtr)->bytes != NULL) /* *---------------------------------------------------------------- -- cgit v0.12 From 3ee0402bd5245e265b10cff5f2bdb7c0f135ed6f Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 23 Sep 2020 05:57:35 +0000 Subject: Let's see if we can recover from an occasional hickup like happened here: [https://travis-ci.org/github/tcltk/tcl/jobs/729226819] --- .travis.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.travis.yml b/.travis.yml index 7f93fa0..53e0bac 100644 --- a/.travis.yml +++ b/.travis.yml @@ -332,5 +332,5 @@ install: before_script: - export ERROR_ON_FAILURES=1 script: - - make all tcltest + - make all tcltest || echo "Something wrong, maybe a hickup, let's try again" - make test -- cgit v0.12 From e4fcd7152b8701ae9adbf0cc608572d7f253e2c3 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 24 Sep 2020 06:41:04 +0000 Subject: Add gcc-10 build to Travis --- .travis.yml | 30 ++++++++---------------------- 1 file changed, 8 insertions(+), 22 deletions(-) diff --git a/.travis.yml b/.travis.yml index 53e0bac..ac27dd2 100644 --- a/.travis.yml +++ b/.travis.yml @@ -1,6 +1,8 @@ language: c addons: apt: + sources: + - ubuntu-toolchain-r-test packages: - binutils-mingw-w64-i686 - binutils-mingw-w64-x86-64 @@ -11,7 +13,7 @@ addons: - gcc-multilib jobs: include: -# Testing on Linux with various compilers +# Testing on Linux GCC - name: "Linux/GCC/Shared" os: linux dist: focal @@ -60,29 +62,15 @@ jobs: env: - BUILD_DIR=unix - CFGOPT="--enable-symbols=mem" -# Older versions of GCC... - - name: "Linux/GCC 7/Shared" +# Newer/Older versions of GCC + - name: "Linux/GCC 10/Shared" os: linux dist: focal - compiler: gcc-7 + compiler: gcc-10 addons: apt: - sources: - - ubuntu-toolchain-r-test packages: - - g++-7 - env: - - BUILD_DIR=unix - - name: "Linux/GCC 6/Shared" - os: linux - dist: bionic - compiler: gcc-6 - addons: - apt: - sources: - - ubuntu-toolchain-r-test - packages: - - g++-6 + - g++-10 env: - BUILD_DIR=unix - name: "Linux/GCC 5/Shared" @@ -91,13 +79,11 @@ jobs: compiler: gcc-5 addons: apt: - sources: - - ubuntu-toolchain-r-test packages: - g++-5 env: - BUILD_DIR=unix -# Clang +# Testing on Linux Clang - name: "Linux/Clang/Shared" os: linux dist: focal -- cgit v0.12 From 9d34b872ced6c6713cf84f914f11a017ecd2cd49 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 25 Sep 2020 11:09:08 +0000 Subject: When sourcing script files (even when simulating that through open|read), always set -eofchar \032 just like the source command does. Possible security issue: this could make it possible to evaluate hidden content at the end of pkgIndex files. --- library/auto.tcl | 2 ++ library/init.tcl | 1 + 2 files changed, 3 insertions(+) diff --git a/library/auto.tcl b/library/auto.tcl index 6cb09b6..32a5f52 100644 --- a/library/auto.tcl +++ b/library/auto.tcl @@ -248,6 +248,7 @@ proc auto_mkindex_old {dir args} { set f "" set error [catch { set f [open $file] + fconfigure $f -eofchar \032 while {[gets $f line] >= 0} { if {[regexp {^proc[ ]+([^ ]*)} $line match procName]} { set procName [lindex [auto_qualify $procName "::"] 0] @@ -351,6 +352,7 @@ proc auto_mkindex_parser::mkindex {file} { set scriptFile $file set fid [open $file] + fconfigure $fid -eofchar \032 set contents [read $fid] close $fid diff --git a/library/init.tcl b/library/init.tcl index 0a5e71b..6e4cf89 100644 --- a/library/init.tcl +++ b/library/init.tcl @@ -501,6 +501,7 @@ proc auto_load_index {} { continue } else { set error [catch { + fconfigure $f -eofchar \032 set id [gets $f] if {$id eq "# Tcl autoload index file, version 2.0"} { eval [read $f] -- cgit v0.12 From 67f864dc656ad9a88f134514172bc55a2c73c3d5 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 25 Sep 2020 14:24:24 +0000 Subject: It's "utf-8", not "utf8" or "UTF8" --- ChangeLog.2001 | 2 +- ChangeLog.2002 | 2 +- ChangeLog.2004 | 4 ++-- tests/string.test | 6 +++--- tests/stringComp.test | 4 ++-- tests/util.test | 12 ++++++------ tests/winDde.test | 4 ++-- 7 files changed, 17 insertions(+), 17 deletions(-) diff --git a/ChangeLog.2001 b/ChangeLog.2001 index 06e7c36..9d6d541 100644 --- a/ChangeLog.2001 +++ b/ChangeLog.2001 @@ -351,7 +351,7 @@ * mac/tclMacFile.c: fixed bug in permission checking code - * mac/tclMacLoad.c: corrected utf8 handling, comparison of package + * mac/tclMacLoad.c: corrected utf-8 handling, comparison of package names to code fragment names changed to only match on the length of package name, this allows for fragment names with version numbers appended. diff --git a/ChangeLog.2002 b/ChangeLog.2002 index 9931657..fa31e42 100644 --- a/ChangeLog.2002 +++ b/ChangeLog.2002 @@ -1753,7 +1753,7 @@ 2002-07-05 Reinhard Max - * generic/tclClock.c (FormatClock): Convert the format string to UTF8 + * generic/tclClock.c (FormatClock): Convert the format string to utf-8 before calling TclpStrftime, so that non-ASCII characters don't get mangled when the result string is being converted back. * tests/clock.test: Added a test for that. diff --git a/ChangeLog.2004 b/ChangeLog.2004 index daf124f..f7da18d 100644 --- a/ChangeLog.2004 +++ b/ChangeLog.2004 @@ -2302,7 +2302,7 @@ 934511]. * doc/CrtCommand.3: Added note that the arguments given to the command - proc of a Tcl_CreateCommand are in utf8 since Tcl 8.1. Closing [Patch + proc of a Tcl_CreateCommand are in utf-8 since Tcl 8.1. Closing [Patch 414778]. * doc/ChnlStack.3: Removed the declaration that the interp argument to @@ -2873,7 +2873,7 @@ 2004-06-02 Jeff Hobbs * win/tclWinFile.c (TclpFindExecutable): when using GetModuleFileNameA - (Win9x), convert from CP_ACP to WCHAR then convert back to utf8. + (Win9x), convert from CP_ACP to WCHAR then convert back to utf-8. Adjunct to 2004-04-07 fix. 2004-06-02 David Gravereaux diff --git a/tests/string.test b/tests/string.test index dabe3a4..12108ca 100644 --- a/tests/string.test +++ b/tests/string.test @@ -71,11 +71,11 @@ test string-2.11 {string compare, unicode} { string compare ab\u7266 ab\u7267 } -1 test string-2.12 {string compare, high bit} { - # This test will fail if the underlying comparaison + # This test will fail if the underlying comparison # is using signed chars instead of unsigned chars. # (like SunOS's default memcmp thus the compat/memcmp.c) string compare "\x80" "@" - # Nb this tests works also in utf8 space because \x80 is + # Nb this tests works also in utf-8 space because \x80 is # translated into a 2 or more bytelength but whose first byte has # the high bit set. } 1 @@ -2034,7 +2034,7 @@ test string-28.12 {tcl::prefix longest} { tcl::prefix longest {apa {} appa} {} } {} test string-28.13 {tcl::prefix longest} { - # Test UTF8 handling + # Test utf-8 handling tcl::prefix longest {ax\x90 bep ax\x91} a } ax diff --git a/tests/stringComp.test b/tests/stringComp.test index 1cd0193..a17390d 100644 --- a/tests/stringComp.test +++ b/tests/stringComp.test @@ -100,11 +100,11 @@ foreach {tname tbody tresult tcode} { {unicode} {string compare \334 \u00fc} -1 {} {unicode} {string compare \334\334\334\374\374 \334\334\334\334\334} 1 {} {high bit} { - # This test will fail if the underlying comparaison + # This test will fail if the underlying comparison # is using signed chars instead of unsigned chars. # (like SunOS's default memcmp thus the compat/memcmp.c) string compare "\x80" "@" - # Nb this tests works also in utf8 space because \x80 is + # Nb this tests works also in utf-8 space because \x80 is # translated into a 2 or more bytelength but whose first byte has # the high bit set. } {1} {} diff --git a/tests/util.test b/tests/util.test index a7d21f1..c8a081b 100644 --- a/tests/util.test +++ b/tests/util.test @@ -472,7 +472,7 @@ test util-7.4 {TclPrecTraceProc - write traces, bogus values} -setup { } -result {1 {can't set "tcl_precision": improper value for precision} 12} # This test always succeeded in the C locale anyway... -test util-8.1 {TclNeedSpace - correct UTF8 handling} { +test util-8.1 {TclNeedSpace - correct utf-8 handling} { # Bug 411825 # Note that this test relies on the fact that # [interp target] calls on Tcl_AppendElement() @@ -486,7 +486,7 @@ test util-8.1 {TclNeedSpace - correct UTF8 handling} { interp delete \u5420 set result } "\u5420 foo" -test util-8.2 {TclNeedSpace - correct UTF8 handling} testdstring { +test util-8.2 {TclNeedSpace - correct utf-8 handling} testdstring { # Bug 411825 # This tests the same bug as the previous test, but # should be more future-proof, as the DString @@ -496,14 +496,14 @@ test util-8.2 {TclNeedSpace - correct UTF8 handling} testdstring { testdstring element foo llength [testdstring get] } 2 -test util-8.3 {TclNeedSpace - correct UTF8 handling} testdstring { +test util-8.3 {TclNeedSpace - correct utf-8 handling} testdstring { # Bug 411825 - new variant reported by Dossy Shiobara testdstring free testdstring append \u00A0 -1 testdstring element foo llength [testdstring get] } 2 -test util-8.4 {TclNeedSpace - correct UTF8 handling} testdstring { +test util-8.4 {TclNeedSpace - correct utf-8 handling} testdstring { # Another bug uncovered while fixing 411825 testdstring free testdstring append {\ } -1 @@ -511,13 +511,13 @@ test util-8.4 {TclNeedSpace - correct UTF8 handling} testdstring { testdstring element foo llength [testdstring get] } 2 -test util-8.5 {TclNeedSpace - correct UTF8 handling} testdstring { +test util-8.5 {TclNeedSpace - correct utf-8 handling} testdstring { testdstring free testdstring append {\\ } -1 testdstring element foo list [llength [testdstring get]] [string length [testdstring get]] } {2 6} -test util-8.6 {TclNeedSpace - correct UTF8 handling} testdstring { +test util-8.6 {TclNeedSpace - correct utf-8 handling} testdstring { testdstring free testdstring append {\\ } -1 testdstring append \{ -1 diff --git a/tests/winDde.test b/tests/winDde.test index 1c3daa5..1238102 100644 --- a/tests/winDde.test +++ b/tests/winDde.test @@ -154,8 +154,8 @@ test winDde-3.5 {DDE request locally} -constraints dde -body { dde request -binary TclEval self \xe1 } -result "foo\x00" # Set variable a to A with diaeresis (unicode C4) by relying on the fact -# that utf8 is sent (e.g. "c3 84" on the wire) -test winDde-3.6 {DDE request utf8} -constraints dde -body { +# that utf-8 is sent (e.g. "c3 84" on the wire) +test winDde-3.6 {DDE request utf-8} -constraints dde -body { set \xe1 "not set" dde execute TclEval self "set \xe1 \xc4" scan [set \xe1] %c -- cgit v0.12 From e6b8f92493a256940ee1e55c0bf5df6a60cb8760 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 25 Sep 2020 15:17:06 +0000 Subject: Build Travis with Xcode 12 and 12u (Universal Apps) --- .travis.yml | 28 ++++++++++++++++++---------- 1 file changed, 18 insertions(+), 10 deletions(-) diff --git a/.travis.yml b/.travis.yml index ac27dd2..32ccb48 100644 --- a/.travis.yml +++ b/.travis.yml @@ -112,9 +112,9 @@ jobs: - BUILD_DIR=unix - CFGOPT="--enable-symbols=mem" # Testing on Mac, various styles - - name: "macOS/Xcode 11.7/Shared" + - name: "macOS/Xcode 12/Shared" os: osx - osx_image: xcode11.7 + osx_image: xcode12 env: - BUILD_DIR=macosx install: [] @@ -122,34 +122,42 @@ jobs: - make all # The styles=develop avoids some weird problems on OSX - make test styles=develop - - name: "macOS/Xcode 11.7/Shared/Unix-like" + - name: "macOS/Xcode 12/Shared/Unix-like" os: osx - osx_image: xcode11.7 + osx_image: xcode12 env: - BUILD_DIR=unix +# Newer MacOS versions + - name: "macOS 10.15/Xcode 12/Universal Apps/Shared" + os: osx + osx_image: xcode12u + env: + - BUILD_DIR=macosx + install: [] + script: *mactest # Older MacOS versions - - name: "macOS/Xcode 11/Shared" + - name: "macOS 10.15/Xcode 11/Shared" os: osx - osx_image: xcode11 + osx_image: xcode11.7 env: - BUILD_DIR=macosx install: [] script: *mactest - - name: "macOS/Xcode 10/Shared" + - name: "macOS 10.14/Xcode 10/Shared" os: osx osx_image: xcode10.3 env: - BUILD_DIR=macosx install: [] script: *mactest - - name: "macOS/Xcode 9/Shared" + - name: "macOS 10.13/Xcode 9/Shared" os: osx - osx_image: xcode9.2 + osx_image: xcode9.4 env: - BUILD_DIR=macosx install: [] script: *mactest - - name: "macOS/Xcode 8/Shared" + - name: "macOS 10.12/Xcode 8/Shared" os: osx osx_image: xcode8.3 env: -- cgit v0.12 From 636e4d4826142fcd8b3d159eeca1c226ea25e9c6 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sat, 26 Sep 2020 18:25:56 +0000 Subject: Tweak xcode labels for Travis build --- .travis.yml | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/.travis.yml b/.travis.yml index 32ccb48..5773b5b 100644 --- a/.travis.yml +++ b/.travis.yml @@ -128,7 +128,7 @@ jobs: env: - BUILD_DIR=unix # Newer MacOS versions - - name: "macOS 10.15/Xcode 12/Universal Apps/Shared" + - name: "macOS/Xcode 12/Universal Apps/Shared" os: osx osx_image: xcode12u env: @@ -136,28 +136,28 @@ jobs: install: [] script: *mactest # Older MacOS versions - - name: "macOS 10.15/Xcode 11/Shared" + - name: "macOS/Xcode 11/Shared" os: osx osx_image: xcode11.7 env: - BUILD_DIR=macosx install: [] script: *mactest - - name: "macOS 10.14/Xcode 10/Shared" + - name: "macOS/Xcode 10/Shared" os: osx osx_image: xcode10.3 env: - BUILD_DIR=macosx install: [] script: *mactest - - name: "macOS 10.13/Xcode 9/Shared" + - name: "macOS/Xcode 9/Shared" os: osx osx_image: xcode9.4 env: - BUILD_DIR=macosx install: [] script: *mactest - - name: "macOS 10.12/Xcode 8/Shared" + - name: "macOS/Xcode 8/Shared" os: osx osx_image: xcode8.3 env: -- cgit v0.12 From f6bf85fb67eb15e637ecf7c7de4f661dc0557b43 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 28 Sep 2020 10:13:51 +0000 Subject: Make Tcl compile warning-free using -Wshadow --- generic/tclCompCmdsGR.c | 2 +- generic/tclCompExpr.c | 16 +++++++------- generic/tclExecute.c | 34 ++++++++++++++--------------- generic/tclIOUtil.c | 2 +- generic/tclListObj.c | 22 +++++++++---------- generic/tclPathObj.c | 2 +- generic/tclPkg.c | 5 +++-- generic/tclTest.c | 9 ++------ generic/tclTestObj.c | 4 ++-- generic/tclTrace.c | 39 ++++++++++++++++----------------- generic/tclVar.c | 58 ++++++++++++++++++++++++------------------------- win/tclWinFile.c | 4 +--- win/tclWinPipe.c | 2 +- win/tclWinSerial.c | 14 ++++++------ 14 files changed, 103 insertions(+), 110 deletions(-) diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index 16fafad..990be2a 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -881,7 +881,7 @@ TclCompileLappendCmd( */ if (numWords > 2) { - Tcl_Token *valueTokenPtr = TokenAfter(varTokenPtr); + valueTokenPtr = TokenAfter(varTokenPtr); CompileWord(envPtr, valueTokenPtr, interp, 2); } diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c index 0d33821..729ad52 100644 --- a/generic/tclCompExpr.c +++ b/generic/tclCompExpr.c @@ -2424,8 +2424,8 @@ CompileExprTree( if (optimize) { int length; const char *bytes = TclGetStringFromObj(literal, &length); - int index = TclRegisterNewLiteral(envPtr, bytes, length); - Tcl_Obj *objPtr = TclFetchLiteral(envPtr, index); + int idx = TclRegisterNewLiteral(envPtr, bytes, length); + Tcl_Obj *objPtr = TclFetchLiteral(envPtr, idx); if ((objPtr->typePtr == NULL) && (literal->typePtr != NULL)) { /* @@ -2445,7 +2445,7 @@ CompileExprTree( objPtr->internalRep = literal->internalRep; literal->typePtr = NULL; } - TclEmitPush(index, envPtr); + TclEmitPush(idx, envPtr); } else { /* * When optimize==0, we know the expression is a one-off and @@ -2471,7 +2471,7 @@ CompileExprTree( if (ExecConstantExprTree(interp, nodes, next, litObjvPtr) == TCL_OK) { - int index; + int idx; Tcl_Obj *objPtr = Tcl_GetObjResult(interp); /* @@ -2482,9 +2482,9 @@ CompileExprTree( if (objPtr->bytes) { Tcl_Obj *tableValue; - index = TclRegisterNewLiteral(envPtr, objPtr->bytes, + idx = TclRegisterNewLiteral(envPtr, objPtr->bytes, objPtr->length); - tableValue = TclFetchLiteral(envPtr, index); + tableValue = TclFetchLiteral(envPtr, idx); if ((tableValue->typePtr == NULL) && (objPtr->typePtr != NULL)) { /* @@ -2496,9 +2496,9 @@ CompileExprTree( objPtr->typePtr = NULL; } } else { - index = TclAddLiteralObj(envPtr, objPtr, NULL); + idx = TclAddLiteralObj(envPtr, objPtr, NULL); } - TclEmitPush(index, envPtr); + TclEmitPush(idx, envPtr); } else { TclCompileSyntaxError(interp, envPtr); } diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 4d92468..b8e9312 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -1407,7 +1407,7 @@ int Tcl_ExprObj( Tcl_Interp *interp, /* Context in which to evaluate the * expression. */ - register Tcl_Obj *objPtr, /* Points to Tcl object containing expression + Tcl_Obj *objPtr, /* Points to Tcl object containing expression * to evaluate. */ Tcl_Obj **resultPtrPtr) /* Where the Tcl_Obj* that is the expression * result is stored if no errors occur. */ @@ -1526,7 +1526,7 @@ CompileExprObj( Interp *iPtr = (Interp *) interp; CompileEnv compEnv; /* Compilation environment structure allocated * in frame. */ - register ByteCode *codePtr = NULL; + ByteCode *codePtr = NULL; /* Tcl Internal type of bytecode. Initialized * to avoid compiler warning. */ @@ -1680,8 +1680,8 @@ TclCompileObj( const CmdFrame *invoker, int word) { - register Interp *iPtr = (Interp *) interp; - register ByteCode *codePtr; /* Tcl Internal type of bytecode. */ + Interp *iPtr = (Interp *) interp; + ByteCode *codePtr; /* Tcl Internal type of bytecode. */ Namespace *namespacePtr = iPtr->varFramePtr->nsPtr; /* @@ -6806,8 +6806,8 @@ TEBCresume( if (valuePtr->typePtr == &tclBooleanType) { objResultPtr = TCONST(1); } else { - int result = (TclSetBooleanFromAny(NULL, valuePtr) == TCL_OK); - objResultPtr = TCONST(result); + int res = (TclSetBooleanFromAny(NULL, valuePtr) == TCL_OK); + objResultPtr = TCONST(res); } TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(valuePtr)), objResultPtr); NEXT_INST_F(1, 0, 1); @@ -7000,7 +7000,7 @@ TEBCresume( } { ForeachInfo *infoPtr; - Tcl_Obj *listPtr, **elements, *tmpPtr; + Tcl_Obj *listPtr, **elements; ForeachVarList *varListPtr; int numLists, iterMax, listLen, numVars; int iterTmp, iterNum, listTmpDepth; @@ -7286,8 +7286,8 @@ TEBCresume( case INST_DICT_GET: case INST_DICT_EXISTS: { - register Tcl_Interp *interp2 = interp; - register int found; + Tcl_Interp *interp2 = interp; + int found; opnd = TclGetUInt4AtPtr(pc+1); TRACE(("%u => ", opnd)); @@ -9599,7 +9599,7 @@ TclCompareTwoNumbers( static void PrintByteCodeInfo( - register ByteCode *codePtr) /* The bytecode whose summary is printed to + ByteCode *codePtr) /* The bytecode whose summary is printed to * stdout. */ { Proc *procPtr = codePtr->procPtr; @@ -9663,7 +9663,7 @@ PrintByteCodeInfo( #ifdef TCL_COMPILE_DEBUG static void ValidatePcAndStackTop( - register ByteCode *codePtr, /* The bytecode whose summary is printed to + ByteCode *codePtr, /* The bytecode whose summary is printed to * stdout. */ const unsigned char *pc, /* Points to first byte of a bytecode * instruction. The program counter. */ @@ -9906,7 +9906,7 @@ GetSrcInfoForPc( * of the command containing the pc should * be stored. */ { - register int pcOffset = (pc - codePtr->codeStart); + int pcOffset = (pc - codePtr->codeStart); int numCmds = codePtr->numCommands; unsigned char *codeDeltaNext, *codeLengthNext; unsigned char *srcDeltaNext, *srcLengthNext; @@ -10059,9 +10059,9 @@ GetExceptRangeForPc( { ExceptionRange *rangeArrayPtr; int numRanges = codePtr->numExceptRanges; - register ExceptionRange *rangePtr; + ExceptionRange *rangePtr; int pcOffset = pc - codePtr->codeStart; - register int start; + int start; if (numRanges == 0) { return NULL; @@ -10193,11 +10193,11 @@ TclExprFloatError( int TclLog2( - register int value) /* The integer for which to compute the log + int value) /* The integer for which to compute the log * base 2. */ { - register int n = value; - register int result = 0; + int n = value; + int result = 0; while (n > 1) { n = n >> 1; diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c index 6e1cb1f..513f1fb 100644 --- a/generic/tclIOUtil.c +++ b/generic/tclIOUtil.c @@ -3244,7 +3244,7 @@ Tcl_LoadFile( } if (fsPtr->loadFileProc != NULL) { - int retVal = ((Tcl_FSLoadFileProc2 *)(void *)(fsPtr->loadFileProc)) + retVal = ((Tcl_FSLoadFileProc2 *)(void *)(fsPtr->loadFileProc)) (interp, pathPtr, handlePtr, &unloadProcPtr, flags); if (retVal == TCL_OK) { diff --git a/generic/tclListObj.c b/generic/tclListObj.c index e0d7bcc..481cae7 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -420,14 +420,14 @@ TclListObjCopy( int Tcl_ListObjGetElements( Tcl_Interp *interp, /* Used to report errors if not NULL. */ - register Tcl_Obj *listPtr, /* List object for which an element array is + Tcl_Obj *listPtr, /* List object for which an element array is * to be returned. */ int *objcPtr, /* Where to store the count of objects * referenced by objv. */ Tcl_Obj ***objvPtr) /* Where to store the pointer to an array of * pointers to the list's objects. */ { - register List *listRepPtr; + List *listRepPtr; if (listPtr->typePtr != &tclListType) { int result; @@ -481,7 +481,7 @@ Tcl_ListObjGetElements( int Tcl_ListObjAppendList( Tcl_Interp *interp, /* Used to report errors if not NULL. */ - register Tcl_Obj *listPtr, /* List object to append elements to. */ + Tcl_Obj *listPtr, /* List object to append elements to. */ Tcl_Obj *elemListPtr) /* List obj with elements to append. */ { int objc; @@ -543,7 +543,7 @@ Tcl_ListObjAppendElement( Tcl_Obj *listPtr, /* List object to append objPtr to. */ Tcl_Obj *objPtr) /* Object to append to listPtr's list. */ { - register List *listRepPtr, *newPtr = NULL; + List *listRepPtr, *newPtr = NULL; int numElems, numRequired, needGrow, isShared, attempt; if (Tcl_IsShared(listPtr)) { @@ -711,11 +711,11 @@ Tcl_ListObjAppendElement( int Tcl_ListObjIndex( Tcl_Interp *interp, /* Used to report errors if not NULL. */ - register Tcl_Obj *listPtr, /* List object to index into. */ - register int index, /* Index of element to return. */ + Tcl_Obj *listPtr, /* List object to index into. */ + int index, /* Index of element to return. */ Tcl_Obj **objPtrPtr) /* The resulting Tcl_Obj* is stored here. */ { - register List *listRepPtr; + List *listRepPtr; if (listPtr->typePtr != &tclListType) { int result; @@ -766,10 +766,10 @@ Tcl_ListObjIndex( int Tcl_ListObjLength( Tcl_Interp *interp, /* Used to report errors if not NULL. */ - register Tcl_Obj *listPtr, /* List object whose #elements to return. */ - register int *intPtr) /* The resulting int is stored here. */ + Tcl_Obj *listPtr, /* List object whose #elements to return. */ + int *intPtr) /* The resulting int is stored here. */ { - register List *listRepPtr; + List *listRepPtr; if (listPtr->typePtr != &tclListType) { int result; @@ -839,7 +839,7 @@ Tcl_ListObjReplace( * insert. */ { List *listRepPtr; - register Tcl_Obj **elemPtrs; + Tcl_Obj **elemPtrs; int needGrow, numElems, numRequired, numAfterLast, start, i, j, isShared; if (Tcl_IsShared(listPtr)) { diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c index 0f98881..a41d9fd 100644 --- a/generic/tclPathObj.c +++ b/generic/tclPathObj.c @@ -2617,7 +2617,7 @@ DupFsPathInternalRep( static void UpdateStringOfFsPath( - register Tcl_Obj *pathPtr) /* path obj with string rep to update. */ + Tcl_Obj *pathPtr) /* path obj with string rep to update. */ { FsPath *fsPathPtr = PATHOBJ(pathPtr); int cwdLen; diff --git a/generic/tclPkg.c b/generic/tclPkg.c index 06d6ade..0a0c868 100644 --- a/generic/tclPkg.c +++ b/generic/tclPkg.c @@ -1137,9 +1137,10 @@ TclNRPackageObjCmd( Tcl_NRAddCallback(interp, PkgRequireCore, (void *)argv3, INT2PTR(newobjc), newObjvPtr, NULL); return TCL_OK; } else { - int i, newobjc = objc-3; Tcl_Obj *const *newobjv = objv + 3; - if (CheckAllRequirements(interp, objc-3, objv+3) != TCL_OK) { + newobjc = objc - 3; + + if (CheckAllRequirements(interp, objc - 3, objv + 3) != TCL_OK) { return TCL_ERROR; } objvListPtr = Tcl_NewListObj(0, NULL); diff --git a/generic/tclTest.c b/generic/tclTest.c index 03f40dd..f1e3fac 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -7398,8 +7398,6 @@ TestconcatobjCmd( "\n\t* (e) concatObj does not have refCount 0", NULL); } if (concatPtr == tmpPtr) { - int len; - result = TCL_ERROR; Tcl_AppendResult(interp, "\n\t* (e) concatObj is not a new obj ", NULL); @@ -7430,8 +7428,6 @@ TestconcatobjCmd( "\n\t* (f) concatObj does not have refCount 0", NULL); } if (concatPtr == tmpPtr) { - int len; - result = TCL_ERROR; Tcl_AppendResult(interp, "\n\t* (f) concatObj is not a new obj ", NULL); @@ -7463,8 +7459,6 @@ TestconcatobjCmd( "\n\t* (g) concatObj does not have refCount 0", NULL); } if (concatPtr == tmpPtr) { - int len; - result = TCL_ERROR; Tcl_AppendResult(interp, "\n\t* (g) concatObj is not a new obj ", NULL); @@ -7559,7 +7553,7 @@ static int InterpCmdResolver( Tcl_Interp *interp, const char *name, - Tcl_Namespace *context, + Tcl_Namespace *dummy, int flags, Tcl_Command *rPtr) { @@ -7569,6 +7563,7 @@ InterpCmdResolver( varFramePtr->procPtr : NULL; Namespace *callerNsPtr = varFramePtr->nsPtr; Tcl_Command resolvedCmdPtr = NULL; + (void)dummy; /* * Just do something special on a cmd literal "z" in two cases: diff --git a/generic/tclTestObj.c b/generic/tclTestObj.c index ba1dda6..3fe9d02 100644 --- a/generic/tclTestObj.c +++ b/generic/tclTestObj.c @@ -53,7 +53,7 @@ static int TeststringobjCmd(ClientData dummy, Tcl_Interp *interp, static void VarPtrDeleteProc(ClientData clientData, Tcl_Interp *interp) { - register int i; + int i; Tcl_Obj **varPtr = (Tcl_Obj **) clientData; for (i = 0; i < NUMBER_OF_OBJECT_VARS; i++) { if (varPtr[i]) Tcl_DecrRefCount(varPtr[i]); @@ -91,7 +91,7 @@ int TclObjTest_Init( Tcl_Interp *interp) { - register int i; + int i; /* * An array of Tcl_Obj pointers used in the commands that operate on or get * the values of Tcl object-valued variables. varPtr[i] is the i-th variable's diff --git a/generic/tclTrace.c b/generic/tclTrace.c index 3178441..0228aff 100644 --- a/generic/tclTrace.c +++ b/generic/tclTrace.c @@ -136,7 +136,7 @@ static int StringTraceProc(ClientData clientData, static void StringTraceDeleteProc(ClientData clientData); static void DisposeTraceResult(int flags, char *result); static int TraceVarEx(Tcl_Interp *interp, const char *part1, - const char *part2, register VarTrace *tracePtr); + const char *part2, VarTrace *tracePtr); /* * The following structure holds the client data for string-based @@ -1049,7 +1049,7 @@ Tcl_CommandTraceInfo( * call will return the first trace. */ { Command *cmdPtr; - register CommandTrace *tracePtr; + CommandTrace *tracePtr; cmdPtr = (Command *) Tcl_FindCommand(interp, cmdName, NULL, TCL_LEAVE_ERR_MSG); @@ -1114,7 +1114,7 @@ Tcl_TraceCommand( ClientData clientData) /* Arbitrary argument to pass to proc. */ { Command *cmdPtr; - register CommandTrace *tracePtr; + CommandTrace *tracePtr; cmdPtr = (Command *) Tcl_FindCommand(interp, cmdName, NULL, TCL_LEAVE_ERR_MSG); @@ -1177,10 +1177,10 @@ Tcl_UntraceCommand( Tcl_CommandTraceProc *proc, /* Function assocated with trace. */ ClientData clientData) /* Arbitrary argument to pass to proc. */ { - register CommandTrace *tracePtr; + CommandTrace *tracePtr; CommandTrace *prevPtr; Command *cmdPtr; - Interp *iPtr = (Interp *) interp; + Interp *iPtr = (Interp *)interp; ActiveCommandTrace *activePtr; int hasExecTraces = 0; @@ -1255,7 +1255,6 @@ Tcl_UntraceCommand( */ if (cmdPtr->compileProc != NULL) { - Interp *iPtr = (Interp *) interp; iPtr->compileEpoch++; } } @@ -1672,13 +1671,13 @@ TclCheckInterpTraces( static int CallTraceFunction( Tcl_Interp *interp, /* The current interpreter. */ - register Trace *tracePtr, /* Describes the trace function to call. */ + Trace *tracePtr, /* Describes the trace function to call. */ Command *cmdPtr, /* Points to command's Command struct. */ const char *command, /* Points to the first character of the * command's source before substitutions. */ int numChars, /* The number of characters in the command's * source. */ - register int objc, /* Number of arguments for the command. */ + int objc, /* Number of arguments for the command. */ Tcl_Obj *const objv[]) /* Pointers to Tcl_Obj of each argument. */ { Interp *iPtr = (Interp *) interp; @@ -1920,7 +1919,7 @@ TraceExecutionProc( if ((flags & TCL_TRACE_ENTER_EXEC) && (tcmdPtr->stepTrace == NULL) && (tcmdPtr->flags & (TCL_TRACE_ENTER_DURING_EXEC | TCL_TRACE_LEAVE_DURING_EXEC))) { - register unsigned len = strlen(command) + 1; + unsigned len = strlen(command) + 1; tcmdPtr->startLevel = level; tcmdPtr->startCmd = ckalloc(len); @@ -2065,7 +2064,7 @@ TraceVarProc( } } if (destroy && result != NULL) { - register Tcl_Obj *errMsgObj = (Tcl_Obj *) result; + Tcl_Obj *errMsgObj = (Tcl_Obj *) result; Tcl_DecrRefCount(errMsgObj); result = NULL; @@ -2142,8 +2141,8 @@ Tcl_CreateObjTrace( Tcl_CmdObjTraceDeleteProc *delProc) /* Function to call when trace is deleted */ { - register Trace *tracePtr; - register Interp *iPtr = (Interp *) interp; + Trace *tracePtr; + Interp *iPtr = (Interp *) interp; /* * Test if this trace allows inline compilation of commands. @@ -2342,7 +2341,7 @@ Tcl_DeleteTrace( { Interp *iPtr = (Interp *) interp; Trace *prevPtr, *tracePtr = (Trace *) trace; - register Trace **tracePtr2 = &iPtr->tracePtr; + Trace **tracePtr2 = &iPtr->tracePtr; ActiveInterpTrace *activePtr; /* @@ -2534,7 +2533,7 @@ TclCheckArrayTraces( int TclObjCallVarTraces( Interp *iPtr, /* Interpreter containing variable. */ - register Var *arrayPtr, /* Pointer to array variable that contains the + Var *arrayPtr, /* Pointer to array variable that contains the * variable, or NULL if the variable isn't an * element of an array. */ Var *varPtr, /* Variable whose traces are to be invoked. */ @@ -2568,7 +2567,7 @@ TclObjCallVarTraces( int TclCallVarTraces( Interp *iPtr, /* Interpreter containing variable. */ - register Var *arrayPtr, /* Pointer to array variable that contains the + Var *arrayPtr, /* Pointer to array variable that contains the * variable, or NULL if the variable isn't an * element of an array. */ Var *varPtr, /* Variable whose traces are to be invoked. */ @@ -2581,7 +2580,7 @@ TclCallVarTraces( * error, then leave an error message and * stack trace information in *iPTr. */ { - register VarTrace *tracePtr; + VarTrace *tracePtr; ActiveVarTrace active; char *result; const char *openParen, *p; @@ -2909,7 +2908,7 @@ Tcl_UntraceVar2( Tcl_VarTraceProc *proc, /* Function assocated with trace. */ ClientData clientData) /* Arbitrary argument to pass to proc. */ { - register VarTrace *tracePtr; + VarTrace *tracePtr; VarTrace *prevPtr, *nextPtr; Var *varPtr, *arrayPtr; Interp *iPtr = (Interp *) interp; @@ -3099,7 +3098,7 @@ Tcl_VarTraceInfo2( hPtr = Tcl_FindHashEntry(&iPtr->varTraces, (char *) varPtr); if (hPtr) { - register VarTrace *tracePtr = Tcl_GetHashValue(hPtr); + VarTrace *tracePtr = Tcl_GetHashValue(hPtr); if (prevClientData != NULL) { for (; tracePtr != NULL; tracePtr = tracePtr->nextPtr) { @@ -3195,7 +3194,7 @@ Tcl_TraceVar2( * invoked upon varName. */ ClientData clientData) /* Arbitrary argument to pass to proc. */ { - register VarTrace *tracePtr; + VarTrace *tracePtr; int result; tracePtr = ckalloc(sizeof(VarTrace)); @@ -3240,7 +3239,7 @@ TraceVarEx( const char *part2, /* Name of element within array; NULL means * trace applies to scalar variable or array * as-a-whole. */ - register VarTrace *tracePtr)/* Structure containing flags, traceProc and + VarTrace *tracePtr)/* Structure containing flags, traceProc and * clientData fields. Others should be left * blank. Will be ckfree()d (eventually) if * this function returns TCL_OK, and up to diff --git a/generic/tclVar.c b/generic/tclVar.c index 5d8d88c..b7567a8 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -123,17 +123,17 @@ VarHashNextVar( * access is denied. */ -static const char *noSuchVar = "no such variable"; -static const char *isArray = "variable is array"; -static const char *needArray = "variable isn't array"; -static const char *noSuchElement = "no such element in array"; -static const char *danglingElement = +static const char NOSUCHVAR[] = "no such variable"; +static const char ISARRAY[] = "variable is array"; +static const char NEEDARRAY[] = "variable isn't array"; +static const char NOSUCHELEMENT[] = "no such element in array"; +static const char DANGLINGELEMENT[] = "upvar refers to element in deleted array"; -static const char *danglingVar = +static const char DANGLINGVAR[] = "upvar refers to variable in deleted namespace"; -static const char *badNamespace = "parent namespace doesn't exist"; -static const char *missingName = "missing variable name"; -static const char *isArrayElement = +static const char BADNAMESPACE[] = "parent namespace doesn't exist"; +static const char MISSINGNAME[] = "missing variable name"; +static const char ISARRAYELEMENT[] = "name refers to an element in an array"; /* @@ -613,7 +613,7 @@ TclObjLookupVarEx( if (flags & TCL_LEAVE_ERR_MSG) { TclObjVarErrMsg(interp, part1Ptr, part2Ptr, msg, - noSuchVar, -1); + NOSUCHVAR, -1); Tcl_SetErrorCode(interp, "TCL", "VALUE", "VARNAME", NULL); } return NULL; @@ -648,7 +648,7 @@ TclObjLookupVarEx( if (part2Ptr != NULL) { if (flags & TCL_LEAVE_ERR_MSG) { TclObjVarErrMsg(interp, part1Ptr, part2Ptr, msg, - needArray, -1); + NEEDARRAY, -1); Tcl_SetErrorCode(interp, "TCL", "VALUE", "VARNAME", NULL); } @@ -942,10 +942,10 @@ TclLookupSimpleVar( TclGetNamespaceForQualName(interp, varName, cxtNsPtr, flags, &varNsPtr, &dummy1Ptr, &dummy2Ptr, &tail); if (varNsPtr == NULL) { - *errMsgPtr = badNamespace; + *errMsgPtr = BADNAMESPACE; return NULL; } else if (tail == NULL) { - *errMsgPtr = missingName; + *errMsgPtr = MISSINGNAME; return NULL; } if (tail != varName) { @@ -967,7 +967,7 @@ TclLookupSimpleVar( *indexPtr = -2; } } else { /* Var wasn't found and not to create it. */ - *errMsgPtr = noSuchVar; + *errMsgPtr = NOSUCHVAR; return NULL; } } @@ -1007,7 +1007,7 @@ TclLookupSimpleVar( varPtr = VarHashFindVar(tablePtr, varNamePtr); } if (varPtr == NULL) { - *errMsgPtr = noSuchVar; + *errMsgPtr = NOSUCHVAR; } } } @@ -1087,7 +1087,7 @@ TclLookupArrayElement( if (!createArray) { if (flags & TCL_LEAVE_ERR_MSG) { TclObjVarErrMsg(interp, arrayNamePtr, elNamePtr, msg, - noSuchVar, index); + NOSUCHVAR, index); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME", arrayNamePtr?TclGetString(arrayNamePtr):NULL, NULL); } @@ -1102,7 +1102,7 @@ TclLookupArrayElement( if (TclIsVarDeadHash(arrayPtr)) { if (flags & TCL_LEAVE_ERR_MSG) { TclObjVarErrMsg(interp, arrayNamePtr, elNamePtr, msg, - danglingVar, index); + DANGLINGVAR, index); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME", arrayNamePtr?TclGetString(arrayNamePtr):NULL, NULL); } @@ -1121,7 +1121,7 @@ TclLookupArrayElement( TclInitVarHashTable(arrayPtr->value.tablePtr, nsPtr); } else if (!TclIsVarArray(arrayPtr)) { if (flags & TCL_LEAVE_ERR_MSG) { - TclObjVarErrMsg(interp, arrayNamePtr, elNamePtr, msg, needArray, + TclObjVarErrMsg(interp, arrayNamePtr, elNamePtr, msg, NEEDARRAY, index); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME", arrayNamePtr?TclGetString(arrayNamePtr):NULL, NULL); @@ -1143,7 +1143,7 @@ TclLookupArrayElement( if (varPtr == NULL) { if (flags & TCL_LEAVE_ERR_MSG) { TclObjVarErrMsg(interp, arrayNamePtr, elNamePtr, msg, - noSuchElement, index); + NOSUCHELEMENT, index); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ELEMENT", TclGetString(elNamePtr), NULL); } @@ -1469,11 +1469,11 @@ TclPtrGetVarIdx( if (flags & TCL_LEAVE_ERR_MSG) { if (TclIsVarUndefined(varPtr) && arrayPtr && !TclIsVarUndefined(arrayPtr)) { - msg = noSuchElement; + msg = NOSUCHELEMENT; } else if (TclIsVarArray(varPtr)) { - msg = isArray; + msg = ISARRAY; } else { - msg = noSuchVar; + msg = NOSUCHVAR; } TclObjVarErrMsg(interp, part1Ptr, part2Ptr, "read", msg, index); } @@ -1887,11 +1887,11 @@ TclPtrSetVarIdx( if (flags & TCL_LEAVE_ERR_MSG) { if (TclIsVarArrayElement(varPtr)) { TclObjVarErrMsg(interp, part1Ptr, part2Ptr, "set", - danglingElement, index); + DANGLINGELEMENT, index); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ELEMENT", NULL); } else { TclObjVarErrMsg(interp, part1Ptr, part2Ptr, "set", - danglingVar, index); + DANGLINGVAR, index); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME", NULL); } } @@ -1904,7 +1904,7 @@ TclPtrSetVarIdx( if (TclIsVarArray(varPtr)) { if (flags & TCL_LEAVE_ERR_MSG) { - TclObjVarErrMsg(interp, part1Ptr, part2Ptr, "set", isArray,index); + TclObjVarErrMsg(interp, part1Ptr, part2Ptr, "set", ISARRAY,index); Tcl_SetErrorCode(interp, "TCL", "WRITE", "ARRAY", NULL); } goto earlyError; @@ -2502,7 +2502,7 @@ TclPtrUnsetVarIdx( if (result != TCL_OK) { if (flags & TCL_LEAVE_ERR_MSG) { TclObjVarErrMsg(interp, part1Ptr, part2Ptr, "unset", - ((arrayPtr == NULL) ? noSuchVar : noSuchElement), index); + ((arrayPtr == NULL) ? NOSUCHVAR : NOSUCHELEMENT), index); Tcl_SetErrorCode(interp, "TCL", "UNSET", "VARNAME", NULL); } } @@ -3697,7 +3697,7 @@ ArraySetCmd( } if (arrayPtr) { CleanupVar(varPtr, arrayPtr); - TclObjVarErrMsg(interp, arrayNameObj, NULL, "set", needArray, -1); + TclObjVarErrMsg(interp, arrayNameObj, NULL, "set", NEEDARRAY, -1); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME", TclGetString(arrayNameObj), NULL); return TCL_ERROR; @@ -3815,7 +3815,7 @@ ArraySetCmd( */ TclObjVarErrMsg(interp, arrayNameObj, NULL, "array set", - needArray, -1); + NEEDARRAY, -1); Tcl_SetErrorCode(interp, "TCL", "WRITE", "ARRAY", NULL); return TCL_ERROR; } @@ -4718,7 +4718,7 @@ Tcl_VariableObjCmd( */ TclObjVarErrMsg(interp, varNamePtr, NULL, "define", - isArrayElement, -1); + ISARRAYELEMENT, -1); Tcl_SetErrorCode(interp, "TCL", "UPVAR", "LOCAL_ELEMENT", NULL); return TCL_ERROR; } diff --git a/win/tclWinFile.c b/win/tclWinFile.c index 752aa0c..6cfeae1 100644 --- a/win/tclWinFile.c +++ b/win/tclWinFile.c @@ -1091,7 +1091,6 @@ TclpMatchInDirectory( do { const char *utfname; int checkDrive = 0, isDrive; - DWORD attr; native = data.cFileName; attr = data.dwFileAttributes; @@ -1441,7 +1440,6 @@ TclpGetUserHome( int rc = 0; const char *domain; WCHAR *wName, *wHomeDir, *wDomain; - WCHAR buf[MAX_PATH]; Tcl_DStringInit(bufferPtr); @@ -1505,6 +1503,7 @@ TclpGetUserHome( size = lstrlenW(wHomeDir); Tcl_WinTCharToUtf((TCHAR *)wHomeDir, size*sizeof(WCHAR), bufferPtr); } else { + WCHAR buf[MAX_PATH]; /* * User exists but has no home dir. Return * "{GetProfilesDirectory}/". @@ -2801,7 +2800,6 @@ TclpObjNormalizePath( */ int len; - char *path; Tcl_Obj *tmpPathPtr; tmpPathPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), diff --git a/win/tclWinPipe.c b/win/tclWinPipe.c index 098ead4..204ad85 100644 --- a/win/tclWinPipe.c +++ b/win/tclWinPipe.c @@ -3231,7 +3231,7 @@ TclpOpenTemporaryFile( Tcl_DStringFree(&buf); } else { const WCHAR *baseStr = L"TCL"; - int length = 3 * sizeof(WCHAR); + length = 3 * sizeof(WCHAR); memcpy(namePtr, baseStr, length); namePtr += length; diff --git a/win/tclWinSerial.c b/win/tclWinSerial.c index 9023928..6946907 100644 --- a/win/tclWinSerial.c +++ b/win/tclWinSerial.c @@ -1779,7 +1779,7 @@ SerialSetOptionProc( */ if ((len > 4) && (strncmp(optionName, "-ttycontrol", len) == 0)) { - int i, result = TCL_OK; + int i, res = TCL_OK; if (Tcl_SplitList(interp, value, &argc, &argv) == TCL_ERROR) { return TCL_ERROR; @@ -1797,7 +1797,7 @@ SerialSetOptionProc( for (i = 0; i < argc - 1; i += 2) { if (Tcl_GetBoolean(interp, argv[i+1], &flag) == TCL_ERROR) { - result = TCL_ERROR; + res = TCL_ERROR; break; } if (strncasecmp(argv[i], "DTR", strlen(argv[i])) == 0) { @@ -1809,7 +1809,7 @@ SerialSetOptionProc( Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE", "TTY_SIGNAL", NULL); } - result = TCL_ERROR; + res = TCL_ERROR; break; } } else if (strncasecmp(argv[i], "RTS", strlen(argv[i])) == 0) { @@ -1821,7 +1821,7 @@ SerialSetOptionProc( Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE", "TTY_SIGNAL", NULL); } - result = TCL_ERROR; + res = TCL_ERROR; break; } } else if (strncasecmp(argv[i], "BREAK", strlen(argv[i])) == 0) { @@ -1833,7 +1833,7 @@ SerialSetOptionProc( Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE", "TTY_SIGNAL", NULL); } - result = TCL_ERROR; + res = TCL_ERROR; break; } } else { @@ -1844,13 +1844,13 @@ SerialSetOptionProc( Tcl_SetErrorCode(interp, "TCL", "VALUE", "TTY_SIGNAL", NULL); } - result = TCL_ERROR; + res = TCL_ERROR; break; } } ckfree(argv); - return result; + return res; } /* -- cgit v0.12 From 38b30033c88080b592fdbc043f295bc9b4e97b5d Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 28 Sep 2020 15:00:02 +0000 Subject: Update internal zlib channel type from TCL_CHANNEL_VERSION_3 to TCL_CHANNEL_VERSION_5. Not actually a change, since supported procs are the same. So all internal channels have the same type --- generic/tclZlib.c | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/generic/tclZlib.c b/generic/tclZlib.c index 604ce64..bdda9bc 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -205,7 +205,7 @@ static void ZlibTransformTimerRun(ClientData clientData); static const Tcl_ChannelType zlibChannelType = { "zlib", - TCL_CHANNEL_VERSION_3, + TCL_CHANNEL_VERSION_5, ZlibTransformClose, ZlibTransformInput, ZlibTransformOutput, @@ -2664,21 +2664,21 @@ ZlibStreamAddCmd( switch ((enum addOptions) index) { case ao_flush: /* -flush */ - if (flush > -1) { + if (flush >= 0) { flush = -2; } else { flush = Z_SYNC_FLUSH; } break; case ao_fullflush: /* -fullflush */ - if (flush > -1) { + if (flush >= 0) { flush = -2; } else { flush = Z_FULL_FLUSH; } break; case ao_finalize: /* -finalize */ - if (flush > -1) { + if (flush >= 0) { flush = -2; } else { flush = Z_FINISH; @@ -2788,21 +2788,21 @@ ZlibStreamPutCmd( switch ((enum putOptions) index) { case po_flush: /* -flush */ - if (flush > -1) { + if (flush >= 0) { flush = -2; } else { flush = Z_SYNC_FLUSH; } break; case po_fullflush: /* -fullflush */ - if (flush > -1) { + if (flush >= 0) { flush = -2; } else { flush = Z_FULL_FLUSH; } break; case po_finalize: /* -finalize */ - if (flush > -1) { + if (flush >= 0) { flush = -2; } else { flush = Z_FINISH; @@ -3683,7 +3683,7 @@ ZlibStackChannelTransform( if (cd->inAllocated < cd->readAheadLimit) { cd->inAllocated = cd->readAheadLimit; } - cd->inBuffer = ckalloc(cd->inAllocated); + cd->inBuffer = (char *)ckalloc(cd->inAllocated); if (cd->flags & IN_HEADER) { if (inflateGetHeader(&cd->inStream, &cd->inHeader.header) != Z_OK) { goto error; -- cgit v0.12 From 43e27f10a51ad6b206f06c50ea0cd4653bba694a Mon Sep 17 00:00:00 2001 From: oehhar Date: Tue, 29 Sep 2020 08:15:32 +0000 Subject: Ticket [0063cbcada]: check http::geturl -headers parameter to be a dict. --- library/http/http.tcl | 6 ++++-- tests/http.test | 6 ++++++ 2 files changed, 10 insertions(+), 2 deletions(-) diff --git a/library/http/http.tcl b/library/http/http.tcl index cce1828..abef596 100644 --- a/library/http/http.tcl +++ b/library/http/http.tcl @@ -733,6 +733,7 @@ proc http::geturl {url args} { -strict boolean -timeout integer -validate boolean + -headers list } set state(charset) $defaultCharset set options { @@ -747,8 +748,9 @@ proc http::geturl {url args} { if {[regexp -- $pat $flag]} { # Validate numbers if { - [info exists type($flag)] && - ![string is $type($flag) -strict $value] + ([info exists type($flag)] && + ![string is $type($flag) -strict $value]) || + $flag eq "-headers" && [llength $value] %2 != 0 } { unset $token return -code error \ diff --git a/tests/http.test b/tests/http.test index 636a651..bd776c6 100644 --- a/tests/http.test +++ b/tests/http.test @@ -448,6 +448,12 @@ test http-3.33 {http::geturl application/xml is text} -body { } -cleanup { catch { http::cleanup $token } } -result {test 4660 /test} +test http-3.34 {http::geturl -headers not a dict} -returnCodes error -body { + http::geturl http://test/t -headers NoDict +} -result {Bad value for -headers (NoDict), must be list} +test http-3.2 {http::geturl} -returnCodes error -body { + http::geturl http:junk +} -result {Unsupported URL: http:junk} test http-4.1 {http::Event} -body { set token [http::geturl $url -keepalive 0] -- cgit v0.12 From 2b01204e41b60fe88eae701bd56dc28b0f33926e Mon Sep 17 00:00:00 2001 From: oehhar Date: Tue, 29 Sep 2020 16:12:12 +0000 Subject: Remove wrong copy of test case http-3.2 --- tests/http.test | 3 --- 1 file changed, 3 deletions(-) diff --git a/tests/http.test b/tests/http.test index bd776c6..15bc37f 100644 --- a/tests/http.test +++ b/tests/http.test @@ -451,9 +451,6 @@ test http-3.33 {http::geturl application/xml is text} -body { test http-3.34 {http::geturl -headers not a dict} -returnCodes error -body { http::geturl http://test/t -headers NoDict } -result {Bad value for -headers (NoDict), must be list} -test http-3.2 {http::geturl} -returnCodes error -body { - http::geturl http:junk -} -result {Unsupported URL: http:junk} test http-4.1 {http::Event} -body { set token [http::geturl $url -keepalive 0] -- cgit v0.12 From 1f4f47ccf50b4d6518c3dbfd9fd09c7bbb785929 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 30 Sep 2020 14:49:15 +0000 Subject: (slightly) better error-message for invalid http -headers option. This works for plain 8.6 too --- library/http/http.tcl | 8 +++----- tests/http.test | 2 +- 2 files changed, 4 insertions(+), 6 deletions(-) diff --git a/library/http/http.tcl b/library/http/http.tcl index abef596..b0f87de 100644 --- a/library/http/http.tcl +++ b/library/http/http.tcl @@ -733,7 +733,7 @@ proc http::geturl {url args} { -strict boolean -timeout integer -validate boolean - -headers list + -headers dict } set state(charset) $defaultCharset set options { @@ -747,10 +747,8 @@ proc http::geturl {url args} { foreach {flag value} $args { if {[regexp -- $pat $flag]} { # Validate numbers - if { - ([info exists type($flag)] && - ![string is $type($flag) -strict $value]) || - $flag eq "-headers" && [llength $value] %2 != 0 + if {($flag eq "-headers") ? [catch {dict size $value}] : + ([info exists type($flag)] && ![string is $type($flag) -strict $value]) } { unset $token return -code error \ diff --git a/tests/http.test b/tests/http.test index 15bc37f..97e6cfa 100644 --- a/tests/http.test +++ b/tests/http.test @@ -450,7 +450,7 @@ test http-3.33 {http::geturl application/xml is text} -body { } -result {test 4660 /test} test http-3.34 {http::geturl -headers not a dict} -returnCodes error -body { http::geturl http://test/t -headers NoDict -} -result {Bad value for -headers (NoDict), must be list} +} -result {Bad value for -headers (NoDict), must be dict} test http-4.1 {http::Event} -body { set token [http::geturl $url -keepalive 0] -- cgit v0.12 From a9405cc25305fbdccd97fd95a57d8f76c9eda0ac Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 6 Oct 2020 13:28:24 +0000 Subject: (cherry-pick): HAVE_TM_GMTOFF detection doesn't work if CFLAGS contains -Werror. Here's the fix. --- unix/configure | 2 +- unix/tcl.m4 | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/unix/configure b/unix/configure index 7d40237..9dd612d 100755 --- a/unix/configure +++ b/unix/configure @@ -14030,7 +14030,7 @@ cat >>conftest.$ac_ext <<_ACEOF int main () { -struct tm tm; tm.tm_gmtoff; +struct tm tm; (void)tm.tm_gmtoff; ; return 0; } diff --git a/unix/tcl.m4 b/unix/tcl.m4 index 25a01ac..51ac8d9 100644 --- a/unix/tcl.m4 +++ b/unix/tcl.m4 @@ -2339,7 +2339,7 @@ AC_DEFUN([SC_TIME_HANDLER], [ fi AC_CACHE_CHECK([tm_gmtoff in struct tm], tcl_cv_member_tm_gmtoff, [ - AC_TRY_COMPILE([#include ], [struct tm tm; tm.tm_gmtoff;], + AC_TRY_COMPILE([#include ], [struct tm tm; (void)tm.tm_gmtoff;], tcl_cv_member_tm_gmtoff=yes, tcl_cv_member_tm_gmtoff=no)]) if test $tcl_cv_member_tm_gmtoff = yes ; then AC_DEFINE(HAVE_TM_GMTOFF, 1, [Should we use the tm_gmtoff field of struct tm?]) -- cgit v0.12 From e53cbf77bf43398c097556b24a5c1e6a26e56b40 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 7 Oct 2020 16:34:57 +0000 Subject: xcode12 -> xcode12.2. Prevent build warning about generic/tclStubInit.c --- .travis.yml | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/.travis.yml b/.travis.yml index 5773b5b..6447b34 100644 --- a/.travis.yml +++ b/.travis.yml @@ -114,7 +114,7 @@ jobs: # Testing on Mac, various styles - name: "macOS/Xcode 12/Shared" os: osx - osx_image: xcode12 + osx_image: xcode12.2 env: - BUILD_DIR=macosx install: [] @@ -124,7 +124,7 @@ jobs: - make test styles=develop - name: "macOS/Xcode 12/Shared/Unix-like" os: osx - osx_image: xcode12 + osx_image: xcode12.2 env: - BUILD_DIR=unix # Newer MacOS versions @@ -320,6 +320,7 @@ jobs: - CFGOPT="--enable-threads --enable-symbols=mem" before_install: *makepreinst before_install: + - touch generic/tclStubInit.c - cd ${BUILD_DIR} install: - ./configure ${CFGOPT} --prefix=$HOME || (cat config.log && exit 1) -- cgit v0.12 From 5039e7ce17a9ea6c7352b39a0bd70e31433b7843 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 8 Oct 2020 09:13:57 +0000 Subject: Fix [014ade1d44]: Misleading error message when using "-path" multiple times with "glob" --- generic/tclFileName.c | 10 ++++++++-- tests/fileName.test | 6 ++++++ 2 files changed, 14 insertions(+), 2 deletions(-) diff --git a/generic/tclFileName.c b/generic/tclFileName.c index 6cdfa7e..b47035c 100644 --- a/generic/tclFileName.c +++ b/generic/tclFileName.c @@ -1281,7 +1281,10 @@ Tcl_GlobObjCmd( } if (dir != PATH_NONE) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "\"-directory\" cannot be used with \"-path\"", -1)); + dir == PATH_DIR + ? "\"-directory\" may only be used once" + : "\"-directory\" cannot be used with \"-path\"", + -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB", "BADOPTIONCOMBINATION", NULL); return TCL_ERROR; @@ -1306,7 +1309,10 @@ Tcl_GlobObjCmd( } if (dir != PATH_NONE) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "\"-path\" cannot be used with \"-directory\"", -1)); + dir == PATH_GENERAL + ? "\"-path\" may only be used once" + : "\"-path\" cannot be used with \"-dictionary\"", + -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB", "BADOPTIONCOMBINATION", NULL); return TCL_ERROR; diff --git a/tests/fileName.test b/tests/fileName.test index 725c1dd..0411ea8 100644 --- a/tests/fileName.test +++ b/tests/fileName.test @@ -1083,6 +1083,12 @@ test filename-11.48 {Tcl_GlobCmd} -returnCodes error -body { test filename-11.49 {Tcl_GlobCmd} -returnCodes error -body { glob -types abcde -path foo -join * * } -result {bad argument to "-types": abcde} +test filename-11.50 {Tcl_GlobCmd} -returnCodes error -body { + glob -path hello -path salut * +} -result {"-path" may only be used once} +test filename-11.51 {Tcl_GlobCmd} -returnCodes error -body { + glob -dir hello -dir salut * +} -result {"-directory" may only be used once} file rename $horribleglobname globTest file delete -force $tildeglobname -- cgit v0.12 From 4a3369807be6e501ec6452edf99a73514c24d861 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 8 Oct 2020 12:11:11 +0000 Subject: Eliminate warnings when compiling with -Wundef --- generic/tclAlloc.c | 2 +- generic/tclCkalloc.c | 2 +- generic/tclEvent.c | 2 +- generic/tclObj.c | 2 +- win/tclWinPort.h | 6 +++--- 5 files changed, 7 insertions(+), 7 deletions(-) diff --git a/generic/tclAlloc.c b/generic/tclAlloc.c index dd83385..cc683b6 100644 --- a/generic/tclAlloc.c +++ b/generic/tclAlloc.c @@ -24,7 +24,7 @@ #include "tclInt.h" #if !defined(TCL_THREADS) || !defined(USE_THREAD_ALLOC) -#if USE_TCLALLOC +#if defined(USE_TCLALLOC) && USE_TCLALLOC /* * We should really make use of AC_CHECK_TYPE(caddr_t) here, but it can wait diff --git a/generic/tclCkalloc.c b/generic/tclCkalloc.c index 0dc1dca..6d661f6 100644 --- a/generic/tclCkalloc.c +++ b/generic/tclCkalloc.c @@ -1324,7 +1324,7 @@ TclFinalizeMemorySubsystem(void) Tcl_MutexUnlock(ckallocMutexPtr); #endif -#if USE_TCLALLOC +#if defined(USE_TCLALLOC) && USE_TCLALLOC TclFinalizeAllocSubsystem(); #endif } diff --git a/generic/tclEvent.c b/generic/tclEvent.c index ae40850..d8f5119 100644 --- a/generic/tclEvent.c +++ b/generic/tclEvent.c @@ -1045,7 +1045,7 @@ TclInitSubsystems(void) TclInitThreadStorage(); /* Creates hash table for * thread local storage */ -#if USE_TCLALLOC +#if defined(USE_TCLALLOC) && USE_TCLALLOC TclInitAlloc(); /* Process wide mutex init */ #endif #ifdef TCL_MEM_DEBUG diff --git a/generic/tclObj.c b/generic/tclObj.c index 70b2b1e..2ec5eb8 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -161,7 +161,7 @@ typedef struct PendingObjData { static PendingObjData pendingObjData; #define ObjInitDeletionContext(contextPtr) \ PendingObjData *const contextPtr = &pendingObjData -#elif HAVE_FAST_TSD +#elif defined(HAVE_FAST_TSD) static __thread PendingObjData pendingObjData; #define ObjInitDeletionContext(contextPtr) \ PendingObjData *const contextPtr = &pendingObjData diff --git a/win/tclWinPort.h b/win/tclWinPort.h index 3d61a39..8641e5e 100644 --- a/win/tclWinPort.h +++ b/win/tclWinPort.h @@ -297,7 +297,7 @@ typedef DWORD_PTR * PDWORD_PTR; * defined in header files above. */ -#if TCL_UNION_WAIT +#ifdef TCL_UNION_WAIT # define WAIT_STATUS_TYPE union wait #else # define WAIT_STATUS_TYPE int @@ -439,10 +439,10 @@ typedef DWORD_PTR * PDWORD_PTR; * Define pid_t and uid_t if they're not already defined. */ -#if ! TCL_PID_T +#if !defined(TCL_PID_T) # define pid_t int #endif /* !TCL_PID_T */ -#if ! TCL_UID_T +#if !defined(TCL_UID_T) # define uid_t int #endif /* !TCL_UID_T */ -- cgit v0.12 From e250b6f551523bf4b6fb9ae110bac1279d5eb581 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 9 Oct 2020 07:10:22 +0000 Subject: (cherry-pick): Fix [014ade1d44]: Misleading error message when using "-path" multiple times with "glob". Also fix a few (harmless) -Wundef warnings --- generic/tclExecute.c | 16 ++++++------ generic/tclFileName.c | 51 ++++++++++++++++++++---------------- tests/fileName.test | 72 ++++++++++++++++++++++++--------------------------- unix/tclLoadDyld.c | 12 ++++----- win/tclWinPort.h | 6 ++--- 5 files changed, 80 insertions(+), 77 deletions(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 7a8bf39..be0d932 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -2093,7 +2093,7 @@ TclExecuteByteCode( PUSH_OBJECT(codePtr->objArrayPtr[TclGetUInt1AtPtr(pc+1)]); TRACE_WITH_OBJ(("%u => ", TclGetInt1AtPtr(pc+1)), OBJ_AT_TOS); pc += 2; -#if !TCL_COMPILE_DEBUG +#if !defined(TCL_COMPILE_DEBUG) /* * Runtime peephole optimisation: check if we are pushing again. */ @@ -2124,7 +2124,7 @@ TclExecuteByteCode( */ pc++; -#if !TCL_COMPILE_DEBUG +#if !defined(TCL_COMPILE_DEBUG) if (*pc == INST_START_CMD) { TCL_DTRACE_INST_NEXT(); goto instStartCmdPeephole; @@ -2134,7 +2134,7 @@ TclExecuteByteCode( } case INST_START_CMD: -#if !TCL_COMPILE_DEBUG +#if !defined(TCL_COMPILE_DEBUG) instStartCmdPeephole: #endif /* @@ -2265,7 +2265,7 @@ TclExecuteByteCode( /* TODO: convert panic to error ? */ Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); } -#if !TCL_COMPILE_DEBUG +#if !defined(TCL_COMPILE_DEBUG) if (bytes != tclEmptyStringRep && !Tcl_IsShared(objResultPtr)) { TclFreeIntRep(objResultPtr); objResultPtr->typePtr = NULL; @@ -2280,7 +2280,7 @@ TclExecuteByteCode( objResultPtr->bytes = p; objResultPtr->length = length + appendLen; currPtr = &OBJ_AT_DEPTH(opnd - 1); -#if !TCL_COMPILE_DEBUG +#if !defined(TCL_COMPILE_DEBUG) } #endif @@ -7233,7 +7233,7 @@ TclExecuteByteCode( Tcl_Obj *valuePtr; const char *bytes; int length; -#if TCL_COMPILE_DEBUG +#ifdef TCL_COMPILE_DEBUG int opnd; #endif @@ -7244,7 +7244,7 @@ TclExecuteByteCode( */ processExceptionReturn: -#if TCL_COMPILE_DEBUG +#ifdef TCL_COMPILE_DEBUG switch (*pc) { case INST_INVOKE_STK1: opnd = TclGetUInt1AtPtr(pc+1); @@ -7302,7 +7302,7 @@ TclExecuteByteCode( rangePtr->codeOffset, rangePtr->continueOffset)); NEXT_INST_F(0, 0, 0); } -#if TCL_COMPILE_DEBUG +#ifdef TCL_COMPILE_DEBUG } else if (traceInstructions) { if ((result != TCL_ERROR) && (result != TCL_RETURN)) { Tcl_Obj *objPtr = Tcl_GetObjResult(interp); diff --git a/generic/tclFileName.c b/generic/tclFileName.c index be1fdfa..b3879f7 100644 --- a/generic/tclFileName.c +++ b/generic/tclFileName.c @@ -578,7 +578,7 @@ Tcl_SplitPath( * plus the argv pointers and the terminating NULL pointer. */ - *argvPtr = (const char **) ckalloc((unsigned) + *argvPtr = (const char **) ckalloc( ((((*argcPtr) + 1) * sizeof(char *)) + size)); /* @@ -590,7 +590,7 @@ Tcl_SplitPath( for (i = 0; i < *argcPtr; i++) { Tcl_ListObjIndex(NULL, resultPtr, i, &eltPtr); str = Tcl_GetStringFromObj(eltPtr, &len); - memcpy(p, str, (size_t) len+1); + memcpy(p, str, len + 1); p += len+1; } @@ -636,12 +636,13 @@ SplitUnixPath( { int length; const char *origPath = path, *elementStart; - Tcl_Obj *result = Tcl_NewObj(); + Tcl_Obj *result; /* * Deal with the root directory as a special case. */ + TclNewObj(result); if (*path == '/') { Tcl_Obj *rootElt; ++path; @@ -727,9 +728,10 @@ SplitWinPath( const char *p, *elementStart; Tcl_PathType type = TCL_PATH_ABSOLUTE; Tcl_DString buf; - Tcl_Obj *result = Tcl_NewObj(); + Tcl_Obj *result; Tcl_DStringInit(&buf); + TclNewObj(result); p = ExtractWinRoot(path, &buf, 0, &type); /* @@ -974,7 +976,7 @@ Tcl_JoinPath( Tcl_DString *resultPtr) /* Pointer to previously initialized DString */ { int i, len; - Tcl_Obj *listObj = Tcl_NewObj(); + Tcl_Obj *listObj; Tcl_Obj *resultObj; const char *resultStr; @@ -982,6 +984,7 @@ Tcl_JoinPath( * Build the list of paths. */ + TclNewObj(listObj); for (i = 0; i < argc; i++) { Tcl_ListObjAppendElement(NULL, listObj, Tcl_NewStringObj(argv[i], -1)); @@ -1069,7 +1072,7 @@ Tcl_TranslateFileName( */ if (tclPlatform == TCL_PLATFORM_WINDOWS) { - register char *p; + char *p; for (p = Tcl_DStringValue(bufferPtr); *p != '\0'; p++) { if (*p == '/') { *p = '\\'; @@ -1212,7 +1215,6 @@ DoTildeSubst( *---------------------------------------------------------------------- */ - /* ARGSUSED */ int Tcl_GlobObjCmd( ClientData dummy, /* Not used. */ @@ -1230,12 +1232,13 @@ Tcl_GlobObjCmd( "-directory", "-join", "-nocomplain", "-path", "-tails", "-types", "--", NULL }; - enum options { + enum globOptionsEnum { GLOB_DIR, GLOB_JOIN, GLOB_NOCOMPLAIN, GLOB_PATH, GLOB_TAILS, GLOB_TYPE, GLOB_LAST }; enum pathDirOptions {PATH_NONE = -1 , PATH_GENERAL = 0, PATH_DIR = 1}; Tcl_GlobTypeData *globTypes = NULL; + (void)dummy; globFlags = 0; join = 0; @@ -1263,7 +1266,7 @@ Tcl_GlobObjCmd( } } - switch (index) { + switch ((enum globOptionsEnum) index) { case GLOB_NOCOMPLAIN: /* -nocomplain */ globFlags |= TCL_GLOBMODE_NO_COMPLAIN; break; @@ -1275,7 +1278,10 @@ Tcl_GlobObjCmd( } if (dir != PATH_NONE) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "\"-directory\" cannot be used with \"-path\"", -1)); + dir == PATH_DIR + ? "\"-directory\" may only be used once" + : "\"-directory\" cannot be used with \"-path\"", + -1)); return TCL_ERROR; } dir = PATH_DIR; @@ -1297,7 +1303,10 @@ Tcl_GlobObjCmd( } if (dir != PATH_NONE) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "\"-path\" cannot be used with \"-directory\"", -1)); + dir == PATH_GENERAL + ? "\"-path\" may only be used once" + : "\"-path\" cannot be used with \"-dictionary\"", + -1)); return TCL_ERROR; } dir = PATH_GENERAL; @@ -1334,7 +1343,7 @@ Tcl_GlobObjCmd( return TCL_ERROR; } - separators = NULL; /* lint. */ + separators = NULL; switch (tclPlatform) { case TCL_PLATFORM_UNIX: separators = "/"; @@ -1439,7 +1448,7 @@ Tcl_GlobObjCmd( if (length <= 0) { goto skipTypes; } - globTypes = (Tcl_GlobTypeData*) + globTypes = (Tcl_GlobTypeData *) TclStackAlloc(interp,sizeof(Tcl_GlobTypeData)); globTypes->type = 0; globTypes->perm = 0; @@ -1666,9 +1675,8 @@ Tcl_GlobObjCmd( * * TclGlob -- * - * This procedure prepares arguments for the DoGlob call. It sets the - * separator string based on the platform, performs * tilde substitution, - * and calls DoGlob. + * Sets the separator string based on the platform, performs tilde + * substitution, and calls DoGlob. * * The interpreter's result, on entry to this function, must be a valid * Tcl list (e.g. it could be empty), since we will lappend any new @@ -1691,7 +1699,6 @@ Tcl_GlobObjCmd( *---------------------------------------------------------------------- */ - /* ARGSUSED */ int TclGlob( Tcl_Interp *interp, /* Interpreter for returning error message or @@ -1710,7 +1717,7 @@ TclGlob( int result; Tcl_Obj *filenamesObj, *savedResultObj; - separators = NULL; /* lint. */ + separators = NULL; switch (tclPlatform) { case TCL_PLATFORM_UNIX: separators = "/"; @@ -1891,7 +1898,7 @@ TclGlob( } /* - * To process a [glob] invokation, this function may be called multiple + * To process a [glob] invocation, this function may be called multiple * times. Each time, the previously discovered filenames are in the * interpreter result. We stash that away here so the result is free for * error messsages. @@ -2045,7 +2052,7 @@ TclGlob( * SkipToChar -- * * This function traverses a glob pattern looking for the next unquoted - * occurance of the specified character at the same braces nesting level. + * occurrence of the specified character at the same braces nesting level. * * Results: * Updates stringPtr to point to the matching character, or to the end of @@ -2064,7 +2071,7 @@ SkipToChar( int match) /* Character to find. */ { int quoted, level; - register char *p; + char *p; quoted = 0; level = 0; @@ -2507,7 +2514,7 @@ DoGlob( Tcl_StatBuf * Tcl_AllocStatBuf(void) { - return (Tcl_StatBuf *) ckalloc(sizeof(Tcl_StatBuf)); + return (Tcl_StatBuf *)ckalloc(sizeof(Tcl_StatBuf)); } /* diff --git a/tests/fileName.test b/tests/fileName.test index 3747fc9..aecca46 100644 --- a/tests/fileName.test +++ b/tests/fileName.test @@ -25,6 +25,7 @@ if {[testConstraint win]} { testConstraint linkDirectory 0 } testConstraint symbolicLinkFile 0 + testConstraint sharedCdrive [expr {![catch {cd //[info hostname]/c}]}] } global env @@ -210,11 +211,9 @@ test filename-4.18 {Tcl_SplitPath: unix} {testsetplatform} { testsetplatform unix file split foo/bar~/baz } {foo bar~ baz} - if {[testConstraint testsetplatform]} { testsetplatform $platform } - test filename-4.19 {Tcl_SplitPath} { set oldDir [pwd] set res [catch { @@ -438,7 +437,6 @@ test filename-7.19 {[Bug f34cf83dd0]} { file join foo //bar } /bar - test filename-9.1 {Tcl_JoinPath: win} {testsetplatform} { testsetplatform win file join a b @@ -515,25 +513,25 @@ test filename-9.19 {Tcl_JoinPath: win} {testsetplatform} { testsetplatform win set res {} lappend res \ - [file join {C:\foo\bar}] \ - [file join C:/blah {C:\foo\bar}] \ - [file join C:/blah C:/blah {C:\foo\bar}] + [file join {C:\foo\bar}] \ + [file join C:/blah {C:\foo\bar}] \ + [file join C:/blah C:/blah {C:\foo\bar}] } {C:/foo/bar C:/foo/bar C:/foo/bar} test filename-9.19.1 {Tcl_JoinPath: win} {testsetplatform} { testsetplatform win set res {} lappend res \ - [file join {foo\bar}] \ - [file join C:/blah {foo\bar}] \ - [file join C:/blah C:/blah {foo\bar}] + [file join {foo\bar}] \ + [file join C:/blah {foo\bar}] \ + [file join C:/blah C:/blah {foo\bar}] } {foo/bar C:/blah/foo/bar C:/blah/foo/bar} test filename-9.19.2 {Tcl_JoinPath: win} {testsetplatform win} { testsetplatform win set res {} lappend res \ - [file join {foo\bar}] \ - [file join [pwd] {foo\bar}] \ - [file join [pwd] [pwd] {foo\bar}] + [file join {foo\bar}] \ + [file join [pwd] {foo\bar}] \ + [file join [pwd] [pwd] {foo\bar}] set nres {} foreach elt $res { lappend nres [string map [list [pwd] pwd] $elt] @@ -544,26 +542,26 @@ test filename-9.20 {Tcl_JoinPath: unix} {testsetplatform} { testsetplatform unix set res {} lappend res \ - [file join {/foo/bar}] \ - [file join /x {/foo/bar}] \ - [file join /x /x {/foo/bar}] + [file join {/foo/bar}] \ + [file join /x {/foo/bar}] \ + [file join /x /x {/foo/bar}] } {/foo/bar /foo/bar /foo/bar} test filename-9.23 {Tcl_JoinPath: win} {testsetplatform} { testsetplatform win set res {} lappend res \ - [file join {foo\bar}] \ - [file join C:/blah {foo\bar}] \ - [file join C:/blah C:/blah {foo\bar}] + [file join {foo\bar}] \ + [file join C:/blah {foo\bar}] \ + [file join C:/blah C:/blah {foo\bar}] string map [list C:/blah ""] $res } {foo/bar /foo/bar /foo/bar} test filename-9.24 {Tcl_JoinPath: unix} {testsetplatform} { testsetplatform unix set res {} lappend res \ - [file join {foo/bar}] \ - [file join /x {foo/bar}] \ - [file join /x /x {foo/bar}] + [file join {foo/bar}] \ + [file join /x {foo/bar}] \ + [file join /x /x {foo/bar}] string map [list /x ""] $res } {foo/bar /foo/bar /foo/bar} @@ -1110,6 +1108,12 @@ test filename-11.48 {Tcl_GlobCmd} { test filename-11.49 {Tcl_GlobCmd} { list [catch {glob -types abcde -path foo -join * *} msg] $msg } {1 {bad argument to "-types": abcde}} +test filename-11.50 {Tcl_GlobCmd} -returnCodes error -body { + glob -path hello -path salut * +} -result {"-path" may only be used once} +test filename-11.51 {Tcl_GlobCmd} -returnCodes error -body { + glob -dir hello -dir salut * +} -result {"-directory" may only be used once} file rename $horribleglobname globTest file delete -force $tildeglobname @@ -1493,13 +1497,7 @@ test filename-16.10 {windows specific globbing} {win} { test filename-16.11 {windows specific globbing} {win} { lsort [glob -nocomplain c:\\\\globTest\\\\*.bat] } {c:/globTest/x1.BAT c:/globTest/y1.Bat c:/globTest/z1.bat} - # some tests require a shared C drive - -if {[testConstraint win]} { - testConstraint sharedCdrive [expr {![catch {cd //[info hostname]/c}]}] -} - test filename-16.12 {windows specific globbing} {win sharedCdrive} { cd //[info hostname]/c glob //[info hostname]/c/*Test @@ -1540,8 +1538,8 @@ if {[testConstraint win]} { test filename-17.1 {windows specific special files} {testsetplatform} { testsetplatform win list [file pathtype com1] [file pathtype con] [file pathtype lpt3] \ - [file pathtype prn] [file pathtype nul] [file pathtype aux] \ - [file pathtype foo] + [file pathtype prn] [file pathtype nul] [file pathtype aux] \ + [file pathtype foo] } {absolute absolute absolute absolute absolute absolute relative} if {[testConstraint testsetplatform]} { testsetplatform $platform @@ -1613,7 +1611,6 @@ test fileName-20.4 {Bug 1750300} -setup { removeFile TAGS $d removeDirectory foo } -result 0 - test fileName-20.5 {Bug 2837800} -setup { set dd [makeDirectory isolate] set d [makeDirectory ./~foo $dd] @@ -1628,7 +1625,6 @@ test fileName-20.5 {Bug 2837800} -setup { removeDirectory ./~foo $dd removeDirectory isolate } -result ~foo/test - test fileName-20.6 {Bug 2837800} -setup { # Recall that we have $env(HOME) set so that references # to ~ point to [temporaryDirectory] @@ -1645,7 +1641,6 @@ test fileName-20.6 {Bug 2837800} -setup { removeDirectory isolate removeFile test ~ } -result {} - test fileName-20.7 {Bug 2806250} -setup { set savewd [pwd] cd [temporaryDirectory] @@ -1658,7 +1653,6 @@ test fileName-20.7 {Bug 2806250} -setup { removeDirectory isolate cd $savewd } -result 1 - test fileName-20.8 {Bug 2806250} -setup { set savewd [pwd] cd [temporaryDirectory] @@ -1671,8 +1665,7 @@ test fileName-20.8 {Bug 2806250} -setup { removeDirectory isolate cd $savewd } -result ./~test - -test fileName-20.9 {} -setup { +test fileName-20.9 {globbing for special chars} -setup { makeFile {} test ~ set d [makeDirectory isolate] set savewd [pwd] @@ -1684,8 +1677,7 @@ test fileName-20.9 {} -setup { removeDirectory isolate removeFile test ~ } -result ~/test - -test fileName-20.10 {} -setup { +test fileName-20.10 {globbing for special chars} -setup { set s [makeDirectory sub ~] makeFile {} fileName-20.10 $s set d [makeDirectory isolate] @@ -1699,7 +1691,7 @@ test fileName-20.10 {} -setup { removeFile fileName-20.10 $s removeDirectory sub ~ } -result ~/sub/fileName-20.10 - + # cleanup catch {file delete -force C:/globTest} cd [temporaryDirectory] @@ -1713,3 +1705,7 @@ if {[testConstraint testsetplatform]} { catch {unset oldhome temp result globPreResult} ::tcltest::cleanupTests return + +# Local Variables: +# mode: tcl +# End: diff --git a/unix/tclLoadDyld.c b/unix/tclLoadDyld.c index 0a36215..c71727d 100644 --- a/unix/tclLoadDyld.c +++ b/unix/tclLoadDyld.c @@ -633,14 +633,14 @@ TclpLoadMemory( uint32_t ms = 0; #ifndef __LP64__ const struct mach_header *mh = NULL; - #define mh_size sizeof(struct mach_header) - #define mh_magic MH_MAGIC - #define arch_abi 0 +# define mh_size sizeof(struct mach_header) +# define mh_magic MH_MAGIC +# define arch_abi 0 #else const struct mach_header_64 *mh = NULL; - #define mh_size sizeof(struct mach_header_64) - #define mh_magic MH_MAGIC_64 - #define arch_abi CPU_ARCH_ABI64 +# define mh_size sizeof(struct mach_header_64) +# define mh_magic MH_MAGIC_64 +# define arch_abi CPU_ARCH_ABI64 #endif if ((size_t) codeSize >= sizeof(struct fat_header) diff --git a/win/tclWinPort.h b/win/tclWinPort.h index 056c7c8..d3dbb1b 100644 --- a/win/tclWinPort.h +++ b/win/tclWinPort.h @@ -211,7 +211,7 @@ typedef DWORD_PTR * PDWORD_PTR; * defined in header files above. */ -#if TCL_UNION_WAIT +#ifdef TCL_UNION_WAIT # define WAIT_STATUS_TYPE union wait #else # define WAIT_STATUS_TYPE int @@ -339,10 +339,10 @@ typedef DWORD_PTR * PDWORD_PTR; * Define pid_t and uid_t if they're not already defined. */ -#if ! TCL_PID_T +#if !defined(TCL_PID_T) # define pid_t int #endif /* !TCL_PID_T */ -#if ! TCL_UID_T +#if !defined(TCL_UID_T) # define uid_t int #endif /* !TCL_UID_T */ -- cgit v0.12 From 579cd0b138b020f90e65e83e6bd9f27d473211b1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jos=C3=A9=20Ignacio=20Mar=C3=ADn?= Date: Sat, 10 Oct 2020 20:34:58 +0000 Subject: Update TZ info to tzdata2020b. --- library/tzdata/Africa/Algiers | 2 +- library/tzdata/Africa/Casablanca | 20 ++-- library/tzdata/Africa/El_Aaiun | 20 ++-- library/tzdata/America/Dawson | 3 +- library/tzdata/America/Whitehorse | 3 +- library/tzdata/Antarctica/Casey | 5 + library/tzdata/Antarctica/Macquarie | 181 +++++++++++++++++++++++++++++++++++- library/tzdata/Europe/Budapest | 45 ++++----- library/tzdata/Europe/Monaco | 4 +- library/tzdata/Europe/Paris | 4 +- tools/tclZIC.tcl | 2 +- 11 files changed, 238 insertions(+), 51 deletions(-) diff --git a/library/tzdata/Africa/Algiers b/library/tzdata/Africa/Algiers index fe4de22..b26d31c 100644 --- a/library/tzdata/Africa/Algiers +++ b/library/tzdata/Africa/Algiers @@ -2,7 +2,7 @@ set TZData(:Africa/Algiers) { {-9223372036854775808 732 0 LMT} - {-2486679072 561 0 PMT} + {-2486592732 561 0 PMT} {-1855958961 0 0 WET} {-1689814800 3600 1 WEST} {-1680397200 0 0 WET} diff --git a/library/tzdata/Africa/Casablanca b/library/tzdata/Africa/Casablanca index 05ae49f..cb60740 100644 --- a/library/tzdata/Africa/Casablanca +++ b/library/tzdata/Africa/Casablanca @@ -66,7 +66,7 @@ set TZData(:Africa/Casablanca) { {1648346400 0 1 +01} {1651975200 3600 0 +01} {1679191200 0 1 +01} - {1682215200 3600 0 +01} + {1682820000 3600 0 +01} {1710036000 0 1 +01} {1713060000 3600 0 +01} {1740276000 0 1 +01} @@ -82,7 +82,7 @@ set TZData(:Africa/Casablanca) { {1893290400 0 1 +01} {1896919200 3600 0 +01} {1924135200 0 1 +01} - {1927159200 3600 0 +01} + {1927764000 3600 0 +01} {1954980000 0 1 +01} {1958004000 3600 0 +01} {1985220000 0 1 +01} @@ -98,7 +98,7 @@ set TZData(:Africa/Casablanca) { {2138234400 0 1 +01} {2141863200 3600 0 +01} {2169079200 0 1 +01} - {2172103200 3600 0 +01} + {2172708000 3600 0 +01} {2199924000 0 1 +01} {2202948000 3600 0 +01} {2230164000 0 1 +01} @@ -114,7 +114,7 @@ set TZData(:Africa/Casablanca) { {2383178400 0 1 +01} {2386807200 3600 0 +01} {2414023200 0 1 +01} - {2417047200 3600 0 +01} + {2417652000 3600 0 +01} {2444868000 0 1 +01} {2447892000 3600 0 +01} {2475108000 0 1 +01} @@ -130,7 +130,7 @@ set TZData(:Africa/Casablanca) { {2628122400 0 1 +01} {2631751200 3600 0 +01} {2658967200 0 1 +01} - {2661991200 3600 0 +01} + {2662596000 3600 0 +01} {2689812000 0 1 +01} {2692836000 3600 0 +01} {2720052000 0 1 +01} @@ -146,7 +146,7 @@ set TZData(:Africa/Casablanca) { {2873066400 0 1 +01} {2876695200 3600 0 +01} {2903911200 0 1 +01} - {2906935200 3600 0 +01} + {2907540000 3600 0 +01} {2934756000 0 1 +01} {2937780000 3600 0 +01} {2964996000 0 1 +01} @@ -162,7 +162,7 @@ set TZData(:Africa/Casablanca) { {3118010400 0 1 +01} {3121639200 3600 0 +01} {3148855200 0 1 +01} - {3151879200 3600 0 +01} + {3152484000 3600 0 +01} {3179700000 0 1 +01} {3182724000 3600 0 +01} {3209940000 0 1 +01} @@ -178,7 +178,7 @@ set TZData(:Africa/Casablanca) { {3362954400 0 1 +01} {3366583200 3600 0 +01} {3393799200 0 1 +01} - {3396823200 3600 0 +01} + {3397428000 3600 0 +01} {3424644000 0 1 +01} {3427668000 3600 0 +01} {3454884000 0 1 +01} @@ -188,13 +188,13 @@ set TZData(:Africa/Casablanca) { {3515968800 0 1 +01} {3519597600 3600 0 +01} {3546813600 0 1 +01} - {3549837600 3600 0 +01} + {3550442400 3600 0 +01} {3577658400 0 1 +01} {3580682400 3600 0 +01} {3607898400 0 1 +01} {3611527200 3600 0 +01} {3638743200 0 1 +01} - {3641767200 3600 0 +01} + {3642372000 3600 0 +01} {3669588000 0 1 +01} {3672612000 3600 0 +01} {3699828000 0 1 +01} diff --git a/library/tzdata/Africa/El_Aaiun b/library/tzdata/Africa/El_Aaiun index 8dbbdea..fd3e88f 100644 --- a/library/tzdata/Africa/El_Aaiun +++ b/library/tzdata/Africa/El_Aaiun @@ -55,7 +55,7 @@ set TZData(:Africa/El_Aaiun) { {1648346400 0 1 +01} {1651975200 3600 0 +01} {1679191200 0 1 +01} - {1682215200 3600 0 +01} + {1682820000 3600 0 +01} {1710036000 0 1 +01} {1713060000 3600 0 +01} {1740276000 0 1 +01} @@ -71,7 +71,7 @@ set TZData(:Africa/El_Aaiun) { {1893290400 0 1 +01} {1896919200 3600 0 +01} {1924135200 0 1 +01} - {1927159200 3600 0 +01} + {1927764000 3600 0 +01} {1954980000 0 1 +01} {1958004000 3600 0 +01} {1985220000 0 1 +01} @@ -87,7 +87,7 @@ set TZData(:Africa/El_Aaiun) { {2138234400 0 1 +01} {2141863200 3600 0 +01} {2169079200 0 1 +01} - {2172103200 3600 0 +01} + {2172708000 3600 0 +01} {2199924000 0 1 +01} {2202948000 3600 0 +01} {2230164000 0 1 +01} @@ -103,7 +103,7 @@ set TZData(:Africa/El_Aaiun) { {2383178400 0 1 +01} {2386807200 3600 0 +01} {2414023200 0 1 +01} - {2417047200 3600 0 +01} + {2417652000 3600 0 +01} {2444868000 0 1 +01} {2447892000 3600 0 +01} {2475108000 0 1 +01} @@ -119,7 +119,7 @@ set TZData(:Africa/El_Aaiun) { {2628122400 0 1 +01} {2631751200 3600 0 +01} {2658967200 0 1 +01} - {2661991200 3600 0 +01} + {2662596000 3600 0 +01} {2689812000 0 1 +01} {2692836000 3600 0 +01} {2720052000 0 1 +01} @@ -135,7 +135,7 @@ set TZData(:Africa/El_Aaiun) { {2873066400 0 1 +01} {2876695200 3600 0 +01} {2903911200 0 1 +01} - {2906935200 3600 0 +01} + {2907540000 3600 0 +01} {2934756000 0 1 +01} {2937780000 3600 0 +01} {2964996000 0 1 +01} @@ -151,7 +151,7 @@ set TZData(:Africa/El_Aaiun) { {3118010400 0 1 +01} {3121639200 3600 0 +01} {3148855200 0 1 +01} - {3151879200 3600 0 +01} + {3152484000 3600 0 +01} {3179700000 0 1 +01} {3182724000 3600 0 +01} {3209940000 0 1 +01} @@ -167,7 +167,7 @@ set TZData(:Africa/El_Aaiun) { {3362954400 0 1 +01} {3366583200 3600 0 +01} {3393799200 0 1 +01} - {3396823200 3600 0 +01} + {3397428000 3600 0 +01} {3424644000 0 1 +01} {3427668000 3600 0 +01} {3454884000 0 1 +01} @@ -177,13 +177,13 @@ set TZData(:Africa/El_Aaiun) { {3515968800 0 1 +01} {3519597600 3600 0 +01} {3546813600 0 1 +01} - {3549837600 3600 0 +01} + {3550442400 3600 0 +01} {3577658400 0 1 +01} {3580682400 3600 0 +01} {3607898400 0 1 +01} {3611527200 3600 0 +01} {3638743200 0 1 +01} - {3641767200 3600 0 +01} + {3642372000 3600 0 +01} {3669588000 0 1 +01} {3672612000 3600 0 +01} {3699828000 0 1 +01} diff --git a/library/tzdata/America/Dawson b/library/tzdata/America/Dawson index 1c827ff..c8e3f26 100644 --- a/library/tzdata/America/Dawson +++ b/library/tzdata/America/Dawson @@ -93,5 +93,6 @@ set TZData(:America/Dawson) { {1541322000 -28800 0 PST} {1552212000 -25200 1 PDT} {1572771600 -28800 0 PST} - {1583661600 -25200 0 MST} + {1583661600 -25200 1 PDT} + {1604217600 -25200 0 MST} } diff --git a/library/tzdata/America/Whitehorse b/library/tzdata/America/Whitehorse index da0c0f0..498a203 100644 --- a/library/tzdata/America/Whitehorse +++ b/library/tzdata/America/Whitehorse @@ -93,5 +93,6 @@ set TZData(:America/Whitehorse) { {1541322000 -28800 0 PST} {1552212000 -25200 1 PDT} {1572771600 -28800 0 PST} - {1583661600 -25200 0 MST} + {1583661600 -25200 1 PDT} + {1604217600 -25200 0 MST} } diff --git a/library/tzdata/Antarctica/Casey b/library/tzdata/Antarctica/Casey index aa37480..56935e3 100644 --- a/library/tzdata/Antarctica/Casey +++ b/library/tzdata/Antarctica/Casey @@ -9,4 +9,9 @@ set TZData(:Antarctica/Casey) { {1329843600 28800 0 +08} {1477065600 39600 0 +11} {1520701200 28800 0 +08} + {1538856000 39600 0 +11} + {1552752000 28800 0 +08} + {1570129200 39600 0 +11} + {1583596800 28800 0 +08} + {1601740860 39600 0 +11} } diff --git a/library/tzdata/Antarctica/Macquarie b/library/tzdata/Antarctica/Macquarie index 60bf7a6..e8ed043 100644 --- a/library/tzdata/Antarctica/Macquarie +++ b/library/tzdata/Antarctica/Macquarie @@ -93,5 +93,184 @@ set TZData(:Antarctica/Macquarie) { {1223136000 39600 1 AEDT} {1238860800 36000 0 AEST} {1254585600 39600 1 AEDT} - {1270310400 39600 0 +11} + {1262264400 39600 1 AEDT} + {1293800400 39600 0 AEST} + {1301760000 36000 0 AEST} + {1317484800 39600 1 AEDT} + {1333209600 36000 0 AEST} + {1349539200 39600 1 AEDT} + {1365264000 36000 0 AEST} + {1380988800 39600 1 AEDT} + {1396713600 36000 0 AEST} + {1412438400 39600 1 AEDT} + {1428163200 36000 0 AEST} + {1443888000 39600 1 AEDT} + {1459612800 36000 0 AEST} + {1475337600 39600 1 AEDT} + {1491062400 36000 0 AEST} + {1506787200 39600 1 AEDT} + {1522512000 36000 0 AEST} + {1538841600 39600 1 AEDT} + {1554566400 36000 0 AEST} + {1570291200 39600 1 AEDT} + {1586016000 36000 0 AEST} + {1601740800 39600 1 AEDT} + {1617465600 36000 0 AEST} + {1633190400 39600 1 AEDT} + {1648915200 36000 0 AEST} + {1664640000 39600 1 AEDT} + {1680364800 36000 0 AEST} + {1696089600 39600 1 AEDT} + {1712419200 36000 0 AEST} + {1728144000 39600 1 AEDT} + {1743868800 36000 0 AEST} + {1759593600 39600 1 AEDT} + {1775318400 36000 0 AEST} + {1791043200 39600 1 AEDT} + {1806768000 36000 0 AEST} + {1822492800 39600 1 AEDT} + {1838217600 36000 0 AEST} + {1853942400 39600 1 AEDT} + {1869667200 36000 0 AEST} + {1885996800 39600 1 AEDT} + {1901721600 36000 0 AEST} + {1917446400 39600 1 AEDT} + {1933171200 36000 0 AEST} + {1948896000 39600 1 AEDT} + {1964620800 36000 0 AEST} + {1980345600 39600 1 AEDT} + {1996070400 36000 0 AEST} + {2011795200 39600 1 AEDT} + {2027520000 36000 0 AEST} + {2043244800 39600 1 AEDT} + {2058969600 36000 0 AEST} + {2075299200 39600 1 AEDT} + {2091024000 36000 0 AEST} + {2106748800 39600 1 AEDT} + {2122473600 36000 0 AEST} + {2138198400 39600 1 AEDT} + {2153923200 36000 0 AEST} + {2169648000 39600 1 AEDT} + {2185372800 36000 0 AEST} + {2201097600 39600 1 AEDT} + {2216822400 36000 0 AEST} + {2233152000 39600 1 AEDT} + {2248876800 36000 0 AEST} + {2264601600 39600 1 AEDT} + {2280326400 36000 0 AEST} + {2296051200 39600 1 AEDT} + {2311776000 36000 0 AEST} + {2327500800 39600 1 AEDT} + {2343225600 36000 0 AEST} + {2358950400 39600 1 AEDT} + {2374675200 36000 0 AEST} + {2390400000 39600 1 AEDT} + {2406124800 36000 0 AEST} + {2422454400 39600 1 AEDT} + {2438179200 36000 0 AEST} + {2453904000 39600 1 AEDT} + {2469628800 36000 0 AEST} + {2485353600 39600 1 AEDT} + {2501078400 36000 0 AEST} + {2516803200 39600 1 AEDT} + {2532528000 36000 0 AEST} + {2548252800 39600 1 AEDT} + {2563977600 36000 0 AEST} + {2579702400 39600 1 AEDT} + {2596032000 36000 0 AEST} + {2611756800 39600 1 AEDT} + {2627481600 36000 0 AEST} + {2643206400 39600 1 AEDT} + {2658931200 36000 0 AEST} + {2674656000 39600 1 AEDT} + {2690380800 36000 0 AEST} + {2706105600 39600 1 AEDT} + {2721830400 36000 0 AEST} + {2737555200 39600 1 AEDT} + {2753280000 36000 0 AEST} + {2769609600 39600 1 AEDT} + {2785334400 36000 0 AEST} + {2801059200 39600 1 AEDT} + {2816784000 36000 0 AEST} + {2832508800 39600 1 AEDT} + {2848233600 36000 0 AEST} + {2863958400 39600 1 AEDT} + {2879683200 36000 0 AEST} + {2895408000 39600 1 AEDT} + {2911132800 36000 0 AEST} + {2926857600 39600 1 AEDT} + {2942582400 36000 0 AEST} + {2958912000 39600 1 AEDT} + {2974636800 36000 0 AEST} + {2990361600 39600 1 AEDT} + {3006086400 36000 0 AEST} + {3021811200 39600 1 AEDT} + {3037536000 36000 0 AEST} + {3053260800 39600 1 AEDT} + {3068985600 36000 0 AEST} + {3084710400 39600 1 AEDT} + {3100435200 36000 0 AEST} + {3116764800 39600 1 AEDT} + {3132489600 36000 0 AEST} + {3148214400 39600 1 AEDT} + {3163939200 36000 0 AEST} + {3179664000 39600 1 AEDT} + {3195388800 36000 0 AEST} + {3211113600 39600 1 AEDT} + {3226838400 36000 0 AEST} + {3242563200 39600 1 AEDT} + {3258288000 36000 0 AEST} + {3274012800 39600 1 AEDT} + {3289737600 36000 0 AEST} + {3306067200 39600 1 AEDT} + {3321792000 36000 0 AEST} + {3337516800 39600 1 AEDT} + {3353241600 36000 0 AEST} + {3368966400 39600 1 AEDT} + {3384691200 36000 0 AEST} + {3400416000 39600 1 AEDT} + {3416140800 36000 0 AEST} + {3431865600 39600 1 AEDT} + {3447590400 36000 0 AEST} + {3463315200 39600 1 AEDT} + {3479644800 36000 0 AEST} + {3495369600 39600 1 AEDT} + {3511094400 36000 0 AEST} + {3526819200 39600 1 AEDT} + {3542544000 36000 0 AEST} + {3558268800 39600 1 AEDT} + {3573993600 36000 0 AEST} + {3589718400 39600 1 AEDT} + {3605443200 36000 0 AEST} + {3621168000 39600 1 AEDT} + {3636892800 36000 0 AEST} + {3653222400 39600 1 AEDT} + {3668947200 36000 0 AEST} + {3684672000 39600 1 AEDT} + {3700396800 36000 0 AEST} + {3716121600 39600 1 AEDT} + {3731846400 36000 0 AEST} + {3747571200 39600 1 AEDT} + {3763296000 36000 0 AEST} + {3779020800 39600 1 AEDT} + {3794745600 36000 0 AEST} + {3810470400 39600 1 AEDT} + {3826195200 36000 0 AEST} + {3842524800 39600 1 AEDT} + {3858249600 36000 0 AEST} + {3873974400 39600 1 AEDT} + {3889699200 36000 0 AEST} + {3905424000 39600 1 AEDT} + {3921148800 36000 0 AEST} + {3936873600 39600 1 AEDT} + {3952598400 36000 0 AEST} + {3968323200 39600 1 AEDT} + {3984048000 36000 0 AEST} + {4000377600 39600 1 AEDT} + {4016102400 36000 0 AEST} + {4031827200 39600 1 AEDT} + {4047552000 36000 0 AEST} + {4063276800 39600 1 AEDT} + {4079001600 36000 0 AEST} + {4094726400 39600 1 AEDT} } diff --git a/library/tzdata/Europe/Budapest b/library/tzdata/Europe/Budapest index e660ad1..4b92c5f 100644 --- a/library/tzdata/Europe/Budapest +++ b/library/tzdata/Europe/Budapest @@ -2,17 +2,19 @@ set TZData(:Europe/Budapest) { {-9223372036854775808 4580 0 LMT} - {-2500938980 3600 0 CET} + {-2498260580 3600 0 CET} {-1693706400 7200 1 CEST} {-1680483600 3600 0 CET} {-1663455600 7200 1 CEST} {-1650150000 3600 0 CET} {-1640998800 3600 0 CET} - {-1633212000 7200 1 CEST} + {-1632006000 7200 1 CEST} {-1618700400 3600 0 CET} - {-1600466400 7200 1 CEST} - {-1581202800 3600 0 CET} - {-906771600 3600 0 CET} + {-1600470000 7200 1 CEST} + {-1587250800 3600 0 CET} + {-1569711600 7200 1 CEST} + {-1555196400 3600 0 CET} + {-906775200 3600 0 CET} {-857257200 3600 0 CET} {-844556400 7200 1 CEST} {-828226800 3600 0 CET} @@ -20,33 +22,32 @@ set TZData(:Europe/Budapest) { {-796777200 3600 0 CET} {-788922000 3600 0 CET} {-778471200 7200 1 CEST} - {-762660000 3600 0 CET} + {-762656400 3600 0 CET} {-749689200 7200 1 CEST} - {-733359600 3600 0 CET} + {-733276800 3600 0 CET} {-717634800 7200 1 CEST} {-701910000 3600 0 CET} {-686185200 7200 1 CEST} {-670460400 3600 0 CET} {-654130800 7200 1 CEST} {-639010800 3600 0 CET} - {-621990000 7200 1 CEST} - {-605660400 3600 0 CET} {-492656400 7200 1 CEST} {-481168800 3600 0 CET} - {-461120400 7200 1 CEST} - {-449632800 3600 0 CET} - {-428547600 7200 1 CEST} - {-418269600 3600 0 CET} - {-397094400 7200 1 CEST} + {-461199600 7200 1 CEST} + {-449708400 3600 0 CET} + {-428540400 7200 1 CEST} + {-418258800 3600 0 CET} + {-397090800 7200 1 CEST} {-386809200 3600 0 CET} - {323827200 7200 1 CEST} - {338950800 3600 0 CET} - {354675600 7200 1 CEST} - {370400400 3600 0 CET} - {386125200 7200 1 CEST} - {401850000 3600 0 CET} - {417574800 7200 1 CEST} - {433299600 3600 0 CET} + {323823600 7200 1 CEST} + {338943600 3600 0 CET} + {354668400 7200 1 CEST} + {370393200 3600 0 CET} + {386118000 7200 1 CEST} + {401842800 3600 0 CET} + {417567600 7200 1 CEST} + {433292400 3600 0 CET} + {441759600 3600 0 CET} {449024400 7200 1 CEST} {465354000 3600 0 CET} {481078800 7200 1 CEST} diff --git a/library/tzdata/Europe/Monaco b/library/tzdata/Europe/Monaco index f887b0b..7428b2f 100644 --- a/library/tzdata/Europe/Monaco +++ b/library/tzdata/Europe/Monaco @@ -2,8 +2,8 @@ set TZData(:Europe/Monaco) { {-9223372036854775808 1772 0 LMT} - {-2486680172 561 0 PMT} - {-1855958961 0 0 WET} + {-2448318572 561 0 PMT} + {-1854403761 0 0 WET} {-1689814800 3600 1 WEST} {-1680397200 0 0 WET} {-1665363600 3600 1 WEST} diff --git a/library/tzdata/Europe/Paris b/library/tzdata/Europe/Paris index 4b22a09..7208e55 100644 --- a/library/tzdata/Europe/Paris +++ b/library/tzdata/Europe/Paris @@ -2,8 +2,8 @@ set TZData(:Europe/Paris) { {-9223372036854775808 561 0 LMT} - {-2486678901 561 0 PMT} - {-1855958901 0 0 WET} + {-2486592561 561 0 PMT} + {-1855958961 0 0 WET} {-1689814800 3600 1 WEST} {-1680397200 0 0 WET} {-1665363600 3600 1 WEST} diff --git a/tools/tclZIC.tcl b/tools/tclZIC.tcl index 85c9ba9..6282111 100755 --- a/tools/tclZIC.tcl +++ b/tools/tclZIC.tcl @@ -36,7 +36,7 @@ set olsonFiles { africa antarctica asia australasia backward etcetera europe northamerica - pacificnew southamerica systemv + southamerica } # Define the year at which the DST information will stop. -- cgit v0.12