summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--ChangeLog82
-rw-r--r--doc/Tcl.n30
-rw-r--r--doc/re_syntax.n29
-rw-r--r--generic/regc_lex.c35
-rw-r--r--generic/regcomp.c2
-rw-r--r--generic/regcustom.h2
-rw-r--r--generic/tcl.h14
-rw-r--r--generic/tclCompExpr.c26
-rw-r--r--generic/tclDTrace.d16
-rw-r--r--generic/tclParse.c15
-rw-r--r--generic/tclProc.c2
-rw-r--r--generic/tclUtil.c3
-rw-r--r--library/http/http.tcl8
-rw-r--r--tests/http.test26
-rw-r--r--tests/httpd8
-rw-r--r--tests/oo.test142
-rw-r--r--tests/reg.test15
-rw-r--r--tests/socket.test30
-rw-r--r--tests/thread.test186
-rw-r--r--tests/unixNotfy.test13
-rw-r--r--tests/utf.test14
-rw-r--r--win/tclWinPort.h8
22 files changed, 502 insertions, 204 deletions
diff --git a/ChangeLog b/ChangeLog
index 69acbec..d93002a 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,15 +1,79 @@
+2011-09-15 Don Porter <dgp@users.sourceforge.net>
+
+ * 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
+ EOVERFLOW==E2BIG
+
+2011-09-11 Don Porter <dgp@users.sourceforge.net>
+
+ * tests/thread.test: Convert [testthread] use to Thread package
+ use in thread-6.1. Eliminates a memory leak in `make valgrind`.
+
+ * tests/socket.test: [Bug 3390699]: Convert [testthread] use to
+ Thread package use in socket_*-13.1. Eliminates a memory leak in
+ `make valgrind`.
+
2011-09-09 Don Porter <dgp@users.sourceforge.net>
- * tests/chanio.test: [Bug 3389733] Convert [testthread] use to
+ * tests/chanio.test: [Bug 3389733]: Convert [testthread] use to
* tests/io.test: Thread package use in *io-70.1. Eliminates a
memory leak in `make valgrind`.
2011-09-07 Don Porter <dgp@users.sourceforge.net>
- * generic/tclCompExpr.c: [Bug 3401704] Allow function names like
- * tests/parseExpr.test: influence(), nanobot(), and 99bottles()
- that have been parsed as missing operator syntax errors before
- with the form NUMBER + FUNCTION.
+ * generic/tclCompExpr.c: [Bug 3401704]: Allow function names like
+ * tests/parseExpr.test: influence(), nanobot(), and 99bottles() that
+ have been parsed as missing operator syntax errors before with the
+ form NUMBER + FUNCTION.
***POTENTIAL INCOMPATIBILITY***
2011-09-06 Venkat Iyer <venkat@comit.com>
@@ -36,13 +100,13 @@
2011-09-01 Alexandre Ferrieux <ferrieux@users.sourceforge.net>
- * unix/tclUnixSock.c: [Bug 3401422] Cache script-level changes to
- the nonblocking flag of an async client socket in progress, and
- commit them on completion.
+ * unix/tclUnixSock.c: [Bug 3401422]: Cache script-level changes to the
+ nonblocking flag of an async client socket in progress, and commit
+ them on completion.
2011-09-01 Don Porter <dgp@users.sourceforge.net>
- * generic/tclStrToD.c: [Bug 3402540] Corrections to TclParseNumber()
+ * generic/tclStrToD.c: [Bug 3402540]: Corrections to TclParseNumber()
* tests/binary.test: to make it reject invalid Nan(Hex) strings.
* tests/scan.test: [scan Inf %g] is portable; remove constraint.
diff --git a/doc/Tcl.n b/doc/Tcl.n
index f56c82c..c14c4dc 100644
--- a/doc/Tcl.n
+++ b/doc/Tcl.n
@@ -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/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/oo.test b/tests/oo.test
index b12cb42..e5a17f1 100644
--- a/tests/oo.test
+++ b/tests/oo.test
@@ -748,6 +748,148 @@ test oo-6.7 {OO: forward resolution scope is per-object} -setup {
} -cleanup {
fooClass destroy
} -result 1
+test oo-6.8 {Bug 3400658: forwarding and wrongargs rewriting} -setup {
+ oo::class create fooClass
+} -body {
+ oo::define fooClass {
+ forward test my handler
+ method handler {a b c} {}
+ }
+ fooClass create ::foo
+ foo test
+} -returnCodes error -cleanup {
+ fooClass destroy
+} -result {wrong # args: should be "foo test a b c"}
+test oo-6.9 {Bug 3400658: forwarding and wrongargs rewriting} -setup {
+ oo::class create fooClass
+} -body {
+ oo::define fooClass {
+ forward test my handler
+ method handler {a b c} {list $a,$b,$c}
+ }
+ fooClass create ::foo
+ foo test 1 2 3
+} -cleanup {
+ fooClass destroy
+} -result 1,2,3
+test oo-6.10 {Bug 3400658: forwarding and wrongargs rewriting} -setup {
+ oo::class create fooClass
+} -body {
+ oo::define fooClass {
+ forward test my handler
+ method handler {a b c} {list $a,$b,$c}
+ }
+ fooClass create ::foo
+ foo test 1 2
+} -returnCodes error -cleanup {
+ fooClass destroy
+} -result {wrong # args: should be "foo test a b c"}
+test oo-6.11 {Bug 3400658: forwarding and wrongargs rewriting} -setup {
+ oo::object create foo
+} -body {
+ oo::objdefine foo {
+ forward test my handler
+ method handler {a b c} {}
+ }
+ foo test
+} -returnCodes error -cleanup {
+ foo destroy
+} -result {wrong # args: should be "foo test a b c"}
+test oo-6.12 {Bug 3400658: forwarding and wrongargs rewriting} -setup {
+ oo::object create foo
+} -body {
+ oo::objdefine foo {
+ forward test my handler
+ method handler {a b c} {list $a,$b,$c}
+ }
+ foo test 1 2 3
+} -cleanup {
+ foo destroy
+} -result 1,2,3
+test oo-6.13 {Bug 3400658: forwarding and wrongargs rewriting} -setup {
+ oo::object create foo
+} -body {
+ oo::objdefine foo {
+ forward test my handler
+ method handler {a b c} {list $a,$b,$c}
+ }
+ foo test 1 2
+} -returnCodes error -cleanup {
+ foo destroy
+} -result {wrong # args: should be "foo test a b c"}
+test oo-6.14 {Bug 3400658: forwarding and wrongargs rewriting - multistep} -setup {
+ oo::class create fooClass
+} -body {
+ oo::define fooClass {
+ forward test my handler1 p
+ forward handler1 my handler q
+ method handler {a b c} {}
+ }
+ fooClass create ::foo
+ foo test
+} -returnCodes error -cleanup {
+ fooClass destroy
+} -result {wrong # args: should be "foo test c"}
+test oo-6.15 {Bug 3400658: forwarding and wrongargs rewriting - multistep} -setup {
+ oo::class create fooClass
+} -body {
+ oo::define fooClass {
+ forward test my handler1 p
+ forward handler1 my handler q
+ method handler {a b c} {list $a,$b,$c}
+ }
+ fooClass create ::foo
+ foo test 1
+} -cleanup {
+ fooClass destroy
+} -result q,p,1
+test oo-6.16 {Bug 3400658: forwarding and wrongargs rewriting - via alias} -setup {
+ oo::class create fooClass
+} -body {
+ oo::define fooClass {
+ forward test handler1 foo bar
+ forward handler2 my handler x
+ method handler {a b c d} {list $a,$b,$c,$d}
+ export eval
+ }
+ fooClass create ::foo
+ foo eval {
+ interp alias {} [namespace current]::handler1 \
+ {} [namespace current]::my handler2
+ }
+ foo test 1 2 3
+} -returnCodes error -cleanup {
+ fooClass destroy
+} -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
+} -body {
+ oo::define fooClass {
+ forward test handler1 foo bar boo
+ forward handler2 my handler
+ method handler {a b c d} {list $a,$b,$c,$d}
+ export eval
+ }
+ fooClass create ::foo
+ foo eval {
+ namespace ensemble create \
+ -command [namespace current]::handler1 -parameters {p q} \
+ -map [list boo [list [namespace current]::my handler2]]
+ }
+ foo test 1 2 3
+} -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 0ea0eb5..f63f5ca 100644
--- a/tests/socket.test
+++ b/tests/socket.test
@@ -63,8 +63,8 @@
package require tcltest 2
namespace import -force ::tcltest::*
-# Some tests require the testthread and exec commands
-testConstraint testthread [llength [info commands testthread]]
+# Some tests require the Thread package or exec command
+testConstraint thread [expr {0 == [catch {package require Thread 2.6}]}]
testConstraint exec [llength [info commands exec]]
# Produce a random port number in the Dynamic/Private range
@@ -1672,9 +1672,9 @@ test socket_$af-12.3 {testing inheritance of accepted sockets} -setup {
catch {close $p}
} -result {accepted socket was not inherited}
-test socket_$af-13.1 {Testing use of shared socket between two threads} -setup {
- threadReap
- set path(script) [makeFile [string map [list @localhost@ $localhost] {
+test socket_$af-13.1 {Testing use of shared socket between two threads} -body {
+ # create a thread
+ set serverthread [thread::create -preserved [string map [list @localhost@ $localhost] {
set f [socket -server accept -myaddr @localhost@ 0]
set listen [lindex [fconfigure $f -sockname] 2]
proc accept {s a p} {
@@ -1696,15 +1696,8 @@ test socket_$af-13.1 {Testing use of shared socket between two threads} -setup {
set i 0
vwait x
close $f
- # thread cleans itself up.
- testthread exit
- }] script]
-} -constraints [list socket supported_$af testthread] -body {
- # create a thread
- set serverthread [testthread create [list source $path(script) ] ]
- update
- set port [testthread send $serverthread {set listen}]
- update
+ }]]
+ set port [thread::send $serverthread {set listen}]
set s [socket $localhost $port]
fconfigure $s -buffering line
catch {
@@ -1712,11 +1705,9 @@ test socket_$af-13.1 {Testing use of shared socket between two threads} -setup {
gets $s result
}
close $s
- update
- append result " " [threadReap]
-} -cleanup {
- removeFile script
-} -result {hello 1}
+ thread::release $serverthread
+ append result " " [llength [thread::names]]
+} -result {hello 1} -constraints [list socket supported_$af thread]
# ----------------------------------------------------------------------
@@ -1769,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 a6961ed..6cd4b5d 100644
--- a/tests/thread.test
+++ b/tests/thread.test
@@ -19,6 +19,7 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
# Some tests require the testthread command
testConstraint testthread [expr {[info commands testthread] != {}}]
+testConstraint thread [expr {0 == [catch {package require Thread 2.6}]}]
if {[testConstraint testthread]} {
testthread errorproc ThreadError
@@ -41,40 +42,34 @@ test thread-1.1 {Tcl_ThreadObjCmd: no args} {testthread} {
test thread-1.2 {Tcl_ThreadObjCmd: bad option} {testthread} {
list [catch {testthread foo} msg] $msg
} {1 {bad option "foo": must be cancel, create, event, exit, id, join, names, send, wait, or errorproc}}
-test thread-1.3 {Tcl_ThreadObjCmd: initial thread list} {testthread} {
- list [threadReap] [llength [testthread names]]
-} {1 1}
-test thread-1.4 {Tcl_ThreadObjCmd: thread create } {testthread} {
- threadReap
- set serverthread [testthread create]
- update
- set numthreads [llength [testthread names]]
- threadReap
+test thread-1.3 {Tcl_ThreadObjCmd: initial thread list} {thread} {
+ llength [thread::names]
+} 1
+test thread-1.4 {Tcl_ThreadObjCmd: thread create } {thread} {
+ set serverthread [thread::create -preserved]
+ set numthreads [llength [thread::names]]
+ thread::release $serverthread
set numthreads
} {2}
-test thread-1.5 {Tcl_ThreadObjCmd: thread create one shot} {testthread} {
- threadReap
- testthread create {set x 5}
+test thread-1.5 {Tcl_ThreadObjCmd: thread create one shot} {thread} {
+ thread::create {set x 5}
foreach try {0 1 2 4 5 6} {
# Try various ways to yield
update
after 10
- set l [llength [testthread names]]
+ set l [llength [thread::names]]
if {$l == 1} {
break
}
}
- threadReap
set l
} {1}
-test thread-1.6 {Tcl_ThreadObjCmd: thread exit} {testthread} {
+test thread-1.6 {Tcl_ThreadObjCmd: thread exit} {thread} {
threadReap
- testthread create {testthread exit}
+ thread::create {{*}{}}
update
after 10
- set result [llength [testthread names]]
- threadReap
- set result
+ llength [thread::names]
} {1}
test thread-1.7 {Tcl_ThreadObjCmd: thread id args} {testthread} {
set x [catch {testthread id x} msg]
@@ -98,11 +93,10 @@ test thread-1.12 {Tcl_ThreadObjCmd: send nonint} {testthread} {
set x [catch {testthread send abc command} msg]
list $x $msg
} {1 {expected integer but got "abc"}}
-test thread-1.13 {Tcl_ThreadObjCmd: send args} {testthread} {
- threadReap
- set serverthread [testthread create]
- set five [testthread send $serverthread {set x 5}]
- threadReap
+test thread-1.13 {Tcl_ThreadObjCmd: send args} {thread} {
+ set serverthread [thread::create -preserved]
+ set five [thread::send $serverthread {set x 5}]
+ thread::release $serverthread
set five
} 5
test thread-1.14 {Tcl_ThreadObjCmd: send bad id} {testthread} {
@@ -110,11 +104,10 @@ test thread-1.14 {Tcl_ThreadObjCmd: send bad id} {testthread} {
set x [catch {testthread send $tid {set x 5}} msg]
list $x $msg
} {1 {invalid thread id}}
-test thread-1.15 {Tcl_ThreadObjCmd: wait} {testthread} {
- threadReap
- set serverthread [testthread create {set z 5 ; testthread wait}]
- set five [testthread send $serverthread {set z}]
- threadReap
+test thread-1.15 {Tcl_ThreadObjCmd: wait} {thread} {
+ set serverthread [thread::create -preserved {set z 5 ; thread::wait}]
+ set five [thread::send $serverthread {set z}]
+ thread::release $serverthread
set five
} 5
test thread-1.16 {Tcl_ThreadObjCmd: errorproc args} {testthread} {
@@ -131,130 +124,115 @@ test thread-1.17 {Tcl_ThreadObjCmd: errorproc change} {testthread} {
# NewThread, safe and regular
# ThreadErrorProc, except for printing to standard error
-test thread-2.1 {ListUpdateInner and ListRemove} {testthread} {
- threadReap
+test thread-2.1 {ListUpdateInner and ListRemove} {thread} {
catch {unset tid}
foreach t {0 1 2} {
upvar #0 t$t tid
- set tid [testthread create]
+ set tid [thread::create -preserved]
}
- threadReap
+ foreach t {0 1 2} {
+ upvar #0 t$t tid
+ thread::release $tid
+ }
+ llength [thread::names]
} 1
-test thread-3.1 {TclThreadList} {testthread} {
- threadReap
+test thread-3.1 {TclThreadList} {thread} {
catch {unset tid}
- set len [llength [testthread names]]
+ set len [llength [thread::names]]
set l1 {}
foreach t {0 1 2} {
- lappend l1 [testthread create]
+ lappend l1 [thread::create -preserved]
+ }
+ set l2 [thread::names]
+ set c [string compare [lsort [concat [thread::id] $l1]] [lsort $l2]]
+ foreach t $l1 {
+ thread::release $t
}
- set l2 [testthread names]
- list $l1 $l2
- set c [string compare \
- [lsort -integer [concat $::tcltest::mainThread $l1]] \
- [lsort -integer $l2]]
- threadReap
list $len $c
} {1 0}
-test thread-4.1 {TclThreadSend to self} {testthread} {
+test thread-4.1 {TclThreadSend to self} {thread} {
catch {unset x}
- testthread send [testthread id] {
+ thread::send [thread::id] {
set x 4
}
set x
} {4}
-test thread-4.2 {TclThreadSend -async} {testthread} {
- threadReap
- set len [llength [testthread names]]
- set serverthread [testthread create]
- testthread send -async $serverthread {
- after 1000
- testthread exit
+test thread-4.2 {TclThreadSend -async} {thread} {
+ set len [llength [thread::names]]
+ set serverthread [thread::create -preserved]
+ thread::send -async $serverthread {
+ after 1 {thread::release}
}
- set two [llength [testthread names]]
- after 1500 {set done 1}
+ set two [llength [thread::names]]
+ after 100 {set done 1}
vwait done
- threadReap
- list $len [llength [testthread names]] $two
+ list $len [llength [thread::names]] $two
} {1 1 2}
-test thread-4.3 {TclThreadSend preserve errorInfo} {testthread} {
- threadReap
- set len [llength [testthread names]]
- set serverthread [testthread create]
- set x [catch {testthread send $serverthread {set undef}} msg]
+test thread-4.3 {TclThreadSend preserve errorInfo} {thread} {
+ set len [llength [thread::names]]
+ set serverthread [thread::create -preserved]
+ set x [catch {thread::send $serverthread {set undef}} msg]
set savedErrorInfo $::errorInfo
- threadReap
+ thread::release $serverthread
list $len $x $msg $savedErrorInfo
} {1 1 {can't read "undef": no such variable} {can't read "undef": no such variable
while executing
"set undef"
invoked from within
-"testthread send $serverthread {set undef}"}}
-test thread-4.4 {TclThreadSend preserve code} {testthread} {
- threadReap
- set len [llength [testthread names]]
- set serverthread [testthread create]
+"thread::send $serverthread {set undef}"}}
+test thread-4.4 {TclThreadSend preserve code} {thread} {
+ set len [llength [thread::names]]
+ set serverthread [thread::create -preserved]
set ::errorInfo {}
- set x [catch {testthread send $serverthread {set ::errorInfo {}; break}} msg]
+ set x [catch {thread::send $serverthread {set ::errorInfo {}; break}} msg]
set savedErrorInfo $::errorInfo
- threadReap
+ thread::release $serverthread
list $len $x $msg $savedErrorInfo
} {1 3 {} {}}
-test thread-4.5 {TclThreadSend preserve errorCode} {testthread} {
- threadReap
- set ::tcltest::mainThread [testthread names]
- set serverthread [testthread create]
- set x [catch {testthread send $serverthread {error ERR INFO CODE}} msg]
+test thread-4.5 {TclThreadSend preserve errorCode} {thread} {
+ set serverthread [thread::create]
+ set x [catch {thread::send $serverthread {error ERR INFO CODE}} msg]
set savedErrorCode $::errorCode
- threadReap
+ thread::release $serverthread
list $x $msg $savedErrorCode
} {1 ERR CODE}
-test thread-5.0 {Joining threads} {testthread} {
- threadReap
- set serverthread [testthread create -joinable]
- testthread send -async $serverthread {after 1000 ; testthread exit}
- set res [testthread join $serverthread]
- threadReap
- set res
+test thread-5.0 {Joining threads} {thread} {
+ set serverthread [thread::create -joinable -preserved]
+ thread::send -async $serverthread {after 1000 ; thread::release}
+ thread::join $serverthread
} {0}
-test thread-5.1 {Joining threads after the fact} {testthread} {
- threadReap
- set serverthread [testthread create -joinable]
- testthread send -async $serverthread {testthread exit}
+test thread-5.1 {Joining threads after the fact} {thread} {
+ set serverthread [thread::create -joinable -preserved]
+ thread::send -async $serverthread {thread::release}
after 2000
- set res [testthread join $serverthread]
- threadReap
- set res
+ thread::join $serverthread
} {0}
-test thread-5.2 {Try to join a detached thread} {testthread} {
- threadReap
- set serverthread [testthread create]
- testthread send -async $serverthread {after 1000 ; testthread exit}
- catch {set res [testthread join $serverthread]} msg
- threadReap
+test thread-5.2 {Try to join a detached thread} {thread} {
+ set serverthread [thread::create -preserved]
+ thread::send -async $serverthread {after 1000 ; thread::release}
+ catch {set res [thread::join $serverthread]} msg
+ while {[llength [thread::names]] > 1} {
+ after 20
+ }
lrange $msg 0 2
} {cannot join thread}
-test thread-6.1 {freeing very large object trees in a thread} testthread {
+test thread-6.1 {freeing very large object trees in a thread} thread {
# conceptual duplicate of obj-32.1
- threadReap
- set serverthread [testthread create -joinable]
- testthread send -async $serverthread {
+ set serverthread [thread::create -preserved]
+ thread::send -async $serverthread {
set x {}
for {set i 0} {$i<100000} {incr i} {
set x [list $x {}]
}
unset x
- testthread exit
}
- catch {set res [testthread join $serverthread]} msg
- threadReap
- set res
-} {0}
+ thread::release -wait $serverthread
+} 0
# TIP #285: Script cancellation support
test thread-7.1 {cancel: args} {testthread} {
diff --git a/tests/unixNotfy.test b/tests/unixNotfy.test
index 8af8a21..2a17098 100644
--- a/tests/unixNotfy.test
+++ b/tests/unixNotfy.test
@@ -20,7 +20,8 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
}
# When run in a Tk shell, these tests hang.
-testConstraint noTk [expr {![info exists tk_version]}]
+testConstraint noTk [expr {0 != [catch {package present Tk}]}]
+testConstraint thread [expr {0 == [catch {package require Thread 2.6}]}]
testConstraint testthread [expr {[info commands testthread] != {}}]
# Darwin always uses a threaded notifier
testConstraint unthreaded [expr {
@@ -61,16 +62,15 @@ test unixNotfy-1.2 {Tcl_DeleteFileHandler} -constraints {noTk unix unthreaded} -
}
test unixNotfy-2.1 {Tcl_DeleteFileHandler} \
- -constraints {noTk unix testthread} \
+ -constraints {noTk unix thread} \
-body {
update
set f [open [makeFile "" foo] w]
fileevent $f writable {set x 1}
vwait x
close $f
- testthread create "testthread send [testthread id] {set x ok}"
+ thread::create "thread::send [thread::id] {set x ok}"
vwait x
- threadReap
set x
} \
-result {ok} \
@@ -79,7 +79,7 @@ test unixNotfy-2.1 {Tcl_DeleteFileHandler} \
catch { removeFile foo }
}
test unixNotfy-2.2 {Tcl_DeleteFileHandler} \
- -constraints {noTk unix testthread} \
+ -constraints {noTk unix thread} \
-body {
update
set f1 [open [makeFile "" foo] w]
@@ -90,9 +90,8 @@ test unixNotfy-2.2 {Tcl_DeleteFileHandler} \
close $f1
vwait y
close $f2
- testthread create "testthread send [testthread id] {set x ok}"
+ thread::create "thread::send [thread::id] {set x ok}"
vwait x
- threadReap
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/win/tclWinPort.h b/win/tclWinPort.h
index 66888b9..9b19b23 100644
--- a/win/tclWinPort.h
+++ b/win/tclWinPort.h
@@ -250,11 +250,11 @@
#ifndef EOTHER
# define EOTHER 131 /* Other error */
#endif
-#ifndef EOVERFLOW
-# define EOVERFLOW 132 /* File too big */
-#endif
+/* workaround for mingw-w64 bug 3407992 */
+#undef EOVERFLOW
+#define EOVERFLOW 132 /* File too big */
#ifndef EOWNERDEAD
-# define EOWNERDEAD 133 /* File too big */
+# define EOWNERDEAD 133 /* Owner dead */
#endif
#ifndef EPROTO
# define EPROTO 134 /* Protocol error */
generated by cgit v0.12 at 2024-11-21 14:01:38 (GMT)