diff options
| -rw-r--r-- | ChangeLog | 65 | ||||
| -rw-r--r-- | doc/Tcl.n | 30 | ||||
| -rw-r--r-- | doc/re_syntax.n | 29 | ||||
| -rw-r--r-- | generic/regc_lex.c | 35 | ||||
| -rw-r--r-- | generic/regcomp.c | 2 | ||||
| -rw-r--r-- | generic/regcustom.h | 2 | ||||
| -rw-r--r-- | generic/tcl.h | 14 | ||||
| -rw-r--r-- | generic/tclCompExpr.c | 26 | ||||
| -rw-r--r-- | generic/tclDTrace.d | 16 | ||||
| -rw-r--r-- | generic/tclIORChan.c | 70 | ||||
| -rw-r--r-- | generic/tclOOMethod.c | 2 | ||||
| -rw-r--r-- | generic/tclParse.c | 15 | ||||
| -rw-r--r-- | generic/tclProc.c | 2 | ||||
| -rw-r--r-- | generic/tclUtil.c | 3 | ||||
| -rw-r--r-- | library/http/http.tcl | 8 | ||||
| -rw-r--r-- | tests/http.test | 26 | ||||
| -rw-r--r-- | tests/httpd | 8 | ||||
| -rw-r--r-- | tests/ioCmd.test | 309 | ||||
| -rw-r--r-- | tests/oo.test | 12 | ||||
| -rw-r--r-- | tests/reg.test | 15 | ||||
| -rw-r--r-- | tests/socket.test | 1 | ||||
| -rw-r--r-- | tests/thread.test | 14 | ||||
| -rw-r--r-- | tests/unixNotfy.test | 6 | ||||
| -rw-r--r-- | tests/utf.test | 14 | ||||
| -rw-r--r-- | unix/Makefile.in | 2 |
25 files changed, 468 insertions, 258 deletions
@@ -1,6 +1,63 @@ +2011-09-15 Don Porter <dgp@users.sourceforge.net> + + * tests/thread.test: Plug most memory leaks in thread.test Constrain + the rest to be skipped during `make valgrind`. Tests using the + [testthread cancel] testing command are leaky. Corrections wait for + either addition of [thread::cancel] to the Thread package, or improvements + to the [testthread] testing command to make leak-free versions of these + tests possible. + + * generic/tclIORChan.c: Plug all memory leaks in ioCmd.test exposed + * tests/ioCmd.test: by `make valgrind`. + * unix/Makefile.in: + +2011-09-16 Jan Nijtmans <nijtmans@users.sf.net> + + IMPLEMENTATION OF TIP #388 + + * doc/Tcl.n + * doc/re_syntax.n + * generic/regc_lex.c + * generic/regcomp.c + * generic/regcustom.h + * generic/tcl.h + * generic/tclParse.c + * tests/reg.test + * tests/utf.test + +2011-09-16 Jan Nijtmans <nijtmans@users.sf.net> + + * generic/tcl.h: Don't change Tcl_UniChar type when + * generic/regcustom.h: TCL_UTF_MAX == 4 (not supported anyway) + +2011-09-16 Donal K. Fellows <dkf@users.sf.net> + + * generic/tclProc.c (ProcWrongNumArgs): [Bugs 3400658,3408830]: + Ensemble-like rewriting of error messages is complex, and TclOO (in + combination with iTcl) hits the most tricky cases. + + * library/http/http.tcl (http::geturl): [Bug 3391977]: Ensure that the + -headers option overrides the -type option (important because -type + has a default that is not always appropriate, and the header must not + be duplicated). + +2011-09-15 Don Porter <dgp@users.sourceforge.net> + + * generic/tclCompExpr.c: [Bug 3408408]: Partial improvement by sharing + as literals the computed values of constant subexpressions when we can + do so without incurring the cost of string rep generation. + +2011-09-13 Don Porter <dgp@users.sourceforge.net> + + * generic/tclUtil.c: [Bug 3390638]: Workaround broken solaris + studio cc optimizer. Thanks to Wolfgang S. Kechel. + + * generic/tclDTrace.d: [Bug 3405652]: Portability workaround for + broken system DTrace support. Thanks to Dagobert Michelson. + 2011-09-12 Jan Nijtmans <nijtmans@users.sf.net> - * win/tclWinPort.h: [Bug 3407070] tclPosixStr.c won't build with + * win/tclWinPort.h: [Bug 3407070]: tclPosixStr.c won't build with EOVERFLOW==E2BIG 2011-09-11 Don Porter <dgp@users.sourceforge.net> @@ -12,12 +69,6 @@ Thread package use in socket_*-13.1. Eliminates a memory leak in `make valgrind`. -2011-09-10 Donal K. Fellows <dkf@users.sf.net> - - * generic/tclOOMethod.c (InitEnsembleRewrite): [Bug 3400658]: Set the - ensemble-like rewriting up correctly for forwarded methods so that - computed error messages are correct. - 2011-09-09 Don Porter <dgp@users.sourceforge.net> * tests/chanio.test: [Bug 3389733]: Convert [testthread] use to @@ -6,7 +6,7 @@ '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .so man.macros -.TH Tcl n "8.5" Tcl "Tcl Built-In Commands" +.TH Tcl n "8.6" Tcl "Tcl Built-In Commands" .BS .SH NAME Tcl \- Tool Command Language @@ -193,23 +193,33 @@ Backslash .TP 7 \e\fIooo\fR . -The digits \fIooo\fR (one, two, or three of them) give an eight-bit octal -value for the Unicode character that will be inserted. The upper bits of the -Unicode character will be 0. +The digits \fIooo\fR (one, two, or three of them) give a eight-bit octal +value for the Unicode character that will be inserted, in the range \fI000\fR +- \fI377\fR. The parser will stop just before this range overflows, or when +the maximum of three digits is reached. The upper bits of the Unicode +character will be 0. .TP 7 \e\fBx\fIhh\fR . -The hexadecimal digits \fIhh\fR give an eight-bit hexadecimal value for the -Unicode character that will be inserted. Any number of hexadecimal digits -may be present; however, all but the last two are ignored (the result is -always a one-byte quantity). The upper bits of the Unicode character will -be 0. +The hexadecimal digits \fIhh\fR (one or two of them) give an eight-bit +hexadecimal value for the Unicode character that will be inserted. The upper +bits of the Unicode character will be 0. .TP 7 \e\fBu\fIhhhh\fR . The hexadecimal digits \fIhhhh\fR (one, two, three, or four of them) give a sixteen-bit hexadecimal value for the Unicode character that will be -inserted. +inserted. The upper bits of the Unicode character will be 0. +.TP 7 +\e\fBU\fIhhhhhhhh\fR +. +The hexadecimal digits \fIhhhhhhhh\fR (one up to eight of them) give a +twentiy-one-bit hexadecimal value for the Unicode character that will be +inserted, in the range U+0000..U+10FFFF. The parser will stop just +before this range overflows, or when the maximum of eight digits +is reached. The upper bits of the Unicode character will be 0. +.PP +The range U+010000..U+10FFFD is reserved for the future. .PP Backslash substitution is not performed on words enclosed in braces, except for backslash-newline as described above. diff --git a/doc/re_syntax.n b/doc/re_syntax.n index 8701641..a53f58b 100644 --- a/doc/re_syntax.n +++ b/doc/re_syntax.n @@ -359,39 +359,42 @@ horizontal tab, as in C .TP \fB\eu\fIwxyz\fR . -(where \fIwxyz\fR is exactly four hexadecimal digits) the Unicode +(where \fIwxyz\fR is one up to four hexadecimal digits) the Unicode character \fBU+\fIwxyz\fR in the local byte ordering .TP \fB\eU\fIstuvwxyz\fR . -(where \fIstuvwxyz\fR is exactly eight hexadecimal digits) reserved -for a somewhat-hypothetical Unicode extension to 32 bits +(where \fIstuvwxyz\fR is one up to eight hexadecimal digits) reserved +for a Unicode extension up to 21 bits. The digits are parsed until the +first non-hexadecimal character is encountered, the maximun of eight +hexadecimal digits are reached, or an overflow would occur in the maximum +value of \fBU+\fI10ffff\fR. .TP \fB\ev\fR . vertical tab, as in C are all available. .TP -\fB\ex\fIhhh\fR +\fB\ex\fIhh\fR . -(where \fIhhh\fR is any sequence of hexadecimal digits) the character -whose hexadecimal value is \fB0x\fIhhh\fR (a single character no -matter how many hexadecimal digits are used). +(where \fIhh\fR is one or two hexadecimal digits) the character +whose hexadecimal value is \fB0x\fIhh\fR. .TP \fB\e0\fR . the character whose value is \fB0\fR .TP +\fB\e\fIxyz\fR +. +(where \fIxyz\fR is exactly three octal digits, and is not a \fIback +reference\fR (see below)) the character whose octal value is +\fB0\fIxyz\fR. The first digit must be in the range 0-3, otherwise +the two-digit form is assumed. +.TP \fB\e\fIxy\fR . (where \fIxy\fR is exactly two octal digits, and is not a \fIback reference\fR (see below)) the character whose octal value is \fB0\fIxy\fR -.TP -\fB\e\fIxyz\fR -. -(where \fIxyz\fR is exactly three octal digits, and is not a back -reference (see below)) the character whose octal value is -\fB0\fIxyz\fR .RE .PP Hexadecimal digits are diff --git a/generic/regc_lex.c b/generic/regc_lex.c index f3a46da..132e757 100644 --- a/generic/regc_lex.c +++ b/generic/regc_lex.c @@ -742,6 +742,7 @@ lexescape( struct vars *v) { chr c; + int i; static const chr alert[] = { CHR('a'), CHR('l'), CHR('e'), CHR('r'), CHR('t') }; @@ -818,18 +819,23 @@ lexescape( RETV(PLAIN, CHR('\t')); break; case CHR('u'): - c = lexdigits(v, 16, 4, 4); + c = (uchr) lexdigits(v, 16, 1, 4); if (ISERR()) { FAILW(REG_EESCAPE); } RETV(PLAIN, c); break; case CHR('U'): - c = lexdigits(v, 16, 8, 8); + i = lexdigits(v, 16, 1, 8); if (ISERR()) { FAILW(REG_EESCAPE); } - RETV(PLAIN, c); + if (i > 0xFFFF) { + /* TODO: output a Surrogate pair + */ + i = 0xFFFD; + } + RETV(PLAIN, (uchr) i); break; case CHR('v'): RETV(PLAIN, CHR('\v')); @@ -844,7 +850,7 @@ lexescape( break; case CHR('x'): NOTE(REG_UUNPORT); - c = lexdigits(v, 16, 1, 255); /* REs >255 long outside spec */ + c = (uchr) lexdigits(v, 16, 1, 2); if (ISERR()) { FAILW(REG_EESCAPE); } @@ -866,7 +872,7 @@ lexescape( case CHR('9'): save = v->now; v->now--; /* put first digit back */ - c = lexdigits(v, 10, 1, 255); /* REs >255 long outside spec */ + c = (uchr) lexdigits(v, 10, 1, 255); /* REs >255 long outside spec */ if (ISERR()) { FAILW(REG_EESCAPE); } @@ -893,10 +899,15 @@ lexescape( case CHR('0'): NOTE(REG_UUNPORT); v->now--; /* put first digit back */ - c = lexdigits(v, 8, 1, 3); + c = (uchr) lexdigits(v, 8, 1, 3); if (ISERR()) { FAILW(REG_EESCAPE); } + if (c > 0xff) { + /* out of range, so we handled one digit too much */ + v->now--; + c >>= 3; + } RETV(PLAIN, c); break; default: @@ -909,16 +920,16 @@ lexescape( /* - lexdigits - slurp up digits and return chr value - ^ static chr lexdigits(struct vars *, int, int, int); + ^ static int lexdigits(struct vars *, int, int, int); */ -static chr /* chr value; errors signalled via ERR */ +static int /* chr value; errors signalled via ERR */ lexdigits( struct vars *v, int base, int minlen, int maxlen) { - uchr n; /* unsigned to avoid overflow misbehavior */ + int n; int len; chr c; int d; @@ -926,6 +937,10 @@ lexdigits( n = 0; for (len = 0; len < maxlen && !ATEOS(); len++) { + if (n > 0x10fff) { + /* Stop when continuing would otherwise overflow */ + break; + } c = *v->now++; switch (c) { case CHR('0'): case CHR('1'): case CHR('2'): case CHR('3'): @@ -958,7 +973,7 @@ lexdigits( ERR(REG_EESCAPE); } - return (chr)n; + return n; } /* diff --git a/generic/regcomp.c b/generic/regcomp.c index d7ae05e..65555aa 100644 --- a/generic/regcomp.c +++ b/generic/regcomp.c @@ -79,7 +79,7 @@ static void lexnest(struct vars *, const chr *, const chr *); static void lexword(struct vars *); static int next(struct vars *); static int lexescape(struct vars *); -static chr lexdigits(struct vars *, int, int, int); +static int lexdigits(struct vars *, int, int, int); static int brenext(struct vars *, pchr); static void skip(struct vars *); static chr newline(NOPARMS); diff --git a/generic/regcustom.h b/generic/regcustom.h index bc8c28c..1c970ea 100644 --- a/generic/regcustom.h +++ b/generic/regcustom.h @@ -97,7 +97,7 @@ typedef int celt; /* Type to hold chr, or NOCELT */ #define NOCELT (-1) /* Celt value which is not valid chr */ #define CHR(c) (UCHAR(c)) /* Turn char literal into chr literal */ #define DIGITVAL(c) ((c)-'0') /* Turn chr digit into its value */ -#if TCL_UTF_MAX > 3 +#if TCL_UTF_MAX > 4 #define CHRBITS 32 /* Bits in a chr; must not use sizeof */ #define CHR_MIN 0x00000000 /* Smallest and largest chr; the value */ #define CHR_MAX 0xffffffff /* CHR_MAX-CHR_MIN+1 should fit in uchr */ diff --git a/generic/tcl.h b/generic/tcl.h index 177126a..7a94956 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -2153,12 +2153,12 @@ typedef struct Tcl_EncodingType { /* * The maximum number of bytes that are necessary to represent a single - * Unicode character in UTF-8. The valid values should be 3 or 6 (or perhaps 1 - * if we want to support a non-unicode enabled core). If 3, then Tcl_UniChar - * must be 2-bytes in size (UCS-2) (the default). If 6, then Tcl_UniChar must - * be 4-bytes in size (UCS-4). At this time UCS-2 mode is the default and - * recommended mode. UCS-4 is experimental and not recommended. It works for - * the core, but most extensions expect UCS-2. + * Unicode character in UTF-8. The valid values should be 3, 4 or 6 + * (or perhaps 1 if we want to support a non-unicode enabled core). If 3 or + * 4, then Tcl_UniChar must be 2-bytes in size (UCS-2) (the default). If 6, + * then Tcl_UniChar must be 4-bytes in size (UCS-4). At this time UCS-2 mode + * is the default and recommended mode. UCS-4 is experimental and not + * recommended. It works for the core, but most extensions expect UCS-2. */ #ifndef TCL_UTF_MAX @@ -2170,7 +2170,7 @@ typedef struct Tcl_EncodingType { * reflected in regcustom.h. */ -#if TCL_UTF_MAX > 3 +#if TCL_UTF_MAX > 4 /* * unsigned int isn't 100% accurate as it should be a strict 4-byte value * (perhaps wchar_t). 64-bit systems may have troubles. The size of this diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c index 80f21e4..d96670c 100644 --- a/generic/tclCompExpr.c +++ b/generic/tclCompExpr.c @@ -2471,8 +2471,30 @@ CompileExprTree( if (ExecConstantExprTree(interp, nodes, next, litObjvPtr) == TCL_OK) { - TclEmitPush(TclAddLiteralObj(envPtr, - Tcl_GetObjResult(interp), NULL), envPtr); + int index; + Tcl_Obj *objPtr = Tcl_GetObjResult(interp); + + /* + * Don't generate a string rep, but if we have one + * already, then use it to share via the literal table. + */ + if (objPtr->bytes) { + Tcl_Obj *tableValue; + + index = TclRegisterNewLiteral(envPtr, objPtr->bytes, + objPtr->length); + tableValue = envPtr->literalArrayPtr[index].objPtr; + if ((tableValue->typePtr == NULL) && + (objPtr->typePtr != NULL)) { + /* Same intrep surgery as for OT_LITERAL */ + tableValue->typePtr = objPtr->typePtr; + tableValue->internalRep = objPtr->internalRep; + objPtr->typePtr = NULL; + } + } else { + index = TclAddLiteralObj(envPtr, objPtr, NULL); + } + TclEmitPush(index, envPtr); } else { TclCompileSyntaxError(interp, envPtr); } diff --git a/generic/tclDTrace.d b/generic/tclDTrace.d index 0ee592f..360bdff 100644 --- a/generic/tclDTrace.d +++ b/generic/tclDTrace.d @@ -25,7 +25,7 @@ provider tcl { * arg1: number of arguments (int) * arg2: array of proc argument objects (Tcl_Obj**) */ - probe proc__entry(TclDTraceStr name, int objc, Tcl_Obj **objv); + probe proc__entry(TclDTraceStr name, int objc, struct Tcl_Obj **objv); /* * tcl*:::proc-return probe * triggered immediately after proc bytecode execution @@ -42,7 +42,7 @@ provider tcl { * arg3: proc result object (Tcl_Obj*) */ probe proc__result(TclDTraceStr name, int code, TclDTraceStr result, - Tcl_Obj *resultobj); + struct Tcl_Obj *resultobj); /* * tcl*:::proc-args probe * triggered before proc-entry probe, gives access to string @@ -79,7 +79,7 @@ provider tcl { * arg1: number of arguments (int) * arg2: array of command argument objects (Tcl_Obj**) */ - probe cmd__entry(TclDTraceStr name, int objc, Tcl_Obj **objv); + probe cmd__entry(TclDTraceStr name, int objc, struct Tcl_Obj **objv); /* * tcl*:::cmd-return probe * triggered immediately after commmand execution @@ -96,7 +96,7 @@ provider tcl { * arg3: command result object (Tcl_Obj*) */ probe cmd__result(TclDTraceStr name, int code, TclDTraceStr result, - Tcl_Obj *resultobj); + struct Tcl_Obj *resultobj); /* * tcl*:::cmd-args probe * triggered before cmd-entry probe, gives access to string @@ -133,7 +133,7 @@ provider tcl { * arg1: depth of stack (int) * arg2: top of stack (Tcl_Obj**) */ - probe inst__start(TclDTraceStr name, int depth, Tcl_Obj **stack); + probe inst__start(TclDTraceStr name, int depth, struct Tcl_Obj **stack); /* * tcl*:::inst-done probe * triggered immediately after execution of a bytecode @@ -141,7 +141,7 @@ provider tcl { * arg1: depth of stack (int) * arg2: top of stack (Tcl_Obj**) */ - probe inst__done(TclDTraceStr name, int depth, Tcl_Obj **stack); + probe inst__done(TclDTraceStr name, int depth, struct Tcl_Obj **stack); /***************************** obj probes ******************************/ /* @@ -149,13 +149,13 @@ provider tcl { * triggered immediately after a new Tcl_Obj has been created * arg0: object created (Tcl_Obj*) */ - probe obj__create(Tcl_Obj* obj); + probe obj__create(struct Tcl_Obj* obj); /* * tcl*:::obj-free probe * triggered immediately before a Tcl_Obj is freed * arg0: object to be freed (Tcl_Obj*) */ - probe obj__free(Tcl_Obj* obj); + probe obj__free(struct Tcl_Obj* obj); /***************************** tcl probes ******************************/ /* diff --git a/generic/tclIORChan.c b/generic/tclIORChan.c index 846618c..da6f642 100644 --- a/generic/tclIORChan.c +++ b/generic/tclIORChan.c @@ -1066,15 +1066,9 @@ ReflectClose( ForwardOpToOwnerThread(rcPtr, ForwardedClose, &p); result = p.base.code; - /* - * FreeReflectedChannel is done in the forwarded operation!, in - * the other thread. rcPtr here is gone! - */ - if (result != TCL_OK) { FreeReceivedError(&p); } - return EOK; } #endif @@ -1105,10 +1099,7 @@ ReflectClose( ForwardOpToOwnerThread(rcPtr, ForwardedClose, &p); result = p.base.code; - /* - * FreeReflectedChannel is done in the forwarded operation!, in the - * other thread. rcPtr here is gone! - */ + Tcl_EventuallyFree (rcPtr, (Tcl_FreeProc *) FreeReflectedChannel); if (result != TCL_OK) { PassReceivedErrorInterp(interp, &p); @@ -2130,21 +2121,14 @@ NextHandle(void) } static void -FreeReflectedChannel( +FreeReflectedChannelArgs( ReflectedChannel *rcPtr) { - Channel *chanPtr = (Channel *) rcPtr->chan; - int i, n; - - if (chanPtr->typePtr != &tclRChannelType) { - /* - * Delete a cloned ChannelType structure. - */ + int i, n = rcPtr->argc - 2; - ckfree(chanPtr->typePtr); + if (n < 0) { + return; } - - n = rcPtr->argc - 2; for (i=0; i<n; i++) { Tcl_DecrRefCount(rcPtr->argv[i]); } @@ -2155,6 +2139,25 @@ FreeReflectedChannel( Tcl_DecrRefCount(rcPtr->argv[n+1]); + rcPtr->argc = 1; +} + +static void +FreeReflectedChannel( + ReflectedChannel *rcPtr) +{ + Channel *chanPtr = (Channel *) rcPtr->chan; + + if (chanPtr->typePtr != &tclRChannelType) { + /* + * Delete a cloned ChannelType structure. + */ + + ckfree(chanPtr->typePtr); + } + + FreeReflectedChannelArgs(rcPtr); + ckfree(rcPtr->argv); ckfree(rcPtr); } @@ -2506,6 +2509,11 @@ DeleteReflectedChannelMap( */ evPtr = resultPtr->evPtr; + + /* Basic crash safety until this routine can get revised [3411310] */ + if (evPtr == NULL) { + continue; + } paramPtr = evPtr->param; evPtr->resultPtr = NULL; @@ -2639,6 +2647,11 @@ DeleteThreadReflectedChannelMap( */ evPtr = resultPtr->evPtr; + + /* Basic crash safety until this routine can get revised [3411310] */ + if (evPtr == NULL ) { + continue; + } paramPtr = evPtr->param; evPtr->resultPtr = NULL; @@ -2665,6 +2678,7 @@ DeleteThreadReflectedChannelMap( ReflectedChannel *rcPtr = Tcl_GetChannelInstanceData(chan); rcPtr->interp = NULL; + FreeReflectedChannelArgs(rcPtr); Tcl_DeleteHashEntry(hPtr); } ckfree(rcmPtr); @@ -2862,7 +2876,7 @@ ForwardProc( Tcl_GetChannelName(rcPtr->chan)); Tcl_DeleteHashEntry(hPtr); - Tcl_EventuallyFree (rcPtr, (Tcl_FreeProc *) FreeReflectedChannel); + FreeReflectedChannelArgs(rcPtr); break; case ForwardedInput: { @@ -2927,7 +2941,9 @@ ForwardProc( int written; if (Tcl_GetIntFromObj(interp, resObj, &written) != TCL_OK) { - ForwardSetObjError(paramPtr, MarshallError(interp)); + Tcl_DecrRefCount(resObj); + resObj = MarshallError(interp); + ForwardSetObjError(paramPtr, resObj); paramPtr->output.toWrite = -1; } else if (written==0 || paramPtr->output.toWrite<written) { ForwardSetStaticError(paramPtr, msg_write_toomuch); @@ -2970,7 +2986,9 @@ ForwardProc( paramPtr->seek.offset = newLoc; } } else { - ForwardSetObjError(paramPtr, MarshallError(interp)); + Tcl_DecrRefCount(resObj); + resObj = MarshallError(interp); + ForwardSetObjError(paramPtr, resObj); paramPtr->seek.offset = -1; } } @@ -3061,7 +3079,9 @@ ForwardProc( if (Tcl_ListObjGetElements(interp, resObj, &listc, &listv) != TCL_OK) { - ForwardSetObjError(paramPtr, MarshallError(interp)); + Tcl_DecrRefCount(resObj); + resObj = MarshallError(interp); + ForwardSetObjError(paramPtr, resObj); } else if ((listc % 2) == 1) { /* * Odd number of elements is wrong. [x]. diff --git a/generic/tclOOMethod.c b/generic/tclOOMethod.c index 708295a..4e7edb8 100644 --- a/generic/tclOOMethod.c +++ b/generic/tclOOMethod.c @@ -1595,7 +1595,7 @@ InitEnsembleRewrite( if (isRootEnsemble) { iPtr->ensembleRewrite.sourceObjs = objv; iPtr->ensembleRewrite.numRemovedObjs = toRewrite; - iPtr->ensembleRewrite.numInsertedObjs = rewriteLength - 1; + iPtr->ensembleRewrite.numInsertedObjs = rewriteLength; } else { int numIns = iPtr->ensembleRewrite.numInsertedObjs; diff --git a/generic/tclParse.c b/generic/tclParse.c index 2b0dab4..3c984bf 100644 --- a/generic/tclParse.c +++ b/generic/tclParse.c @@ -754,7 +754,7 @@ TclParseHex( while (numBytes--) { unsigned char digit = UCHAR(*p); - if (!isxdigit(digit)) { + if (!isxdigit(digit) || (result > 0x10fff)) { break; } @@ -866,7 +866,7 @@ TclParseBackslash( result = 0xb; break; case 'x': - count += TclParseHex(p+1, numBytes-2, &result); + count += TclParseHex(p+1, (numBytes > 3) ? 2 : numBytes-2, &result); if (count == 2) { /* * No hexadigits -> This is just "x". @@ -889,6 +889,15 @@ TclParseBackslash( result = 'u'; } break; + case 'U': + count += TclParseHex(p+1, (numBytes > 9) ? 8 : numBytes-2, &result); + if (count == 2) { + /* + * No hexadigits -> This is just "U". + */ + result = 'U'; + } + break; case '\n': count--; do { @@ -917,7 +926,7 @@ TclParseBackslash( result = (result << 3) + (*p - '0'); p++; if ((numBytes == 3) || !isdigit(UCHAR(*p)) /* INTL: digit */ - || (UCHAR(*p) >= '8')) { + || (UCHAR(*p) >= '8') || (result >= 0x20)) { break; } count = 4; diff --git a/generic/tclProc.c b/generic/tclProc.c index 50cf0f7..d008217 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -1120,6 +1120,8 @@ ProcWrongNumArgs( if (framePtr->isProcCallFrame & FRAME_IS_LAMBDA) { desiredObjs[0] = Tcl_NewStringObj("lambdaExpr", -1); } else { + ((Interp *) interp)->ensembleRewrite.numInsertedObjs -= skip - 1; + #ifdef AVOID_HACKS_FOR_ITCL desiredObjs[0] = framePtr->objv[skip-1]; #else diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 51508d2..31c9fd3 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -3156,7 +3156,8 @@ TclFormatInt(buffer, n) * negating it produces the same value. */ - if (n == -n) { + intVal = -n; /* [Bug 3390638] Workaround for*/ + if (n == -n || intVal == n) { /* broken compiler optimizers. */ return sprintf(buffer, "%ld", n); } diff --git a/library/http/http.tcl b/library/http/http.tcl index c636458..69817b8 100644 --- a/library/http/http.tcl +++ b/library/http/http.tcl @@ -684,6 +684,7 @@ proc http::geturl {url args} { puts $sock "Proxy-Connection: Keep-Alive" } set accept_encoding_seen 0 + set content_type_seen 0 foreach {key value} $state(-headers) { if {[string equal -nocase $key "host"]} { continue @@ -691,6 +692,9 @@ proc http::geturl {url args} { if {[string equal -nocase $key "accept-encoding"]} { set accept_encoding_seen 1 } + if {[string equal -nocase $key "content-type"]} { + set content_type_seen 1 + } set value [string map [list \n "" \r ""] $value] set key [string trim $key] if {[string equal -nocase $key "content-length"]} { @@ -733,7 +737,9 @@ proc http::geturl {url args} { # response. if {$isQuery || $isQueryChannel} { - puts $sock "Content-Type: $state(-type)" + if {!$content_type_seen} { + puts $sock "Content-Type: $state(-type)" + } if {!$contDone} { puts $sock "Content-Length: $state(querylength)" } diff --git a/tests/http.test b/tests/http.test index e6e7649..d9c1efb 100644 --- a/tests/http.test +++ b/tests/http.test @@ -364,6 +364,32 @@ test http-3.26 {http::meta} -setup { http::cleanup $token unset -nocomplain m token } -result {Content-Length Content-Type Date X-Check} +test http-3.27 {http::geturl: -headers override -type} -body { + set token [http::geturl $url/headers -type "text/plain" -query dummy \ + -headers [list "Content-Type" "text/plain;charset=utf-8"]] + http::data $token +} -cleanup { + http::cleanup $token +} -match regexp -result {(?n)Accept \*/\* +Host .* +User-Agent .* +Connection close +Content-Type {text/plain;charset=utf-8} +Accept-Encoding .* +Content-Length 5} +test http-3.28 {http::geturl: -headers override -type default} -body { + set token [http::geturl $url/headers -query dummy \ + -headers [list "Content-Type" "text/plain;charset=utf-8"]] + http::data $token +} -cleanup { + http::cleanup $token +} -match regexp -result {(?n)Accept \*/\* +Host .* +User-Agent .* +Connection close +Content-Type {text/plain;charset=utf-8} +Accept-Encoding .* +Content-Length 5} test http-4.1 {http::Event} -body { set token [http::geturl $url -keepalive 0] diff --git a/tests/httpd b/tests/httpd index 5272385..f810797 100644 --- a/tests/httpd +++ b/tests/httpd @@ -175,6 +175,14 @@ proc httpdRespond { sock } { set html "Got [string length $data(query)] bytes" set type text/plain } + *headers* { + set html "" + set type text/plain + foreach {key value} $data(meta) { + append html [list $key $value] "\n" + } + set html [string trim $html] + } default { set type text/html diff --git a/tests/ioCmd.test b/tests/ioCmd.test index 6536072..4c08229 100644 --- a/tests/ioCmd.test +++ b/tests/ioCmd.test @@ -21,7 +21,7 @@ if {[lsearch [namespace children] ::tcltest] == -1} { # Custom constraints used in this file testConstraint fcopy [llength [info commands fcopy]] testConstraint testchannel [llength [info commands testchannel]] -testConstraint testthread [llength [info commands testthread]] +testConstraint thread [expr {0 == [catch {package require Thread 2.6}]}] #---------------------------------------------------------------------- @@ -1991,7 +1991,6 @@ test iocmd-32.1 {origin interpreter of moved channel destroyed during access} -m # response. interp eval $idb [list set chan $chan] - interp eval $idb [list set mid $tcltest::mainThread] set res [interp eval $idb { # wait a bit, give the main thread the time to start its event # loop to wait for the response from B @@ -2028,23 +2027,6 @@ test iocmd-32.2 {delete interp of reflected chan} { ## forwarding, and gaps due to tests not applicable to forwarding are ## left to keep this asociation. -# Duplicate of code in "thread.test". Find a better way of doing this -# without duplication. Maybe placement into a proc which transforms to -# nop after the first call, and placement of its defintion in a -# central location. - -if {[testConstraint testthread]} { - testthread errorproc ThreadError - - proc ThreadError {id info} { - global threadError - set threadError $info - } - proc ThreadNullError {id info} { - # ignore - } -} - # ### ### ### ######### ######### ######### ## Helper command. Runs a script in a separate thread and returns the ## result. A channel is transfered into the thread as well, and list of @@ -2053,7 +2035,8 @@ if {[testConstraint testthread]} { proc inthread {chan script args} { # Test thread. - set tid [testthread create] + set tid [thread::create -preserved] + thread::send $tid {load {} Tcltest} # Init thread configuration. # - Listed variables @@ -2062,22 +2045,23 @@ proc inthread {chan script args} { foreach v $args { upvar 1 $v x - testthread send $tid [list set $v $x] + thread::send $tid [list set $v $x] + } - testthread send $tid [list set mid $tcltest::mainThread] - testthread send $tid { + thread::send $tid [list set mid [thread::id]] + thread::send $tid { proc note {item} {global notes; lappend notes $item} proc notes {} {global notes; return $notes} proc noteOpts opts {global notes; lappend notes [dict merge { -code !?! -level !?! -errorcode !?! -errorline !?! -errorinfo !?! } $opts]} } - testthread send $tid [list proc s {} [list uplevel 1 $script]]; # (*) + thread::send $tid [list proc s {} [list uplevel 1 $script]]; # (*) # Transfer channel (cut/splice aka detach/attach) testchannel cut $chan - testthread send $tid [list testchannel splice $chan] + thread::send $tid [list testchannel splice $chan] # Run test script, also run local event loop! # The local event loop waits for the result to come back. @@ -2085,15 +2069,15 @@ proc inthread {chan script args} { # operations. set ::tres "" - testthread send -async $tid { + thread::send -async $tid { after 500 catch {s} res; # This runs the script, 's' was defined at (*) - testthread send -async $mid [list set ::tres $res] + thread::send -async $mid [list set ::tres $res] } vwait ::tres # Remove test thread, and return the captured result. - tcltest::threadReap + thread::release $tid return $::tres } @@ -2114,7 +2098,7 @@ test iocmd.tf-22.2 {chan finalize, for close} -match glob -body { note [info command foo] rename foo {} set res -} -constraints {testchannel testthread} -result {{initialize rc* {read write}} rc* {finalize rc*} {} foo} +} -constraints {testchannel thread} -result {{initialize rc* {read write}} rc* {finalize rc*} {} foo} test iocmd.tf-22.3 {chan finalize, for close, error, close error} -match glob -body { set res {} proc foo {args} {track; oninit; return -code error 5} @@ -2127,7 +2111,7 @@ test iocmd.tf-22.3 {chan finalize, for close, error, close error} -match glob -b } c] rename foo {} set res -} -constraints {testchannel testthread} -result {{initialize rc* {read write}} rc* {finalize rc*} 1 5 {}} +} -constraints {testchannel thread} -result {{initialize rc* {read write}} rc* {finalize rc*} 1 5 {}} test iocmd.tf-22.4 {chan finalize, for close, error, close errror} -match glob -body { set res {} proc foo {args} {track; oninit; error FOO} @@ -2138,7 +2122,7 @@ test iocmd.tf-22.4 {chan finalize, for close, error, close errror} -match glob - } c] rename foo {} set res -} -constraints {testchannel testthread} -result {{initialize rc* {read write}} rc* {finalize rc*} 1 FOO} +} -constraints {testchannel thread} -result {{initialize rc* {read write}} rc* {finalize rc*} 1 FOO} test iocmd.tf-22.5 {chan finalize, for close, arbitrary result} -match glob -body { set res {} proc foo {args} {track; oninit; return SOMETHING} @@ -2149,7 +2133,7 @@ test iocmd.tf-22.5 {chan finalize, for close, arbitrary result} -match glob -bod } c] rename foo {} set res -} -constraints {testchannel testthread} -result {{initialize rc* {read write}} rc* {finalize rc*} 0 {}} +} -constraints {testchannel thread} -result {{initialize rc* {read write}} rc* {finalize rc*} 0 {}} test iocmd.tf-22.6 {chan finalize, for close, break, close error} -match glob -body { set res {} proc foo {args} {track; oninit; return -code 3} @@ -2161,7 +2145,7 @@ test iocmd.tf-22.6 {chan finalize, for close, break, close error} -match glob -b rename foo {} set res } -result {{initialize rc* {read write}} rc* {finalize rc*} 1 *bad code*} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} test iocmd.tf-22.7 {chan finalize, for close, continue, close error} -match glob -body { set res {} proc foo {args} {track; oninit; return -code 4} @@ -2173,7 +2157,7 @@ test iocmd.tf-22.7 {chan finalize, for close, continue, close error} -match glob rename foo {} set res } -result {{initialize rc* {read write}} rc* {finalize rc*} 1 *bad code*} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} test iocmd.tf-22.8 {chan finalize, for close, custom code, close error} -match glob -body { set res {} proc foo {args} {track; oninit; return -code 777 BANG} @@ -2185,7 +2169,7 @@ test iocmd.tf-22.8 {chan finalize, for close, custom code, close error} -match g rename foo {} set res } -result {{initialize rc* {read write}} rc* {finalize rc*} 1 *bad code*} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} test iocmd.tf-22.9 {chan finalize, for close, ignore level, close error} -match glob -body { set res {} proc foo {args} {track; oninit; return -level 5 -code 777 BANG} @@ -2197,7 +2181,7 @@ test iocmd.tf-22.9 {chan finalize, for close, ignore level, close error} -match rename foo {} set res } -result {{initialize rc* {read write}} rc* {finalize rc*} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "finalize"*}} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} # --- === *** ########################### # method read @@ -2216,7 +2200,7 @@ test iocmd.tf-23.1 {chan read, regular data return} -match glob -body { } c] rename foo {} set res -} -constraints {testchannel testthread} -result {{read rc* 4096} {read rc* 4096} snarfsnarf} +} -constraints {testchannel thread} -result {{read rc* 4096} {read rc* 4096} snarfsnarf} test iocmd.tf-23.2 {chan read, bad data return, to much} -match glob -body { set res {} proc foo {args} { @@ -2231,7 +2215,7 @@ test iocmd.tf-23.2 {chan read, bad data return, to much} -match glob -body { } c] rename foo {} set res -} -constraints {testchannel testthread} -result {{read rc* 4096} 1 {read delivered more than requested}} +} -constraints {testchannel thread} -result {{read rc* 4096} 1 {read delivered more than requested}} test iocmd.tf-23.3 {chan read, for non-readable channel} -match glob -body { set res {} proc foo {args} { @@ -2245,7 +2229,7 @@ test iocmd.tf-23.3 {chan read, for non-readable channel} -match glob -body { } c] rename foo {} set res -} -constraints {testchannel testthread} -result {1 {channel "rc*" wasn't opened for reading}} +} -constraints {testchannel thread} -result {1 {channel "rc*" wasn't opened for reading}} test iocmd.tf-23.4 {chan read, error return} -match glob -body { set res {} proc foo {args} { @@ -2261,7 +2245,7 @@ test iocmd.tf-23.4 {chan read, error return} -match glob -body { rename foo {} set res } -result {{read rc* 4096} 1 BOOM!} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} test iocmd.tf-23.5 {chan read, break return is error} -match glob -body { set res {} proc foo {args} { @@ -2277,7 +2261,7 @@ test iocmd.tf-23.5 {chan read, break return is error} -match glob -body { rename foo {} set res } -result {{read rc* 4096} 1 *bad code*} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} test iocmd.tf-23.6 {chan read, continue return is error} -match glob -body { set res {} proc foo {args} { @@ -2293,7 +2277,7 @@ test iocmd.tf-23.6 {chan read, continue return is error} -match glob -body { rename foo {} set res } -result {{read rc* 4096} 1 *bad code*} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} test iocmd.tf-23.7 {chan read, custom return is error} -match glob -body { set res {} proc foo {args} { @@ -2309,7 +2293,7 @@ test iocmd.tf-23.7 {chan read, custom return is error} -match glob -body { rename foo {} set res } -result {{read rc* 4096} 1 *bad code*} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} test iocmd.tf-23.8 {chan read, level is squashed} -match glob -body { set res {} proc foo {args} { @@ -2325,7 +2309,7 @@ test iocmd.tf-23.8 {chan read, level is squashed} -match glob -body { rename foo {} set res } -result {{read rc* 4096} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "read"*}} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} test iocmd.tf-23.9 {chan read, no data means eof} -match glob -setup { set res {} proc foo {args} { @@ -2345,7 +2329,7 @@ test iocmd.tf-23.9 {chan read, no data means eof} -match glob -setup { rename foo {} unset res } -result {{read rc* 4096} {} 1} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} test iocmd.tf-23.10 {chan read, EAGAIN means no data, yet no eof either} -match glob -setup { set res {} proc foo {args} { @@ -2365,7 +2349,7 @@ test iocmd.tf-23.10 {chan read, EAGAIN means no data, yet no eof either} -match rename foo {} unset res } -result {{read rc* 4096} {} 0} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} # --- === *** ########################### # method write @@ -2385,7 +2369,7 @@ test iocmd.tf-24.1 {chan write, regular write} -match glob -body { } c rename foo {} set res -} -constraints {testchannel testthread} -result {{write rc* snarf} 5} +} -constraints {testchannel thread} -result {{write rc* snarf} 5} test iocmd.tf-24.2 {chan write, ack partial writes} -match glob -body { set res {} proc foo {args} { @@ -2402,7 +2386,7 @@ test iocmd.tf-24.2 {chan write, ack partial writes} -match glob -body { } c rename foo {} set res -} -constraints {testchannel testthread} -result {{write rc* snarfsnarfsnarf} 7 {write rc* arfsnarf} 8} +} -constraints {testchannel thread} -result {{write rc* snarfsnarfsnarf} 7 {write rc* arfsnarf} 8} test iocmd.tf-24.3 {chan write, failed write} -match glob -body { set res {} proc foo {args} {oninit; onfinal; track; note -1; return -1} @@ -2413,7 +2397,7 @@ test iocmd.tf-24.3 {chan write, failed write} -match glob -body { } c rename foo {} set res -} -constraints {testchannel testthread} -result {{write rc* snarfsnarfsnarf} -1} +} -constraints {testchannel thread} -result {{write rc* snarfsnarfsnarf} -1} test iocmd.tf-24.4 {chan write, non-writable channel} -match glob -body { set res {} proc foo {args} {oninit; onfinal; track; note MUST_NOT_HAPPEN; return} @@ -2426,7 +2410,7 @@ test iocmd.tf-24.4 {chan write, non-writable channel} -match glob -body { } c] rename foo {} set res -} -constraints {testchannel testthread} -result {1 {channel "rc*" wasn't opened for writing}} +} -constraints {testchannel thread} -result {1 {channel "rc*" wasn't opened for writing}} test iocmd.tf-24.5 {chan write, bad result, more written than data} -match glob -body { set res {} proc foo {args} {oninit; onfinal; track; return 10000} @@ -2439,7 +2423,7 @@ test iocmd.tf-24.5 {chan write, bad result, more written than data} -match glob } c] rename foo {} set res -} -constraints {testchannel testthread} -result {{write rc* snarf} 1 {write wrote more than requested}} +} -constraints {testchannel thread} -result {{write rc* snarf} 1 {write wrote more than requested}} test iocmd.tf-24.6 {chan write, zero writes} -match glob -body { set res {} proc foo {args} {oninit; onfinal; track; return 0} @@ -2452,7 +2436,7 @@ test iocmd.tf-24.6 {chan write, zero writes} -match glob -body { } c] rename foo {} set res -} -constraints {testchannel testthread} -result {{write rc* snarf} 1 {write wrote more than requested}} +} -constraints {testchannel thread} -result {{write rc* snarf} 1 {write wrote more than requested}} test iocmd.tf-24.7 {chan write, failed write, error return} -match glob -body { set res {} proc foo {args} {oninit; onfinal; track; return -code error BOOM!} @@ -2466,7 +2450,7 @@ test iocmd.tf-24.7 {chan write, failed write, error return} -match glob -body { rename foo {} set res } -result {{write rc* snarfsnarfsnarf} 1 BOOM!} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} test iocmd.tf-24.8 {chan write, failed write, error return} -match glob -body { set res {} proc foo {args} {oninit; onfinal; track; error BOOM!} @@ -2480,7 +2464,7 @@ test iocmd.tf-24.8 {chan write, failed write, error return} -match glob -body { rename foo {} set res } -result {{write rc* snarfsnarfsnarf} 1 BOOM!} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} test iocmd.tf-24.9 {chan write, failed write, break return is error} -match glob -body { set res {} proc foo {args} {oninit; onfinal; track; return -code break BOOM!} @@ -2494,7 +2478,7 @@ test iocmd.tf-24.9 {chan write, failed write, break return is error} -match glob rename foo {} set res } -result {{write rc* snarfsnarfsnarf} 1 *bad code*} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} test iocmd.tf-24.10 {chan write, failed write, continue return is error} -match glob -body { set res {} proc foo {args} {oninit; onfinal; track; return -code continue BOOM!} @@ -2508,7 +2492,7 @@ test iocmd.tf-24.10 {chan write, failed write, continue return is error} -match rename foo {} set res } -result {{write rc* snarfsnarfsnarf} 1 *bad code*} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} test iocmd.tf-24.11 {chan write, failed write, custom return is error} -match glob -body { set res {} proc foo {args} {oninit; onfinal; track; return -code 777 BOOM!} @@ -2522,7 +2506,7 @@ test iocmd.tf-24.11 {chan write, failed write, custom return is error} -match gl rename foo {} set res } -result {{write rc* snarfsnarfsnarf} 1 *bad code*} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} test iocmd.tf-24.12 {chan write, failed write, non-numeric return is error} -match glob -body { set res {} proc foo {args} {oninit; onfinal; track; return BANG} @@ -2536,7 +2520,7 @@ test iocmd.tf-24.12 {chan write, failed write, non-numeric return is error} -mat rename foo {} set res } -result {{write rc* snarfsnarfsnarf} 1 {expected integer but got "BANG"}} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} test iocmd.tf-24.13 {chan write, failed write, level is ignored} -match glob -body { set res {} proc foo {args} {oninit; onfinal; track; return -level 55 -code 777 BOOM!} @@ -2551,7 +2535,7 @@ test iocmd.tf-24.13 {chan write, failed write, level is ignored} -match glob -bo rename foo {} set res } -result {{write rc* snarfsnarfsnarf} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "write"*}} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} test iocmd.tf-24.14 {chan write, no EAGAIN means that writing is allowed at this time, bug 2936225} -match glob -setup { set res {} proc foo {args} { @@ -2570,7 +2554,7 @@ test iocmd.tf-24.14 {chan write, no EAGAIN means that writing is allowed at this rename foo {} unset res } -result {{write rc* ABC} {}} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} test iocmd.tf-24.15 {chan write, EAGAIN means that writing is not allowed at this time, bug 2936225} -match glob -setup { set res {} proc foo {args} { @@ -2590,11 +2574,12 @@ test iocmd.tf-24.15 {chan write, EAGAIN means that writing is not allowed at thi } c] set res } -cleanup { + proc foo {args} {onfinal; set ::done-24.15 1; return 3} + vwait done-24.15 rename foo {} unset res - update } -result {{write rc* ABC} {watch rc* write} {}} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} test iocmd.tf-24.16 {chan write, note the background flush setup by close due to the EAGAIN leaving data in buffers.} -match glob -setup { set res {} @@ -2615,16 +2600,18 @@ test iocmd.tf-24.16 {chan write, note the background flush setup by close due to } c] # Replace handler with all-tracking one which doesn't error. # This will tell us if a write-due-flush is there. - proc foo {args} { note BG ; track } + proc foo {args} { onfinal; note BG ; track ; set ::endbody-24.16 1} # Flush (sic!) the event-queue to capture the write from a # BG-flush. - update + vwait endbody-24.16 set res } -cleanup { + proc foo {args} {onfinal; set ::done-24.16 1; return 3} + vwait done-24.16 rename foo {} unset res } -result {{write rc* ABC} {watch rc* write} {} BG {write rc* ABC}} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} # --- === *** ########################### # method cgetall @@ -2640,7 +2627,7 @@ test iocmd.tf-25.1 {chan configure, cgetall, standard options} -match glob -body } c] rename foo {} set res -} -constraints {testchannel testthread} \ +} -constraints {testchannel thread} \ -result {{-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -translation {auto *}}} test iocmd.tf-25.2 {chan configure, cgetall, no options} -match glob -body { set res {} @@ -2653,7 +2640,7 @@ test iocmd.tf-25.2 {chan configure, cgetall, no options} -match glob -body { } c] rename foo {} set res -} -constraints {testchannel testthread} \ +} -constraints {testchannel thread} \ -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -translation {auto *}}} test iocmd.tf-25.3 {chan configure, cgetall, regular result} -match glob -body { set res {} @@ -2669,7 +2656,7 @@ test iocmd.tf-25.3 {chan configure, cgetall, regular result} -match glob -body { } c] rename foo {} set res -} -constraints {testchannel testthread} \ +} -constraints {testchannel thread} \ -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -translation {auto *} -bar foo -snarf x}} test iocmd.tf-25.4 {chan configure, cgetall, bad result, list of uneven length} -match glob -body { set res {} @@ -2686,7 +2673,7 @@ test iocmd.tf-25.4 {chan configure, cgetall, bad result, list of uneven length} } c] rename foo {} set res -} -constraints {testchannel testthread} -result {{cgetall rc*} 1 {Expected list with even number of elements, got 1 element instead}} +} -constraints {testchannel thread} -result {{cgetall rc*} 1 {Expected list with even number of elements, got 1 element instead}} test iocmd.tf-25.5 {chan configure, cgetall, bad result, not a list} -match glob -body { set res {} proc foo {args} { @@ -2702,7 +2689,7 @@ test iocmd.tf-25.5 {chan configure, cgetall, bad result, not a list} -match glob } c] rename foo {} set res -} -constraints {testchannel testthread} -result {{cgetall rc*} 1 {unmatched open brace in list}} +} -constraints {testchannel thread} -result {{cgetall rc*} 1 {unmatched open brace in list}} test iocmd.tf-25.6 {chan configure, cgetall, error return} -match glob -body { set res {} proc foo {args} { @@ -2718,7 +2705,7 @@ test iocmd.tf-25.6 {chan configure, cgetall, error return} -match glob -body { } c] rename foo {} set res -} -constraints {testchannel testthread} -result {{cgetall rc*} 1 BOOM!} +} -constraints {testchannel thread} -result {{cgetall rc*} 1 BOOM!} test iocmd.tf-25.7 {chan configure, cgetall, break return is error} -match glob -body { set res {} proc foo {args} { @@ -2735,7 +2722,7 @@ test iocmd.tf-25.7 {chan configure, cgetall, break return is error} -match glob rename foo {} set res } -result {{cgetall rc*} 1 *bad code*} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} test iocmd.tf-25.8 {chan configure, cgetall, continue return is error} -match glob -body { set res {} proc foo {args} { @@ -2752,7 +2739,7 @@ test iocmd.tf-25.8 {chan configure, cgetall, continue return is error} -match gl rename foo {} set res } -result {{cgetall rc*} 1 *bad code*} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} test iocmd.tf-25.9 {chan configure, cgetall, custom return is error} -match glob -body { set res {} proc foo {args} { @@ -2769,7 +2756,7 @@ test iocmd.tf-25.9 {chan configure, cgetall, custom return is error} -match glob rename foo {} set res } -result {{cgetall rc*} 1 *bad code*} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} test iocmd.tf-25.10 {chan configure, cgetall, level is ignored} -match glob -body { set res {} proc foo {args} { @@ -2787,7 +2774,7 @@ test iocmd.tf-25.10 {chan configure, cgetall, level is ignored} -match glob -bod rename foo {} set res } -result {{cgetall rc*} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "cgetall"*}} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} # --- === *** ########################### # method configure @@ -2805,7 +2792,7 @@ test iocmd.tf-26.1 {chan configure, set standard option} -match glob -body { } c] rename foo {} set res -} -constraints {testchannel testthread} -result {{}} +} -constraints {testchannel thread} -result {{}} test iocmd.tf-26.2 {chan configure, set option, error return} -match glob -body { set res {} proc foo {args} { @@ -2821,7 +2808,7 @@ test iocmd.tf-26.2 {chan configure, set option, error return} -match glob -body } c] rename foo {} set res -} -constraints {testchannel testthread} -result {{configure rc* -rc-foo bar} 1 BOOM!} +} -constraints {testchannel thread} -result {{configure rc* -rc-foo bar} 1 BOOM!} test iocmd.tf-26.3 {chan configure, set option, ok return} -match glob -body { set res {} proc foo {args} {oninit configure; onfinal; track; return} @@ -2833,7 +2820,7 @@ test iocmd.tf-26.3 {chan configure, set option, ok return} -match glob -body { } c] rename foo {} set res -} -constraints {testchannel testthread} -result {{configure rc* -rc-foo bar} {}} +} -constraints {testchannel thread} -result {{configure rc* -rc-foo bar} {}} test iocmd.tf-26.4 {chan configure, set option, break return is error} -match glob -body { set res {} proc foo {args} { @@ -2850,7 +2837,7 @@ test iocmd.tf-26.4 {chan configure, set option, break return is error} -match gl rename foo {} set res } -result {{configure rc* -rc-foo bar} 1 *bad code*} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} test iocmd.tf-26.5 {chan configure, set option, continue return is error} -match glob -body { set res {} proc foo {args} { @@ -2867,7 +2854,7 @@ test iocmd.tf-26.5 {chan configure, set option, continue return is error} -match rename foo {} set res } -result {{configure rc* -rc-foo bar} 1 *bad code*} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} test iocmd.tf-26.6 {chan configure, set option, custom return is error} -match glob -body { set res {} proc foo {args} { @@ -2884,7 +2871,7 @@ test iocmd.tf-26.6 {chan configure, set option, custom return is error} -match g rename foo {} set res } -result {{configure rc* -rc-foo bar} 1 *bad code*} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} test iocmd.tf-26.7 {chan configure, set option, level is ignored} -match glob -body { set res {} proc foo {args} { @@ -2902,7 +2889,7 @@ test iocmd.tf-26.7 {chan configure, set option, level is ignored} -match glob -b rename foo {} set res } -result {{configure rc* -rc-foo bar} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "configure"*}} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} # --- === *** ########################### # method cget @@ -2918,7 +2905,7 @@ test iocmd.tf-27.1 {chan configure, get option, ok return} -match glob -body { } c] rename foo {} set res -} -constraints {testchannel testthread} -result {{cget rc* -rc-foo} foo} +} -constraints {testchannel thread} -result {{cget rc* -rc-foo} foo} test iocmd.tf-27.2 {chan configure, get option, error return} -match glob -body { set res {} proc foo {args} { @@ -2934,7 +2921,7 @@ test iocmd.tf-27.2 {chan configure, get option, error return} -match glob -body } c] rename foo {} set res -} -constraints {testchannel testthread} -result {{cget rc* -rc-foo} 1 BOOM!} +} -constraints {testchannel thread} -result {{cget rc* -rc-foo} 1 BOOM!} test iocmd.tf-27.3 {chan configure, get option, break return is error} -match glob -body { set res {} proc foo {args} { @@ -2951,7 +2938,7 @@ test iocmd.tf-27.3 {chan configure, get option, break return is error} -match gl rename foo {} set res } -result {{cget rc* -rc-foo} 1 BOOM!} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} test iocmd.tf-27.4 {chan configure, get option, continue return is error} -match glob -body { set res {} proc foo {args} { @@ -2968,7 +2955,7 @@ test iocmd.tf-27.4 {chan configure, get option, continue return is error} -match rename foo {} set res } -result {{cget rc* -rc-foo} 1 *bad code*} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} test iocmd.tf-27.5 {chan configure, get option, custom return is error} -match glob -body { set res {} proc foo {args} { @@ -2985,7 +2972,7 @@ test iocmd.tf-27.5 {chan configure, get option, custom return is error} -match g rename foo {} set res } -result {{cget rc* -rc-foo} 1 *bad code*} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} test iocmd.tf-27.6 {chan configure, get option, level is ignored} -match glob -body { set res {} proc foo {args} { @@ -3003,7 +2990,7 @@ test iocmd.tf-27.6 {chan configure, get option, level is ignored} -match glob -b rename foo {} set res } -result {{cget rc* -rc-foo} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "cget"*}} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} # --- === *** ########################### # method seek @@ -3020,7 +3007,7 @@ test iocmd.tf-28.1 {chan tell, not supported by handler} -match glob -body { rename foo {} set res } -result {-1} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} test iocmd.tf-28.2 {chan tell, error return} -match glob -body { set res {} proc foo {args} {oninit seek; onfinal; track; return -code error BOOM!} @@ -3034,7 +3021,7 @@ test iocmd.tf-28.2 {chan tell, error return} -match glob -body { rename foo {} set res } -result {{seek rc* 0 current} 1 BOOM!} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} test iocmd.tf-28.3 {chan tell, break return is error} -match glob -body { set res {} proc foo {args} {oninit seek; onfinal; track; return -code break BOOM!} @@ -3048,7 +3035,7 @@ test iocmd.tf-28.3 {chan tell, break return is error} -match glob -body { rename foo {} set res } -result {{seek rc* 0 current} 1 *bad code*} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} test iocmd.tf-28.4 {chan tell, continue return is error} -match glob -body { set res {} proc foo {args} {oninit seek; onfinal; track; return -code continue BOOM!} @@ -3062,7 +3049,7 @@ test iocmd.tf-28.4 {chan tell, continue return is error} -match glob -body { rename foo {} set res } -result {{seek rc* 0 current} 1 *bad code*} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} test iocmd.tf-28.5 {chan tell, custom return is error} -match glob -body { set res {} proc foo {args} {oninit seek; onfinal; track; return -code 222 BOOM!} @@ -3076,7 +3063,7 @@ test iocmd.tf-28.5 {chan tell, custom return is error} -match glob -body { rename foo {} set res } -result {{seek rc* 0 current} 1 *bad code*} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} test iocmd.tf-28.6 {chan tell, level is ignored} -match glob -body { set res {} proc foo {args} {oninit seek; onfinal; track; return -level 11 -code 222 BANG} @@ -3091,7 +3078,7 @@ test iocmd.tf-28.6 {chan tell, level is ignored} -match glob -body { rename foo {} set res } -result {{seek rc* 0 current} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "seek"*}} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} test iocmd.tf-28.7 {chan tell, regular return} -match glob -body { set res {} proc foo {args} {oninit seek; onfinal; track; return 88} @@ -3104,7 +3091,7 @@ test iocmd.tf-28.7 {chan tell, regular return} -match glob -body { rename foo {} set res } -result {{seek rc* 0 current} 88} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} test iocmd.tf-28.8 {chan tell, negative return} -match glob -body { set res {} proc foo {args} {oninit seek; onfinal; track; return -1} @@ -3118,7 +3105,7 @@ test iocmd.tf-28.8 {chan tell, negative return} -match glob -body { rename foo {} set res } -result {{seek rc* 0 current} 1 {Tried to seek before origin}} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} test iocmd.tf-28.9 {chan tell, string return} -match glob -body { set res {} proc foo {args} {oninit seek; onfinal; track; return BOGUS} @@ -3132,7 +3119,7 @@ test iocmd.tf-28.9 {chan tell, string return} -match glob -body { rename foo {} set res } -result {{seek rc* 0 current} 1 {expected integer but got "BOGUS"}} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} test iocmd.tf-28.10 {chan seek, not supported by handler} -match glob -body { set res {} proc foo {args} {oninit; onfinal; track; note MUST_NOT_HAPPEN; return} @@ -3146,7 +3133,7 @@ test iocmd.tf-28.10 {chan seek, not supported by handler} -match glob -body { rename foo {} set res } -result {1 {error during seek on "rc*": invalid argument}} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} test iocmd.tf-28.11 {chan seek, error return} -match glob -body { set res {} proc foo {args} {oninit seek; onfinal; track; return -code error BOOM!} @@ -3160,7 +3147,7 @@ test iocmd.tf-28.11 {chan seek, error return} -match glob -body { rename foo {} set res } -result {{seek rc* 0 start} 1 BOOM!} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} test iocmd.tf-28.12 {chan seek, break return is error} -match glob -body { set res {} proc foo {args} {oninit seek; onfinal; track; return -code break BOOM!} @@ -3174,7 +3161,7 @@ test iocmd.tf-28.12 {chan seek, break return is error} -match glob -body { rename foo {} set res } -result {{seek rc* 0 start} 1 *bad code*} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} test iocmd.tf-28.13 {chan seek, continue return is error} -match glob -body { set res {} proc foo {args} {oninit seek; onfinal; track; return -code continue BOOM!} @@ -3188,7 +3175,7 @@ test iocmd.tf-28.13 {chan seek, continue return is error} -match glob -body { rename foo {} set res } -result {{seek rc* 0 start} 1 *bad code*} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} test iocmd.tf-28.14 {chan seek, custom return is error} -match glob -body { set res {} proc foo {args} {oninit seek; onfinal; track; return -code 99 BOOM!} @@ -3202,7 +3189,7 @@ test iocmd.tf-28.14 {chan seek, custom return is error} -match glob -body { rename foo {} set res } -result {{seek rc* 0 start} 1 *bad code*} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} test iocmd.tf-28.15 {chan seek, level is ignored} -match glob -body { set res {} proc foo {args} {oninit seek; onfinal; track; return -level 33 -code 99 BANG} @@ -3217,7 +3204,7 @@ test iocmd.tf-28.15 {chan seek, level is ignored} -match glob -body { rename foo {} set res } -result {{seek rc* 0 start} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "seek"*}} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} test iocmd.tf-28.16 {chan seek, bogus return, negative location} -match glob -body { set res {} proc foo {args} {oninit seek; onfinal; track; return -45} @@ -3231,7 +3218,7 @@ test iocmd.tf-28.16 {chan seek, bogus return, negative location} -match glob -bo rename foo {} set res } -result {{seek rc* 0 start} 1 {Tried to seek before origin}} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} test iocmd.tf-28.17 {chan seek, bogus return, string return} -match glob -body { set res {} proc foo {args} {oninit seek; onfinal; track; return BOGUS} @@ -3245,7 +3232,7 @@ test iocmd.tf-28.17 {chan seek, bogus return, string return} -match glob -body { rename foo {} set res } -result {{seek rc* 0 start} 1 {expected integer but got "BOGUS"}} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} test iocmd.tf-28.18 {chan seek, ok result} -match glob -body { set res {} proc foo {args} {oninit seek; onfinal; track; return 23} @@ -3258,7 +3245,7 @@ test iocmd.tf-28.18 {chan seek, ok result} -match glob -body { rename foo {} set res } -result {{seek rc* 0 current} {}} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} foreach {testname code} { iocmd.tf-28.19.0 start iocmd.tf-28.19.1 current @@ -3276,7 +3263,7 @@ foreach {testname code} { rename foo {} set res } -result [list [list seek rc* 0 $code] {}] \ - -constraints {testchannel testthread} + -constraints {testchannel thread} } # --- === *** ########################### @@ -3294,7 +3281,7 @@ test iocmd.tf-29.1 {chan blocking, no handler support} -match glob -body { rename foo {} set res } -result {1} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} test iocmd.tf-29.2 {chan blocking, no handler support} -match glob -body { set res {} proc foo {args} {oninit; onfinal; track; note MUST_NOT_HAPPEN; return} @@ -3308,7 +3295,7 @@ test iocmd.tf-29.2 {chan blocking, no handler support} -match glob -body { rename foo {} set res } -result {{} 0} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} test iocmd.tf-29.3 {chan blocking, retrieval, handler support} -match glob -body { set res {} proc foo {args} {oninit blocking; onfinal; track; note MUST_NOT_HAPPEN; return} @@ -3321,7 +3308,7 @@ test iocmd.tf-29.3 {chan blocking, retrieval, handler support} -match glob -body rename foo {} set res } -result {1} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} test iocmd.tf-29.4 {chan blocking, resetting, handler support} -match glob -body { set res {} proc foo {args} {oninit blocking; onfinal; track; return} @@ -3335,7 +3322,7 @@ test iocmd.tf-29.4 {chan blocking, resetting, handler support} -match glob -body rename foo {} set res } -result {{blocking rc* 0} {} 0} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} test iocmd.tf-29.5 {chan blocking, setting, handler support} -match glob -body { set res {} proc foo {args} {oninit blocking; onfinal; track; return} @@ -3349,7 +3336,7 @@ test iocmd.tf-29.5 {chan blocking, setting, handler support} -match glob -body { rename foo {} set res } -result {{blocking rc* 1} {} 1} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} test iocmd.tf-29.6 {chan blocking, error return} -match glob -body { set res {} proc foo {args} {oninit blocking; onfinal; track; error BOOM!} @@ -3364,7 +3351,7 @@ test iocmd.tf-29.6 {chan blocking, error return} -match glob -body { rename foo {} set res } -result {{blocking rc* 0} 1 BOOM!} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} test iocmd.tf-29.7 {chan blocking, break return is error} -match glob -body { set res {} proc foo {args} {oninit blocking; onfinal; track; return -code break BOOM!} @@ -3378,7 +3365,7 @@ test iocmd.tf-29.7 {chan blocking, break return is error} -match glob -body { rename foo {} set res } -result {{blocking rc* 0} 1 *bad code*} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} test iocmd.tf-29.8 {chan blocking, continue return is error} -match glob -body { set res {} proc foo {args} {oninit blocking; onfinal; track; return -code continue BOOM!} @@ -3392,7 +3379,7 @@ test iocmd.tf-29.8 {chan blocking, continue return is error} -match glob -body { rename foo {} set res } -result {{blocking rc* 0} 1 *bad code*} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} test iocmd.tf-29.9 {chan blocking, custom return is error} -match glob -body { set res {} proc foo {args} {oninit blocking; onfinal; track; return -code 44 BOOM!} @@ -3406,7 +3393,7 @@ test iocmd.tf-29.9 {chan blocking, custom return is error} -match glob -body { rename foo {} set res } -result {{blocking rc* 0} 1 *bad code*} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} test iocmd.tf-29.10 {chan blocking, level is ignored} -match glob -body { set res {} proc foo {args} {oninit blocking; onfinal; track; return -level 99 -code 44 BANG} @@ -3421,7 +3408,7 @@ test iocmd.tf-29.10 {chan blocking, level is ignored} -match glob -body { rename foo {} set res } -result {{blocking rc* 0} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "blocking"*}} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} test iocmd.tf-29.11 {chan blocking, regular return ok, value ignored} -match glob -body { set res {} proc foo {args} {oninit blocking; onfinal; track; return BOGUS} @@ -3435,7 +3422,7 @@ test iocmd.tf-29.11 {chan blocking, regular return ok, value ignored} -match glo rename foo {} set res } -result {{blocking rc* 0} 0 {}} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} # --- === *** ########################### # method watch @@ -3451,7 +3438,7 @@ test iocmd.tf-30.1 {chan watch, read interest, some return} -match glob -body { } c] rename foo {} set res -} -constraints {testchannel testthread} -result {{watch rc* read} {watch rc* {}} {}} +} -constraints {testchannel thread} -result {{watch rc* read} {watch rc* {}} {}} test iocmd.tf-30.2 {chan watch, write interest, error return} -match glob -body { set res {} proc foo {args} {oninit; onfinal; track; return -code error BOOM!_IGNORED} @@ -3464,7 +3451,7 @@ test iocmd.tf-30.2 {chan watch, write interest, error return} -match glob -body } c] rename foo {} set res -} -constraints {testchannel testthread} -result {{watch rc* write} {watch rc* {}} {} {}} +} -constraints {testchannel thread} -result {{watch rc* write} {watch rc* {}} {} {}} test iocmd.tf-30.3 {chan watch, accumulated interests} -match glob -body { set res {} proc foo {args} {oninit; onfinal; track; return} @@ -3479,7 +3466,7 @@ test iocmd.tf-30.3 {chan watch, accumulated interests} -match glob -body { } c] rename foo {} set res -} -constraints {testchannel testthread} \ +} -constraints {testchannel thread} \ -result {{watch rc* write} {watch rc* {read write}} {watch rc* read} {watch rc* {}} {} {} {} {}} test iocmd.tf-30.4 {chan watch, unchanged interest not forwarded} -match glob -body { set res {} @@ -3494,7 +3481,7 @@ test iocmd.tf-30.4 {chan watch, unchanged interest not forwarded} -match glob -b } c] rename foo {} set res -} -constraints {testchannel testthread} \ +} -constraints {testchannel thread} \ -result {{watch rc* write} {watch rc* {read write}} {watch rc* write} {watch rc* {}} {} {} {}} # --- === *** ########################### @@ -3514,7 +3501,7 @@ test iocmd.tf-31.8 {chan postevent, bad input} -match glob -body { } c] rename foo {} set res -} -constraints {testchannel testthread} \ +} -constraints {testchannel thread} \ -result {{can not find reflected channel named "rc*"}} # --- === *** ########################### @@ -3525,12 +3512,15 @@ test iocmd.tf-31.8 {chan postevent, bad input} -match glob -body { test iocmd.tf-32.0 {origin thread of moved channel gone} -match glob -body { #puts <<$tcltest::mainThread>>main - set tida [testthread create];#puts <<$tida>> - set tidb [testthread create];#puts <<$tidb>> + set tida [thread::create -preserved];#puts <<$tida>> + thread::send $tida {load {} Tcltest} + + set tidb [thread::create -preserved];#puts <<$tidb>> + thread::send $tidb {load {} Tcltest} # Set up channel in thread - testthread send $tida $helperscript - set chan [testthread send $tida { + thread::send $tida $helperscript + set chan [thread::send $tida { proc foo {args} {oninit seek; onfinal; track; return} set chan [chan create {r w} foo] fconfigure $chan -buffering none @@ -3538,67 +3528,82 @@ test iocmd.tf-32.0 {origin thread of moved channel gone} -match glob -body { }] # Move channel to 2nd thread. - testthread send $tida [list testchannel cut $chan] - testthread send $tidb [list testchannel splice $chan] + thread::send $tida [list testchannel cut $chan] + thread::send $tidb [list testchannel splice $chan] # Kill origin thread, then access channel from 2nd thread. - testthread send -async $tida {testthread exit} - after 100 + thread::release $tida set res {} - lappend res [catch {testthread send $tidb [list puts $chan shoo]} msg] $msg + lappend res [catch {thread::send $tidb [list puts $chan shoo]} msg] $msg - lappend res [catch {testthread send $tidb [list tell $chan]} msg] $msg - lappend res [catch {testthread send $tidb [list seek $chan 1]} msg] $msg - lappend res [catch {testthread send $tidb [list gets $chan]} msg] $msg - lappend res [catch {testthread send $tidb [list close $chan]} msg] $msg - tcltest::threadReap + lappend res [catch {thread::send $tidb [list tell $chan]} msg] $msg + lappend res [catch {thread::send $tidb [list seek $chan 1]} msg] $msg + lappend res [catch {thread::send $tidb [list gets $chan]} msg] $msg + lappend res [catch {thread::send $tidb [list close $chan]} msg] $msg + thread::release $tidb set res -} -constraints {testchannel testthread} \ +} -constraints {testchannel thread} \ -result {1 {Owner lost} 1 {Owner lost} 1 {Owner lost} 1 {Owner lost} 1 {Owner lost}} + +# The test iocmd.tf-32.1 unavoidably exhibits a memory leak. We are testing +# the ability of the reflected channel system to react to the situation where +# the thread in which the driver routines runs exits during driver operations. +# In this case, thread exit handlers signal back to the owner thread so that the +# channel operation does not hang. There's no way to test this without actually +# exiting a thread in mid-operation, and that action is unavoidably leaky (which +# is why [thread::exit] is advised against). +# +# Use constraints to skip this test while valgrinding so this expected leak +# doesn't prevent a finding of "leak-free". +# +testConstraint notValgrind [expr {![testConstraint valgrind]}] test iocmd.tf-32.1 {origin thread of moved channel destroyed during access} -match glob -body { #puts <<$tcltest::mainThread>>main - set tida [testthread create];#puts <<$tida>> - set tidb [testthread create];#puts <<$tidb>> + set tida [thread::create -preserved];#puts <<$tida>> + thread::send $tida {load {} Tcltest} + set tidb [thread::create -preserved];#puts <<$tidb>> + thread::send $tidb {load {} Tcltest} # Set up channel in thread - set chan [testthread send $tida $helperscript] - set chan [testthread send $tida { + thread::send $tida $helperscript + set chan [thread::send $tida { proc foo {args} { oninit; onfinal; track; # destroy thread during channel access - testthread exit - return} + thread::exit + } set chan [chan create {r w} foo] fconfigure $chan -buffering none set chan }] # Move channel to 2nd thread. - testthread send $tida [list testchannel cut $chan] - testthread send $tidb [list testchannel splice $chan] + thread::send $tida [list testchannel cut $chan] + thread::send $tidb [list testchannel splice $chan] # Run access from thread B, wait for response from A (A is not # using event loop at this point, so the event pile up in the # queue. - testthread send $tidb [list set chan $chan] - testthread send $tidb [list set mid $tcltest::mainThread] - testthread send -async $tidb { + thread::send $tidb [list set chan $chan] + thread::send $tidb [list set mid [thread::id]] + thread::send -async $tidb { # wait a bit, give the main thread the time to start its event # loop to wait for the response from B after 2000 catch { puts $chan shoo } res - testthread send -async $mid [list set ::res $res] + thread::send -async $mid [list set ::res $res] } vwait ::res - tcltest::threadReap + catch {thread::release $tida} + thread::release $tidb set res -} -constraints {testchannel testthread} \ +} -constraints {testchannel thread notValgrind} \ -result {Owner lost} # ### ### ### ######### ######### ######### diff --git a/tests/oo.test b/tests/oo.test index 5ec5d2f..e5a17f1 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -863,7 +863,7 @@ test oo-6.16 {Bug 3400658: forwarding and wrongargs rewriting - via alias} -setu } -result {wrong # args: should be "foo test d"} test oo-6.17 {Bug 3400658: forwarding and wrongargs rewriting - via ensemble} -setup { oo::class create fooClass -} -constraints knownBug -body { +} -body { oo::define fooClass { forward test handler1 foo bar boo forward handler2 my handler @@ -880,6 +880,16 @@ test oo-6.17 {Bug 3400658: forwarding and wrongargs rewriting - via ensemble} -s } -returnCodes error -cleanup { fooClass destroy } -result {wrong # args: should be "foo test c d"} +test oo-6.18 {Bug 3408830: more forwarding cases} -setup { + oo::class create fooClass +} -body { + oo::define fooClass { + forward len string length + } + [fooClass create foo] len a b +} -returnCodes error -cleanup { + fooClass destroy +} -result {wrong # args: should be "::foo len string"} test oo-7.1 {OO: inheritance 101} -setup { oo::class create superClass diff --git a/tests/reg.test b/tests/reg.test index d92339f..ca6cdd1 100644 --- a/tests/reg.test +++ b/tests/reg.test @@ -626,16 +626,24 @@ expectMatch 13.13 P "a\\nb" "a\nb" "a\nb" expectMatch 13.14 P "a\\rb" "a\rb" "a\rb" expectMatch 13.15 P "a\\tb" "a\tb" "a\tb" expectMatch 13.16 P "a\\u0008x" "a\bx" "a\bx" -expectError 13.17 - {a\u008x} EESCAPE +expectMatch 13.17 P {a\u008x} "a\bx" "a\bx" expectMatch 13.18 P "a\\u00088x" "a\b8x" "a\b8x" expectMatch 13.19 P "a\\U00000008x" "a\bx" "a\bx" -expectError 13.20 - {a\U0000008x} EESCAPE +expectMatch 13.20 P {a\U0000008x} "a\bx" "a\bx" expectMatch 13.21 P "a\\vb" "a\vb" "a\vb" expectMatch 13.22 MP "a\\x08x" "a\bx" "a\bx" expectError 13.23 - {a\xq} EESCAPE -expectMatch 13.24 MP "a\\x0008x" "a\bx" "a\bx" +expectMatch 13.24 MP "a\\x08x" "a\bx" "a\bx" expectError 13.25 - {a\z} EESCAPE expectMatch 13.26 MP "a\\010b" "a\bb" "a\bb" +expectMatch 13.27 P "a\\U00001234x" "a\u1234x" "a\u1234x" +expectMatch 13.28 P {a\U00001234x} "a\u1234x" "a\u1234x" +expectMatch 13.29 P "a\\U0001234x" "a\u1234x" "a\u1234x" +expectMatch 13.30 P {a\U0001234x} "a\u1234x" "a\u1234x" +expectMatch 13.31 P "a\\U000012345x" "a\u12345x" "a\u12345x" +expectMatch 13.32 P {a\U000012345x} "a\u12345x" "a\u12345x" +expectMatch 13.33 P "a\\U1000000x" "a\ufffd0x" "a\ufffd0x" +expectMatch 13.34 P {a\U1000000x} "a\ufffd0x" "a\ufffd0x" doing 14 "back references" @@ -682,6 +690,7 @@ expectError 15.9 - {a((((((((((b\10))))))))))c} ESUBREG expectMatch 15.10 MP "a\\12b" "a\nb" "a\nb" expectError 15.11 b {a\12b} ESUBREG expectMatch 15.12 eAS {a\12b} a12b a12b +expectMatch 15.13 MP {a\701b} a\u00381b a\u00381b doing 16 "expanded syntax" diff --git a/tests/socket.test b/tests/socket.test index 58eb3ee..f63f5ca 100644 --- a/tests/socket.test +++ b/tests/socket.test @@ -1760,6 +1760,7 @@ test socket-14.1 {[socket -async] fileevent while still connecting} \ set client [socket -async localhost $port] fileevent $client writable { lappend x [fconfigure $client -error] + fileevent $client writable {} } set after [after 1000 {lappend x timeout}] while {[llength $x] < 2 && "timeout" ni $x} { diff --git a/tests/thread.test b/tests/thread.test index 865c7c6..e818388 100644 --- a/tests/thread.test +++ b/tests/thread.test @@ -21,6 +21,8 @@ if {[lsearch [namespace children] ::tcltest] == -1} { testConstraint testthread [expr {[info commands testthread] != {}}] testConstraint thread [expr {0 == [catch {package require Thread 2.6}]}] +testConstraint notValgrind [expr {![testConstraint valgrind]}] + if {[testConstraint testthread]} { testthread errorproc ThreadError } @@ -855,7 +857,7 @@ test thread-7.23 {cancel: slave interp -unwind} {testthread} { [expr {[info exists ::threadError] ? \ [lindex [split $::threadError \n] 0] : "" }] } {{} 1 1 {eval unwound}} -test thread-7.24 {cancel: nested catch inside pure bytecode loop} {testthread} { +test thread-7.24 {cancel: nested catch inside pure bytecode loop} {notValgrind testthread} { threadReap unset -nocomplain ::threadError ::threadId ::threadIdStarted set serverthread [testthread create -joinable { @@ -897,7 +899,7 @@ test thread-7.24 {cancel: nested catch inside pure bytecode loop} {testthread} { [expr {[info exists ::threadError] ? \ [lindex [split $::threadError \n] 0] : "" }] } {{} 1 0 {}} -test thread-7.25 {cancel: nested catch inside pure inside-command loop} {testthread} { +test thread-7.25 {cancel: nested catch inside pure inside-command loop} {notValgrind testthread} { threadReap unset -nocomplain ::threadError ::threadId ::threadIdStarted set serverthread [testthread create -joinable { @@ -1003,7 +1005,7 @@ test thread-7.27 {cancel: send async cancel -- switch} {testthread} { [expr {[info exists ::threadError] ? \ [lindex [split $::threadError \n] 0] : "" }] } {{} 1 1 {eval canceled}} -test thread-7.28 {cancel: send async cancel nested catch inside pure bytecode loop} {testthread} { +test thread-7.28 {cancel: send async cancel nested catch inside pure bytecode loop} {notValgrind testthread} { threadReap unset -nocomplain ::threadError ::threadId ::threadIdStarted set serverthread [testthread create -joinable { @@ -1045,7 +1047,7 @@ test thread-7.28 {cancel: send async cancel nested catch inside pure bytecode lo [expr {[info exists ::threadError] ? \ [lindex [split $::threadError \n] 0] : "" }] } {{} 1 0 {}} -test thread-7.29 {cancel: send async cancel nested catch pure inside-command loop} {testthread} { +test thread-7.29 {cancel: send async cancel nested catch pure inside-command loop} {notValgrind testthread} { threadReap unset -nocomplain ::threadError ::threadId ::threadIdStarted set serverthread [testthread create -joinable { @@ -1089,7 +1091,7 @@ test thread-7.29 {cancel: send async cancel nested catch pure inside-command loo [expr {[info exists ::threadError] ? \ [lindex [split $::threadError \n] 0] : "" }] } {{} 1 0 {}} -test thread-7.30 {cancel: send async testthread cancel nested catch inside pure bytecode loop} {testthread} { +test thread-7.30 {cancel: send async testthread cancel nested catch inside pure bytecode loop} {notValgrind testthread} { threadReap unset -nocomplain ::threadError ::threadId ::threadIdStarted set serverthread [testthread create -joinable { @@ -1131,7 +1133,7 @@ test thread-7.30 {cancel: send async testthread cancel nested catch inside pure [expr {[info exists ::threadError] ? \ [lindex [split $::threadError \n] 0] : "" }] } {{} 1 0 {}} -test thread-7.31 {cancel: send async testthread cancel nested catch pure inside-command loop} {testthread} { +test thread-7.31 {cancel: send async testthread cancel nested catch pure inside-command loop} {notValgrind testthread} { threadReap unset -nocomplain ::threadError ::threadId ::threadIdStarted set serverthread [testthread create -joinable { diff --git a/tests/unixNotfy.test b/tests/unixNotfy.test index 9684bfe..2a17098 100644 --- a/tests/unixNotfy.test +++ b/tests/unixNotfy.test @@ -69,9 +69,8 @@ test unixNotfy-2.1 {Tcl_DeleteFileHandler} \ fileevent $f writable {set x 1} vwait x close $f - set t [thread::create -preserved "thread::send [thread::id] {set x ok}"] + thread::create "thread::send [thread::id] {set x ok}" vwait x - thread::release $t set x } \ -result {ok} \ @@ -91,9 +90,8 @@ test unixNotfy-2.2 {Tcl_DeleteFileHandler} \ close $f1 vwait y close $f2 - set t [thread::create -preserved "thread::send [thread::id] {set x ok}"] + thread::create "thread::send [thread::id] {set x ok}" vwait x - thread::release $t set x } \ -result {ok} \ diff --git a/tests/utf.test b/tests/utf.test index 3bf7b06..64b5cd4 100644 --- a/tests/utf.test +++ b/tests/utf.test @@ -171,7 +171,7 @@ bsCheck \x 120 bsCheck \xa 10 bsCheck \xA 10 bsCheck \x41 65 -bsCheck \x541 65 +bsCheck \x541 84 bsCheck \u 117 bsCheck \uk 117 bsCheck \u41 65 @@ -180,6 +180,18 @@ bsCheck \uA 10 bsCheck \340 224 bsCheck \ua1 161 bsCheck \u4e21 20001 +bsCheck \741 60 +bsCheck \U 85 +bsCheck \Uk 85 +bsCheck \U41 65 +bsCheck \Ua 10 +bsCheck \UA 10 +bsCheck \Ua1 161 +bsCheck \U4e21 20001 +bsCheck \U004e21 20001 +bsCheck \U00004e21 20001 +bsCheck \U00110000 65533 +bsCheck \Uffffffff 65533 test utf-11.1 {Tcl_UtfToUpper} { string toupper {} diff --git a/unix/Makefile.in b/unix/Makefile.in index b3507ba..5014ccb 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -738,7 +738,7 @@ gdb: ${TCL_EXE} $(SHELL_ENV) $(GDB) ./${TCL_EXE} valgrind: ${TCL_EXE} ${TCLTEST_EXE} - $(SHELL_ENV) $(VALGRIND) $(VALGRINDARGS) ./${TCLTEST_EXE} $(TOP_DIR)/tests/all.tcl -singleproc 1 $(TESTFLAGS) + $(SHELL_ENV) $(VALGRIND) $(VALGRINDARGS) ./${TCLTEST_EXE} $(TOP_DIR)/tests/all.tcl -singleproc 1 -constraints valgrind $(TESTFLAGS) valgrindshell: ${TCL_EXE} $(SHELL_ENV) $(VALGRIND) $(VALGRINDARGS) ./${TCL_EXE} $(SCRIPT) |