diff options
99 files changed, 6146 insertions, 4107 deletions
diff --git a/doc/StringObj.3 b/doc/StringObj.3 index d81f23d..cf8f6d3 100644 --- a/doc/StringObj.3 +++ b/doc/StringObj.3 @@ -293,6 +293,7 @@ of \fBTcl_Format\fR with functionality equivalent to: Tcl_Obj *newPtr = \fBTcl_Format\fR(interp, format, objc, objv); if (newPtr == NULL) return TCL_ERROR; \fBTcl_AppendObjToObj\fR(objPtr, newPtr); +\fBTcl_DecrRefCount\fR(newPtr); return TCL_OK; .CE .PP @@ -337,7 +338,9 @@ Compile-time protection may be provided by some compilers. of \fBTcl_ObjPrintf\fR with functionality equivalent to .PP .CS -\fBTcl_AppendObjToObj\fR(objPtr, \fBTcl_ObjPrintf\fR(format, ...)); +Tcl_Obj *newPtr = \fBTcl_ObjPrintf\fR(format, ...); +\fBTcl_AppendObjToObj\fR(objPtr, newPtr); +\fBTcl_DecrRefCount\fR(newPtr); .CE .PP but with greater convenience and efficiency when the appending diff --git a/doc/clock.n b/doc/clock.n index 42dca80..910ebb8 100644 --- a/doc/clock.n +++ b/doc/clock.n @@ -637,8 +637,9 @@ On output, produces a locale-dependent time of day representation on a 12-hour clock. On input, accepts whatever \fB%r\fR produces. .TP \fB%R\fR -On output, produces a locale-dependent time of day representation on a -24-hour clock. On input, accepts whatever \fB%R\fR produces. +On output, the time in 24-hour notation (%H:%M). For a version +including the seconds, see \fB%T\fR below. On input, accepts whatever +\fB%R\fR produces. .TP \fB%s\fR On output, simply formats the \fItimeVal\fR argument as a decimal @@ -25,11 +25,12 @@ below for a description), depending on \fIoption\fR. The legal This appends the given string (or strings) to the value that the given key maps to in the dictionary value contained in the given variable, writing the resulting dictionary value back to that variable. -Non-existent keys are treated as if they map to an empty string. +Non-existent keys are treated as if they map to an empty string. The +updated dictionary value is returned. .TP \fBdict create \fR?\fIkey value ...\fR? . -Create a new dictionary that contains each of the key/value mappings +Return a new dictionary that contains each of the key/value mappings listed as arguments (keys and values alternating, with each key being followed by its associated value.) .TP @@ -53,10 +54,10 @@ The key rule only matches those key/value pairs whose keys match any of the given patterns (in the style of \fBstring match\fR.) .VE 8.6 .TP -\fBdict filter \fIdictionaryValue \fBscript {\fIkeyVar valueVar\fB} \fIscript\fR +\fBdict filter \fIdictionaryValue \fBscript {\fIkeyVariable valueVariable\fB} \fIscript\fR . The script rule tests for matching by assigning the key to the -\fIkeyVar\fR and the value to the \fIvalueVar\fR, and then evaluating +\fIkeyVariable\fR and the value to the \fIvalueVariable\fR, and then evaluating the given script which should return a boolean value (with the key/value pair only being included in the result of the \fBdict filter\fR when a true value is returned.) Note that the first @@ -74,7 +75,7 @@ of the given patterns (in the style of \fBstring match\fR.) .VE 8.6 .RE .TP -\fBdict for {\fIkeyVar valueVar\fB} \fIdictionaryValue body\fR +\fBdict for {\fIkeyVariable valueVariable\fB} \fIdictionaryValue body\fR . This command takes three arguments, the first a two-element list of variable names (for the key and value respectively of each mapping in @@ -121,7 +122,8 @@ not specified) to the value that the given key maps to in the dictionary value contained in the given variable, writing the resulting dictionary value back to that variable. Non-existent keys are treated as if they map to 0. It is an error to increment a value -for an existing key if that value is not an integer. +for an existing key if that value is not an integer. The updated +dictionary value is returned. .TP \fBdict info \fIdictionaryValue\fR . @@ -145,9 +147,10 @@ to in the dictionary value contained in the given variable, writing the resulting dictionary value back to that variable. Non-existent keys are treated as if they map to an empty list, and it is legal for there to be no items to append to the list. It is an error for the -value that the key maps to to not be representable as a list. +value that the key maps to to not be representable as a list. The +updated dictionary value is returned. .TP -\fBdict map \fR{\fIkeyVar valueVar\fR} \fIdictionaryValue body\fR +\fBdict map \fR{\fIkeyVariable valueVariable\fR} \fIdictionaryValue body\fR . This command applies a transformation to each element of a dictionary, returning a new dictionary. It takes three arguments: the first is a @@ -157,7 +160,7 @@ and the third a script to be evaluated for each mapping with the key and value variables set appropriately (in the manner of \fBlmap\fR). In an iteration where the evaluated script completes normally (\fBTCL_OK\fR, as opposed to an \fBerror\fR, etc.) the result of the script is put into an accumulator -dictionary using the key that is the current contents of the \fIkeyVar\fR +dictionary using the key that is the current contents of the \fIkeyVariable\fR variable at that point. The result of the \fBdict map\fR command is the accumulator dictionary after all keys have been iterated over. .RS @@ -202,7 +205,7 @@ This operation takes the name of a variable containing a dictionary value and places an updated dictionary value in that variable containing a mapping from the given key to the given value. When multiple keys are present, this operation creates or updates a chain -of nested dictionaries. +of nested dictionaries. The updated dictionary value is returned. .TP \fBdict size \fIdictionaryValue\fR . @@ -216,7 +219,8 @@ dictionary value in that variable that does not contain a mapping for the given key. Where multiple keys are present, this describes a path through nested dictionaries to the mapping to remove. At least one key must be specified, but the last key on the key-path need not exist. -All other components on the path must exist. +All other components on the path must exist. The updated dictionary +value is returned. .TP \fBdict update \fIdictionaryVariable key varName \fR?\fIkey varName ...\fR? \fIbody\fR . diff --git a/doc/encoding.n b/doc/encoding.n index be1dc3f..5782199 100644 --- a/doc/encoding.n +++ b/doc/encoding.n @@ -14,10 +14,21 @@ encoding \- Manipulate encodings .BE .SH INTRODUCTION .PP -Strings in Tcl are encoded using 16-bit Unicode characters. Different -operating system interfaces or applications may generate strings in -other encodings such as Shift-JIS. The \fBencoding\fR command helps -to bridge the gap between Unicode and these other formats. +Strings in Tcl are logically a sequence of 16-bit Unicode characters. +These strings are represented in memory as a sequence of bytes that +may be in one of several encodings: modified UTF\-8 (which uses 1 to 3 +bytes per character), 16-bit +.QW Unicode +(which uses 2 bytes per character, with an endianness that is +dependent on the host architecture), and binary (which uses a single +byte per character but only handles a restricted range of characters). +Tcl does not guarantee to always use the same encoding for the same +string. +.PP +Different operating system interfaces or applications may generate +strings in other encodings such as Shift\-JIS. The \fBencoding\fR +command helps to bridge the gap between Unicode and these other +formats. .SH DESCRIPTION .PP Performs one of several encoding related operations, depending on @@ -37,8 +48,9 @@ system encoding is used. Convert \fIstring\fR from Unicode to the specified \fIencoding\fR. The result is a sequence of bytes that represents the converted string. Each byte is stored in the lower 8-bits of a Unicode -character. If \fIencoding\fR is not specified, the current -system encoding is used. +character (indeed, the resulting string is a binary string as far as +Tcl is concerned, at least initially). If \fIencoding\fR is not +specified, the current system encoding is used. .TP \fBencoding dirs\fR ?\fIdirectoryList\fR? . @@ -56,6 +68,11 @@ searchable directory, that element is ignored. . Returns a list containing the names of all of the encodings that are currently available. +The encodings +.QW utf-8 +and +.QW iso8859-1 +are guaranteed to be present in the list. .TP \fBencoding system\fR ?\fIencoding\fR? . @@ -73,7 +90,7 @@ However, because the \fBsource\fR command always reads files using the current system encoding, Tcl will only source such files correctly when the encoding used to write the file is the same. This tends not to be true in an internationalized setting. For example, if such a -file was sourced in North America (where the ISO8859-1 is normally +file was sourced in North America (where the ISO8859\-1 is normally used), each byte in the file would be treated as a separate character that maps to the 00 page in Unicode. The resulting Tcl strings will not contain the expected Japanese characters. Instead, they will @@ -93,3 +110,6 @@ which is the Hiragana letter HA. Tcl_GetEncoding(3) .SH KEYWORDS encoding, unicode +.\" Local Variables: +.\" mode: nroff +.\" End: diff --git a/doc/fcopy.n b/doc/fcopy.n index ec3d5c6..071896c 100644 --- a/doc/fcopy.n +++ b/doc/fcopy.n @@ -46,8 +46,11 @@ non-blocking mode; the \fBfcopy\fR command takes care of that automatically. However, it is necessary to enter the event loop by using the \fBvwait\fR command or by using Tk. .PP -You are not allowed to do other I/O operations with -\fIinchan\fR or \fIoutchan\fR during a background \fBfcopy\fR. +You are not allowed to do other input operations with \fIinchan\fR, or +output operations with \fIoutchan\fR, during a background +\fBfcopy\fR. The converse is entirely legitimate, as exhibited by the +bidirectional fcopy example below. +.PP If either \fIinchan\fR or \fIoutchan\fR get closed while the copy is in progress, the current copy is stopped and the command callback is \fInot\fR made. @@ -57,7 +60,7 @@ then all data already queued for \fIoutchan\fR is written out. Note that \fIinchan\fR can become readable during a background copy. You should turn off any \fBfileevent\fR handlers during a background copy so those handlers do not interfere with the copy. -Any I/O attempted by a \fBfileevent\fR handler will get a +Any wrong-sided I/O attempted (by a \fBfileevent\fR handler or otherwise) will get a .QW "channel busy" error. .PP @@ -149,6 +152,24 @@ set total 0 -command [list CopyMore $in $out $chunk] vwait done .CE +.PP +The fourth example starts an asynchronous, bidirectional fcopy between +two sockets. Those could also be pipes from two [open "|hal 9000" r+] +(though their conversation would remain secret to the script, since +all four fileevent slots are busy). +.PP +.CS +set flows 2 +proc Done {dir args} { + global flows done + puts "$dir is over." + incr flows -1 + if {$flows<=0} {set done 1} +} +\fBfcopy\fR $sok1 $sok2 -command [list Done UP] +\fBfcopy\fR $sok2 $sok1 -command [list Done DOWN] +vwait done +.CE .SH "SEE ALSO" eof(n), fblocked(n), fconfigure(n), file(n) .SH KEYWORDS diff --git a/doc/string.n b/doc/string.n index 76005fc..163abdd 100644 --- a/doc/string.n +++ b/doc/string.n @@ -343,10 +343,13 @@ misleading. \fBstring bytelength \fIstring\fR . Returns a decimal string giving the number of bytes used to represent -\fIstring\fR in memory. Because UTF\-8 uses one to three bytes to -represent Unicode characters, the byte length will not be the same as -the character length in general. The cases where a script cares about -the byte length are rare. +\fIstring\fR in memory when encoded as Tcl's internal modified UTF\-8; +Tcl may use other encodings for \fIstring\fR as well, and does not +guarantee to only use a single encoding for a particular \fIstring\fR. +Because UTF\-8 uses a variable number of bytes to represent Unicode +characters, the byte length will not be the same as the character +length in general. The cases where a script cares about the byte +length are rare. .RS .PP In almost all cases, you should use the @@ -354,10 +357,27 @@ In almost all cases, you should use the Tcl byte array value). Refer to the \fBTcl_NumUtfChars\fR manual entry for more details on the UTF\-8 representation. .PP +Formally, the \fBstring bytelength\fR operation returns the content of +the \fIlength\fR field of the \fBTcl_Obj\fR structure, after calling +\fBTcl_GetString\fR to ensure that the \fIbytes\fR field is populated. +This is highly unlikely to be useful to Tcl scripts, as Tcl's internal +encoding is not strict UTF\-8, but rather a modified CESU\-8 with a +denormalized NUL (identical to that used in a number of places by +Java's serialization mechanism) to enable basic processing with +non-Unicode-aware C functions. As this representation should only +ever be used by Tcl's implementation, the number of bytes used to +store the representation is of very low value (except to C extension +code, which has direct access for the purpose of memory management, +etc.) +.PP \fICompatibility note:\fR it is likely that this subcommand will be withdrawn in a future version of Tcl. It is better to use the \fBencoding convertto\fR command to convert a string to a known encoding and then apply \fBstring length\fR to that. +.PP +.CS +\fBstring length\fR [encoding convertto utf-8 $theString] +.CE .RE .TP \fBstring wordend \fIstring charIndex\fR diff --git a/doc/tclvars.n b/doc/tclvars.n index 2fec222..48ab83a 100644 --- a/doc/tclvars.n +++ b/doc/tclvars.n @@ -10,7 +10,7 @@ .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME -argc, argv, argv0, auto_path, env, errorCode, errorInfo, tcl_interactive, tcl_library, tcl_nonwordchars, tcl_patchLevel, tcl_pkgPath, tcl_platform, tcl_precision, tcl_rcFileName, tcl_traceCompile, tcl_traceEval, tcl_wordchars, tcl_version \- Variables used by Tcl +argc, argv, argv0, auto_path, env, errorCode, errorInfo, tcl_interactive, tcl_library, tcl_nonwordchars, tcl_patchLevel, tcl_pkgPath, tcl_platform, tcl_precision, tcl_rcFileName, tcl_traceCompile, tcl_traceExec, tcl_wordchars, tcl_version \- Variables used by Tcl .BE .SH DESCRIPTION .PP @@ -347,8 +347,8 @@ was compiled with threads enabled. . This identifies the current user based on the login information available on the platform. -This comes from the USER or LOGNAME environment variable on Unix, -and the value from GetUserName on Windows. +This value comes from the getuid() and getpwuid() system calls on Unix, +and the value from the GetUserName() system call on Windows. .TP \fBwordSize\fR . diff --git a/generic/tcl.h b/generic/tcl.h index b7237bf..e557290 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -67,15 +67,12 @@ extern "C" { * We use this method because there is no autoconf equivalent. */ -#ifndef __WIN32__ -# if defined(_WIN32) || defined(WIN32) || defined(__MINGW32__) || defined(__BORLANDC__) || (defined(__WATCOMC__) && defined(__WINDOWS_386__)) +#ifdef _WIN32 +# ifndef __WIN32__ # define __WIN32__ -# ifndef WIN32 -# define WIN32 -# endif -# ifndef _WIN32 -# define _WIN32 -# endif +# endif +# ifndef WIN32 +# define WIN32 # endif #endif @@ -83,11 +80,11 @@ extern "C" { * STRICT: See MSDN Article Q83456 */ -#ifdef __WIN32__ +#ifdef _WIN32 # ifndef STRICT # define STRICT # endif -#endif /* __WIN32__ */ +#endif /* _WIN32 */ /* * Utility macros: STRINGIFY takes an argument and wraps it in "" (double @@ -191,7 +188,7 @@ extern "C" { * MSVCRT. */ -#if (defined(__WIN32__) && (defined(_MSC_VER) || (defined(__BORLANDC__) && (__BORLANDC__ >= 0x0550)) || defined(__LCC__) || defined(__WATCOMC__) || (defined(__GNUC__) && defined(__declspec)))) +#if (defined(_WIN32) && (defined(_MSC_VER) || (defined(__BORLANDC__) && (__BORLANDC__ >= 0x0550)) || defined(__LCC__) || defined(__WATCOMC__) || (defined(__GNUC__) && defined(__declspec)))) # define HAVE_DECLSPEC 1 # ifdef STATIC_BUILD # define DLLIMPORT @@ -315,14 +312,14 @@ extern "C" { * VOID. This block is skipped under Cygwin and Mingw. */ -#if defined(__WIN32__) && !defined(HAVE_WINNT_IGNORE_VOID) +#if defined(_WIN32) && !defined(HAVE_WINNT_IGNORE_VOID) #ifndef VOID #define VOID void typedef char CHAR; typedef short SHORT; typedef long LONG; #endif -#endif /* __WIN32__ && !HAVE_WINNT_IGNORE_VOID */ +#endif /* _WIN32 && !HAVE_WINNT_IGNORE_VOID */ /* * Macro to use instead of "void" for arguments that must have type "void *" @@ -390,7 +387,7 @@ typedef long LONG; */ #if !defined(TCL_WIDE_INT_TYPE)&&!defined(TCL_WIDE_INT_IS_LONG) -# if defined(__WIN32__) +# if defined(_WIN32) # define TCL_WIDE_INT_TYPE __int64 # ifdef __BORLANDC__ # define TCL_LL_MODIFIER "L" @@ -400,7 +397,7 @@ typedef long LONG; # elif defined(__GNUC__) # define TCL_WIDE_INT_TYPE long long # define TCL_LL_MODIFIER "ll" -# else /* ! __WIN32__ && ! __GNUC__ */ +# else /* ! _WIN32 && ! __GNUC__ */ /* * Don't know what platform it is and configure hasn't discovered what is * going on for us. Try to guess... @@ -415,7 +412,7 @@ typedef long LONG; # define TCL_WIDE_INT_TYPE long long # endif # endif /* NO_LIMITS_H */ -# endif /* __WIN32__ */ +# endif /* _WIN32 */ #endif /* !TCL_WIDE_INT_TYPE & !TCL_WIDE_INT_IS_LONG */ #ifdef TCL_WIDE_INT_IS_LONG # undef TCL_WIDE_INT_TYPE @@ -447,7 +444,7 @@ typedef unsigned TCL_WIDE_INT_TYPE Tcl_WideUInt; # define Tcl_DoubleAsWide(val) ((Tcl_WideInt)((double)(val))) #endif /* TCL_WIDE_INT_IS_LONG */ -#if defined(__WIN32__) +#if defined(_WIN32) # ifdef __BORLANDC__ typedef struct stati64 Tcl_StatBuf; # elif defined(_WIN64) @@ -562,7 +559,7 @@ typedef struct Tcl_ZLibStream_ *Tcl_ZlibStream; * will be called as the main fuction of the new thread created by that call. */ -#if defined __WIN32__ +#if defined _WIN32 typedef unsigned (__stdcall Tcl_ThreadCreateProc) (ClientData clientData); #else typedef void (Tcl_ThreadCreateProc) (ClientData clientData); @@ -574,7 +571,7 @@ typedef void (Tcl_ThreadCreateProc) (ClientData clientData); * in generic/tclThreadTest.c for it's usage. */ -#if defined __WIN32__ +#if defined _WIN32 # define Tcl_ThreadCreateType unsigned __stdcall # define TCL_THREAD_CREATE_RETURN return 0 #else @@ -2436,9 +2433,15 @@ EXTERN void Tcl_GetMemoryInfo(Tcl_DString *dsPtr); /* * Include platform specific public function declarations that are accessible - * via the stubs table. + * via the stubs table. Make all TclOO symbols MODULE_SCOPE (which only + * has effect on building it as a shared library). See ticket [3010352]. */ +#if defined(BUILD_tcl) +# undef TCLAPI +# define TCLAPI MODULE_SCOPE +#endif + #include "tclPlatDecls.h" /* diff --git a/generic/tclClock.c b/generic/tclClock.c index 6d2976d..7e917f6 100644 --- a/generic/tclClock.c +++ b/generic/tclClock.c @@ -19,7 +19,7 @@ * Windows has mktime. The configurators do not check. */ -#ifdef __WIN32__ +#ifdef _WIN32 #define HAVE_MKTIME 1 #endif @@ -548,18 +548,21 @@ ClockGetjuliandayfromerayearmonthdayObjCmd( } dict = objv[1]; if (Tcl_DictObjGet(interp, dict, literals[LIT_ERA], &fieldPtr) != TCL_OK + || fieldPtr == NULL || Tcl_GetIndexFromObj(interp, fieldPtr, eras, "era", TCL_EXACT, &era) != TCL_OK - || Tcl_DictObjGet(interp, dict, literals[LIT_YEAR], - &fieldPtr) != TCL_OK + || Tcl_DictObjGet(interp, dict, literals[LIT_YEAR], &fieldPtr) != TCL_OK + || fieldPtr == NULL || TclGetIntFromObj(interp, fieldPtr, &fields.year) != TCL_OK - || Tcl_DictObjGet(interp, dict, literals[LIT_MONTH], - &fieldPtr) != TCL_OK + || Tcl_DictObjGet(interp, dict, literals[LIT_MONTH], &fieldPtr) != TCL_OK + || fieldPtr == NULL || TclGetIntFromObj(interp, fieldPtr, &fields.month) != TCL_OK - || Tcl_DictObjGet(interp, dict, literals[LIT_DAYOFMONTH], - &fieldPtr) != TCL_OK + || Tcl_DictObjGet(interp, dict, literals[LIT_DAYOFMONTH], &fieldPtr) != TCL_OK + || fieldPtr == NULL || TclGetIntFromObj(interp, fieldPtr, &fields.dayOfMonth)!=TCL_OK || TclGetIntFromObj(interp, objv[2], &changeover) != TCL_OK) { + if (fieldPtr == NULL) + Tcl_SetObjResult(interp, Tcl_NewStringObj("expected key(s) not found in dictionary", -1)); return TCL_ERROR; } fields.era = era; @@ -638,18 +641,21 @@ ClockGetjuliandayfromerayearweekdayObjCmd( } dict = objv[1]; if (Tcl_DictObjGet(interp, dict, literals[LIT_ERA], &fieldPtr) != TCL_OK + || fieldPtr == NULL || Tcl_GetIndexFromObj(interp, fieldPtr, eras, "era", TCL_EXACT, &era) != TCL_OK - || Tcl_DictObjGet(interp, dict, literals[LIT_ISO8601YEAR], - &fieldPtr) != TCL_OK - || TclGetIntFromObj(interp, fieldPtr, &fields.iso8601Year)!=TCL_OK - || Tcl_DictObjGet(interp, dict, literals[LIT_ISO8601WEEK], - &fieldPtr) != TCL_OK - || TclGetIntFromObj(interp, fieldPtr, &fields.iso8601Week)!=TCL_OK - || Tcl_DictObjGet(interp, dict, literals[LIT_DAYOFWEEK], - &fieldPtr) != TCL_OK - || TclGetIntFromObj(interp, fieldPtr, &fields.dayOfWeek) != TCL_OK + || Tcl_DictObjGet(interp, dict, literals[LIT_ISO8601YEAR], &fieldPtr) != TCL_OK + || fieldPtr == NULL + || TclGetIntFromObj(interp, fieldPtr, &(fields.iso8601Year)) != TCL_OK + || Tcl_DictObjGet(interp, dict, literals[LIT_ISO8601WEEK], &fieldPtr) != TCL_OK + || fieldPtr == NULL + || TclGetIntFromObj(interp, fieldPtr, &(fields.iso8601Week)) != TCL_OK + || Tcl_DictObjGet(interp, dict, literals[LIT_DAYOFWEEK], &fieldPtr) != TCL_OK + || fieldPtr == NULL + || TclGetIntFromObj(interp, fieldPtr, &(fields.dayOfWeek)) != TCL_OK || TclGetIntFromObj(interp, objv[2], &changeover) != TCL_OK) { + if (fieldPtr == NULL) + Tcl_SetObjResult(interp, Tcl_NewStringObj("expected key(s) not found in dictionary", -1)); return TCL_ERROR; } fields.era = era; @@ -1697,7 +1703,7 @@ ClockClicksObjCmd( case 1: break; case 2: - if (Tcl_GetIndexFromObj(interp, objv[1], clicksSwitches, "switch", 0, + if (Tcl_GetIndexFromObj(interp, objv[1], clicksSwitches, "option", 0, &index) != TCL_OK) { return TCL_ERROR; } @@ -1867,9 +1873,9 @@ ClockParseformatargsObjCmd( localeObj = litPtr[LIT_C]; timezoneObj = litPtr[LIT__NIL]; for (i = 2; i < objc; i+=2) { - if (Tcl_GetIndexFromObj(interp, objv[i], options, "switch", 0, + if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, &optionIndex) != TCL_OK) { - Tcl_SetErrorCode(interp, "CLOCK", "badSwitch", + Tcl_SetErrorCode(interp, "CLOCK", "badOption", Tcl_GetString(objv[i]), NULL); return TCL_ERROR; } diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index f90819a..d90a747 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -1590,7 +1590,7 @@ FileAttrIsOwnedCmd( * test for equivalence to the current user. */ -#if defined(__WIN32__) || defined(__CYGWIN__) +#if defined(_WIN32) || defined(__CYGWIN__) value = 1; #else value = (geteuid() == buf.st_uid); diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index 41c1eb6..db216e5 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -29,7 +29,7 @@ typedef struct SortElement { union { /* The value that we sorting by. */ const char *strValuePtr; - long intValue; + Tcl_WideInt wideValue; double doubleValue; Tcl_Obj *objValuePtr; } collationKey; @@ -2893,7 +2893,8 @@ Tcl_LsearchObjCmd( { const char *bytes, *patternBytes; int i, match, index, result, listc, length, elemLen, bisect; - int dataType, isIncreasing, lower, upper, patInt, objInt, offset; + int dataType, isIncreasing, lower, upper, offset; + Tcl_WideInt patWide, objWide; int allMatches, inlineReturn, negatedMatch, returnSubindices, noCase; double patDouble, objDouble; SortInfo sortInfo; @@ -3212,7 +3213,7 @@ Tcl_LsearchObjCmd( patternBytes = TclGetStringFromObj(patObj, &length); break; case INTEGER: - result = TclGetIntFromObj(interp, patObj, &patInt); + result = TclGetWideIntFromObj(interp, patObj, &patWide); if (result != TCL_OK) { goto done; } @@ -3281,13 +3282,13 @@ Tcl_LsearchObjCmd( match = DictionaryCompare(patternBytes, bytes); break; case INTEGER: - result = TclGetIntFromObj(interp, itemPtr, &objInt); + result = TclGetWideIntFromObj(interp, itemPtr, &objWide); if (result != TCL_OK) { goto done; } - if (patInt == objInt) { + if (patWide == objWide) { match = 0; - } else if (patInt < objInt) { + } else if (patWide < objWide) { match = -1; } else { match = 1; @@ -3400,14 +3401,14 @@ Tcl_LsearchObjCmd( break; case INTEGER: - result = TclGetIntFromObj(interp, itemPtr, &objInt); + result = TclGetWideIntFromObj(interp, itemPtr, &objWide); if (result != TCL_OK) { if (listPtr != NULL) { Tcl_DecrRefCount(listPtr); } goto done; } - match = (objInt == patInt); + match = (objWide == patWide); break; case REAL: @@ -3971,13 +3972,13 @@ Tcl_LsortObjCmd( if (sortMode == SORTMODE_ASCII) { elementArray[i].collationKey.strValuePtr = TclGetString(indexPtr); } else if (sortMode == SORTMODE_INTEGER) { - long a; + Tcl_WideInt a; - if (TclGetLongFromObj(sortInfo.interp, indexPtr, &a) != TCL_OK) { + if (TclGetWideIntFromObj(sortInfo.interp, indexPtr, &a) != TCL_OK) { sortInfo.resultCode = TCL_ERROR; goto done1; } - elementArray[i].collationKey.intValue = a; + elementArray[i].collationKey.wideValue = a; } else if (sortMode == SORTMODE_REAL) { double a; @@ -4226,10 +4227,10 @@ SortCompare( order = DictionaryCompare(elemPtr1->collationKey.strValuePtr, elemPtr2->collationKey.strValuePtr); } else if (infoPtr->sortMode == SORTMODE_INTEGER) { - long a, b; + Tcl_WideInt a, b; - a = elemPtr1->collationKey.intValue; - b = elemPtr2->collationKey.intValue; + a = elemPtr1->collationKey.wideValue; + b = elemPtr2->collationKey.wideValue; order = ((a >= b) - (a <= b)); } else if (infoPtr->sortMode == SORTMODE_REAL) { double a, b; diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 00c9f2f..0f7f20a 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -161,7 +161,7 @@ Tcl_RegexpObjCmd( if (name[0] != '-') { break; } - if (Tcl_GetIndexFromObj(interp, objv[i], options, "switch", TCL_EXACT, + if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", TCL_EXACT, &index) != TCL_OK) { goto optionError; } @@ -217,7 +217,7 @@ Tcl_RegexpObjCmd( endOfForLoop: if ((objc - i) < (2 - about)) { Tcl_WrongNumArgs(interp, 1, objv, - "?-switch ...? exp string ?matchVar? ?subMatchVar ...?"); + "?-option ...? exp string ?matchVar? ?subMatchVar ...?"); goto optionError; } objc -= i; @@ -231,6 +231,8 @@ Tcl_RegexpObjCmd( if (doinline && ((objc - 2) != 0)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "regexp match variables not allowed when using -inline", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "REGEXP", + "MIX_VAR_INLINE", NULL); goto optionError; } @@ -519,7 +521,7 @@ Tcl_RegsubObjCmd( if (name[0] != '-') { break; } - if (Tcl_GetIndexFromObj(interp, objv[idx], options, "switch", + if (Tcl_GetIndexFromObj(interp, objv[idx], options, "option", TCL_EXACT, &index) != TCL_OK) { goto optionError; } @@ -566,7 +568,7 @@ Tcl_RegsubObjCmd( endOfForLoop: if (objc-idx < 3 || objc-idx > 4) { Tcl_WrongNumArgs(interp, 1, objv, - "?-switch ...? exp string subSpec ?varName?"); + "?-option ...? exp string subSpec ?varName?"); optionError: if (startIndex) { Tcl_DecrRefCount(startIndex); @@ -3391,7 +3393,7 @@ TclSubstOptions( for (i = 0; i < numOpts; i++) { int optionIndex; - if (Tcl_GetIndexFromObj(interp, opts[i], substOptions, "switch", 0, + if (Tcl_GetIndexFromObj(interp, opts[i], substOptions, "option", 0, &optionIndex) != TCL_OK) { return TCL_ERROR; } @@ -3591,7 +3593,7 @@ TclNRSwitchObjCmd( finishedOptions: if (objc - i < 2) { Tcl_WrongNumArgs(interp, 1, objv, - "?-switch ...? string ?pattern body ...? ?default body?"); + "?-option ...? string ?pattern body ...? ?default body?"); return TCL_ERROR; } if (indexVarObj != NULL && mode != OPT_REGEXP) { @@ -3638,7 +3640,7 @@ TclNRSwitchObjCmd( if (objc < 1) { Tcl_WrongNumArgs(interp, 1, savedObjv, - "?-switch ...? string {?pattern body ...? ?default body?}"); + "?-option ...? string {?pattern body ...? ?default body?}"); return TCL_ERROR; } objv = listv; diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 830c998..91c0add 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -63,7 +63,7 @@ EXTERN void Tcl_DbCkfree(char *ptr, const char *file, int line); /* 8 */ EXTERN char * Tcl_DbCkrealloc(char *ptr, unsigned int size, const char *file, int line); -#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */ +#if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */ /* 9 */ EXTERN void Tcl_CreateFileHandler(int fd, int mask, Tcl_FileProc *proc, ClientData clientData); @@ -73,7 +73,7 @@ EXTERN void Tcl_CreateFileHandler(int fd, int mask, EXTERN void Tcl_CreateFileHandler(int fd, int mask, Tcl_FileProc *proc, ClientData clientData); #endif /* MACOSX */ -#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */ +#if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */ /* 10 */ EXTERN void Tcl_DeleteFileHandler(int fd); #endif /* UNIX */ @@ -511,7 +511,7 @@ EXTERN Tcl_Interp * Tcl_GetMaster(Tcl_Interp *interp); EXTERN const char * Tcl_GetNameOfExecutable(void); /* 166 */ EXTERN Tcl_Obj * Tcl_GetObjResult(Tcl_Interp *interp); -#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */ +#if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */ /* 167 */ EXTERN int Tcl_GetOpenFile(Tcl_Interp *interp, const char *chanID, int forWriting, @@ -1835,19 +1835,19 @@ typedef struct TclStubs { char * (*tcl_DbCkalloc) (unsigned int size, const char *file, int line); /* 6 */ void (*tcl_DbCkfree) (char *ptr, const char *file, int line); /* 7 */ char * (*tcl_DbCkrealloc) (char *ptr, unsigned int size, const char *file, int line); /* 8 */ -#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */ +#if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */ void (*tcl_CreateFileHandler) (int fd, int mask, Tcl_FileProc *proc, ClientData clientData); /* 9 */ #endif /* UNIX */ -#if defined(__WIN32__) /* WIN */ +#if defined(_WIN32) /* WIN */ void (*reserved9)(void); #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ void (*tcl_CreateFileHandler) (int fd, int mask, Tcl_FileProc *proc, ClientData clientData); /* 9 */ #endif /* MACOSX */ -#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */ +#if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */ void (*tcl_DeleteFileHandler) (int fd); /* 10 */ #endif /* UNIX */ -#if defined(__WIN32__) /* WIN */ +#if defined(_WIN32) /* WIN */ void (*reserved10)(void); #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ @@ -2009,10 +2009,10 @@ typedef struct TclStubs { Tcl_Interp * (*tcl_GetMaster) (Tcl_Interp *interp); /* 164 */ const char * (*tcl_GetNameOfExecutable) (void); /* 165 */ Tcl_Obj * (*tcl_GetObjResult) (Tcl_Interp *interp); /* 166 */ -#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */ +#if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */ int (*tcl_GetOpenFile) (Tcl_Interp *interp, const char *chanID, int forWriting, int checkUsage, ClientData *filePtr); /* 167 */ #endif /* UNIX */ -#if defined(__WIN32__) /* WIN */ +#if defined(_WIN32) /* WIN */ void (*reserved167)(void); #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ @@ -2513,7 +2513,7 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_DbCkfree) /* 7 */ #define Tcl_DbCkrealloc \ (tclStubsPtr->tcl_DbCkrealloc) /* 8 */ -#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */ +#if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */ #define Tcl_CreateFileHandler \ (tclStubsPtr->tcl_CreateFileHandler) /* 9 */ #endif /* UNIX */ @@ -2521,7 +2521,7 @@ extern const TclStubs *tclStubsPtr; #define Tcl_CreateFileHandler \ (tclStubsPtr->tcl_CreateFileHandler) /* 9 */ #endif /* MACOSX */ -#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */ +#if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */ #define Tcl_DeleteFileHandler \ (tclStubsPtr->tcl_DeleteFileHandler) /* 10 */ #endif /* UNIX */ @@ -2841,7 +2841,7 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_GetNameOfExecutable) /* 165 */ #define Tcl_GetObjResult \ (tclStubsPtr->tcl_GetObjResult) /* 166 */ -#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */ +#if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */ #define Tcl_GetOpenFile \ (tclStubsPtr->tcl_GetOpenFile) /* 167 */ #endif /* UNIX */ diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index e31d708..3c0ddd8 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -155,6 +155,13 @@ typedef struct Dict { } Dict; /* + * Accessor macro for converting between a Tcl_Obj* and a Dict. Note that this + * must be assignable as well as readable. + */ + +#define DICT(dictObj) (*((Dict **)&(dictObj)->internalRep.twoPtrValue.ptr1)) + +/* * The structure below defines the dictionary object type by means of * functions that can be invoked by generic object code. */ @@ -312,6 +319,7 @@ DeleteChainEntry( return 0; } else { Tcl_Obj *valuePtr = Tcl_GetHashValue(&cPtr->entry); + TclDecrRefCount(valuePtr); } @@ -361,7 +369,7 @@ DupDictInternalRep( Tcl_Obj *srcPtr, Tcl_Obj *copyPtr) { - Dict *oldDict = srcPtr->internalRep.twoPtrValue.ptr1; + Dict *oldDict = DICT(srcPtr); Dict *newDict = ckalloc(sizeof(Dict)); ChainEntry *cPtr; @@ -396,7 +404,7 @@ DupDictInternalRep( * Store in the object. */ - copyPtr->internalRep.twoPtrValue.ptr1 = newDict; + DICT(copyPtr) = newDict; copyPtr->typePtr = &tclDictType; } @@ -422,7 +430,7 @@ static void FreeDictInternalRep( Tcl_Obj *dictPtr) { - Dict *dict = dictPtr->internalRep.twoPtrValue.ptr1; + Dict *dict = DICT(dictPtr); dict->refcount--; if (dict->refcount <= 0) { @@ -487,7 +495,7 @@ UpdateStringOfDict( { #define LOCAL_SIZE 20 int localFlags[LOCAL_SIZE], *flagPtr = NULL; - Dict *dict = dictPtr->internalRep.twoPtrValue.ptr1; + Dict *dict = DICT(dictPtr); ChainEntry *cPtr; Tcl_Obj *keyPtr, *valuePtr; int i, length, bytesNeeded = 0; @@ -600,7 +608,7 @@ SetDictFromAny( Tcl_Obj *objPtr) { Tcl_HashEntry *hPtr; - int isNew, result; + int isNew; Dict *dict = ckalloc(sizeof(Dict)); InitChainTable(dict); @@ -651,10 +659,9 @@ SetDictFromAny( const char *elemStart; int elemSize, literal; - result = TclFindElement(interp, nextElem, (limit - nextElem), - &elemStart, &nextElem, &elemSize, &literal); - if (result != TCL_OK) { - goto errorExit; + if (TclFindDictElement(interp, nextElem, (limit - nextElem), + &elemStart, &nextElem, &elemSize, &literal) != TCL_OK) { + goto errorInFindDictElement; } if (elemStart == limit) { break; @@ -673,11 +680,10 @@ SetDictFromAny( keyPtr->bytes); } - result = TclFindElement(interp, nextElem, (limit - nextElem), - &elemStart, &nextElem, &elemSize, &literal); - if (result != TCL_OK) { + if (TclFindDictElement(interp, nextElem, (limit - nextElem), + &elemStart, &nextElem, &elemSize, &literal) != TCL_OK) { TclDecrRefCount(keyPtr); - goto errorExit; + goto errorInFindDictElement; } if (literal) { @@ -713,7 +719,7 @@ SetDictFromAny( dict->epoch = 0; dict->chain = NULL; dict->refcount = 1; - objPtr->internalRep.twoPtrValue.ptr1 = dict; + DICT(objPtr) = dict; objPtr->typePtr = &tclDictType; return TCL_OK; @@ -723,15 +729,10 @@ SetDictFromAny( "missing value to go with key", -1)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "DICTIONARY", NULL); } - result = TCL_ERROR; - - errorExit: - if (interp != NULL) { - Tcl_SetErrorCode(interp, "TCL", "VALUE", "DICTIONARY", NULL); - } + errorInFindDictElement: DeleteChainTable(dict); ckfree(dict); - return result; + return TCL_ERROR; } /* @@ -777,12 +778,11 @@ TclTraceDictPath( Dict *dict, *newDict; int i; - if (dictPtr->typePtr != &tclDictType) { - if (SetDictFromAny(interp, dictPtr) != TCL_OK) { - return NULL; - } + if (dictPtr->typePtr != &tclDictType + && SetDictFromAny(interp, dictPtr) != TCL_OK) { + return NULL; } - dict = dictPtr->internalRep.twoPtrValue.ptr1; + dict = DICT(dictPtr); if (flags & DICT_PATH_UPDATE) { dict->chain = NULL; } @@ -818,14 +818,13 @@ TclTraceDictPath( Tcl_SetHashValue(hPtr, tmpObj); } else { tmpObj = Tcl_GetHashValue(hPtr); - if (tmpObj->typePtr != &tclDictType) { - if (SetDictFromAny(interp, tmpObj) != TCL_OK) { - return NULL; - } + if (tmpObj->typePtr != &tclDictType + && SetDictFromAny(interp, tmpObj) != TCL_OK) { + return NULL; } } - newDict = tmpObj->internalRep.twoPtrValue.ptr1; + newDict = DICT(tmpObj); if (flags & DICT_PATH_UPDATE) { if (Tcl_IsShared(tmpObj)) { TclDecrRefCount(tmpObj); @@ -833,7 +832,7 @@ TclTraceDictPath( Tcl_IncrRefCount(tmpObj); Tcl_SetHashValue(hPtr, tmpObj); dict->epoch++; - newDict = tmpObj->internalRep.twoPtrValue.ptr1; + newDict = DICT(tmpObj); } newDict->chain = dictPtr; @@ -868,7 +867,7 @@ static void InvalidateDictChain( Tcl_Obj *dictObj) { - Dict *dict = dictObj->internalRep.twoPtrValue.ptr1; + Dict *dict = DICT(dictObj); do { TclInvalidateStringRep(dictObj); @@ -878,7 +877,7 @@ InvalidateDictChain( break; } dict->chain = NULL; - dict = dictObj->internalRep.twoPtrValue.ptr1; + dict = DICT(dictObj); } while (dict != NULL); } @@ -916,18 +915,15 @@ Tcl_DictObjPut( Tcl_Panic("%s called with shared object", "Tcl_DictObjPut"); } - if (dictPtr->typePtr != &tclDictType) { - int result = SetDictFromAny(interp, dictPtr); - - if (result != TCL_OK) { - return result; - } + if (dictPtr->typePtr != &tclDictType + && SetDictFromAny(interp, dictPtr) != TCL_OK) { + return TCL_ERROR; } if (dictPtr->bytes != NULL) { TclInvalidateStringRep(dictPtr); } - dict = dictPtr->internalRep.twoPtrValue.ptr1; + dict = DICT(dictPtr); hPtr = CreateChainEntry(dict, keyPtr, &isNew); Tcl_IncrRefCount(valuePtr); if (!isNew) { @@ -970,15 +966,13 @@ Tcl_DictObjGet( Dict *dict; Tcl_HashEntry *hPtr; - if (dictPtr->typePtr != &tclDictType) { - int result = SetDictFromAny(interp, dictPtr); - if (result != TCL_OK) { - *valuePtrPtr = NULL; - return result; - } + if (dictPtr->typePtr != &tclDictType + && SetDictFromAny(interp, dictPtr) != TCL_OK) { + *valuePtrPtr = NULL; + return TCL_ERROR; } - dict = dictPtr->internalRep.twoPtrValue.ptr1; + dict = DICT(dictPtr); hPtr = Tcl_FindHashEntry(&dict->table, keyPtr); if (hPtr == NULL) { *valuePtrPtr = NULL; @@ -1019,18 +1013,16 @@ Tcl_DictObjRemove( Tcl_Panic("%s called with shared object", "Tcl_DictObjRemove"); } - if (dictPtr->typePtr != &tclDictType) { - int result = SetDictFromAny(interp, dictPtr); - if (result != TCL_OK) { - return result; - } + if (dictPtr->typePtr != &tclDictType + && SetDictFromAny(interp, dictPtr) != TCL_OK) { + return TCL_ERROR; } - if (dictPtr->bytes != NULL) { - TclInvalidateStringRep(dictPtr); - } - dict = dictPtr->internalRep.twoPtrValue.ptr1; + dict = DICT(dictPtr); if (DeleteChainEntry(dict, keyPtr)) { + if (dictPtr->bytes != NULL) { + TclInvalidateStringRep(dictPtr); + } dict->epoch++; } return TCL_OK; @@ -1062,14 +1054,12 @@ Tcl_DictObjSize( { Dict *dict; - if (dictPtr->typePtr != &tclDictType) { - int result = SetDictFromAny(interp, dictPtr); - if (result != TCL_OK) { - return result; - } + if (dictPtr->typePtr != &tclDictType + && SetDictFromAny(interp, dictPtr) != TCL_OK) { + return TCL_ERROR; } - dict = dictPtr->internalRep.twoPtrValue.ptr1; + dict = DICT(dictPtr); *sizePtr = dict->table.numEntries; return TCL_OK; } @@ -1116,15 +1106,12 @@ Tcl_DictObjFirst( Dict *dict; ChainEntry *cPtr; - if (dictPtr->typePtr != &tclDictType) { - int result = SetDictFromAny(interp, dictPtr); - - if (result != TCL_OK) { - return result; - } + if (dictPtr->typePtr != &tclDictType + && SetDictFromAny(interp, dictPtr) != TCL_OK) { + return TCL_ERROR; } - dict = dictPtr->internalRep.twoPtrValue.ptr1; + dict = DICT(dictPtr); cPtr = dict->entryChainHead; if (cPtr == NULL) { searchPtr->epoch = -1; @@ -1299,11 +1286,12 @@ Tcl_DictObjPutKeyList( return TCL_ERROR; } - dict = dictPtr->internalRep.twoPtrValue.ptr1; + dict = DICT(dictPtr); hPtr = CreateChainEntry(dict, keyv[keyc-1], &isNew); Tcl_IncrRefCount(valuePtr); if (!isNew) { Tcl_Obj *oldValuePtr = Tcl_GetHashValue(hPtr); + TclDecrRefCount(oldValuePtr); } Tcl_SetHashValue(hPtr, valuePtr); @@ -1355,7 +1343,7 @@ Tcl_DictObjRemoveKeyList( return TCL_ERROR; } - dict = dictPtr->internalRep.twoPtrValue.ptr1; + dict = DICT(dictPtr); DeleteChainEntry(dict, keyv[keyc-1]); InvalidateDictChain(dictPtr); return TCL_OK; @@ -1401,7 +1389,7 @@ Tcl_NewDictObj(void) dict->epoch = 0; dict->chain = NULL; dict->refcount = 1; - dictPtr->internalRep.twoPtrValue.ptr1 = dict; + DICT(dictPtr) = dict; dictPtr->typePtr = &tclDictType; return dictPtr; #endif @@ -1450,7 +1438,7 @@ Tcl_DbNewDictObj( dict->epoch = 0; dict->chain = NULL; dict->refcount = 1; - dictPtr->internalRep.twoPtrValue.ptr1 = dict; + DICT(dictPtr) = dict; dictPtr->typePtr = &tclDictType; return dictPtr; #else /* !TCL_MEM_DEBUG */ @@ -1504,7 +1492,7 @@ DictCreateCmd( /* * The next command is assumed to never fail... */ - Tcl_DictObjPut(interp, dictObj, objv[i], objv[i+1]); + Tcl_DictObjPut(NULL, dictObj, objv[i], objv[i+1]); } Tcl_SetObjResult(interp, dictObj); return TCL_OK; @@ -1629,8 +1617,7 @@ DictReplaceCmd( Tcl_Obj *const *objv) { Tcl_Obj *dictPtr; - int i, result; - int allocatedDict = 0; + int i; if ((objc < 2) || (objc & 1)) { Tcl_WrongNumArgs(interp, 1, objv, "dictionary ?key value ...?"); @@ -1638,18 +1625,18 @@ DictReplaceCmd( } dictPtr = objv[1]; + if (dictPtr->typePtr != &tclDictType + && SetDictFromAny(interp, dictPtr) != TCL_OK) { + return TCL_ERROR; + } if (Tcl_IsShared(dictPtr)) { dictPtr = Tcl_DuplicateObj(dictPtr); - allocatedDict = 1; + } + if (dictPtr->bytes != NULL) { + TclInvalidateStringRep(dictPtr); } for (i=2 ; i<objc ; i+=2) { - result = Tcl_DictObjPut(interp, dictPtr, objv[i], objv[i+1]); - if (result != TCL_OK) { - if (allocatedDict) { - TclDecrRefCount(dictPtr); - } - return TCL_ERROR; - } + Tcl_DictObjPut(NULL, dictPtr, objv[i], objv[i+1]); } Tcl_SetObjResult(interp, dictPtr); return TCL_OK; @@ -1681,8 +1668,7 @@ DictRemoveCmd( Tcl_Obj *const *objv) { Tcl_Obj *dictPtr; - int i, result; - int allocatedDict = 0; + int i; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "dictionary ?key ...?"); @@ -1690,18 +1676,18 @@ DictRemoveCmd( } dictPtr = objv[1]; + if (dictPtr->typePtr != &tclDictType + && SetDictFromAny(interp, dictPtr) != TCL_OK) { + return TCL_ERROR; + } if (Tcl_IsShared(dictPtr)) { dictPtr = Tcl_DuplicateObj(dictPtr); - allocatedDict = 1; + } + if (dictPtr->bytes != NULL) { + TclInvalidateStringRep(dictPtr); } for (i=2 ; i<objc ; i++) { - result = Tcl_DictObjRemove(interp, dictPtr, objv[i]); - if (result != TCL_OK) { - if (allocatedDict) { - TclDecrRefCount(dictPtr); - } - return TCL_ERROR; - } + Tcl_DictObjRemove(NULL, dictPtr, objv[i]); } Tcl_SetObjResult(interp, dictPtr); return TCL_OK; @@ -1750,10 +1736,9 @@ DictMergeCmd( */ targetObj = objv[1]; - if (targetObj->typePtr != &tclDictType) { - if (SetDictFromAny(interp, targetObj) != TCL_OK) { - return TCL_ERROR; - } + if (targetObj->typePtr != &tclDictType + && SetDictFromAny(interp, targetObj) != TCL_OK) { + return TCL_ERROR; } if (objc == 2) { @@ -1835,12 +1820,9 @@ DictKeysCmd( * need. [Bug 1705778, leak K04] */ - if (objv[1]->typePtr != &tclDictType) { - int result = SetDictFromAny(interp, objv[1]); - - if (result != TCL_OK) { - return result; - } + if (objv[1]->typePtr != &tclDictType + && SetDictFromAny(interp, objv[1]) != TCL_OK) { + return TCL_ERROR; } if (objc == 3) { @@ -2056,13 +2038,11 @@ DictInfoCmd( } dictPtr = objv[1]; - if (dictPtr->typePtr != &tclDictType) { - int result = SetDictFromAny(interp, dictPtr); - if (result != TCL_OK) { - return result; - } + if (dictPtr->typePtr != &tclDictType + && SetDictFromAny(interp, dictPtr) != TCL_OK) { + return TCL_ERROR; } - dict = dictPtr->internalRep.twoPtrValue.ptr1; + dict = DICT(dictPtr); statsStr = Tcl_HashStats(&dict->table); Tcl_SetObjResult(interp, Tcl_NewStringObj(statsStr, -1)); @@ -2099,7 +2079,7 @@ DictIncrCmd( Tcl_Obj *dictPtr, *valuePtr = NULL; if (objc < 3 || objc > 4) { - Tcl_WrongNumArgs(interp, 1, objv, "varName key ?increment?"); + Tcl_WrongNumArgs(interp, 1, objv, "dictVarName key ?increment?"); return TCL_ERROR; } @@ -2152,10 +2132,10 @@ DictIncrCmd( */ mp_clear(&increment); - Tcl_DictObjPut(interp, dictPtr, objv[2], objv[3]); + Tcl_DictObjPut(NULL, dictPtr, objv[2], objv[3]); } } else { - Tcl_DictObjPut(interp, dictPtr, objv[2], Tcl_NewIntObj(1)); + Tcl_DictObjPut(NULL, dictPtr, objv[2], Tcl_NewIntObj(1)); } } else { /* @@ -2164,7 +2144,7 @@ DictIncrCmd( if (Tcl_IsShared(valuePtr)) { valuePtr = Tcl_DuplicateObj(valuePtr); - Tcl_DictObjPut(interp, dictPtr, objv[2], valuePtr); + Tcl_DictObjPut(NULL, dictPtr, objv[2], valuePtr); } if (objc == 4) { code = TclIncrObj(interp, valuePtr, objv[3]); @@ -2173,7 +2153,7 @@ DictIncrCmd( Tcl_IncrRefCount(incrPtr); code = TclIncrObj(interp, valuePtr, incrPtr); - Tcl_DecrRefCount(incrPtr); + TclDecrRefCount(incrPtr); } } if (code == TCL_OK) { @@ -2186,7 +2166,7 @@ DictIncrCmd( Tcl_SetObjResult(interp, valuePtr); } } else if (dictPtr->refCount == 0) { - Tcl_DecrRefCount(dictPtr); + TclDecrRefCount(dictPtr); } return code; } @@ -2220,7 +2200,7 @@ DictLappendCmd( int i, allocatedDict = 0, allocatedValue = 0; if (objc < 3) { - Tcl_WrongNumArgs(interp, 1, objv, "varName key ?value ...?"); + Tcl_WrongNumArgs(interp, 1, objv, "dictVarName key ?value ...?"); return TCL_ERROR; } @@ -2264,7 +2244,7 @@ DictLappendCmd( } if (allocatedValue) { - Tcl_DictObjPut(interp, dictPtr, objv[2], valuePtr); + Tcl_DictObjPut(NULL, dictPtr, objv[2], valuePtr); } else if (dictPtr->bytes != NULL) { TclInvalidateStringRep(dictPtr); } @@ -2307,7 +2287,7 @@ DictAppendCmd( int i, allocatedDict = 0; if (objc < 3) { - Tcl_WrongNumArgs(interp, 1, objv, "varName key ?value ...?"); + Tcl_WrongNumArgs(interp, 1, objv, "dictVarName key ?value ...?"); return TCL_ERROR; } @@ -2329,17 +2309,15 @@ DictAppendCmd( if (valuePtr == NULL) { TclNewObj(valuePtr); - } else { - if (Tcl_IsShared(valuePtr)) { - valuePtr = Tcl_DuplicateObj(valuePtr); - } + } else if (Tcl_IsShared(valuePtr)) { + valuePtr = Tcl_DuplicateObj(valuePtr); } for (i=3 ; i<objc ; i++) { Tcl_AppendObjToObj(valuePtr, objv[i]); } - Tcl_DictObjPut(interp, dictPtr, objv[2], valuePtr); + Tcl_DictObjPut(NULL, dictPtr, objv[2], valuePtr); resultPtr = Tcl_ObjSetVar2(interp, objv[1], NULL, dictPtr, TCL_LEAVE_ERR_MSG); @@ -2383,7 +2361,7 @@ DictForNRCmd( if (objc != 4) { Tcl_WrongNumArgs(interp, 1, objv, - "{keyVar valueVar} dictionary script"); + "{keyVarName valueVarName} dictionary script"); return TCL_ERROR; } @@ -2397,6 +2375,7 @@ DictForNRCmd( if (varc != 2) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "must have exactly two variable names", -1)); + Tcl_SetErrorCode(interp, "TCL", "SYNTAX", "dict", "for", NULL); return TCL_ERROR; } searchPtr = TclStackAlloc(interp, sizeof(Tcl_DictSearch)); @@ -2430,12 +2409,14 @@ DictForNRCmd( */ Tcl_IncrRefCount(valueObj); - if (Tcl_ObjSetVar2(interp, keyVarObj, NULL, keyObj, TCL_LEAVE_ERR_MSG) == NULL) { + if (Tcl_ObjSetVar2(interp, keyVarObj, NULL, keyObj, + TCL_LEAVE_ERR_MSG) == NULL) { TclDecrRefCount(valueObj); goto error; } TclDecrRefCount(valueObj); - if (Tcl_ObjSetVar2(interp, valueVarObj, NULL, valueObj, TCL_LEAVE_ERR_MSG) == NULL) { + if (Tcl_ObjSetVar2(interp, valueVarObj, NULL, valueObj, + TCL_LEAVE_ERR_MSG) == NULL) { goto error; } @@ -2574,7 +2555,7 @@ DictMapNRCmd( if (objc != 4) { Tcl_WrongNumArgs(interp, 1, objv, - "{keyVar valueVar} dictionary script"); + "{keyVarName valueVarName} dictionary script"); return TCL_ERROR; } @@ -2588,6 +2569,7 @@ DictMapNRCmd( if (varc != 2) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "must have exactly two variable names", -1)); + Tcl_SetErrorCode(interp, "TCL", "SYNTAX", "dict", "map", NULL); return TCL_ERROR; } storagePtr = TclStackAlloc(interp, sizeof(DictMapStorage)); @@ -2782,7 +2764,7 @@ DictSetCmd( int result, allocatedDict = 0; if (objc < 4) { - Tcl_WrongNumArgs(interp, 1, objv, "varName key ?key ...? value"); + Tcl_WrongNumArgs(interp, 1, objv, "dictVarName key ?key ...? value"); return TCL_ERROR; } @@ -2842,7 +2824,7 @@ DictUnsetCmd( int result, allocatedDict = 0; if (objc < 3) { - Tcl_WrongNumArgs(interp, 1, objv, "varName key ?key ...?"); + Tcl_WrongNumArgs(interp, 1, objv, "dictVarName key ?key ...?"); return TCL_ERROR; } @@ -2949,12 +2931,12 @@ DictFilterCmd( Tcl_DictObjDone(&search); Tcl_DictObjGet(interp, objv[1], objv[3], &valueObj); if (valueObj != NULL) { - Tcl_DictObjPut(interp, resultObj, objv[3], valueObj); + Tcl_DictObjPut(NULL, resultObj, objv[3], valueObj); } } else { while (!done) { if (Tcl_StringMatch(TclGetString(keyObj), pattern)) { - Tcl_DictObjPut(interp, resultObj, keyObj, valueObj); + Tcl_DictObjPut(NULL, resultObj, keyObj, valueObj); } Tcl_DictObjNext(&search, &keyObj, &valueObj, &done); } @@ -2972,7 +2954,7 @@ DictFilterCmd( for (i=3 ; i<objc ; i++) { pattern = TclGetString(objv[i]); if (Tcl_StringMatch(TclGetString(keyObj), pattern)) { - Tcl_DictObjPut(interp, resultObj, keyObj, valueObj); + Tcl_DictObjPut(NULL, resultObj, keyObj, valueObj); break; /* stop inner loop */ } } @@ -2998,7 +2980,7 @@ DictFilterCmd( for (i=3 ; i<objc ; i++) { pattern = TclGetString(objv[i]); if (Tcl_StringMatch(TclGetString(valueObj), pattern)) { - Tcl_DictObjPut(interp, resultObj, keyObj, valueObj); + Tcl_DictObjPut(NULL, resultObj, keyObj, valueObj); break; /* stop inner loop */ } } @@ -3010,7 +2992,7 @@ DictFilterCmd( case FILTER_SCRIPT: if (objc != 5) { Tcl_WrongNumArgs(interp, 1, objv, - "dictionary script {keyVar valueVar} filterScript"); + "dictionary script {keyVarName valueVarName} filterScript"); return TCL_ERROR; } @@ -3026,6 +3008,7 @@ DictFilterCmd( if (varc != 2) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "must have exactly two variable names", -1)); + Tcl_SetErrorCode(interp, "TCL", "SYNTAX", "dict", "filter", NULL); return TCL_ERROR; } keyVarObj = varv[0]; @@ -3064,19 +3047,15 @@ DictFilterCmd( Tcl_IncrRefCount(valueObj); if (Tcl_ObjSetVar2(interp, keyVarObj, NULL, keyObj, TCL_LEAVE_ERR_MSG) == NULL) { - Tcl_ResetResult(interp); - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "couldn't set key variable: \"%s\"", - TclGetString(keyVarObj))); + Tcl_AddErrorInfo(interp, + "\n (\"dict filter\" filter script key variable)"); result = TCL_ERROR; goto abnormalResult; } if (Tcl_ObjSetVar2(interp, valueVarObj, NULL, valueObj, TCL_LEAVE_ERR_MSG) == NULL) { - Tcl_ResetResult(interp); - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "couldn't set value variable: \"%s\"", - TclGetString(valueVarObj))); + Tcl_AddErrorInfo(interp, + "\n (\"dict filter\" filter script value variable)"); result = TCL_ERROR; goto abnormalResult; } @@ -3099,7 +3078,7 @@ DictFilterCmd( } TclDecrRefCount(boolObj); if (satisfied) { - Tcl_DictObjPut(interp, resultObj, keyObj, valueObj); + Tcl_DictObjPut(NULL, resultObj, keyObj, valueObj); } break; case TCL_BREAK: @@ -3190,7 +3169,7 @@ DictUpdateCmd( if (objc < 5 || !(objc & 1)) { Tcl_WrongNumArgs(interp, 1, objv, - "varName key varName ?key varName ...? script"); + "dictVarName key varName ?key varName ...? script"); return TCL_ERROR; } @@ -3287,18 +3266,17 @@ FinalizeDictUpdate( for (i=0 ; i<objc ; i+=2) { objPtr = Tcl_ObjGetVar2(interp, objv[i+1], NULL, 0); if (objPtr == NULL) { - Tcl_DictObjRemove(interp, dictPtr, objv[i]); + Tcl_DictObjRemove(NULL, dictPtr, objv[i]); } else if (objPtr == dictPtr) { /* * Someone is messing us around, trying to build a recursive * structure. [Bug 1786481] */ - Tcl_DictObjPut(interp, dictPtr, objv[i], - Tcl_DuplicateObj(objPtr)); + Tcl_DictObjPut(NULL, dictPtr, objv[i], Tcl_DuplicateObj(objPtr)); } else { /* Shouldn't fail */ - Tcl_DictObjPut(interp, dictPtr, objv[i], objPtr); + Tcl_DictObjPut(NULL, dictPtr, objv[i], objPtr); } } TclDecrRefCount(argsObj); @@ -3347,7 +3325,7 @@ DictWithCmd( Tcl_Obj *dictPtr, *keysPtr, *pathPtr; if (objc < 3) { - Tcl_WrongNumArgs(interp, 1, objv, "dictVar ?key ...? script"); + Tcl_WrongNumArgs(interp, 1, objv, "dictVarName ?key ...? script"); return TCL_ERROR; } diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index 9bb7a0c..022dafa 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -2751,13 +2751,6 @@ TclCompileEnsemble( const char *word; Tcl_IncrRefCount(replaced); - - /* - * This is where we return to if we are parsing multiple nested compiled - * ensembles. [info object] is such a beast. - */ - - checkNextWord: if (parsePtr->numWords < depth + 1) { goto failed; } @@ -2769,6 +2762,12 @@ TclCompileEnsemble( goto failed; } + /* + * This is where we return to if we are parsing multiple nested compiled + * ensembles. [info object] is such a beast. + */ + + checkNextWord: word = tokenPtr[1].start; numBytes = tokenPtr[1].size; @@ -2979,6 +2978,17 @@ TclCompileEnsemble( if (cmdPtr->compileProc == TclCompileEnsemble) { tokenPtr = TokenAfter(tokenPtr); + if (parsePtr->numWords < depth + 1 + || tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + /* + * Too hard because the user has done something unpleasant like + * omitting the sub-ensemble's command name or used a non-constant + * name for a sub-ensemble's command name; we respond by bailing + * out completely (this is a rare case). [Bug 6d2f249a01] + */ + + goto cleanup; + } ensemble = (Tcl_Command) cmdPtr; goto checkNextWord; } diff --git a/generic/tclEnv.c b/generic/tclEnv.c index 8f51c1b..cd1a954 100644 --- a/generic/tclEnv.c +++ b/generic/tclEnv.c @@ -444,7 +444,7 @@ TclUnsetEnv( * that no = should be included, and Windows requires it. */ -#if defined(__WIN32__) || defined(__CYGWIN__) +#if defined(_WIN32) || defined(__CYGWIN__) string = ckalloc(length + 2); memcpy(string, name, (size_t) length); string[length] = '='; @@ -453,7 +453,7 @@ TclUnsetEnv( string = ckalloc(length + 1); memcpy(string, name, (size_t) length); string[length] = '\0'; -#endif /* WIN32 */ +#endif /* _WIN32 */ Tcl_UtfToExternalDString(NULL, string, -1, &envString); string = ckrealloc(string, Tcl_DStringLength(&envString) + 1); diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 89305e6..d8c5935 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -556,30 +556,6 @@ VarHashCreateVar( : Tcl_GetBooleanFromObj((interp), (objPtr), (boolPtr))) /* - * Macro used in this file to save a function call for common uses of - * Tcl_GetWideIntFromObj(). The ANSI C "prototype" is: - * - * MODULE_SCOPE int TclGetWideIntFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, - * Tcl_WideInt *wideIntPtr); - */ - -#ifdef TCL_WIDE_INT_IS_LONG -#define TclGetWideIntFromObj(interp, objPtr, wideIntPtr) \ - (((objPtr)->typePtr == &tclIntType) \ - ? (*(wideIntPtr) = (Tcl_WideInt) \ - ((objPtr)->internalRep.longValue), TCL_OK) : \ - Tcl_GetWideIntFromObj((interp), (objPtr), (wideIntPtr))) -#else /* !TCL_WIDE_INT_IS_LONG */ -#define TclGetWideIntFromObj(interp, objPtr, wideIntPtr) \ - (((objPtr)->typePtr == &tclWideIntType) \ - ? (*(wideIntPtr) = (objPtr)->internalRep.wideValue, TCL_OK) : \ - ((objPtr)->typePtr == &tclIntType) \ - ? (*(wideIntPtr) = (Tcl_WideInt) \ - ((objPtr)->internalRep.longValue), TCL_OK) : \ - Tcl_GetWideIntFromObj((interp), (objPtr), (wideIntPtr))) -#endif /* TCL_WIDE_INT_IS_LONG */ - -/* * Macro used to make the check for type overflow more mnemonic. This works by * comparing sign bits; the rest of the word is irrelevant. The ANSI C * "prototype" (where inttype_t is any integer type) is: @@ -5392,6 +5368,7 @@ TEBCresume( } else { length = Tcl_UtfToUpper(TclGetString(valuePtr)); Tcl_SetObjLength(valuePtr, length); + TclFreeIntRep(valuePtr); TRACE_APPEND(("\"%.20s\"\n", O2S(valuePtr))); NEXT_INST_F(1, 0, 0); } @@ -5408,6 +5385,7 @@ TEBCresume( } else { length = Tcl_UtfToLower(TclGetString(valuePtr)); Tcl_SetObjLength(valuePtr, length); + TclFreeIntRep(valuePtr); TRACE_APPEND(("\"%.20s\"\n", O2S(valuePtr))); NEXT_INST_F(1, 0, 0); } @@ -5424,6 +5402,7 @@ TEBCresume( } else { length = Tcl_UtfToTitle(TclGetString(valuePtr)); Tcl_SetObjLength(valuePtr, length); + TclFreeIntRep(valuePtr); TRACE_APPEND(("\"%.20s\"\n", O2S(valuePtr))); NEXT_INST_F(1, 0, 0); } @@ -5699,11 +5678,21 @@ TEBCresume( length - toIdx); } } else { - objResultPtr = value3Ptr; + /* + * Be careful with splicing the stack in this case; we have a + * refCount:1 object in value3Ptr and we want to append to it and + * make it be the refCount:1 object at the top of the stack + * afterwards. [Bug 82e7f67325] + */ + if (toIdx < length) { - Tcl_AppendUnicodeToObj(objResultPtr, ustring1 + toIdx + 1, + Tcl_AppendUnicodeToObj(value3Ptr, ustring1 + toIdx + 1, length - toIdx); } + TRACE_APPEND(("\"%.30s\"\n", O2S(value3Ptr))); + TclDecrRefCount(valuePtr); + OBJ_AT_TOS = value3Ptr; /* Tricky! */ + NEXT_INST_F(1, 0, 0); } TclDecrRefCount(value3Ptr); TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr))); @@ -5986,6 +5975,31 @@ TEBCresume( case INST_NUM_TYPE: if (GetNumberFromObj(NULL, OBJ_AT_TOS, &ptr1, &type1) != TCL_OK) { type1 = 0; + } else if (type1 == TCL_NUMBER_LONG) { + /* value is between LONG_MIN and LONG_MAX */ + /* [string is integer] is -UINT_MAX to UINT_MAX range */ + int i; + + if (Tcl_GetIntFromObj(NULL, OBJ_AT_TOS, &i) != TCL_OK) { + type1 = TCL_NUMBER_WIDE; + } +#ifndef TCL_WIDE_INT_IS_LONG + } else if (type1 == TCL_NUMBER_WIDE) { + /* value is between WIDE_MIN and WIDE_MAX */ + /* [string is wideinteger] is -UWIDE_MAX to UWIDE_MAX range */ + int i; + if (Tcl_GetIntFromObj(NULL, OBJ_AT_TOS, &i) == TCL_OK) { + type1 = TCL_NUMBER_LONG; + } +#endif + } else if (type1 == TCL_NUMBER_BIG) { + /* value is an integer outside the WIDE_MIN to WIDE_MAX range */ + /* [string is wideinteger] is -UWIDE_MAX to UWIDE_MAX range */ + Tcl_WideInt w; + + if (Tcl_GetWideIntFromObj(NULL, OBJ_AT_TOS, &w) == TCL_OK) { + type1 = TCL_NUMBER_WIDE; + } } TclNewIntObj(objResultPtr, type1); TRACE(("\"%.20s\" => %d\n", O2S(OBJ_AT_TOS), type1)); diff --git a/generic/tclFCmd.c b/generic/tclFCmd.c index 13377d3..8bf0a5a 100644 --- a/generic/tclFCmd.c +++ b/generic/tclFCmd.c @@ -517,7 +517,7 @@ CopyRenameOneFile( * 16 bits and we get collisions. See bug #2015723. */ -#if !defined(WIN32) && !defined(__CYGWIN__) +#if !defined(_WIN32) && !defined(__CYGWIN__) if ((sourceStatBuf.st_ino != 0) && (targetStatBuf.st_ino != 0)) { if ((sourceStatBuf.st_ino == targetStatBuf.st_ino) && (sourceStatBuf.st_dev == targetStatBuf.st_dev)) { @@ -1196,7 +1196,7 @@ TclFileLinkCmd( static const char *const linkTypes[] = { "-symbolic", "-hard", NULL }; - if (Tcl_GetIndexFromObj(interp, objv[1], linkTypes, "switch", 0, + if (Tcl_GetIndexFromObj(interp, objv[1], linkTypes, "option", 0, &linkAction) != TCL_OK) { return TCL_ERROR; } diff --git a/generic/tclIO.c b/generic/tclIO.c index ff975c3..c8c9aec 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -6,6 +6,7 @@ * * Copyright (c) 1998-2000 Ajuba Solutions * Copyright (c) 1995-1997 Sun Microsystems, Inc. + * Contributions from Don Porter, NIST, 2014. (not subject to US copyright) * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -162,7 +163,11 @@ typedef struct CloseCallback { */ static ChannelBuffer * AllocChannelBuffer(int length); +static void PreserveChannelBuffer(ChannelBuffer *bufPtr); +static void ReleaseChannelBuffer(ChannelBuffer *bufPtr); +static int IsShared(ChannelBuffer *bufPtr); static void ChannelTimerProc(ClientData clientData); +static int ChanRead(Channel *chanPtr, char *dst, int dstSize); static int CheckChannelErrors(ChannelState *statePtr, int direction); static int CheckForDeadChannel(Tcl_Interp *interp, @@ -176,9 +181,6 @@ static int CloseChannelPart(Tcl_Interp *interp, Channel *chanPtr, int errorCode, int flags); static int CloseWrite(Tcl_Interp *interp, Channel *chanPtr); static void CommonGetsCleanup(Channel *chanPtr); -static int CopyAndTranslateBuffer(ChannelState *statePtr, - char *result, int space); -static int CopyBuffer(Channel *chanPtr, char *result, int space); static int CopyData(CopyState *csPtr, int mask); static void CopyEventProc(ClientData clientData, int mask); static void CreateScriptRecord(Tcl_Interp *interp, @@ -191,7 +193,8 @@ static int DetachChannel(Tcl_Interp *interp, Tcl_Channel chan); static void DiscardInputQueued(ChannelState *statePtr, int discardSavedBuffers); static void DiscardOutputQueued(ChannelState *chanPtr); -static int DoRead(Channel *chanPtr, char *srcPtr, int slen, int allowShortReads); +static int DoRead(Channel *chanPtr, char *dst, int bytesToRead, + int allowShortReads); static int DoReadChars(Channel *chan, Tcl_Obj *objPtr, int toRead, int appendFlag); static int FilterInputBytes(Channel *chanPtr, @@ -208,16 +211,16 @@ static int HaveVersion(const Tcl_ChannelType *typePtr, static void PeekAhead(Channel *chanPtr, char **dstEndPtr, GetsState *gsPtr); static int ReadBytes(ChannelState *statePtr, Tcl_Obj *objPtr, - int charsLeft, int *offsetPtr); + int charsLeft); static int ReadChars(ChannelState *statePtr, Tcl_Obj *objPtr, - int charsLeft, int *offsetPtr, int *factorPtr); + int charsLeft, int *factorPtr); static void RecycleBuffer(ChannelState *statePtr, ChannelBuffer *bufPtr, int mustDiscard); static int StackSetBlockMode(Channel *chanPtr, int mode); static int SetBlockMode(Tcl_Interp *interp, Channel *chanPtr, int mode); static void StopCopy(CopyState *csPtr); -static int TranslateInputEOL(ChannelState *statePtr, char *dst, +static void TranslateInputEOL(ChannelState *statePtr, char *dst, const char *src, int *dstLenPtr, int *srcLenPtr); static void UpdateInterest(Channel *chanPtr); static int Write(Channel *chanPtr, const char *src, @@ -284,7 +287,7 @@ static int WillRead(Channel *chanPtr); #define IsBufferEmpty(bufPtr) ((bufPtr)->nextAdded == (bufPtr)->nextRemoved) -#define IsBufferFull(bufPtr) ((bufPtr)->nextAdded >= (bufPtr)->bufLength) +#define IsBufferFull(bufPtr) ((bufPtr) && (bufPtr)->nextAdded >= (bufPtr)->bufLength) #define IsBufferOverflowing(bufPtr) ((bufPtr)->nextAdded>(bufPtr)->bufLength) @@ -379,19 +382,79 @@ ChanCloseHalf( return chanPtr->typePtr->close2Proc(chanPtr->instanceData, interp, flags); } -static inline int +/* + *--------------------------------------------------------------------------- + * + * ChanRead -- + * + * Read up to dstSize bytes using the inputProc of chanPtr, store + * them at dst, and return the number of bytes stored. + * + * Results: + * The return value of the driver inputProc, + * - number of bytes stored at dst, ot + * - -1 on error, with a Posix error code available to the + * caller by calling Tcl_GetErrno(). + * + * Side effects: + * The CHANNEL_BLOCKED and CHANNEL_EOF flags of the channel state are + * set as appropriate. + * On EOF, the inputEncodingFlags are set to perform ending operations + * on decoding. + * TODO - Is this really the right place for that? + * + *--------------------------------------------------------------------------- + */ +static int ChanRead( Channel *chanPtr, char *dst, - int dstSize, - int *errnoPtr) + int dstSize) { + int bytesRead, result; + + /* + * If the caller asked for zero bytes, we'd force the inputProc + * to return zero bytes, and then misinterpret that as EOF. + */ + assert(dstSize > 0); + + /* + * Each read op must set the blocked and eof states anew, not let + * the effect of prior reads leak through. + */ + ResetFlag(chanPtr->state, CHANNEL_BLOCKED | CHANNEL_EOF); if (WillRead(chanPtr) < 0) { return -1; } - return chanPtr->typePtr->inputProc(chanPtr->instanceData, dst, dstSize, - errnoPtr); + bytesRead = chanPtr->typePtr->inputProc(chanPtr->instanceData, + dst, dstSize, &result); + + /* Stop any flag leakage through stacked channel levels */ + ResetFlag(chanPtr->state, CHANNEL_BLOCKED | CHANNEL_EOF); + if (bytesRead > 0) { + /* + * If we get a short read, signal up that we may be BLOCKED. + * We should avoid calling the driver because on some + * platforms we will block in the low level reading code even + * though the channel is set into nonblocking mode. + */ + + if (bytesRead < dstSize) { + SetFlag(chanPtr->state, CHANNEL_BLOCKED); + } + } else if (bytesRead == 0) { + SetFlag(chanPtr->state, CHANNEL_EOF); + chanPtr->state->inputEncodingFlags |= TCL_ENCODING_END; + } else if (bytesRead < 0) { + if ((result == EWOULDBLOCK) || (result == EAGAIN)) { + SetFlag(chanPtr->state, CHANNEL_BLOCKED); + result = EAGAIN; + } + Tcl_SetErrno(result); + } + return bytesRead; } static inline Tcl_WideInt @@ -1174,15 +1237,6 @@ Tcl_UnregisterChannel( */ if (statePtr->refCount <= 0) { - /* - * Ensure that if there is another buffer, it gets flushed whether or - * not we are doing a background flush. - */ - - if ((statePtr->curOutPtr != NULL) && - IsBufferReady(statePtr->curOutPtr)) { - SetFlag(statePtr, BUFFER_READY); - } Tcl_Preserve(statePtr); if (!GotFlag(statePtr, BG_FLUSH_SCHEDULED)) { /* @@ -1743,6 +1797,10 @@ Tcl_StackChannel( statePtr->csPtrR = NULL; statePtr->csPtrW = NULL; + /* + * TODO: Examine what can go wrong if Tcl_Flush() call disturbs + * the stacking state of this channel during its operations. + */ if (Tcl_Flush((Tcl_Channel) prevChanPtr) != TCL_OK) { statePtr->csPtrR = csPtrR; statePtr->csPtrW = csPtrW; @@ -1774,17 +1832,17 @@ Tcl_StackChannel( */ if (((mask & TCL_READABLE) != 0) && (statePtr->inQueueHead != NULL)) { + /* - * Remark: It is possible that the channel buffers contain data from - * some earlier push-backs. + * When statePtr->inQueueHead is not NULL, we know + * prevChanPtr->inQueueHead must be NULL. */ - statePtr->inQueueTail->nextPtr = prevChanPtr->inQueueHead; - prevChanPtr->inQueueHead = statePtr->inQueueHead; + assert(prevChanPtr->inQueueHead == NULL); + assert(prevChanPtr->inQueueTail == NULL); - if (prevChanPtr->inQueueTail == NULL) { - prevChanPtr->inQueueTail = statePtr->inQueueTail; - } + prevChanPtr->inQueueHead = statePtr->inQueueHead; + prevChanPtr->inQueueTail = statePtr->inQueueTail; statePtr->inQueueHead = NULL; statePtr->inQueueTail = NULL; @@ -1872,6 +1930,13 @@ Tcl_UnstackChannel( * into the old structure. */ + /* + * TODO: Figure out how to handle the situation where the chan + * operations called below by this unstacking operation cause + * another unstacking recursively. In that case the downChanPtr + * value we're holding on to will not be the right thing. + */ + Channel *downChanPtr = chanPtr->downChanPtr; /* @@ -1976,7 +2041,7 @@ Tcl_UnstackChannel( */ Tcl_EventuallyFree(chanPtr, TCL_DYNAMIC); - UpdateInterest(downChanPtr); + UpdateInterest(statePtr->topChanPtr); if (result != 0) { Tcl_SetErrno(result); @@ -2288,8 +2353,36 @@ AllocChannelBuffer( bufPtr->nextRemoved = BUFFER_PADDING; bufPtr->bufLength = length + BUFFER_PADDING; bufPtr->nextPtr = NULL; + bufPtr->refCount = 1; return bufPtr; } + +static void +PreserveChannelBuffer( + ChannelBuffer *bufPtr) +{ + if (bufPtr->refCount == 0) { + Tcl_Panic("Reuse of ChannelBuffer! %p", bufPtr); + } + bufPtr->refCount++; +} + +static void +ReleaseChannelBuffer( + ChannelBuffer *bufPtr) +{ + if (--bufPtr->refCount) { + return; + } + ckfree(bufPtr); +} + +static int +IsShared( + ChannelBuffer *bufPtr) +{ + return bufPtr->refCount > 1; +} /* *---------------------------------------------------------------------- @@ -2320,20 +2413,23 @@ RecycleBuffer( /* * Do we have to free the buffer to the OS? */ + if (IsShared(bufPtr)) { + mustDiscard = 1; + } if (mustDiscard) { - ckfree(bufPtr); + ReleaseChannelBuffer(bufPtr); return; } /* - * Only save buffers which are at least as big as the requested buffersize - * for the channel. This is to honor dynamic changes of the buffersize + * Only save buffers which have the requested buffersize for the + * channel. This is to honor dynamic changes of the buffersize * made by the user. */ - if ((bufPtr->bufLength - BUFFER_PADDING) < statePtr->bufSize) { - ckfree(bufPtr); + if ((bufPtr->bufLength - BUFFER_PADDING) != statePtr->bufSize) { + ReleaseChannelBuffer(bufPtr); return; } @@ -2368,7 +2464,7 @@ RecycleBuffer( * If we reached this code we return the buffer to the OS. */ - ckfree(bufPtr); + ReleaseChannelBuffer(bufPtr); return; keepBuffer: @@ -2406,6 +2502,11 @@ DiscardOutputQueued( } statePtr->outQueueHead = NULL; statePtr->outQueueTail = NULL; + bufPtr = statePtr->curOutPtr; + if (bufPtr && BytesLeft(bufPtr)) { + statePtr->curOutPtr = NULL; + RecycleBuffer(statePtr, bufPtr, 0); + } } /* @@ -2473,8 +2574,6 @@ FlushChannel( ChannelState *statePtr = chanPtr->state; /* State of the channel stack. */ ChannelBuffer *bufPtr; /* Iterates over buffered output queue. */ - int toWrite; /* Amount of output data in current buffer - * available to be written. */ int written; /* Amount of output data actually written in * current round. */ int errorCode = 0; /* Stores POSIX error codes from channel @@ -2494,63 +2593,58 @@ FlushChannel( } /* - * Loop over the queued buffers and attempt to flush as much as possible - * of the queued output to the channel. + * Should we shift the current output buffer over to the output queue? + * First check that there are bytes in it. If so then... + * If the output queue is empty, then yes, trusting the caller called + * us only when written bytes ought to be flushed. + * If the current output buffer is full, then yes, so we can meet + * the post-condition that on a successful return to caller we've + * left space in the current output buffer for more writing (the flush + * call was to make new room). + * Otherwise, no. Keep the current output buffer where it is so more + * can be written to it, possibly filling it, to promote more efficient + * buffer usage. */ - Tcl_Preserve(chanPtr); - while (1) { - /* - * If the queue is empty and there is a ready current buffer, OR if - * the current buffer is full, then move the current buffer to the - * queue. - */ - - if (((statePtr->curOutPtr != NULL) && - IsBufferFull(statePtr->curOutPtr)) - || (GotFlag(statePtr, BUFFER_READY) && - (statePtr->outQueueHead == NULL))) { - ResetFlag(statePtr, BUFFER_READY); - statePtr->curOutPtr->nextPtr = NULL; - if (statePtr->outQueueHead == NULL) { - statePtr->outQueueHead = statePtr->curOutPtr; - } else { - statePtr->outQueueTail->nextPtr = statePtr->curOutPtr; - } - statePtr->outQueueTail = statePtr->curOutPtr; - statePtr->curOutPtr = NULL; + bufPtr = statePtr->curOutPtr; + if (bufPtr && BytesLeft(bufPtr) && /* Keep empties off queue */ + (statePtr->outQueueHead == NULL || IsBufferFull(bufPtr))) { + if (statePtr->outQueueHead == NULL) { + statePtr->outQueueHead = bufPtr; + } else { + statePtr->outQueueTail->nextPtr = bufPtr; } - bufPtr = statePtr->outQueueHead; + statePtr->outQueueTail = bufPtr; + statePtr->curOutPtr = NULL; + } - /* - * If we are not being called from an async flush and an async flush - * is active, we just return without producing any output. - */ + assert(!IsBufferFull(statePtr->curOutPtr)); - if (!calledFromAsyncFlush && GotFlag(statePtr, BG_FLUSH_SCHEDULED)) { - errorCode = 0; - goto done; - } + /* + * If we are not being called from an async flush and an async flush + * is active, we just return without producing any output. + */ - /* - * If the output queue is still empty, break out of the while loop. - */ + if (!calledFromAsyncFlush && GotFlag(statePtr, BG_FLUSH_SCHEDULED)) { + return 0; + } - if (bufPtr == NULL) { - break; /* Out of the "while (1)". */ - } + /* + * Loop over the queued buffers and attempt to flush as much as possible + * of the queued output to the channel. + */ + + Tcl_Preserve(chanPtr); + while (statePtr->outQueueHead) { + bufPtr = statePtr->outQueueHead; /* * Produce the output on the channel. */ - toWrite = BytesLeft(bufPtr); - if (toWrite == 0) { - written = 0; - } else { - written = ChanWrite(chanPtr, RemovePoint(bufPtr), toWrite, - &errorCode); - } + PreserveChannelBuffer(bufPtr); + written = ChanWrite(chanPtr, RemovePoint(bufPtr), BytesLeft(bufPtr), + &errorCode); /* * If the write failed completely attempt to start the asynchronous @@ -2565,6 +2659,7 @@ FlushChannel( if (errorCode == EINTR) { errorCode = 0; + ReleaseChannelBuffer(bufPtr); continue; } @@ -2586,6 +2681,7 @@ FlushChannel( UpdateInterest(chanPtr); } errorCode = 0; + ReleaseChannelBuffer(bufPtr); break; } @@ -2647,14 +2743,15 @@ FlushChannel( */ DiscardOutputQueued(statePtr); - continue; + ReleaseChannelBuffer(bufPtr); + break; } else { + /* TODO: Consider detecting and reacting to short writes + * on blocking channels. Ought not happen. See iocmd-24.2. */ wroteSome = 1; } - if (!IsBufferEmpty(bufPtr)) { - bufPtr->nextRemoved += written; - } + bufPtr->nextRemoved += written; /* * If this buffer is now empty, recycle it. @@ -2667,7 +2764,8 @@ FlushChannel( } RecycleBuffer(statePtr, bufPtr, 0); } - } /* Closes "while (1)". */ + ReleaseChannelBuffer(bufPtr); + } /* Closes "while". */ /* * If we wrote some data while flushing in the background, we are done. @@ -2682,6 +2780,19 @@ FlushChannel( } else if (statePtr->outQueueHead == NULL) { ResetFlag(statePtr, BG_FLUSH_SCHEDULED); ChanWatch(chanPtr, statePtr->interestMask); + } else { + + /* + * When we are calledFromAsyncFlush, that means a writable + * state on the channel triggered the call, so we should be + * able to write something. Either we did write something + * and wroteSome should be set, or there was nothing left to + * write in this call, and we've completed the BG flush. + * These are the two cases above. If we get here, that means + * there is some kind failure in the writable event machinery. + */ + + assert(!calledFromAsyncFlush); } } @@ -2768,7 +2879,7 @@ CloseChannel( */ if (statePtr->curOutPtr != NULL) { - ckfree(statePtr->curOutPtr); + ReleaseChannelBuffer(statePtr->curOutPtr); statePtr->curOutPtr = NULL; } @@ -3180,10 +3291,18 @@ Tcl_Close( stickyError = 0; - if ((statePtr->encoding != NULL) && (statePtr->curOutPtr != NULL) - && (CheckChannelErrors(statePtr, TCL_WRITABLE) == 0)) { - statePtr->outputEncodingFlags |= TCL_ENCODING_END; - if (WriteChars(chanPtr, "", 0) < 0) { + if (GotFlag(statePtr, TCL_WRITABLE) && (statePtr->encoding != NULL) + && !(statePtr->outputEncodingFlags & TCL_ENCODING_START)) { + + int code = CheckChannelErrors(statePtr, TCL_WRITABLE); + + if (code == 0) { + statePtr->outputEncodingFlags |= TCL_ENCODING_END; + code = WriteChars(chanPtr, "", 0); + statePtr->outputEncodingFlags &= ~TCL_ENCODING_END; + statePtr->outputEncodingFlags |= TCL_ENCODING_START; + } + if (code < 0) { stickyError = Tcl_GetErrno(); } @@ -3218,14 +3337,6 @@ Tcl_Close( ResetFlag(statePtr, CHANNEL_INCLOSE); /* - * Ensure that the last output buffer will be flushed. - */ - - if ((statePtr->curOutPtr != NULL) && IsBufferReady(statePtr->curOutPtr)) { - SetFlag(statePtr, BUFFER_READY); - } - - /* * If this channel supports it, close the read side, since we don't need * it anymore and this will help avoid deadlocks on some channel types. */ @@ -3270,7 +3381,17 @@ Tcl_Close( Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_PosixError(interp), -1)); } - flushcode = -1; + return TCL_ERROR; + } + /* + * Bug 97069ea11a: set error message if a flush code is set and no error + * message set up to now. + */ + if (flushcode != 0 && interp != NULL + && 0 == Tcl_GetCharLength(Tcl_GetObjResult(interp)) ) { + Tcl_SetErrno(flushcode); + Tcl_SetObjResult(interp, + Tcl_NewStringObj(Tcl_PosixError(interp), -1)); } if ((flushcode != 0) || (result != 0)) { return TCL_ERROR; @@ -3383,10 +3504,6 @@ Tcl_CloseEx( return CloseChannelPart(interp, chanPtr, 0, flags); } else if (flags & TCL_CLOSE_WRITE) { - if ((statePtr->curOutPtr != NULL) && - IsBufferReady(statePtr->curOutPtr)) { - SetFlag(statePtr, BUFFER_READY); - } Tcl_Preserve(statePtr); if (!GotFlag(statePtr, BG_FLUSH_SCHEDULED)) { /* @@ -3448,14 +3565,6 @@ CloseWrite( int result = 0; /* - * Ensure that the last output buffer will be flushed. - */ - - if ((statePtr->curOutPtr != NULL) && IsBufferReady(statePtr->curOutPtr)) { - SetFlag(statePtr, BUFFER_READY); - } - - /* * The call to FlushChannel will flush any queued output and invoke the * close function of the channel driver, or it will set up the channel to * be flushed and closed asynchronously. @@ -3967,12 +4076,25 @@ static int WillRead( Channel *chanPtr) { + if (chanPtr->typePtr == NULL) { + /* Prevent read attempts on a closed channel */ + DiscardInputQueued(chanPtr->state, 0); + Tcl_SetErrno(EINVAL); + return -1; + } if ((chanPtr->typePtr->seekProc != NULL) && (Tcl_OutputBuffered((Tcl_Channel) chanPtr) > 0)) { - if ((chanPtr->state->curOutPtr != NULL) - && IsBufferReady(chanPtr->state->curOutPtr)) { - SetFlag(chanPtr->state, BUFFER_READY); - } + + /* + * CAVEAT - The assumption here is that FlushChannel() will + * push out the bytes of any writes that are in progress. + * Since this is a seekable channel, we assume it is not one + * that can block and force bg flushing. Channels we know that + * can do that -- sockets, pipes -- are not seekable. If the + * assumption is wrong, more drastic measures may be required here + * like temporarily setting the channel into blocking mode. + */ + if (FlushChannel(NULL, chanPtr, 0) != 0) { return -1; } @@ -4053,6 +4175,7 @@ Write( bufPtr->nextAdded += saved; saved = 0; } + PreserveChannelBuffer(bufPtr); dst = InsertPoint(bufPtr); dstLen = SpaceLeft(bufPtr); @@ -4066,6 +4189,7 @@ Write( if ((result != TCL_OK) && (srcRead + dstWrote == 0)) { /* We're reading from invalid/incomplete UTF-8 */ + ReleaseChannelBuffer(bufPtr); if (total == 0) { Tcl_SetErrno(EINVAL); return -1; @@ -4108,9 +4232,7 @@ Write( &statePtr->outputEncodingState, dst, dstLen + BUFFER_PADDING, &srcRead, &dstWrote, NULL); - if (srcRead != nlLen) { - Tcl_Panic("Can This Happen?"); - } + assert (srcRead == nlLen); bufPtr->nextAdded += dstWrote; src++; @@ -4142,6 +4264,7 @@ Write( if (IsBufferFull(bufPtr)) { if (FlushChannel(NULL, chanPtr, 0) != 0) { + ReleaseChannelBuffer(bufPtr); return -1; } flushed += statePtr->bufSize; @@ -4149,10 +4272,10 @@ Write( needNlFlush = 0; } } + ReleaseChannelBuffer(bufPtr); } if ((flushed < total) && (GotFlag(statePtr, CHANNEL_UNBUFFERED) || (needNlFlush && GotFlag(statePtr, CHANNEL_LINEBUFFERED)))) { - SetFlag(statePtr, BUFFER_READY); if (FlushChannel(NULL, chanPtr, 0) != 0) { return -1; } @@ -4240,8 +4363,7 @@ Tcl_GetsObj( Tcl_EncodingState oldState; if (CheckChannelErrors(statePtr, TCL_READABLE) != 0) { - copiedTotal = -1; - goto done; + return -1; } /* @@ -4261,6 +4383,7 @@ Tcl_GetsObj( */ chanPtr = statePtr->topChanPtr; + Tcl_Preserve(chanPtr); bufPtr = statePtr->inQueueHead; encoding = statePtr->encoding; @@ -4473,6 +4596,7 @@ Tcl_GetsObj( Tcl_SetObjLength(objPtr, oldLength); CommonGetsCleanup(chanPtr); copiedTotal = -1; + ResetFlag(statePtr, CHANNEL_BLOCKED); goto done; } goto gotEOL; @@ -4494,7 +4618,11 @@ Tcl_GetsObj( * self-modifying reflected transforms. */ - chanPtr = statePtr->topChanPtr; + if (chanPtr != statePtr->topChanPtr) { + Tcl_Release(chanPtr); + chanPtr = statePtr->topChanPtr; + Tcl_Preserve(chanPtr); + } bufPtr = gs.bufPtr; if (bufPtr == NULL) { @@ -4528,16 +4656,18 @@ Tcl_GetsObj( * Regenerate the top channel, in case it was changed due to * self-modifying reflected transforms. */ - - chanPtr = statePtr->topChanPtr; - + if (chanPtr != statePtr->topChanPtr) { + Tcl_Release(chanPtr); + chanPtr = statePtr->topChanPtr; + Tcl_Preserve(chanPtr); + } bufPtr = statePtr->inQueueHead; - if (bufPtr == NULL) { - Tcl_Panic("Tcl_GetsObj: restore reached with bufPtr==NULL"); + if (bufPtr != NULL) { + bufPtr->nextRemoved = oldRemoved; + bufPtr = bufPtr->nextPtr; } - bufPtr->nextRemoved = oldRemoved; - for (bufPtr = bufPtr->nextPtr; bufPtr != NULL; bufPtr = bufPtr->nextPtr) { + for ( ; bufPtr != NULL; bufPtr = bufPtr->nextPtr) { bufPtr->nextRemoved = BUFFER_PADDING; } CommonGetsCleanup(chanPtr); @@ -4570,10 +4700,13 @@ Tcl_GetsObj( * Regenerate the top channel, in case it was changed due to * self-modifying reflected transforms. */ - - chanPtr = statePtr->topChanPtr; - + if (chanPtr != statePtr->topChanPtr) { + Tcl_Release(chanPtr); + chanPtr = statePtr->topChanPtr; + Tcl_Preserve(chanPtr); + } UpdateInterest(chanPtr); + Tcl_Release(chanPtr); return copiedTotal; } @@ -4619,6 +4752,7 @@ TclGetsObjBinary( */ chanPtr = statePtr->topChanPtr; + Tcl_Preserve(chanPtr); bufPtr = statePtr->inQueueHead; @@ -4666,16 +4800,17 @@ TclGetsObjBinary( * device. Side effect is to allocate another channel buffer. */ - if (GotFlag(statePtr, CHANNEL_BLOCKED)) { - if (GotFlag(statePtr, CHANNEL_NONBLOCKING)) { - goto restore; - } - ResetFlag(statePtr, CHANNEL_BLOCKED); + if (GotFlag(statePtr, CHANNEL_BLOCKED|CHANNEL_NONBLOCKING) + == (CHANNEL_BLOCKED|CHANNEL_NONBLOCKING)) { + goto restore; } if (GetInput(chanPtr) != 0) { goto restore; } bufPtr = statePtr->inQueueTail; + if (bufPtr == NULL) { + goto restore; + } } dst = (unsigned char *) RemovePoint(bufPtr); @@ -4730,6 +4865,7 @@ TclGetsObjBinary( byteArray = Tcl_SetByteArrayLength(objPtr, oldLength); CommonGetsCleanup(chanPtr); copiedTotal = -1; + ResetFlag(statePtr, CHANNEL_BLOCKED); goto done; } goto gotEOL; @@ -4788,12 +4924,12 @@ TclGetsObjBinary( restore: bufPtr = statePtr->inQueueHead; - if (bufPtr == NULL) { - Tcl_Panic("TclGetsObjBinary: restore reached with bufPtr==NULL"); + if (bufPtr) { + bufPtr->nextRemoved = oldRemoved; + bufPtr = bufPtr->nextPtr; } - bufPtr->nextRemoved = oldRemoved; - for (bufPtr = bufPtr->nextPtr; bufPtr != NULL; bufPtr = bufPtr->nextPtr) { + for ( ; bufPtr != NULL; bufPtr = bufPtr->nextPtr) { bufPtr->nextRemoved = BUFFER_PADDING; } CommonGetsCleanup(chanPtr); @@ -4822,6 +4958,7 @@ TclGetsObjBinary( done: UpdateInterest(chanPtr); + Tcl_Release(chanPtr); return copiedTotal; } @@ -4898,7 +5035,7 @@ FilterInputBytes( ChannelState *statePtr = chanPtr->state; /* State info for channel */ ChannelBuffer *bufPtr; - char *raw, *rawStart, *dst; + char *raw, *dst; int offset, toRead, dstNeeded, spaceLeft, result, rawLen; Tcl_Obj *objPtr; #define ENCODING_LINESIZE 20 /* Lower bound on how many bytes to convert at @@ -4932,14 +5069,6 @@ FilterInputBytes( */ read: - if (GotFlag(statePtr, CHANNEL_BLOCKED)) { - if (GotFlag(statePtr, CHANNEL_NONBLOCKING)) { - gsPtr->charsWrote = 0; - gsPtr->rawRead = 0; - return -1; - } - ResetFlag(statePtr, CHANNEL_BLOCKED); - } if (GetInput(chanPtr) != 0) { gsPtr->charsWrote = 0; gsPtr->rawRead = 0; @@ -4947,6 +5076,11 @@ FilterInputBytes( } bufPtr = statePtr->inQueueTail; gsPtr->bufPtr = bufPtr; + if (bufPtr == NULL) { + gsPtr->charsWrote = 0; + gsPtr->rawRead = 0; + return -1; + } } /* @@ -4955,8 +5089,7 @@ FilterInputBytes( * string rep if we need more space. */ - rawStart = RemovePoint(bufPtr); - raw = rawStart; + raw = RemovePoint(bufPtr); rawLen = BytesLeft(bufPtr); dst = *gsPtr->dstPtr; @@ -5023,9 +5156,15 @@ FilterInputBytes( } else { /* * There are no more cached raw bytes left. See if we can get - * some more. + * some more, but avoid blocking on a non-blocking channel. */ + if (GotFlag(statePtr, CHANNEL_NONBLOCKING|CHANNEL_BLOCKED) + == (CHANNEL_NONBLOCKING|CHANNEL_BLOCKED)) { + gsPtr->charsWrote = 0; + gsPtr->rawRead = 0; + return -1; + } goto read; } } else { @@ -5264,134 +5403,77 @@ Tcl_Read( int Tcl_ReadRaw( Tcl_Channel chan, /* The channel from which to read. */ - char *bufPtr, /* Where to store input read. */ + char *readBuf, /* Where to store input read. */ int bytesToRead) /* Maximum number of bytes to read. */ { Channel *chanPtr = (Channel *) chan; ChannelState *statePtr = chanPtr->state; /* State info for channel */ - int nread, result, copied, copiedNow; - - /* - * The check below does too much because it will reject a call to this - * function with a channel which is part of an 'fcopy'. But we have to - * allow this here or else the chaining in the transformation drivers will - * fail with 'file busy' error instead of retrieving and transforming the - * data to copy. - * - * We let the check procedure now believe that there is no fcopy in - * progress. A better solution than this might be an additional flag - * argument to switch off specific checks. - */ + int copied = 0; if (CheckChannelErrors(statePtr, TCL_READABLE | CHANNEL_RAW_MODE) != 0) { return -1; } - /* - * Check for information in the push-back buffers. If there is some, use - * it. Go to the driver only if there is none (anymore) and the caller - * requests more bytes. - */ + /* First read bytes from the push-back buffers. */ - for (copied = 0; copied < bytesToRead; copied += copiedNow) { - copiedNow = CopyBuffer(chanPtr, bufPtr + copied, - bytesToRead - copied); - if (copiedNow == 0) { - if (GotFlag(statePtr, CHANNEL_EOF)) { - goto done; - } - if (GotFlag(statePtr, CHANNEL_BLOCKED)) { - if (GotFlag(statePtr, CHANNEL_NONBLOCKING)) { - goto done; - } - ResetFlag(statePtr, CHANNEL_BLOCKED); - } + while (chanPtr->inQueueHead && bytesToRead > 0) { + ChannelBuffer *bufPtr = chanPtr->inQueueHead; + int bytesInBuffer = BytesLeft(bufPtr); + int toCopy = (bytesInBuffer < bytesToRead) ? bytesInBuffer + : bytesToRead; -#ifdef TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING - /* - * [Bug 943274]. Better emulation of non-blocking channels for - * channels without BlockModeProc, by keeping track of true - * fileevents generated by the OS == Data waiting and reading if - * and only if we are sure to have data. - */ + /* Copy the current chunk into the read buffer. */ - if (GotFlag(statePtr, CHANNEL_NONBLOCKING) && - (Tcl_ChannelBlockModeProc(chanPtr->typePtr) == NULL) && - !GotFlag(statePtr, CHANNEL_HAS_MORE_DATA)) { - /* - * We bypass the driver; it would block as no data is - * available. - */ + memcpy(readBuf, RemovePoint(bufPtr), (size_t) toCopy); + bufPtr->nextRemoved += toCopy; + copied += toCopy; + readBuf += toCopy; + bytesToRead -= toCopy; - nread = -1; - result = EWOULDBLOCK; - } else -#endif /* TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING */ - { - /* - * Now go to the driver to get as much as is possible to fill - * the remaining request. Do all the error handling by - * ourselves. The code was stolen from 'GetInput' and slightly - * adapted (different return value here). - * - * The case of 'bytesToRead == 0' at this point cannot happen. - */ + /* If the current buffer is empty recycle it. */ - nread = ChanRead(chanPtr, bufPtr + copied, - bytesToRead - copied, &result); + if (IsBufferEmpty(bufPtr)) { + chanPtr->inQueueHead = bufPtr->nextPtr; + if (chanPtr->inQueueHead == NULL) { + chanPtr->inQueueTail = NULL; } + RecycleBuffer(chanPtr->state, bufPtr, 0); + } + } - if (nread > 0) { - /* - * If we get a short read, signal up that we may be BLOCKED. - * We should avoid calling the driver because on some - * platforms we will block in the low level reading code even - * though the channel is set into nonblocking mode. - */ + /* Go to the driver if more data needed. */ - if (nread < (bytesToRead - copied)) { - SetFlag(statePtr, CHANNEL_BLOCKED); - } + if (bytesToRead > 0) { -#ifdef TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING - if (nread <= (bytesToRead - copied)) { - /* - * [Bug 943274] We have read the available data, clear - * flag. - */ - - ResetFlag(statePtr, CHANNEL_HAS_MORE_DATA); - } -#endif /* TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING */ - } else if (nread == 0) { - SetFlag(statePtr, CHANNEL_EOF); - statePtr->inputEncodingFlags |= TCL_ENCODING_END; - - } else if (nread < 0) { - if ((result == EWOULDBLOCK) || (result == EAGAIN)) { - if (copied > 0) { - /* - * Information that was copied earlier has precedence - * over EAGAIN/WOULDBLOCK handling. - */ - - return copied; - } + int nread = ChanRead(chanPtr, readBuf+copied, bytesToRead); - SetFlag(statePtr, CHANNEL_BLOCKED); - result = EAGAIN; - } - - Tcl_SetErrno(result); - return -1; + if (nread > 0) { + /* Successful read (short is OK) - add to bytes copied */ + copied += nread; + } else if (nread < 0) { + /* + * An error signaled. If CHANNEL_BLOCKED, then the error + * is not real, but an indication of blocked state. In + * that case, retain the flag and let caller receive the + * short read of copied bytes from the pushback. + * HOWEVER, if copied==0 bytes from pushback then repeat + * signalling the blocked state as an error to caller so + * there is no false report of an EOF. + * When !CHANNEL_BLOCKED, the error is real and passes on + * to caller. + */ + if (!GotFlag(statePtr, CHANNEL_BLOCKED) || copied == 0) { + copied = -1; } - - return copied + nread; + } else if (copied > 0) { + /* + * nread == 0. Driver is at EOF, but if copied>0 bytes + * from pushback, then we should not signal it yet. + */ + ResetFlag(statePtr, CHANNEL_EOF); } } - - done: return copied; } @@ -5488,8 +5570,9 @@ DoReadChars( ChannelState *statePtr = chanPtr->state; /* State info for channel */ ChannelBuffer *bufPtr; - int offset, factor, copied, copiedNow, result; + int factor, copied, copiedNow, result; Tcl_Encoding encoding; + int binaryMode; #define UTF_EXPANSION_FACTOR 1024 /* @@ -5499,9 +5582,14 @@ DoReadChars( chanPtr = statePtr->topChanPtr; encoding = statePtr->encoding; factor = UTF_EXPANSION_FACTOR; + Tcl_Preserve(chanPtr); + + binaryMode = (encoding == NULL) + && (statePtr->inputTranslation == TCL_TRANSLATE_LF) + && (statePtr->inEofChar == '\0'); if (appendFlag == 0) { - if (encoding == NULL) { + if (binaryMode) { Tcl_SetByteArrayLength(objPtr, 0); } else { Tcl_SetObjLength(objPtr, 0); @@ -5510,27 +5598,23 @@ DoReadChars( * We're going to access objPtr->bytes directly, so we must ensure * that this is actually a string object (otherwise it might have * been pure Unicode). + * + * Probably not needed anymore. */ TclGetString(objPtr); } - offset = 0; - } else { - if (encoding == NULL) { - Tcl_GetByteArrayFromObj(objPtr, &offset); - } else { - TclGetStringFromObj(objPtr, &offset); - } } + /* Must clear the BLOCKED flag here since we check before reading */ + ResetFlag(statePtr, CHANNEL_BLOCKED); for (copied = 0; (unsigned) toRead > 0; ) { copiedNow = -1; if (statePtr->inQueueHead != NULL) { - if (encoding == NULL) { - copiedNow = ReadBytes(statePtr, objPtr, toRead, &offset); + if (binaryMode) { + copiedNow = ReadBytes(statePtr, objPtr, toRead); } else { - copiedNow = ReadChars(statePtr, objPtr, toRead, &offset, - &factor); + copiedNow = ReadChars(statePtr, objPtr, toRead, &factor); } /* @@ -5553,19 +5637,21 @@ DoReadChars( if (GotFlag(statePtr, CHANNEL_EOF)) { break; } - if (GotFlag(statePtr, CHANNEL_BLOCKED)) { - if (GotFlag(statePtr, CHANNEL_NONBLOCKING)) { - break; - } - ResetFlag(statePtr, CHANNEL_BLOCKED); + if (GotFlag(statePtr, CHANNEL_NONBLOCKING|CHANNEL_BLOCKED) + == (CHANNEL_NONBLOCKING|CHANNEL_BLOCKED)) { + break; } result = GetInput(chanPtr); + if (chanPtr != statePtr->topChanPtr) { + Tcl_Release(chanPtr); + chanPtr = statePtr->topChanPtr; + Tcl_Preserve(chanPtr); + } if (result != 0) { - if (result == EAGAIN) { - break; + if (!GotFlag(statePtr, CHANNEL_BLOCKED)) { + copied = -1; } - copied = -1; - goto done; + break; } } else { copied += copiedNow; @@ -5573,27 +5659,31 @@ DoReadChars( } } - ResetFlag(statePtr, CHANNEL_BLOCKED); - if (encoding == NULL) { - Tcl_SetByteArrayLength(objPtr, offset); - } else { - Tcl_SetObjLength(objPtr, offset); - } - /* - * Update the notifier state so we don't block while there is still data - * in the buffers. + * Failure to fill a channel buffer may have left channel reporting + * a "blocked" state, but so long as we fulfilled the request here, + * the caller does not consider us blocked. */ + if (toRead == 0) { + ResetFlag(statePtr, CHANNEL_BLOCKED); + } - done: /* * Regenerate the top channel, in case it was changed due to * self-modifying reflected transforms. */ + if (chanPtr != statePtr->topChanPtr) { + Tcl_Release(chanPtr); + chanPtr = statePtr->topChanPtr; + Tcl_Preserve(chanPtr); + } - chanPtr = statePtr->topChanPtr; - + /* + * Update the notifier state so we don't block while there is still data + * in the buffers. + */ UpdateInterest(chanPtr); + Tcl_Release(chanPtr); return copied; } @@ -5611,13 +5701,11 @@ DoReadChars( * allocated to hold data read from the channel as needed. * * Results: - * The return value is the number of bytes appended to the object and - * *offsetPtr is filled with the total number of bytes in the object - * (greater than the return value if there were already bytes in the - * object). + * The return value is the number of bytes appended to the object, or + * -1 to indicate that zero bytes were read due to an EOF. * * Side effects: - * None. + * The storage of bytes in objPtr can cause (re-)allocation of memory. * *--------------------------------------------------------------------------- */ @@ -5630,72 +5718,22 @@ ReadBytes( * been allocated to hold data, not how many * bytes of data have been stored in the * object. */ - int bytesToRead, /* Maximum number of bytes to store, or < 0 to + int bytesToRead) /* Maximum number of bytes to store, or < 0 to * get all available bytes. Bytes are obtained * from the first buffer in the queue - even * if this number is larger than the number of * bytes available in the first buffer, only * the bytes from the first buffer are * returned. */ - int *offsetPtr) /* On input, contains how many bytes of objPtr - * have been used to hold data. On output, - * filled with how many bytes are now being - * used. */ { - int toRead, srcLen, offset, length, srcRead, dstWrote; - ChannelBuffer *bufPtr; - char *src, *dst; - - offset = *offsetPtr; - - bufPtr = statePtr->inQueueHead; - src = RemovePoint(bufPtr); - srcLen = BytesLeft(bufPtr); - - toRead = bytesToRead; - if ((unsigned) toRead > (unsigned) srcLen) { - toRead = srcLen; - } - - dst = (char *) Tcl_GetByteArrayFromObj(objPtr, &length); - if (toRead > length - offset - 1) { - /* - * Double the existing size of the object or make enough room to hold - * all the characters we may get from the source buffer, whichever is - * larger. - */ + ChannelBuffer *bufPtr = statePtr->inQueueHead; + int srcLen = BytesLeft(bufPtr); + int toRead = bytesToRead>srcLen || bytesToRead<0 ? srcLen : bytesToRead; - length = offset * 2; - if (offset < toRead) { - length = offset + toRead + 1; - } - dst = (char *) Tcl_SetByteArrayLength(objPtr, length); - } - dst += offset; - - if (GotFlag(statePtr, INPUT_NEED_NL)) { - ResetFlag(statePtr, INPUT_NEED_NL); - if ((srcLen == 0) || (*src != '\n')) { - *dst = '\r'; - *offsetPtr += 1; - return 1; - } - *dst++ = '\n'; - src++; - srcLen--; - toRead--; - } - - srcRead = srcLen; - dstWrote = toRead; - if (TranslateInputEOL(statePtr, dst, src, &dstWrote, &srcRead) != 0) { - if (dstWrote == 0) { - return -1; - } - } - bufPtr->nextRemoved += srcRead; - *offsetPtr += dstWrote; - return dstWrote; + TclAppendBytesToByteArray(objPtr, (unsigned char *) RemovePoint(bufPtr), + toRead); + bufPtr->nextRemoved += toRead; + return toRead; } /* @@ -5739,262 +5777,351 @@ ReadChars( * is larger than the number of characters * available in the first buffer, only the * characters from the first buffer are - * returned. */ - int *offsetPtr, /* On input, contains how many bytes of objPtr - * have been used to hold data. On output, - * filled with how many bytes are now being - * used. */ + * returned. The execption is when there is + * not any complete character in the first + * buffer. In that case, a recursive call + * effectively obtains chars from the + * second buffer. */ int *factorPtr) /* On input, contains a guess of how many * bytes need to be allocated to hold the * result of converting N source bytes to * UTF-8. On output, contains another guess * based on the data seen so far. */ { - int toRead, factor, offset, spaceLeft, srcLen, dstNeeded; - int srcRead, dstWrote, numChars, dstRead; - ChannelBuffer *bufPtr; - char *src, *dst; - Tcl_EncodingState oldState; - int encEndFlagSuppressed = 0; + Tcl_Encoding encoding = statePtr->encoding? statePtr->encoding + : GetBinaryEncoding(); + Tcl_EncodingState savedState = statePtr->inputEncodingState; + ChannelBuffer *bufPtr = statePtr->inQueueHead; + int savedIEFlags = statePtr->inputEncodingFlags; + int savedFlags = statePtr->flags; + char *dst, *src = RemovePoint(bufPtr); + int dstLimit, numBytes, srcLen = BytesLeft(bufPtr); - factor = *factorPtr; - offset = *offsetPtr; - - bufPtr = statePtr->inQueueHead; - src = RemovePoint(bufPtr); - srcLen = BytesLeft(bufPtr); + /* + * One src byte can yield at most one character. So when the + * number of src bytes we plan to read is less than the limit on + * character count to be read, clearly we will remain within that + * limit, and we can use the value of "srcLen" as a tighter limit + * for sizing receiving buffers. + */ - toRead = charsToRead; - if ((unsigned) toRead > (unsigned) srcLen) { - toRead = srcLen; - } + int toRead = ((charsToRead<0)||(charsToRead > srcLen)) ? srcLen : charsToRead; /* * 'factor' is how much we guess that the bytes in the source buffer will * expand when converted to UTF-8 chars. This guess comes from analyzing * how many characters were produced by the previous pass. */ + + int factor = *factorPtr; + int dstNeeded = TCL_UTF_MAX - 1 + toRead * factor / UTF_EXPANSION_FACTOR; - dstNeeded = TCL_UTF_MAX - 1 + toRead * factor / UTF_EXPANSION_FACTOR; - spaceLeft = objPtr->length - offset; - - if (dstNeeded > spaceLeft) { - /* - * Double the existing size of the object or make enough room to hold - * all the characters we want from the source buffer, whichever is - * larger. - */ - - int length = offset + ((offset < dstNeeded) ? dstNeeded : offset); - - if (Tcl_AttemptSetObjLength(objPtr, length) == 0) { - length = offset + dstNeeded; - if (Tcl_AttemptSetObjLength(objPtr, length) == 0) { - dstNeeded = TCL_UTF_MAX - 1 + toRead; - length = offset + dstNeeded; - Tcl_SetObjLength(objPtr, length); - } - } - spaceLeft = length - offset; - } + (void) TclGetStringFromObj(objPtr, &numBytes); + Tcl_AppendToObj(objPtr, NULL, dstNeeded); if (toRead == srcLen) { - /* - * Want to convert the whole buffer in one pass. If we have enough - * space, convert it using all available space in object rather than - * using the factor. - */ - - dstNeeded = spaceLeft; + unsigned int size; + dst = TclGetStringStorage(objPtr, &size) + numBytes; + dstNeeded = size - numBytes; + } else { + dst = TclGetString(objPtr) + numBytes; } - dst = objPtr->bytes + offset; /* - * [Bug 1462248]: The cause of the crash reported in this bug is this: - * - * - ReadChars, called with a single buffer, with a incomplete - * multi-byte character at the end (only the first byte of it). - * - Encoding translation fails, asks for more data - * - Data is read, and eof is reached, TCL_ENCODING_END (TEE) is set. - * - ReadChar is called again, converts the first buffer, but due to TEE - * it does not check for incomplete multi-byte data, and the character - * just after the end of the first buffer is a valid completion of the - * multi-byte header in the actual buffer. The conversion reads more - * characters from the buffer then present. This causes nextRemoved to - * overshoot nextAdded and the next reads compute a negative srcLen, - * cause further translations to fail, causing copying of data into the - * next buffer using bad arguments, causing the mecpy for to eventually - * fail. + * This routine is burdened with satisfying several constraints. + * It cannot append more than 'charsToRead` chars onto objPtr. + * This is measured after encoding and translation transformations + * are completed. There is no precise number of src bytes that can + * be associated with the limit. Yet, when we are done, we must know + * precisely the number of src bytes that were consumed to produce + * the appended chars, so that all subsequent bytes are left in + * the buffers for future read operations. * - * In the end it is a memory access bug spiraling out of control if the - * conditions are _just so_. And ultimate cause is that TEE is given to a - * conversion where it should not. TEE signals that this is the last - * buffer. Except in our case it is not. - * - * My solution is to suppress TEE if the first buffer is not the last. We - * will eventually need it given that EOF has been reached, but not right - * now. This is what the new flag "endEncSuppressFlag" is for. - * - * The bug in 'Tcl_Utf2UtfProc' where it read from memory behind the - * actual buffer has been fixed as well, and fixes the problem with the - * crash too, but this would still allow the generic layer to - * accidentially break a multi-byte sequence if the conditions are just - * right, because again the ExternalToUtf would be successful where it - * should not. + * The consequence is that we have no choice but to implement a + * "trial and error" approach, where in general we may need to + * perform transformations and copies multiple times to achieve + * a consistent set of results. This takes the shape of a loop. */ - if ((statePtr->inputEncodingFlags & TCL_ENCODING_END) && - (bufPtr->nextPtr != NULL)) { + dstLimit = dstNeeded + 1; + while (1) { + int dstDecoded, dstRead, dstWrote, srcRead, numChars; + /* - * TEE is set for a buffer which is not the last. Squash it for now, - * and restore it later, before yielding control to our caller. + * Perform the encoding transformation. Read no more than + * srcLen bytes, write no more than dstLimit bytes. */ - statePtr->inputEncodingFlags &= ~TCL_ENCODING_END; - encEndFlagSuppressed = 1; - } + int code = Tcl_ExternalToUtf(NULL, encoding, src, srcLen, + statePtr->inputEncodingFlags & (bufPtr->nextPtr + ? ~0 : ~TCL_ENCODING_END), &statePtr->inputEncodingState, + dst, dstLimit, &srcRead, &dstDecoded, &numChars); - oldState = statePtr->inputEncodingState; - if (GotFlag(statePtr, INPUT_NEED_NL)) { /* - * We want a '\n' because the last character we saw was '\r'. + * Perform the translation transformation in place. Read no more + * than the dstDecoded bytes the encoding transformation actually + * produced. Capture the number of bytes written in dstWrote. + * Capture the number of bytes actually consumed in dstRead. */ - ResetFlag(statePtr, INPUT_NEED_NL); - Tcl_ExternalToUtf(NULL, statePtr->encoding, src, srcLen, - statePtr->inputEncodingFlags, &statePtr->inputEncodingState, - dst, TCL_UTF_MAX + 1, &srcRead, &dstWrote, &numChars); - if ((dstWrote > 0) && (*dst == '\n')) { + dstWrote = dstLimit; + dstRead = dstDecoded; + TranslateInputEOL(statePtr, dst, dst, &dstWrote, &dstRead); + + if (dstRead < dstDecoded) { + /* - * The next char was a '\n'. Consume it and produce a '\n'. + * The encoding transformation produced bytes that the + * translation transformation did not consume. Why did + * this happen? */ - bufPtr->nextRemoved += srcRead; - } else { + if (statePtr->inEofChar && dst[dstRead] == statePtr->inEofChar) { + /* + * 1) There's an eof char set on the channel, and + * we saw it and stopped translating at that point. + * + * NOTE the bizarre spec of TranslateInputEOL in this case. + * Clearly the eof char had to be read in order to account + * for the stopping, but the value of dstRead does not + * include it. + * + * Also rather bizarre, our caller can only notice an + * EOF condition if we return the value -1 as the number + * of chars read. This forces us to perform a 2-call + * dance where the first call can read all the chars + * up to the eof char, and the second call is solely + * for consuming the encoded eof char then pointed at + * by src so that we can return that magic -1 value. + * This seems really wasteful, especially since + * the first decoding pass of each call is likely to + * decode many bytes beyond that eof char that's all we + * care about. + */ + + if (dstRead == 0) { + /* + * Curious choice in the eof char handling. We leave + * the eof char in the buffer. So, no need to compute + * a proper srcRead value. At this point, there + * are no chars before the eof char in the buffer. + */ + Tcl_SetObjLength(objPtr, numBytes); + return -1; + } + + { + /* + * There are chars leading the buffer before the eof + * char. Adjust the dstLimit so we go back and read + * only those and do not encounter the eof char this + * time. + */ + + dstLimit = dstRead + TCL_UTF_MAX; + statePtr->flags = savedFlags; + statePtr->inputEncodingFlags = savedIEFlags; + statePtr->inputEncodingState = savedState; + continue; + } + } + /* - * The next char was not a '\n'. Produce a '\r'. + * 2) The other way to read fewer bytes than are decoded + * is when the final byte is \r and we're in a CRLF + * translation mode so we cannot decide whether to + * record \r or \n yet. */ - *dst = '\r'; - } - statePtr->inputEncodingFlags &= ~TCL_ENCODING_START; - *offsetPtr += 1; + assert(dst[dstRead] == '\r'); + assert(statePtr->inputTranslation == TCL_TRANSLATE_CRLF); - if (encEndFlagSuppressed) { - statePtr->inputEncodingFlags |= TCL_ENCODING_END; - } - return 1; - } + if (dstWrote > 0) { + /* + * There are chars we can read before we hit the bare cr. + * Go back with a smaller dstLimit so we get them in the + * next pass, compute a matching srcRead, and don't end + * up back here in this call. + */ - Tcl_ExternalToUtf(NULL, statePtr->encoding, src, srcLen, - statePtr->inputEncodingFlags, &statePtr->inputEncodingState, dst, - dstNeeded + 1, &srcRead, &dstWrote, &numChars); + dstLimit = dstRead + TCL_UTF_MAX; + statePtr->flags = savedFlags; + statePtr->inputEncodingFlags = savedIEFlags; + statePtr->inputEncodingState = savedState; + continue; + } - if (encEndFlagSuppressed) { - statePtr->inputEncodingFlags |= TCL_ENCODING_END; - } + assert(dstWrote == 0); + assert(dstRead == 0); - if (srcRead == 0) { - /* - * Not enough bytes in src buffer to make a complete char. Copy the - * bytes to the next buffer to make a new contiguous string, then tell - * the caller to fill the buffer with more bytes. - */ + /* + * We decoded only the bare cr, and we cannot read a + * translated char from that alone. We have to know what's + * next. So why do we only have the one decoded char? + */ - ChannelBuffer *nextPtr; + if (code != TCL_OK) { + char buffer[TCL_UTF_MAX + 2]; + int read, decoded, count; + + /* + * Didn't get everything the buffer could offer + */ + + statePtr->flags = savedFlags; + statePtr->inputEncodingFlags = savedIEFlags; + statePtr->inputEncodingState = savedState; + + Tcl_ExternalToUtf(NULL, encoding, src, srcLen, + statePtr->inputEncodingFlags & (bufPtr->nextPtr + ? ~0 : ~TCL_ENCODING_END), &statePtr->inputEncodingState, + buffer, TCL_UTF_MAX + 2, &read, &decoded, &count); + + if (count == 2) { + if (buffer[1] == '\n') { + /* \r\n translate to \n */ + dst[0] = '\n'; + bufPtr->nextRemoved += read; + } else { + dst[0] = '\r'; + bufPtr->nextRemoved += srcRead; + } + + dst[1] = '\0'; + statePtr->inputEncodingFlags &= ~TCL_ENCODING_START; + + Tcl_SetObjLength(objPtr, numBytes + 1); + return 1; + } + + } else if (statePtr->flags & CHANNEL_EOF) { - nextPtr = bufPtr->nextPtr; - if (nextPtr == NULL) { - if (srcLen > 0) { /* - * There isn't enough data in the buffers to complete the next - * character, so we need to wait for more data before the next - * file event can be delivered. [Bug 478856] - * - * The exception to this is if the input buffer was completely - * empty before we tried to convert its contents. Nothing in, - * nothing out, and no incomplete character data. The - * conversion before the current one was complete. + * The bare \r is the only char and we will never read + * a subsequent char to make the determination. */ - SetFlag(statePtr, CHANNEL_NEED_MORE_DATA); + dst[0] = '\r'; + bufPtr->nextRemoved = bufPtr->nextAdded; + Tcl_SetObjLength(objPtr, numBytes + 1); + return 1; } - return -1; + + /* + * Revise the dstRead value so that the numChars calc + * below correctly computes zero characters read. + */ + + dstRead = numChars; + + /* FALL THROUGH - get more data (dstWrote == 0) */ } - /* - * Space is made at the beginning of the buffer to copy the previous - * unused bytes there. Check first if the buffer we are using actually - * has enough space at its beginning for the data we are copying. - * Because if not we will write over the buffer management - * information, especially the 'nextPtr'. - * - * Note that the BUFFER_PADDING (See AllocChannelBuffer) is used to - * prevent exactly this situation. I.e. it should never happen. - * Therefore it is ok to panic should it happen despite the - * precautions. + /* + * The translation transformation can only reduce the number + * of chars when it converts \r\n into \n. The reduction in + * the number of chars is the difference in bytes read and written. */ - if (nextPtr->nextRemoved - srcLen < 0) { - Tcl_Panic("Buffer Underflow, BUFFER_PADDING not enough"); - } + numChars -= (dstRead - dstWrote); - nextPtr->nextRemoved -= srcLen; - memcpy(RemovePoint(nextPtr), src, (size_t) srcLen); - RecycleBuffer(statePtr, bufPtr, 0); - statePtr->inQueueHead = nextPtr; - return ReadChars(statePtr, objPtr, charsToRead, offsetPtr, factorPtr); - } + if (charsToRead > 0 && numChars > charsToRead) { - dstRead = dstWrote; - if (TranslateInputEOL(statePtr, dst, dst, &dstWrote, &dstRead) != 0) { - /* - * Hit EOF char. How many bytes of src correspond to where the EOF was - * located in dst? Run the conversion again with an output buffer just - * big enough to hold the data so we can get the correct value for - * srcRead. - */ + /* + * We read more chars than allowed. Reset limits to + * prevent that and try again. Don't forget the extra + * padding of TCL_UTF_MAX - 1 bytes demanded by the + * Tcl_ExternalToUtf() call! + */ - if (dstWrote == 0) { - return -1; + dstLimit = Tcl_UtfAtIndex(dst, charsToRead + 1) + + TCL_UTF_MAX - 1 - dst; + statePtr->flags = savedFlags; + statePtr->inputEncodingFlags = savedIEFlags; + statePtr->inputEncodingState = savedState; + continue; } - statePtr->inputEncodingState = oldState; - Tcl_ExternalToUtf(NULL, statePtr->encoding, src, srcLen, - statePtr->inputEncodingFlags, &statePtr->inputEncodingState, - dst, dstRead + TCL_UTF_MAX, &srcRead, &dstWrote, &numChars); - TranslateInputEOL(statePtr, dst, dst, &dstWrote, &dstRead); - } - /* - * The number of characters that we got may be less than the number that - * we started with because "\r\n" sequences may have been turned into just - * '\n' in dst. - */ + if (dstWrote == 0) { + ChannelBuffer *nextPtr; - numChars -= dstRead - dstWrote; + /* We were not able to read any chars. */ - if ((unsigned) numChars > (unsigned) toRead) { - /* - * Got too many chars. - */ + assert (numChars == 0); + + /* + * There is one situation where this is the correct final + * result. If the src buffer contains only a single \n + * byte, and we are in TCL_TRANSLATE_AUTO mode, and + * when the translation pass was made the INPUT_SAW_CR + * flag was set on the channel. In that case, the + * correct behavior is to consume that \n and produce the + * empty string. + */ - const char *eof = Tcl_UtfAtIndex(dst, toRead); + if (dst[0] == '\n') { + assert(statePtr->inputTranslation == TCL_TRANSLATE_AUTO); + assert(dstRead == 1); - statePtr->inputEncodingState = oldState; - Tcl_ExternalToUtf(NULL, statePtr->encoding, src, srcLen, - statePtr->inputEncodingFlags, &statePtr->inputEncodingState, - dst, eof - dst + TCL_UTF_MAX, &srcRead, &dstWrote, &numChars); - dstRead = dstWrote; - TranslateInputEOL(statePtr, dst, dst, &dstWrote, &dstRead); - numChars -= (dstRead - dstWrote); - } - statePtr->inputEncodingFlags &= ~TCL_ENCODING_START; + goto consume; + } + + /* Otherwise, reading zero characters indicates there's + * something incomplete at the end of the src buffer. + * Maybe there were not enough src bytes to decode into + * a char. Maybe a lone \r could not be translated (crlf + * mode). Need to combine any unused src bytes we have + * in the first buffer with subsequent bytes to try again. + */ + + nextPtr = bufPtr->nextPtr; + + if (nextPtr == NULL) { + if (srcLen > 0) { + SetFlag(statePtr, CHANNEL_NEED_MORE_DATA); + } + Tcl_SetObjLength(objPtr, numBytes); + return -1; + } + + /* + * Space is made at the beginning of the buffer to copy the + * previous unused bytes there. Check first if the buffer we + * are using actually has enough space at its beginning for + * the data we are copying. Because if not we will write over + * the buffer management information, especially the 'nextPtr'. + * + * Note that the BUFFER_PADDING (See AllocChannelBuffer) is + * used to prevent exactly this situation. I.e. it should never + * happen. Therefore it is ok to panic should it happen despite + * the precautions. + */ + + if (nextPtr->nextRemoved - srcLen < 0) { + Tcl_Panic("Buffer Underflow, BUFFER_PADDING not enough"); + } + + nextPtr->nextRemoved -= srcLen; + memcpy(RemovePoint(nextPtr), src, (size_t) srcLen); + RecycleBuffer(statePtr, bufPtr, 0); + statePtr->inQueueHead = nextPtr; + Tcl_SetObjLength(objPtr, numBytes); + return ReadChars(statePtr, objPtr, charsToRead, factorPtr); + } + + statePtr->inputEncodingFlags &= ~TCL_ENCODING_START; - bufPtr->nextRemoved += srcRead; - if (dstWrote > srcRead + 1) { - *factorPtr = dstWrote * UTF_EXPANSION_FACTOR / srcRead; + consume: + bufPtr->nextRemoved += srcRead; + /* + * If this read contained multibyte characters, revise factorPtr + * so the next read will allocate bigger buffers. + */ + if (numChars && numChars < srcRead) { + *factorPtr = srcRead * UTF_EXPANSION_FACTOR / numChars; + } + Tcl_SetObjLength(objPtr, numBytes + dstWrote); + return numChars; } - *offsetPtr += dstWrote; - return numChars; } /* @@ -6015,7 +6142,7 @@ ReadChars( *--------------------------------------------------------------------------- */ -static int +static void TranslateInputEOL( ChannelState *statePtr, /* Channel being read, for EOL translation and * EOF character. */ @@ -6024,132 +6151,138 @@ TranslateInputEOL( * characters. */ const char *srcStart, /* Source characters. */ int *dstLenPtr, /* On entry, the maximum length of output - * buffer in bytes; must be <= *srcLenPtr. On - * exit, the number of bytes actually used in - * output buffer. */ + * buffer in bytes. On exit, the number of + * bytes actually used in output buffer. */ int *srcLenPtr) /* On entry, the length of source buffer. On * exit, the number of bytes read from the * source buffer. */ { - int dstLen, srcLen, inEofChar; - const char *eof; + const char *eof = NULL; + int dstLen = *dstLenPtr; + int srcLen = *srcLenPtr; + int inEofChar = statePtr->inEofChar; - dstLen = *dstLenPtr; + /* + * Depending on the translation mode in use, there's no need + * to scan more srcLen bytes at srcStart than can possibly transform + * to dstLen bytes. This keeps the scan for eof char below from + * being pointlessly long. + */ + + switch (statePtr->inputTranslation) { + case TCL_TRANSLATE_LF: + case TCL_TRANSLATE_CR: + if (srcLen > dstLen) { + /* In these modes, each src byte become a dst byte. */ + srcLen = dstLen; + } + break; + default: + /* In other modes, at most 2 src bytes become a dst byte. */ + if (srcLen > 2 * dstLen) { + srcLen = 2 * dstLen; + } + break; + } - eof = NULL; - inEofChar = statePtr->inEofChar; if (inEofChar != '\0') { /* - * Find EOF in translated buffer then compress out the EOL. The source - * buffer may be much longer than the destination buffer - we only - * want to return EOF if the EOF has been copied to the destination - * buffer. + * Make sure we do not read past any logical end of channel input + * created by the presence of the input eof char. */ - const char *src, *srcMax = srcStart + *srcLenPtr; - - for (src = srcStart; src < srcMax; src++) { - if (*src == inEofChar) { - eof = src; - srcLen = src - srcStart; - if (srcLen < dstLen) { - dstLen = srcLen; - } - *srcLenPtr = srcLen; - break; - } + if ((eof = memchr(srcStart, inEofChar, srcLen))) { + srcLen = eof - srcStart; } } + switch (statePtr->inputTranslation) { case TCL_TRANSLATE_LF: + case TCL_TRANSLATE_CR: if (dstStart != srcStart) { - memcpy(dstStart, srcStart, (size_t) dstLen); + memcpy(dstStart, srcStart, (size_t) srcLen); } - srcLen = dstLen; - break; - case TCL_TRANSLATE_CR: { - char *dst, *dstEnd; + if (statePtr->inputTranslation == TCL_TRANSLATE_CR) { + char *dst = dstStart; + char *dstEnd = dstStart + srcLen; - if (dstStart != srcStart) { - memcpy(dstStart, srcStart, (size_t) dstLen); - } - dstEnd = dstStart + dstLen; - for (dst = dstStart; dst < dstEnd; dst++) { - if (*dst == '\r') { - *dst = '\n'; + while ((dst = memchr(dst, '\r', dstEnd - dst))) { + *dst++ = '\n'; } } - srcLen = dstLen; + dstLen = srcLen; break; - } case TCL_TRANSLATE_CRLF: { - char *dst; - const char *src, *srcEnd, *srcMax; - - dst = dstStart; - src = srcStart; - srcEnd = srcStart + dstLen; - srcMax = srcStart + *srcLenPtr; - - for ( ; src < srcEnd; ) { - if (*src == '\r') { - src++; - if (src >= srcMax) { - SetFlag(statePtr, INPUT_NEED_NL); - } else if (*src == '\n') { - *dst++ = *src++; - } else { + const char *crFound, *src = srcStart; + char *dst = dstStart; + int lesser = (dstLen < srcLen) ? dstLen : srcLen; + + while ((crFound = memchr(src, '\r', lesser))) { + int numBytes = crFound - src; + memmove(dst, src, numBytes); + + dst += numBytes; dstLen -= numBytes; + src += numBytes; srcLen -= numBytes; + if (srcLen == 1) { + /* valid src bytes end in \r */ + if (eof) { *dst++ = '\r'; + src++; srcLen--; + } else { + lesser = 0; + break; } + } else if (src[1] == '\n') { + *dst++ = '\n'; + src += 2; srcLen -= 2; } else { - *dst++ = *src++; + *dst++ = '\r'; + src++; srcLen--; } + dstLen--; + lesser = (dstLen < srcLen) ? dstLen : srcLen; } - srcLen = src - srcStart; - dstLen = dst - dstStart; + memmove(dst, src, lesser); + srcLen = src + lesser - srcStart; + dstLen = dst + lesser - dstStart; break; } case TCL_TRANSLATE_AUTO: { - char *dst; - const char *src, *srcEnd, *srcMax; + const char *crFound, *src = srcStart; + char *dst = dstStart; + int lesser; - dst = dstStart; - src = srcStart; - srcEnd = srcStart + dstLen; - srcMax = srcStart + *srcLenPtr; - - if (GotFlag(statePtr, INPUT_SAW_CR) && (src < srcMax)) { - if (*src == '\n') { - src++; - } + if ((statePtr->flags & INPUT_SAW_CR) && srcLen) { + if (*src == '\n') { src++; srcLen--; } ResetFlag(statePtr, INPUT_SAW_CR); } - for ( ; src < srcEnd; ) { - if (*src == '\r') { - src++; - if (src >= srcMax) { - SetFlag(statePtr, INPUT_SAW_CR); - } else if (*src == '\n') { - if (srcEnd < srcMax) { - srcEnd++; - } - src++; - } - *dst++ = '\n'; - } else { - *dst++ = *src++; + lesser = (dstLen < srcLen) ? dstLen : srcLen; + while ((crFound = memchr(src, '\r', lesser))) { + int numBytes = crFound - src; + memmove(dst, src, numBytes); + + dst[numBytes] = '\n'; + dst += numBytes + 1; dstLen -= numBytes + 1; + src += numBytes + 1; srcLen -= numBytes + 1; + if (srcLen == 0) { + SetFlag(statePtr, INPUT_SAW_CR); + } else if (*src == '\n') { + src++; srcLen--; } + lesser = (dstLen < srcLen) ? dstLen : srcLen; } - srcLen = src - srcStart; - dstLen = dst - dstStart; + memmove(dst, src, lesser); + srcLen = src + lesser - srcStart; + dstLen = dst + lesser - dstStart; break; } default: - return 0; + Tcl_Panic("unknown input translation %d", statePtr->inputTranslation); } *dstLenPtr = dstLen; + *srcLenPtr = srcLen; - if ((eof != NULL) && (srcStart + srcLen >= eof)) { + if (srcStart + srcLen == eof) { /* * EOF character was seen in EOL translated range. Leave current file * position pointing at the EOF character, but don't store the EOF @@ -6158,12 +6291,8 @@ TranslateInputEOL( SetFlag(statePtr, CHANNEL_EOF | CHANNEL_STICKY_EOF); statePtr->inputEncodingFlags |= TCL_ENCODING_END; - ResetFlag(statePtr, INPUT_SAW_CR | INPUT_NEED_NL); - return 1; + ResetFlag(statePtr, INPUT_SAW_CR); } - - *srcLenPtr = srcLen; - return 0; } /* @@ -6217,16 +6346,11 @@ Tcl_Ungets( statePtr->flags = flags; /* - * If we have encountered a sticky EOF, just punt without storing (sticky - * EOF is set if we have seen the input eofChar, to prevent reading beyond - * the eofChar). Otherwise, clear the EOF flags, and clear the BLOCKED - * bit. We want to discover these conditions anew in each operation. + * Clear the EOF flags, and clear the BLOCKED bit. */ - if (GotFlag(statePtr, CHANNEL_STICKY_EOF)) { - goto done; - } - ResetFlag(statePtr, CHANNEL_BLOCKED | CHANNEL_EOF); + ResetFlag(statePtr, + CHANNEL_BLOCKED | CHANNEL_STICKY_EOF | CHANNEL_EOF | INPUT_SAW_CR); bufPtr = AllocChannelBuffer(len); memcpy(InsertPoint(bufPtr), str, (size_t) len); @@ -6291,14 +6415,6 @@ Tcl_Flush( return -1; } - /* - * Force current output buffer to be output also. - */ - - if ((statePtr->curOutPtr != NULL) && IsBufferReady(statePtr->curOutPtr)) { - SetFlag(statePtr, BUFFER_READY); - } - result = FlushChannel(NULL, chanPtr, 0); if (result != 0) { return TCL_ERROR; @@ -6349,7 +6465,7 @@ DiscardInputQueued( */ if (discardSavedBuffers && statePtr->saveInBufPtr != NULL) { - ckfree(statePtr->saveInBufPtr); + ReleaseChannelBuffer(statePtr->saveInBufPtr); statePtr->saveInBufPtr = NULL; } } @@ -6361,6 +6477,9 @@ DiscardInputQueued( * * Reads input data from a device into a channel buffer. * + * IMPORTANT! This routine is only called on a chanPtr argument + * that is the top channel of a stack! + * * Results: * The return value is the Posix error code if an error occurred while * reading from the file, or 0 otherwise. @@ -6393,21 +6512,28 @@ GetInput( return EINVAL; } + /* + * For a channel at EOF do not bother allocating buffers; there's + * nothing more to read. Avoid calling the driver inputproc in + * case some of them do not react well to additional calls after + * they've reported an eof state.. + * TODO: Candidate for a can't happen panic. + */ + + if (GotFlag(statePtr, CHANNEL_EOF)) { + return 0; + } + /* * First check for more buffers in the pushback area of the topmost * channel in the stack and use them. They can be the result of a * transformation which went away without reading all the information * placed in the area when it was stacked. - * - * Two possibilities for the state: No buffers in it, or a single empty - * buffer. In the latter case we can recycle it now. */ if (chanPtr->inQueueHead != NULL) { - if (statePtr->inQueueHead != NULL) { - RecycleBuffer(statePtr, statePtr->inQueueHead, 0); - statePtr->inQueueHead = NULL; - } + + assert(statePtr->inQueueHead == NULL); statePtr->inQueueHead = chanPtr->inQueueHead; statePtr->inQueueTail = chanPtr->inQueueTail; @@ -6428,21 +6554,20 @@ GetInput( */ bufPtr = statePtr->inQueueTail; - if ((bufPtr != NULL) && !IsBufferFull(bufPtr)) { - toRead = SpaceLeft(bufPtr); - } else { + + if ((bufPtr == NULL) || IsBufferFull(bufPtr)) { bufPtr = statePtr->saveInBufPtr; statePtr->saveInBufPtr = NULL; /* * Check the actual buffersize against the requested buffersize. - * Buffers which are smaller than requested are squashed. This is done + * Saved buffers of the wrong size are squashed. This is done * to honor dynamic changes of the buffersize made by the user. */ if ((bufPtr != NULL) - && (bufPtr->bufLength - BUFFER_PADDING < statePtr->bufSize)) { - ckfree(bufPtr); + && (bufPtr->bufLength - BUFFER_PADDING != statePtr->bufSize)) { + ReleaseChannelBuffer(bufPtr); bufPtr = NULL; } @@ -6451,21 +6576,8 @@ GetInput( } bufPtr->nextPtr = NULL; - /* - * SF #427196: Use the actual size of the buffer to determine the - * number of bytes to read from the channel and not the size for new - * buffers. They can be different if the buffersize was changed - * between reads. - * - * Note: This affects performance negatively if the buffersize was - * extended but this small buffer is reused for all subsequent reads. - * The system never uses buffers with the requested bigger size in - * that case. An adjunct patch could try and delete all unused buffers - * it encounters and which are smaller than the formally requested - * buffersize. - */ - toRead = SpaceLeft(bufPtr); + assert(toRead == statePtr->bufSize); if (statePtr->inQueueTail == NULL) { statePtr->inQueueHead = bufPtr; @@ -6473,75 +6585,22 @@ GetInput( statePtr->inQueueTail->nextPtr = bufPtr; } statePtr->inQueueTail = bufPtr; + } else { + toRead = SpaceLeft(bufPtr); } - /* - * If EOF is set, we should avoid calling the driver because on some - * platforms it is impossible to read from a device after EOF. - */ - - if (GotFlag(statePtr, CHANNEL_EOF)) { - return 0; - } - -#ifdef TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING - /* - * [Bug 943274]: Better emulation of non-blocking channels for channels - * without BlockModeProc, by keeping track of true fileevents generated by - * the OS == Data waiting and reading if and only if we are sure to have - * data. - */ - - if (GotFlag(statePtr, CHANNEL_NONBLOCKING) && - (Tcl_ChannelBlockModeProc(chanPtr->typePtr) == NULL) && - !GotFlag(statePtr, CHANNEL_HAS_MORE_DATA)) { - /* - * Bypass the driver, it would block, as no data is available - */ + PreserveChannelBuffer(bufPtr); + nread = ChanRead(chanPtr, InsertPoint(bufPtr), toRead); - nread = -1; - result = EWOULDBLOCK; - } else -#endif /* TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING */ - { - nread = ChanRead(chanPtr, InsertPoint(bufPtr), toRead, &result); - } - - if (nread > 0) { + if (nread < 0) { + result = Tcl_GetErrno(); + } else { + result = 0; bufPtr->nextAdded += nread; - - /* - * If we get a short read, signal up that we may be BLOCKED. We should - * avoid calling the driver because on some platforms we will block in - * the low level reading code even though the channel is set into - * nonblocking mode. - */ - - if (nread < toRead) { - SetFlag(statePtr, CHANNEL_BLOCKED); - } - -#ifdef TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING - if (nread <= toRead) { - /* - * [Bug 943274]: We have read the available data, clear flag. - */ - - ResetFlag(statePtr, CHANNEL_HAS_MORE_DATA); - } -#endif /* TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING */ - } else if (nread == 0) { - SetFlag(statePtr, CHANNEL_EOF); - statePtr->inputEncodingFlags |= TCL_ENCODING_END; - } else if (nread < 0) { - if ((result == EWOULDBLOCK) || (result == EAGAIN)) { - SetFlag(statePtr, CHANNEL_BLOCKED); - result = EAGAIN; - } - Tcl_SetErrno(result); - return result; } - return 0; + + ReleaseChannelBuffer(bufPtr); + return result; } /* @@ -6669,15 +6728,6 @@ Tcl_Seek( } /* - * If there is data buffered in statePtr->curOutPtr then mark the channel - * as ready to flush before invoking FlushChannel. - */ - - if ((statePtr->curOutPtr != NULL) && IsBufferReady(statePtr->curOutPtr)) { - SetFlag(statePtr, BUFFER_READY); - } - - /* * If the flush fails we cannot recover the original position. In that * case the seek is not attempted because we do not know where the access * position is - instead we return the error. FlushChannel has already @@ -7001,17 +7051,7 @@ CheckChannelErrors( } if (direction == TCL_READABLE) { - /* - * If we have not encountered a sticky EOF, clear the EOF bit (sticky - * EOF is set if we have seen the input eofChar, to prevent reading - * beyond the eofChar). Also, always clear the BLOCKED bit. We want to - * discover these conditions anew in each operation. - */ - - if (!GotFlag(statePtr, CHANNEL_STICKY_EOF)) { - ResetFlag(statePtr, CHANNEL_EOF); - } - ResetFlag(statePtr, CHANNEL_BLOCKED | CHANNEL_NEED_MORE_DATA); + ResetFlag(statePtr, CHANNEL_NEED_MORE_DATA); } return 0; @@ -7227,7 +7267,27 @@ Tcl_SetChannelBufferSize( } statePtr = ((Channel *) chan)->state; + + if (statePtr->bufSize == sz) { + return; + } statePtr->bufSize = sz; + + /* + * If bufsize changes, need to get rid of old utility buffer. + */ + + if (statePtr->saveInBufPtr != NULL) { + RecycleBuffer(statePtr, statePtr->saveInBufPtr, 1); + statePtr->saveInBufPtr = NULL; + } + if ((statePtr->inQueueHead != NULL) + && (statePtr->inQueueHead->nextPtr == NULL) + && IsBufferEmpty(statePtr->inQueueHead)) { + RecycleBuffer(statePtr, statePtr->inQueueHead, 1); + statePtr->inQueueHead = NULL; + statePtr->inQueueTail = NULL; + } } /* @@ -7662,6 +7722,7 @@ Tcl_SetChannelOption( return TCL_ERROR; } Tcl_SetChannelBufferSize(chan, newBufferSize); + return TCL_OK; } else if (HaveOpt(2, "-encoding")) { Tcl_Encoding encoding; @@ -7679,7 +7740,8 @@ Tcl_SetChannelOption( * iso2022, the terminated escape sequence must write to the buffer. */ - if ((statePtr->encoding != NULL) && (statePtr->curOutPtr != NULL) + if ((statePtr->encoding != NULL) + && !(statePtr->outputEncodingFlags & TCL_ENCODING_START) && (CheckChannelErrors(statePtr, TCL_WRITABLE) == 0)) { statePtr->outputEncodingFlags |= TCL_ENCODING_END; WriteChars(chanPtr, "", 0); @@ -7692,6 +7754,7 @@ Tcl_SetChannelOption( statePtr->outputEncodingFlags = TCL_ENCODING_START; ResetFlag(statePtr, CHANNEL_NEED_MORE_DATA); UpdateInterest(chanPtr); + return TCL_OK; } else if (HaveOpt(2, "-eofchar")) { if (Tcl_SplitList(interp, newValue, &argc, &argv) == TCL_ERROR) { return TCL_ERROR; @@ -7852,22 +7915,6 @@ Tcl_SetChannelOption( return Tcl_BadChannelOption(interp, optionName, NULL); } - /* - * If bufsize changes, need to get rid of old utility buffer. - */ - - if (statePtr->saveInBufPtr != NULL) { - RecycleBuffer(statePtr, statePtr->saveInBufPtr, 1); - statePtr->saveInBufPtr = NULL; - } - if ((statePtr->inQueueHead != NULL) - && (statePtr->inQueueHead->nextPtr == NULL) - && IsBufferEmpty(statePtr->inQueueHead)) { - RecycleBuffer(statePtr, statePtr->inQueueHead, 1); - statePtr->inQueueHead = NULL; - statePtr->inQueueTail = NULL; - } - return TCL_OK; } @@ -7959,21 +8006,6 @@ Tcl_NotifyChannel( Channel *upChanPtr; const Tcl_ChannelType *upTypePtr; -#ifdef TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING - /* - * [SF Tcl Bug 943274] For a non-blocking channel without blockmodeproc we - * keep track of actual input coming from the OS so that we can do a - * credible imitation of non-blocking behaviour. - */ - - if ((mask & TCL_READABLE) && - GotFlag(statePtr, CHANNEL_NONBLOCKING) && - (Tcl_ChannelBlockModeProc(chanPtr->typePtr) == NULL) && - !GotFlag(statePtr, CHANNEL_TIMER_FEV)) { - SetFlag(statePtr, CHANNEL_HAS_MORE_DATA); - } -#endif /* TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING */ - /* * In contrast to the other API functions this procedure walks towards the * top of a stack and not down from it. @@ -8033,8 +8065,9 @@ Tcl_NotifyChannel( */ if (GotFlag(statePtr, BG_FLUSH_SCHEDULED) && (mask & TCL_WRITABLE)) { - FlushChannel(NULL, chanPtr, 1); - mask &= ~TCL_WRITABLE; + if (0 == FlushChannel(NULL, chanPtr, 1)) { + mask &= ~TCL_WRITABLE; + } } /* @@ -8102,6 +8135,11 @@ UpdateInterest( /* State info for channel */ int mask = statePtr->interestMask; + if (chanPtr->typePtr == NULL) { + /* Do not update interest on a closed channel */ + return; + } + /* * If there are flushed buffers waiting to be written, then we need to * watch for the channel to become writable. @@ -8209,29 +8247,8 @@ ChannelTimerProc( statePtr->timer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME, ChannelTimerProc,chanPtr); - -#ifdef TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING - /* - * Set the TIMER flag to notify the higher levels that the driver - * might have no data for us. We do this only if we are in - * non-blocking mode and the driver has no BlockModeProc because only - * then we really don't know if the driver will block or not. A - * similar test is done in "PeekAhead". - */ - - if (GotFlag(statePtr, CHANNEL_NONBLOCKING) && - (Tcl_ChannelBlockModeProc(chanPtr->typePtr) == NULL)) { - SetFlag(statePtr, CHANNEL_TIMER_FEV); - } -#endif /* TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING */ - Tcl_Preserve(statePtr); Tcl_NotifyChannel((Tcl_Channel) chanPtr, TCL_READABLE); - -#ifdef TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING - ResetFlag(statePtr, CHANNEL_TIMER_FEV); -#endif /* TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING */ - Tcl_Release(statePtr); } else { statePtr->timer = NULL; @@ -9171,12 +9188,23 @@ CopyData( * * DoRead -- * - * Reads a given number of bytes from a channel. No encoding conversions + * Stores up to "bytesToRead" bytes in memory pointed to by "dst". + * These bytes come from reading the channel "chanPtr" and + * performing the configured translations. No encoding conversions * are applied to the bytes being read. * * Results: - * The number of characters read, or -1 on error. Use Tcl_GetErrno() to - * retrieve the error code for the error that occurred. + * The number of bytes actually stored (<= bytesToRead), + * or -1 if there is an error in reading the channel. Use + * Tcl_GetErrno() to retrieve the error code for the error + * that occurred. + * + * The number of bytes stored can be less than the number + * requested when + * - EOF is reached on the channel; or + * - the channel is non-blocking, and we've read all we can + * without blocking. + * - a channel reading error occurs (and we return -1) * * Side effects: * May cause input to be buffered. @@ -9187,382 +9215,152 @@ CopyData( static int DoRead( Channel *chanPtr, /* The channel from which to read. */ - char *bufPtr, /* Where to store input read. */ - int toRead, /* Maximum number of bytes to read. */ + char *dst, /* Where to store input read. */ + int bytesToRead, /* Maximum number of bytes to read. */ int allowShortReads) /* Allow half-blocking (pipes,sockets) */ { ChannelState *statePtr = chanPtr->state; - /* State info for channel */ - int copied; /* How many characters were copied into the - * result string? */ - int copiedNow; /* How many characters were copied from the - * current input buffer? */ - int result; /* Of calling GetInput. */ - - /* - * If we have not encountered a sticky EOF, clear the EOF bit. Either way - * clear the BLOCKED bit. We want to discover these anew during each - * operation. - */ - - if (!GotFlag(statePtr, CHANNEL_STICKY_EOF)) { - ResetFlag(statePtr, CHANNEL_EOF); - } - ResetFlag(statePtr, CHANNEL_BLOCKED | CHANNEL_NEED_MORE_DATA); - - for (copied = 0; copied < toRead; copied += copiedNow) { - copiedNow = CopyAndTranslateBuffer(statePtr, bufPtr + copied, - toRead - copied); - if (copiedNow == 0) { - if (GotFlag(statePtr, CHANNEL_EOF)) { - goto done; - } - if (GotFlag(statePtr, CHANNEL_BLOCKED)) { - if (GotFlag(statePtr, CHANNEL_NONBLOCKING)) { - goto done; - } - ResetFlag(statePtr, CHANNEL_BLOCKED); - } - result = GetInput(chanPtr); - if (result != 0) { - if (result != EAGAIN) { - copied = -1; - } - goto done; - } - } else if (allowShortReads) { - copied += copiedNow; - break; - } - } - - ResetFlag(statePtr, CHANNEL_BLOCKED); - - /* - * Update the notifier state so we don't block while there is still data - * in the buffers. - */ - - done: - UpdateInterest(chanPtr); - return copied; -} - -/* - *---------------------------------------------------------------------- - * - * CopyAndTranslateBuffer -- - * - * Copy at most one buffer of input to the result space, doing eol - * translations according to mode in effect currently. - * - * Results: - * Number of bytes stored in the result buffer (as opposed to the number - * of bytes read from the channel). May return zero if no input is - * available to be translated. - * - * Side effects: - * Consumes buffered input. May deallocate one buffer. - * - *---------------------------------------------------------------------- - */ - -static int -CopyAndTranslateBuffer( - ChannelState *statePtr, /* Channel state from which to read input. */ - char *result, /* Where to store the copied input. */ - int space) /* How many bytes are available in result to - * store the copied input? */ -{ - ChannelBuffer *bufPtr; /* The buffer from which to copy bytes. */ - int bytesInBuffer; /* How many bytes are available to be copied - * in the current input buffer? */ - int copied; /* How many characters were already copied - * into the destination space? */ - int i; /* Iterates over the copied input looking for - * the input eofChar. */ - - /* - * If there is no input at all, return zero. The invariant is that either - * there is no buffer in the queue, or if the first buffer is empty, it is - * also the last buffer (and thus there is no input in the queue). Note - * also that if the buffer is empty, we leave it in the queue. - */ - - if (statePtr->inQueueHead == NULL) { - return 0; - } - bufPtr = statePtr->inQueueHead; - bytesInBuffer = BytesLeft(bufPtr); - - copied = 0; - switch (statePtr->inputTranslation) { - case TCL_TRANSLATE_LF: - if (bytesInBuffer == 0) { - return 0; - } + char *p = dst; + Tcl_Preserve(chanPtr); + while (bytesToRead) { /* - * Copy the current chunk into the result buffer. + * Each pass through the loop is intended to process up to + * one channel buffer. */ - if (bytesInBuffer < space) { - space = bytesInBuffer; - } - memcpy(result, RemovePoint(bufPtr), (size_t) space); - bufPtr->nextRemoved += space; - copied = space; - break; - case TCL_TRANSLATE_CR: { - char *end; - - if (bytesInBuffer == 0) { - return 0; - } + int bytesRead, bytesWritten; + ChannelBuffer *bufPtr = statePtr->inQueueHead; /* - * Copy the current chunk into the result buffer, then replace all \r - * with \n. + * When there's no buffered data to read, and we're at EOF, + * escape to the caller. */ - if (bytesInBuffer < space) { - space = bytesInBuffer; - } - memcpy(result, RemovePoint(bufPtr), (size_t) space); - bufPtr->nextRemoved += space; - copied = space; - - for (end = result + copied; result < end; result++) { - if (*result == '\r') { - *result = '\n'; - } + if (statePtr->flags & CHANNEL_EOF + && (bufPtr == NULL || IsBufferEmpty(bufPtr))) { + break; } - break; - } - case TCL_TRANSLATE_CRLF: { - char *src, *end, *dst; - int curByte; - /* - * If there is a held-back "\r" at EOF, produce it now. - */ + /* If there is no full buffer, attempt to create and/or fill one. */ - if (bytesInBuffer == 0) { - if ((statePtr->flags & (INPUT_SAW_CR | CHANNEL_EOF)) == - (INPUT_SAW_CR | CHANNEL_EOF)) { - result[0] = '\r'; - ResetFlag(statePtr, INPUT_SAW_CR); - return 1; - } - return 0; - } + while (!IsBufferFull(bufPtr)) { + int code; - /* - * Copy the current chunk and replace "\r\n" with "\n" (but not - * standalone "\r"!). - */ + moreData: + code = GetInput(chanPtr); + bufPtr = statePtr->inQueueHead; - if (bytesInBuffer < space) { - space = bytesInBuffer; - } - memcpy(result, RemovePoint(bufPtr), (size_t) space); - bufPtr->nextRemoved += space; - copied = space; + assert (bufPtr != NULL); - end = result + copied; - dst = result; - for (src = result; src < end; src++) { - curByte = *src; - if (curByte == '\n') { - ResetFlag(statePtr, INPUT_SAW_CR); - } else if (GotFlag(statePtr, INPUT_SAW_CR)) { - ResetFlag(statePtr, INPUT_SAW_CR); - *dst = '\r'; - dst++; + if (statePtr->flags & (CHANNEL_EOF|CHANNEL_BLOCKED)) { + /* Further reads cannot do any more */ + break; } - if (curByte == '\r') { - SetFlag(statePtr, INPUT_SAW_CR); - } else { - *dst = (char) curByte; - dst++; + + if (code) { + /* Read error */ + UpdateInterest(chanPtr); + Tcl_Release(chanPtr); + return -1; } - } - copied = dst - result; - break; - } - case TCL_TRANSLATE_AUTO: { - char *src, *end, *dst; - int curByte; - if (bytesInBuffer == 0) { - return 0; + assert (IsBufferFull(bufPtr)); } - /* - * Loop over the current buffer, converting "\r" and "\r\n" to "\n". - */ + assert (bufPtr != NULL); - if (bytesInBuffer < space) { - space = bytesInBuffer; - } - memcpy(result, RemovePoint(bufPtr), (size_t) space); - bufPtr->nextRemoved += space; - copied = space; + bytesRead = BytesLeft(bufPtr); + bytesWritten = bytesToRead; - end = result + copied; - dst = result; - for (src = result; src < end; src++) { - curByte = *src; - if (curByte == '\r') { - SetFlag(statePtr, INPUT_SAW_CR); - *dst = '\n'; - dst++; - } else { - if ((curByte != '\n') || !GotFlag(statePtr, INPUT_SAW_CR)) { - *dst = (char) curByte; - dst++; - } - ResetFlag(statePtr, INPUT_SAW_CR); - } - } - copied = dst - result; - break; - } - default: - Tcl_Panic("unknown eol translation mode"); - } - - /* - * If an in-stream EOF character is set for this channel, check that the - * input we copied so far does not contain the EOF char. If it does, copy - * only up to and excluding that character. - */ + TranslateInputEOL(statePtr, p, RemovePoint(bufPtr), + &bytesWritten, &bytesRead); + bufPtr->nextRemoved += bytesRead; + p += bytesWritten; + bytesToRead -= bytesWritten; - if (statePtr->inEofChar != 0) { - for (i = 0; i < copied; i++) { - if (result[i] == (char) statePtr->inEofChar) { - /* - * Set sticky EOF so that no further input is presented to the - * caller. - */ + if (!IsBufferEmpty(bufPtr)) { + /* + * Buffer is not empty. How can that be? + * + * 0) We stopped early because we got all the bytes + * we were seeking. That's fine. + */ - SetFlag(statePtr, CHANNEL_EOF | CHANNEL_STICKY_EOF); - statePtr->inputEncodingFlags |= TCL_ENCODING_END; - copied = i; + if (bytesToRead == 0) { + UpdateInterest(chanPtr); break; } - } - } - - /* - * If the current buffer is empty recycle it. - */ - - if (IsBufferEmpty(bufPtr)) { - statePtr->inQueueHead = bufPtr->nextPtr; - if (statePtr->inQueueHead == NULL) { - statePtr->inQueueTail = NULL; - } - RecycleBuffer(statePtr, bufPtr, 0); - } - - /* - * Return the number of characters copied into the result buffer. This may - * be different from the number of bytes consumed, because of EOL - * translations. - */ - return copied; -} - -/* - *---------------------------------------------------------------------- - * - * CopyBuffer -- - * - * Copy at most one buffer of input to the result space. - * - * Results: - * Number of bytes stored in the result buffer. May return zero if no - * input is available. - * - * Side effects: - * Consumes buffered input. May deallocate one buffer. - * - *---------------------------------------------------------------------- - */ + /* + * 1) We're @EOF because we saw eof char. + */ -static int -CopyBuffer( - Channel *chanPtr, /* Channel from which to read input. */ - char *result, /* Where to store the copied input. */ - int space) /* How many bytes are available in result to - * store the copied input? */ -{ - ChannelBuffer *bufPtr; /* The buffer from which to copy bytes. */ - int bytesInBuffer; /* How many bytes are available to be copied - * in the current input buffer? */ - int copied; /* How many characters were already copied - * into the destination space? */ + if (statePtr->inEofChar + && RemovePoint(bufPtr)[0] == statePtr->inEofChar) { + UpdateInterest(chanPtr); + break; + } - /* - * If there is no input at all, return zero. The invariant is that either - * there is no buffer in the queue, or if the first buffer is empty, it is - * also the last buffer (and thus there is no input in the queue). Note - * also that if the buffer is empty, we don't leave it in the queue, but - * recycle it. - */ + /* + * 2) The buffer holds a \r while in CRLF translation, + * followed by the end of the buffer. + */ - if (chanPtr->inQueueHead == NULL) { - return 0; - } - bufPtr = chanPtr->inQueueHead; - bytesInBuffer = BytesLeft(bufPtr); + assert(statePtr->inputTranslation == TCL_TRANSLATE_CRLF); + assert(RemovePoint(bufPtr)[0] == '\r'); + assert(BytesLeft(bufPtr) == 1); - copied = 0; + if (bufPtr->nextPtr == NULL) { + /* There's no more buffered data.... */ - if (bytesInBuffer == 0) { - RecycleBuffer(chanPtr->state, bufPtr, 0); - chanPtr->inQueueHead = NULL; - chanPtr->inQueueTail = NULL; - return 0; - } + if (statePtr->flags & CHANNEL_EOF) { + /* ...and there never will be. */ - /* - * Copy the current chunk into the result buffer. - */ + *p++ = '\r'; + bytesToRead--; + bufPtr->nextRemoved++; + } else if (statePtr->flags & CHANNEL_BLOCKED) { + /* ...and we cannot get more now. */ + SetFlag(statePtr, CHANNEL_NEED_MORE_DATA); + UpdateInterest(chanPtr); + break; + } else { + /* ... so we need to get some. */ + goto moreData; + } + } - if (bytesInBuffer < space) { - space = bytesInBuffer; - } + if (bufPtr->nextPtr) { + /* There's a next buffer. Shift orphan \r to it. */ - memcpy(result, RemovePoint(bufPtr), (size_t) space); - bufPtr->nextRemoved += space; - copied = space; + ChannelBuffer *nextPtr = bufPtr->nextPtr; - /* - * We don't care about in-stream EOF characters here as the data read here - * may still flow through one or more transformations, i.e. is not in its - * final state yet. - */ + nextPtr->nextRemoved -= 1; + RemovePoint(nextPtr)[0] = '\r'; + bufPtr->nextRemoved++; + } + } - /* - * If the current buffer is empty recycle it. - */ + if (IsBufferEmpty(bufPtr)) { + statePtr->inQueueHead = bufPtr->nextPtr; + if (statePtr->inQueueHead == NULL) { + statePtr->inQueueTail = NULL; + } + RecycleBuffer(statePtr, bufPtr, 0); + } - if (IsBufferEmpty(bufPtr)) { - chanPtr->inQueueHead = bufPtr->nextPtr; - if (chanPtr->inQueueHead == NULL) { - chanPtr->inQueueTail = NULL; + if ((GotFlag(statePtr, CHANNEL_NONBLOCKING) || allowShortReads) + && GotFlag(statePtr, CHANNEL_BLOCKED)) { + break; } - RecycleBuffer(chanPtr->state, bufPtr, 0); + } + if (bytesToRead == 0) { + ResetFlag(statePtr, CHANNEL_BLOCKED); } - /* - * Return the number of characters copied into the result buffer. - */ - - return copied; + Tcl_Release(chanPtr); + return (int)(p - dst); } /* @@ -9682,12 +9480,15 @@ StackSetBlockMode( { int result = 0; Tcl_DriverBlockModeProc *blockModeProc; + ChannelState *statePtr = chanPtr->state; /* * Start at the top of the channel stack + * TODO: Examine what can go wrong when blockModeProc calls + * disturb the stacking state of the channel. */ - chanPtr = chanPtr->state->topChanPtr; + chanPtr = statePtr->topChanPtr; while (chanPtr != NULL) { blockModeProc = Tcl_ChannelBlockModeProc(chanPtr->typePtr); if (blockModeProc != NULL) { @@ -10826,6 +10627,7 @@ SetChannelFromAny( } if (objPtr->typePtr == &chanObjType) { /* + * TODO: TAINT Flag and dup'd channel values? * The channel is valid until any call to DetachChannel occurs. * Ensure consistency checks are done. */ @@ -10902,20 +10704,14 @@ DumpFlags( ChanFlag('n', CHANNEL_NONBLOCKING); ChanFlag('l', CHANNEL_LINEBUFFERED); ChanFlag('u', CHANNEL_UNBUFFERED); - ChanFlag('R', BUFFER_READY); ChanFlag('F', BG_FLUSH_SCHEDULED); ChanFlag('c', CHANNEL_CLOSED); ChanFlag('E', CHANNEL_EOF); ChanFlag('S', CHANNEL_STICKY_EOF); ChanFlag('B', CHANNEL_BLOCKED); ChanFlag('/', INPUT_SAW_CR); - ChanFlag('*', INPUT_NEED_NL); ChanFlag('D', CHANNEL_DEAD); ChanFlag('R', CHANNEL_RAW_MODE); -#ifdef TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING - ChanFlag('T', CHANNEL_TIMER_FEV); - ChanFlag('H', CHANNEL_HAS_MORE_DATA); -#endif /* TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING */ ChanFlag('x', CHANNEL_INCLOSE); buf[i] ='\0'; diff --git a/generic/tclIO.h b/generic/tclIO.h index e84f300..097cd61 100644 --- a/generic/tclIO.h +++ b/generic/tclIO.h @@ -36,6 +36,7 @@ */ typedef struct ChannelBuffer { + int refCount; /* Current uses count */ int nextAdded; /* The next position into which a character * will be put in the buffer. */ int nextRemoved; /* Position of next byte to be removed from @@ -226,11 +227,6 @@ typedef struct ChannelState { * flushed after every newline. */ #define CHANNEL_UNBUFFERED (1<<5) /* Output to the channel must always * be flushed immediately. */ -#define BUFFER_READY (1<<6) /* Current output buffer (the - * curOutPtr field in the channel - * structure) should be output as soon - * as possible even though it may not - * be full. */ #define BG_FLUSH_SCHEDULED (1<<7) /* A background flush of the queued * output buffers has been * scheduled. */ @@ -252,9 +248,6 @@ typedef struct ChannelState { #define INPUT_SAW_CR (1<<12) /* Channel is in CRLF eol input * translation mode and the last byte * seen was a "\r". */ -#define INPUT_NEED_NL (1<<15) /* Saw a '\r' at end of last buffer, - * and there should be a '\n' at - * beginning of next buffer. */ #define CHANNEL_DEAD (1<<13) /* The channel has been closed by the * exit handler (on exit) but not * deallocated. When any IO operation @@ -274,29 +267,6 @@ typedef struct ChannelState { * changes. */ #define CHANNEL_RAW_MODE (1<<16) /* When set, notes that the Raw API is * being used. */ -#ifdef TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING -#define CHANNEL_TIMER_FEV (1<<17) /* When set the event we are notified - * by is a fileevent generated by a - * timer. We don't know if the driver - * has more data and should not try to - * read from it. If the system needs - * more than is in the buffers out - * read routines will simulate a short - * read (0 characters read) */ -#define CHANNEL_HAS_MORE_DATA (1<<18) /* Set by NotifyChannel for a channel - * if and only if the channel is - * configured non-blocking, the driver - * for said channel has no - * blockmodeproc, and data has arrived - * for reading at the OS level). A - * GetInput will pass reading from the - * driver if the channel is - * non-blocking, without blockmode - * proc and the flag has not been set. - * A read will be performed if the - * flag is set. This will reset the - * flag as well. */ -#endif /* TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING */ #define CHANNEL_INCLOSE (1<<19) /* Channel is currently being closed. * Its structures are still live and diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c index 1673bce..3368a76 100644 --- a/generic/tclIOCmd.c +++ b/generic/tclIOCmd.c @@ -181,6 +181,7 @@ Tcl_PutsObjCmd( return TCL_ERROR; } + Tcl_Preserve(chan); result = Tcl_WriteObj(chan, string); if (result < 0) { goto error; @@ -191,6 +192,7 @@ Tcl_PutsObjCmd( goto error; } } + Tcl_Release(chan); return TCL_OK; /* @@ -205,6 +207,7 @@ Tcl_PutsObjCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf("error writing \"%s\": %s", TclGetString(chanObjPtr), Tcl_PosixError(interp))); } + Tcl_Release(chan); return TCL_ERROR; } @@ -252,6 +255,7 @@ Tcl_FlushObjCmd( return TCL_ERROR; } + Tcl_Preserve(chan); if (Tcl_Flush(chan) != TCL_OK) { /* * TIP #219. @@ -265,8 +269,10 @@ Tcl_FlushObjCmd( "error flushing \"%s\": %s", TclGetString(chanObjPtr), Tcl_PosixError(interp))); } + Tcl_Release(chan); return TCL_ERROR; } + Tcl_Release(chan); return TCL_OK; } @@ -299,6 +305,7 @@ Tcl_GetsObjCmd( int lineLen; /* Length of line just read. */ int mode; /* Mode in which channel is opened. */ Tcl_Obj *linePtr, *chanObjPtr; + int code = TCL_OK; if ((objc != 2) && (objc != 3)) { Tcl_WrongNumArgs(interp, 1, objv, "channelId ?varName?"); @@ -315,6 +322,7 @@ Tcl_GetsObjCmd( return TCL_ERROR; } + Tcl_Preserve(chan); linePtr = Tcl_NewObj(); lineLen = Tcl_GetsObj(chan, linePtr); if (lineLen < 0) { @@ -333,20 +341,24 @@ Tcl_GetsObjCmd( "error reading \"%s\": %s", TclGetString(chanObjPtr), Tcl_PosixError(interp))); } - return TCL_ERROR; + code = TCL_ERROR; + goto done; } lineLen = -1; } if (objc == 3) { if (Tcl_ObjSetVar2(interp, objv[2], NULL, linePtr, TCL_LEAVE_ERR_MSG) == NULL) { - return TCL_ERROR; + code = TCL_ERROR; + goto done; } Tcl_SetObjResult(interp, Tcl_NewIntObj(lineLen)); } else { Tcl_SetObjResult(interp, linePtr); } - return TCL_OK; + done: + Tcl_Release(chan); + return code; } /* @@ -453,6 +465,7 @@ Tcl_ReadObjCmd( resultPtr = Tcl_NewObj(); Tcl_IncrRefCount(resultPtr); + Tcl_Preserve(chan); charactersRead = Tcl_ReadChars(chan, resultPtr, toRead, 0); if (charactersRead < 0) { /* @@ -467,6 +480,7 @@ Tcl_ReadObjCmd( "error reading \"%s\": %s", TclGetString(chanObjPtr), Tcl_PosixError(interp))); } + Tcl_Release(chan); Tcl_DecrRefCount(resultPtr); return TCL_ERROR; } @@ -485,6 +499,7 @@ Tcl_ReadObjCmd( } } Tcl_SetObjResult(interp, resultPtr); + Tcl_Release(chan); Tcl_DecrRefCount(resultPtr); return TCL_OK; } @@ -544,6 +559,7 @@ Tcl_SeekObjCmd( mode = modeArray[optionIndex]; } + Tcl_Preserve(chan); result = Tcl_Seek(chan, offset, mode); if (result == Tcl_LongAsWide(-1)) { /* @@ -558,8 +574,10 @@ Tcl_SeekObjCmd( "error during seek on \"%s\": %s", TclGetString(objv[1]), Tcl_PosixError(interp))); } + Tcl_Release(chan); return TCL_ERROR; } + Tcl_Release(chan); return TCL_OK; } @@ -590,6 +608,7 @@ Tcl_TellObjCmd( { Tcl_Channel chan; /* The channel to tell on. */ Tcl_WideInt newLoc; + int code; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "channelId"); @@ -605,6 +624,7 @@ Tcl_TellObjCmd( return TCL_ERROR; } + Tcl_Preserve(chan); newLoc = Tcl_Tell(chan); /* @@ -613,7 +633,10 @@ Tcl_TellObjCmd( * them into the regular interpreter result. */ - if (TclChanCaughtErrorBypass(interp, chan)) { + + code = TclChanCaughtErrorBypass(interp, chan); + Tcl_Release(chan); + if (code) { return TCL_ERROR; } @@ -896,7 +919,7 @@ Tcl_ExecObjCmd( if (string[0] != '-') { break; } - if (Tcl_GetIndexFromObj(interp, objv[skip], options, "switch", + if (Tcl_GetIndexFromObj(interp, objv[skip], options, "option", TCL_EXACT, &index) != TCL_OK) { return TCL_ERROR; } @@ -910,7 +933,7 @@ Tcl_ExecObjCmd( } } if (objc <= skip) { - Tcl_WrongNumArgs(interp, 1, objv, "?-switch ...? arg ?arg ...?"); + Tcl_WrongNumArgs(interp, 1, objv, "?-option ...? arg ?arg ...?"); return TCL_ERROR; } @@ -1673,7 +1696,7 @@ Tcl_FcopyObjCmd( toRead = -1; cmdPtr = NULL; for (i = 3; i < objc; i += 2) { - if (Tcl_GetIndexFromObj(interp, objv[i], switches, "switch", 0, + if (Tcl_GetIndexFromObj(interp, objv[i], switches, "option", 0, &index) != TCL_OK) { return TCL_ERROR; } diff --git a/generic/tclIOGT.c b/generic/tclIOGT.c index 825f408..9c4347d 100644 --- a/generic/tclIOGT.c +++ b/generic/tclIOGT.c @@ -210,7 +210,27 @@ struct TransformChannelData { * a transformation of incoming data. Also * serves as buffer of all data not yet * consumed by the reader. */ + int refCount; }; + +static void +PreserveData( + TransformChannelData *dataPtr) +{ + dataPtr->refCount++; +} + +static void +ReleaseData( + TransformChannelData *dataPtr) +{ + if (--dataPtr->refCount) { + return; + } + ResultClear(&dataPtr->result); + Tcl_DecrRefCount(dataPtr->command); + ckfree(dataPtr); +} /* *---------------------------------------------------------------------- @@ -240,6 +260,7 @@ TclChannelTransform( Channel *chanPtr; /* The actual channel. */ ChannelState *statePtr; /* State info for channel. */ int mode; /* Read/write mode of the channel. */ + int objc; TransformChannelData *dataPtr; Tcl_DString ds; @@ -247,6 +268,12 @@ TclChannelTransform( return TCL_ERROR; } + if (TCL_OK != Tcl_ListObjLength(interp, cmdObjPtr, &objc)) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("-command value is not a list", -1)); + return TCL_ERROR; + } + chanPtr = (Channel *) chan; statePtr = chanPtr->state; chanPtr = statePtr->topChanPtr; @@ -261,6 +288,7 @@ TclChannelTransform( dataPtr = ckalloc(sizeof(TransformChannelData)); + dataPtr->refCount = 1; Tcl_DStringInit(&ds); Tcl_GetChannelOption(interp, chan, "-blocking", &ds); dataPtr->readIsFlushed = 0; @@ -270,7 +298,6 @@ TclChannelTransform( } Tcl_DStringFree(&ds); - dataPtr->self = chan; dataPtr->watchMask = 0; dataPtr->mode = mode; dataPtr->timer = NULL; @@ -286,19 +313,20 @@ TclChannelTransform( if (dataPtr->self == NULL) { Tcl_AppendPrintfToObj(Tcl_GetObjResult(interp), "\nfailed to stack channel \"%s\"", Tcl_GetChannelName(chan)); - Tcl_DecrRefCount(dataPtr->command); - ResultClear(&dataPtr->result); - ckfree(dataPtr); + ReleaseData(dataPtr); return TCL_ERROR; } + Tcl_Preserve(dataPtr->self); /* * At last initialize the transformation at the script level. */ + PreserveData(dataPtr); if ((dataPtr->mode & TCL_WRITABLE) && ExecuteCallback(dataPtr, NULL, A_CREATE_WRITE, NULL, 0, TRANSMIT_DONT, P_NO_PRESERVE) != TCL_OK){ Tcl_UnstackChannel(interp, chan); + ReleaseData(dataPtr); return TCL_ERROR; } @@ -307,9 +335,11 @@ TclChannelTransform( ExecuteCallback(dataPtr, NULL, A_DELETE_WRITE, NULL, 0, TRANSMIT_DONT, P_NO_PRESERVE); Tcl_UnstackChannel(interp, chan); + ReleaseData(dataPtr); return TCL_ERROR; } + ReleaseData(dataPtr); return TCL_OK; } @@ -350,7 +380,10 @@ ExecuteCallback( unsigned char *resBuf; Tcl_InterpState state = NULL; int res = TCL_OK; - Tcl_Obj *command = Tcl_DuplicateObj(dataPtr->command); + Tcl_Obj *command = TclListObjCopy(NULL, dataPtr->command); + Tcl_Interp *eval = dataPtr->interp; + + Tcl_Preserve(eval); /* * Step 1, create the complete command to execute. Do this by appending @@ -361,26 +394,18 @@ ExecuteCallback( */ if (preserve == P_PRESERVE) { - state = Tcl_SaveInterpState(dataPtr->interp, res); + state = Tcl_SaveInterpState(eval, res); } Tcl_IncrRefCount(command); - res = Tcl_ListObjAppendElement(dataPtr->interp, command, - Tcl_NewStringObj((char *) op, -1)); - if (res != TCL_OK) { - goto cleanup; - } + Tcl_ListObjAppendElement(NULL, command, Tcl_NewStringObj((char *) op, -1)); /* * Use a byte-array to prevent the misinterpretation of binary data coming * through as UTF while at the tcl level. */ - res = Tcl_ListObjAppendElement(dataPtr->interp, command, - Tcl_NewByteArrayObj(buf, bufLen)); - if (res != TCL_OK) { - goto cleanup; - } + Tcl_ListObjAppendElement(NULL, command, Tcl_NewByteArrayObj(buf, bufLen)); /* * Step 2, execute the command at the global level of the interpreter used @@ -390,13 +415,14 @@ ExecuteCallback( * current interpreter. Don't copy if in preservation mode. */ - res = Tcl_EvalObjEx(dataPtr->interp, command, TCL_EVAL_GLOBAL); + res = Tcl_EvalObjEx(eval, command, TCL_EVAL_GLOBAL); Tcl_DecrRefCount(command); command = NULL; - if ((res != TCL_OK) && (interp != NULL) && (dataPtr->interp != interp) + if ((res != TCL_OK) && (interp != NULL) && (eval != interp) && (preserve == P_NO_PRESERVE)) { - Tcl_SetObjResult(interp, Tcl_GetObjResult(dataPtr->interp)); + Tcl_SetObjResult(interp, Tcl_GetObjResult(eval)); + Tcl_Release(eval); return res; } @@ -411,20 +437,26 @@ ExecuteCallback( break; case TRANSMIT_DOWN: - resObj = Tcl_GetObjResult(dataPtr->interp); + if (dataPtr->self == NULL) { + break; + } + resObj = Tcl_GetObjResult(eval); resBuf = Tcl_GetByteArrayFromObj(resObj, &resLen); Tcl_WriteRaw(Tcl_GetStackedChannel(dataPtr->self), (char *) resBuf, resLen); break; case TRANSMIT_SELF: - resObj = Tcl_GetObjResult(dataPtr->interp); + if (dataPtr->self == NULL) { + break; + } + resObj = Tcl_GetObjResult(eval); resBuf = Tcl_GetByteArrayFromObj(resObj, &resLen); Tcl_WriteRaw(dataPtr->self, (char *) resBuf, resLen); break; case TRANSMIT_IBUF: - resObj = Tcl_GetObjResult(dataPtr->interp); + resObj = Tcl_GetObjResult(eval); resBuf = Tcl_GetByteArrayFromObj(resObj, &resLen); ResultAdd(&dataPtr->result, resBuf, resLen); break; @@ -434,24 +466,16 @@ ExecuteCallback( * Interpret result as integer number. */ - resObj = Tcl_GetObjResult(dataPtr->interp); - TclGetIntFromObj(dataPtr->interp, resObj, &dataPtr->maxRead); + resObj = Tcl_GetObjResult(eval); + TclGetIntFromObj(eval, resObj, &dataPtr->maxRead); break; } - Tcl_ResetResult(dataPtr->interp); + Tcl_ResetResult(eval); if (preserve == P_PRESERVE) { - (void) Tcl_RestoreInterpState(dataPtr->interp, state); - } - return res; - - cleanup: - if (preserve == P_PRESERVE) { - (void) Tcl_RestoreInterpState(dataPtr->interp, state); - } - if (command != NULL) { - Tcl_DecrRefCount(command); + (void) Tcl_RestoreInterpState(eval, state); } + Tcl_Release(eval); return res; } @@ -535,6 +559,7 @@ TransformCloseProc( * system rely on (f.e. signaling the close to interested parties). */ + PreserveData(dataPtr); if (dataPtr->mode & TCL_WRITABLE) { ExecuteCallback(dataPtr, interp, A_FLUSH_WRITE, NULL, 0, TRANSMIT_DOWN, P_PRESERVE); @@ -554,14 +579,15 @@ TransformCloseProc( ExecuteCallback(dataPtr, interp, A_DELETE_READ, NULL, 0, TRANSMIT_DONT, P_PRESERVE); } + ReleaseData(dataPtr); /* * General cleanup. */ - ResultClear(&dataPtr->result); - Tcl_DecrRefCount(dataPtr->command); - ckfree(dataPtr); + Tcl_Release(dataPtr->self); + dataPtr->self = NULL; + ReleaseData(dataPtr); return TCL_OK; } @@ -596,7 +622,7 @@ TransformInputProc( * Should assert(dataPtr->mode & TCL_READABLE); */ - if (toRead == 0) { + if (toRead == 0 || dataPtr->self == NULL) { /* * Catch a no-op. */ @@ -606,6 +632,7 @@ TransformInputProc( gotBytes = 0; downChan = Tcl_GetStackedChannel(dataPtr->self); + PreserveData(dataPtr); while (toRead > 0) { /* * Loop until the request is satisfied (or no data is available from @@ -623,7 +650,7 @@ TransformInputProc( * break out of the loop and return to the caller. */ - return gotBytes; + break; } /* @@ -647,7 +674,7 @@ TransformInputProc( } } /* else: 'maxRead < 0' == Accept the current value of toRead. */ if (toRead <= 0) { - return gotBytes; + break; } /* @@ -656,44 +683,40 @@ TransformInputProc( read = Tcl_ReadRaw(downChan, buf, toRead); if (read < 0) { - /* - * Report errors to caller. EAGAIN is a special situation. If we - * had some data before we report that instead of the request to - * re-try. - */ - int error = Tcl_GetErrno(); + if (Tcl_InputBlocked(downChan) && (gotBytes > 0)) { + /* + * Zero bytes available from downChan because blocked. + * But nonzero bytes already copied, so total is a + * valid blocked short read. Return to caller. + */ - if ((error == EAGAIN) && (gotBytes > 0)) { - return gotBytes; + break; } - *errorCodePtr = error; - return -1; - } else if (read == 0) { /* - * Check wether we hit on EOF in the underlying channel or not. If - * not differentiate between blocking and non-blocking modes. In - * non-blocking mode we ran temporarily out of data. Signal this - * to the caller via EWOULDBLOCK and error return (-1). In the - * other cases we simply return what we got and let the caller - * wait for more. On the other hand, if we got an EOF we have to - * convert and flush all waiting partial data. + * Either downChan is not blocked (there's a real error). + * or it is and there are no bytes copied yet. In either + * case we want to pass the "error" along to the caller, + * either to report an error, or to signal to the caller + * that zero bytes are available because blocked. */ - if (!Tcl_Eof(downChan)) { - if ((gotBytes == 0) && (dataPtr->flags & CHANNEL_ASYNC)) { - *errorCodePtr = EWOULDBLOCK; - return -1; - } - return gotBytes; - } + *errorCodePtr = Tcl_GetErrno(); + gotBytes = -1; + break; + } else if (read == 0) { + + /* + * Zero returned from Tcl_ReadRaw() always indicates EOF + * on the down channel. + */ if (dataPtr->readIsFlushed) { /* * Already flushed, nothing to do anymore. */ - return gotBytes; + break; } dataPtr->readIsFlushed = 1; @@ -705,7 +728,7 @@ TransformInputProc( * We had nothing to flush. */ - return gotBytes; + break; } continue; /* at: while (toRead > 0) */ @@ -719,9 +742,11 @@ TransformInputProc( if (ExecuteCallback(dataPtr, NULL, A_READ, UCHARP(buf), read, TRANSMIT_IBUF, P_PRESERVE) != TCL_OK) { *errorCodePtr = EINVAL; - return -1; + gotBytes = -1; + break; } } /* while toRead > 0 */ + ReleaseData(dataPtr); return gotBytes; } @@ -763,11 +788,13 @@ TransformOutputProc( return 0; } + PreserveData(dataPtr); if (ExecuteCallback(dataPtr, NULL, A_WRITE, UCHARP(buf), toWrite, TRANSMIT_DOWN, P_NO_PRESERVE) != TCL_OK) { *errorCodePtr = EINVAL; - return -1; + toWrite = -1; } + ReleaseData(dataPtr); return toWrite; } @@ -820,6 +847,7 @@ TransformSeekProc( * request down, unchanged. */ + PreserveData(dataPtr); if (dataPtr->mode & TCL_WRITABLE) { ExecuteCallback(dataPtr, NULL, A_FLUSH_WRITE, NULL, 0, TRANSMIT_DOWN, P_NO_PRESERVE); @@ -831,6 +859,7 @@ TransformSeekProc( ResultClear(&dataPtr->result); dataPtr->readIsFlushed = 0; } + ReleaseData(dataPtr); return parentSeekProc(Tcl_GetChannelInstanceData(parent), offset, mode, errorCodePtr); @@ -891,6 +920,7 @@ TransformWideSeekProc( * request down, unchanged. */ + PreserveData(dataPtr); if (dataPtr->mode & TCL_WRITABLE) { ExecuteCallback(dataPtr, NULL, A_FLUSH_WRITE, NULL, 0, TRANSMIT_DOWN, P_NO_PRESERVE); @@ -902,6 +932,7 @@ TransformWideSeekProc( ResultClear(&dataPtr->result); dataPtr->readIsFlushed = 0; } + ReleaseData(dataPtr); /* * If we have a wide seek capability, we should stick with that. @@ -1056,6 +1087,9 @@ TransformWatchProc( * unchanged. */ + if (dataPtr->self == NULL) { + return; + } downChan = Tcl_GetStackedChannel(dataPtr->self); Tcl_GetChannelType(downChan)->watchProc( diff --git a/generic/tclIORChan.c b/generic/tclIORChan.c index cb0282a..ff602c6 100644 --- a/generic/tclIORChan.c +++ b/generic/tclIORChan.c @@ -99,31 +99,9 @@ typedef struct { Tcl_ThreadId thread; /* Thread the 'interp' belongs to. == Handler thread */ Tcl_ThreadId owner; /* Thread owning the structure. == Channel thread */ #endif - - /* See [==] as well. - * Storage for the command prefix and the additional words required for - * the invocation of methods in the command handler. - * - * argv [0] ... [.] | [argc-2] [argc-1] | [argc] [argc+2] - * cmd ... pfx | method chan | detail1 detail2 - * ~~~~ CT ~~~ ~~ CT ~~ - * - * CT = Belongs to the 'Command handler Thread'. - */ - - int argc; /* Number of preallocated words - 2 */ - Tcl_Obj **argv; /* Preallocated array for calling the handler. - * args[0] is placeholder for cmd word. - * Followed by the arguments in the prefix, - * plus 4 placeholders for method, channel, - * and at most two varying (method specific) - * words. */ - int methods; /* Bitmask of supported methods */ - - /* - * NOTE (9): Should we have predefined shared literals for the method - * names? - */ + Tcl_Obj *cmd; /* Callback command prefix */ + Tcl_Obj *methods; /* Methods to append to command prefix */ + Tcl_Obj *name; /* Name of the channel as created */ int mode; /* Mask of R/W mode */ int interest; /* Mask of events the channel is interested @@ -450,9 +428,8 @@ static ReflectedChannel * NewReflectedChannel(Tcl_Interp *interp, Tcl_Obj *cmdpfxObj, int mode, Tcl_Obj *handleObj); static Tcl_Obj * NextHandle(void); static void FreeReflectedChannel(ReflectedChannel *rcPtr); -static void FreeReflectedChannelArgs(ReflectedChannel *rcPtr); static int InvokeTclMethod(ReflectedChannel *rcPtr, - const char *method, Tcl_Obj *argOneObj, + MethodName method, Tcl_Obj *argOneObj, Tcl_Obj *argTwoObj, Tcl_Obj **resultObjPtr); static ReflectedChannelMap * GetReflectedChannelMap(Tcl_Interp *interp); @@ -467,16 +444,14 @@ static int ErrnoReturn(ReflectedChannel *rcPtr, Tcl_Obj *resObj); * list-quoting to keep the words of the message together. See also [x]. */ -static const char *msg_read_unsup = "{read not supported by Tcl driver}"; static const char *msg_read_toomuch = "{read delivered more than requested}"; -static const char *msg_write_unsup = "{write not supported by Tcl driver}"; static const char *msg_write_toomuch = "{write wrote more than requested}"; static const char *msg_write_nothing = "{write wrote nothing}"; static const char *msg_seek_beforestart = "{Tried to seek before origin}"; #ifdef TCL_THREADS static const char *msg_send_originlost = "{Channel thread lost}"; -static const char *msg_send_dstlost = "{Owner lost}"; #endif /* TCL_THREADS */ +static const char *msg_send_dstlost = "{Owner lost}"; static const char *msg_dstlost = "-code 1 -level 0 -errorcode NONE -errorinfo {} -errorline 1 {Owner lost}"; /* @@ -583,10 +558,6 @@ TclChanCreateObjCmd( rcId = NextHandle(); rcPtr = NewReflectedChannel(interp, cmdObj, mode, rcId); - chan = Tcl_CreateChannel(&tclRChannelType, TclGetString(rcId), rcPtr, - mode); - rcPtr->chan = chan; - chanPtr = (Channel *) chan; /* * Invoke 'initialize' and validate that the handler is present and ok. @@ -600,7 +571,7 @@ TclChanCreateObjCmd( modeObj = DecodeEventMask(mode); /* assert modeObj.refCount == 1 */ - result = InvokeTclMethod(rcPtr, "initialize", modeObj, NULL, &resObj); + result = InvokeTclMethod(rcPtr, METH_INIT, modeObj, NULL, &resObj); Tcl_DecrRefCount(modeObj); if (result != TCL_OK) { @@ -683,7 +654,11 @@ TclChanCreateObjCmd( * Everything is fine now. */ - rcPtr->methods = methods; + chan = Tcl_CreateChannel(&tclRChannelType, TclGetString(rcId), rcPtr, + mode); + rcPtr->chan = chan; + Tcl_Preserve(chan); + chanPtr = (Channel *) chan; if ((methods & NULLABLE_METHODS) != NULLABLE_METHODS) { /* @@ -744,12 +719,10 @@ TclChanCreateObjCmd( return TCL_OK; error: - /* - * Signal to ReflectClose to not call 'finalize'. - */ - - rcPtr->methods = 0; - Tcl_Close(interp, chan); + Tcl_DecrRefCount(rcPtr->name); + Tcl_DecrRefCount(rcPtr->methods); + Tcl_DecrRefCount(rcPtr->cmd); + ckfree((char*) rcPtr); return TCL_ERROR; #undef MODE @@ -1138,6 +1111,7 @@ ReflectClose( ReflectedChannelMap *rcmPtr;/* Map of reflected channels with handlers in * this interp */ Tcl_HashEntry *hPtr; /* Entry in the above map */ + const Tcl_ChannelType *tctPtr; if (TclInThreadExit()) { /* @@ -1172,21 +1146,15 @@ ReflectClose( if (result != TCL_OK) { FreeReceivedError(&p); } + return EOK; } #endif - Tcl_EventuallyFree(rcPtr, (Tcl_FreeProc *) FreeReflectedChannel); - return EOK; - } - - /* - * -- No -- ASSERT rcPtr->methods & FLAG(METH_FINAL) - * - * A cleaned method mask here implies that the channel creation was - * aborted, and "finalize" must not be called. - */ - - if (rcPtr->methods == 0) { + tctPtr = ((Channel *)rcPtr->chan)->typePtr; + if (tctPtr && tctPtr != &tclRChannelType) { + ckfree((char *)tctPtr); + ((Channel *)rcPtr->chan)->typePtr = NULL; + } Tcl_EventuallyFree(rcPtr, (Tcl_FreeProc *) FreeReflectedChannel); return EOK; } @@ -1208,14 +1176,12 @@ ReflectClose( Tcl_DeleteEvents(ReflectEventDelete, rcPtr); - Tcl_EventuallyFree(rcPtr, (Tcl_FreeProc *) FreeReflectedChannel); - if (result != TCL_OK) { PassReceivedErrorInterp(interp, &p); } } else { #endif - result = InvokeTclMethod(rcPtr, "finalize", NULL, NULL, &resObj); + result = InvokeTclMethod(rcPtr, METH_FINAL, NULL, NULL, &resObj); if ((result != TCL_OK) && (interp != NULL)) { Tcl_SetChannelErrorInterp(interp, resObj); } @@ -1253,6 +1219,11 @@ ReflectClose( } #endif + tctPtr = ((Channel *)rcPtr->chan)->typePtr; + if (tctPtr && tctPtr != &tclRChannelType) { + ckfree((char *)tctPtr); + ((Channel *)rcPtr->chan)->typePtr = NULL; + } Tcl_EventuallyFree(rcPtr, (Tcl_FreeProc *) FreeReflectedChannel); #ifdef TCL_THREADS } @@ -1290,18 +1261,6 @@ ReflectInput( Tcl_Obj *resObj; /* Result data for 'read' */ /* - * The following check can be done before thread redirection, because we - * are reading from an item which is readonly, i.e. will never change - * during the lifetime of the channel. - */ - - if (!(rcPtr->methods & FLAG(METH_READ))) { - SetChannelErrorStr(rcPtr->chan, msg_read_unsup); - *errorCodePtr = EINVAL; - return -1; - } - - /* * Are we in the correct thread? */ @@ -1339,7 +1298,7 @@ ReflectInput( toReadObj = Tcl_NewIntObj(toRead); Tcl_IncrRefCount(toReadObj); - if (InvokeTclMethod(rcPtr, "read", toReadObj, NULL, &resObj)!=TCL_OK) { + if (InvokeTclMethod(rcPtr, METH_READ, toReadObj, NULL, &resObj)!=TCL_OK) { int code = ErrnoReturn(rcPtr, resObj); if (code < 0) { @@ -1405,18 +1364,6 @@ ReflectOutput( int written; /* - * The following check can be done before thread redirection, because we - * are reading from an item which is readonly, i.e. will never change - * during the lifetime of the channel. - */ - - if (!(rcPtr->methods & FLAG(METH_WRITE))) { - SetChannelErrorStr(rcPtr->chan, msg_write_unsup); - *errorCodePtr = EINVAL; - return -1; - } - - /* * Are we in the correct thread? */ @@ -1450,11 +1397,12 @@ ReflectOutput( /* ASSERT: rcPtr->mode & TCL_WRITABLE */ Tcl_Preserve(rcPtr); + Tcl_Preserve(rcPtr->interp); bufObj = Tcl_NewByteArrayObj((unsigned char *) buf, toWrite); Tcl_IncrRefCount(bufObj); - if (InvokeTclMethod(rcPtr, "write", bufObj, NULL, &resObj) != TCL_OK) { + if (InvokeTclMethod(rcPtr, METH_WRITE, bufObj, NULL, &resObj) != TCL_OK) { int code = ErrnoReturn(rcPtr, resObj); if (code < 0) { @@ -1466,6 +1414,14 @@ ReflectOutput( goto invalid; } + if (Tcl_InterpDeleted(rcPtr->interp)) { + /* + * The interp was destroyed during InvokeTclMethod(). + */ + + SetChannelErrorStr(rcPtr->chan, msg_send_dstlost); + goto invalid; + } if (Tcl_GetIntFromObj(rcPtr->interp, resObj, &written) != TCL_OK) { Tcl_SetChannelError(rcPtr->chan, MarshallError(rcPtr->interp)); goto invalid; @@ -1495,6 +1451,7 @@ ReflectOutput( stop: Tcl_DecrRefCount(bufObj); Tcl_DecrRefCount(resObj); /* Remove reference held from invoke */ + Tcl_Release(rcPtr->interp); Tcl_Release(rcPtr); return written; invalid: @@ -1568,7 +1525,7 @@ ReflectSeekWide( Tcl_IncrRefCount(offObj); Tcl_IncrRefCount(baseObj); - if (InvokeTclMethod(rcPtr, "seek", offObj, baseObj, &resObj) != TCL_OK) { + if (InvokeTclMethod(rcPtr, METH_SEEK, offObj, baseObj, &resObj)!=TCL_OK) { Tcl_SetChannelError(rcPtr->chan, resObj); goto invalid; } @@ -1639,8 +1596,6 @@ ReflectWatch( ReflectedChannel *rcPtr = clientData; Tcl_Obj *maskObj; - /* ASSERT rcPtr->methods & FLAG(METH_WATCH) */ - /* * We restrict the interest to what the channel can support. IOW there * will never be write events for a channel which is not writable. @@ -1683,7 +1638,7 @@ ReflectWatch( maskObj = DecodeEventMask(mask); /* assert maskObj.refCount == 1 */ - (void) InvokeTclMethod(rcPtr, "watch", maskObj, NULL, NULL); + (void) InvokeTclMethod(rcPtr, METH_WATCH, maskObj, NULL, NULL); Tcl_DecrRefCount(maskObj); Tcl_Release(rcPtr); @@ -1742,7 +1697,7 @@ ReflectBlock( Tcl_Preserve(rcPtr); - if (InvokeTclMethod(rcPtr, "blocking", blockObj, NULL, &resObj)!=TCL_OK) { + if (InvokeTclMethod(rcPtr,METH_BLOCKING,blockObj,NULL,&resObj)!=TCL_OK) { Tcl_SetChannelError(rcPtr->chan, resObj); errorNum = EINVAL; } else { @@ -1854,7 +1809,7 @@ ReflectSetOption( Tcl_IncrRefCount(optionObj); Tcl_IncrRefCount(valueObj); - result = InvokeTclMethod(rcPtr, "configure",optionObj,valueObj, &resObj); + result = InvokeTclMethod(rcPtr, METH_CONFIGURE,optionObj,valueObj, &resObj); if (result != TCL_OK) { UnmarshallErrorResult(interp, resObj); } @@ -1899,7 +1854,7 @@ ReflectGetOption( Tcl_Obj *resObj; /* Result data for 'configure' */ int listc, result = TCL_OK; Tcl_Obj **listv; - const char *method; + MethodName method; /* * Are we in the correct thread? @@ -1938,14 +1893,14 @@ ReflectGetOption( * Retrieve all options. */ - method = "cgetall"; + method = METH_CGETALL; optionObj = NULL; } else { /* * Retrieve the value of one option. */ - method = "cget"; + method = METH_CGET; optionObj = Tcl_NewStringObj(optionName, -1); Tcl_IncrRefCount(optionObj); } @@ -2159,16 +2114,13 @@ NewReflectedChannel( Tcl_Obj *handleObj) { ReflectedChannel *rcPtr; - int i, listc; - Tcl_Obj **listv; + MethodName mn = METH_BLOCKING; rcPtr = ckalloc(sizeof(ReflectedChannel)); /* rcPtr->chan: Assigned by caller. Dummy data here. */ - /* rcPtr->methods: Assigned by caller. Dummy data here. */ rcPtr->chan = NULL; - rcPtr->methods = 0; rcPtr->interp = interp; rcPtr->dead = 0; #ifdef TCL_THREADS @@ -2177,54 +2129,17 @@ NewReflectedChannel( rcPtr->mode = mode; rcPtr->interest = 0; /* Initially no interest registered */ - /* - * Method placeholder. - */ - /* ASSERT: cmdpfxObj is a Tcl List */ - - Tcl_ListObjGetElements(interp, cmdpfxObj, &listc, &listv); - - /* - * See [==] as well. - * Storage for the command prefix and the additional words required for - * the invocation of methods in the command handler. - * - * listv [0] [listc-1] | [listc] [listc+1] | - * argv [0] ... [.] | [argc-2] [argc-1] | [argc] [argc+2] - * cmd ... pfx | method chan | detail1 detail2 - */ - - rcPtr->argc = listc + 2; - rcPtr->argv = ckalloc(sizeof(Tcl_Obj *) * (listc+4)); - - /* - * Duplicate object references. - */ - - for (i=0; i<listc ; i++) { - Tcl_Obj *word = rcPtr->argv[i] = listv[i]; - - Tcl_IncrRefCount(word); - } - - i++; /* Skip placeholder for method */ - - /* - * [Bug 1667990]: See [x] in FreeReflectedChannel for release - */ - - rcPtr->argv[i] = handleObj; - Tcl_IncrRefCount(handleObj); - - /* - * The next two objects are kept empty, varying arguments. - */ - - /* - * Initialization complete. - */ - + rcPtr->cmd = TclListObjCopy(NULL, cmdpfxObj); + Tcl_IncrRefCount(rcPtr->cmd); + rcPtr->methods = Tcl_NewListObj(METH_WRITE + 1, NULL); + while (mn <= METH_WRITE) { + Tcl_ListObjAppendElement(NULL, rcPtr->methods, + Tcl_NewStringObj(methodNames[mn++], -1)); + } + Tcl_IncrRefCount(rcPtr->methods); + rcPtr->name = handleObj; + Tcl_IncrRefCount(rcPtr->name); return rcPtr; } @@ -2271,45 +2186,15 @@ NextHandle(void) } static void -FreeReflectedChannelArgs( - ReflectedChannel *rcPtr) -{ - int i, n = rcPtr->argc - 2; - - if (n < 0) { - return; - } - for (i=0; i<n; i++) { - Tcl_DecrRefCount(rcPtr->argv[i]); - } - - /* - * [Bug 1667990]: See [x] in NewReflectedChannel for lock. n+1 = argc-1. - */ - - 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); - chanPtr->typePtr = NULL; - } - - FreeReflectedChannelArgs(rcPtr); - - ckfree(rcPtr->argv); + Tcl_Release(chanPtr); + Tcl_DecrRefCount(rcPtr->name); + Tcl_DecrRefCount(rcPtr->methods); + Tcl_DecrRefCount(rcPtr->cmd); ckfree(rcPtr); } @@ -2340,16 +2225,16 @@ FreeReflectedChannel( static int InvokeTclMethod( ReflectedChannel *rcPtr, - const char *method, + MethodName method, Tcl_Obj *argOneObj, /* NULL'able */ Tcl_Obj *argTwoObj, /* NULL'able */ Tcl_Obj **resultObjPtr) /* NULL'able */ { - int cmdc; /* #words in constructed command */ Tcl_Obj *methObj = NULL; /* Method name in object form */ Tcl_InterpState sr; /* State of handler interp */ int result; /* Result code of method invokation */ Tcl_Obj *resObj = NULL; /* Result of method invokation. */ + Tcl_Obj *cmd; if (rcPtr->dead) { /* @@ -2372,19 +2257,15 @@ InvokeTclMethod( } /* - * NOTE (5): Decide impl. issue: Cache objects with method names? Needs - * TSD data as reflections can be created in many different threads. - * NO: Caching of command resolutions means storage per channel. - */ - - /* - * Insert method into the pre-allocated area, after the command prefix, + * Insert method into the callback command, after the command prefix, * before the channel id. */ - methObj = Tcl_NewStringObj(method, -1); - Tcl_IncrRefCount(methObj); - rcPtr->argv[rcPtr->argc - 2] = methObj; + cmd = TclListObjCopy(NULL, rcPtr->cmd); + + Tcl_ListObjIndex(NULL, rcPtr->methods, method, &methObj); + Tcl_ListObjAppendElement(NULL, cmd, methObj); + Tcl_ListObjAppendElement(NULL, cmd, rcPtr->name); /* * Append the additional argument containing method specific details @@ -2394,13 +2275,10 @@ InvokeTclMethod( * The objects will survive the Tcl_EvalObjv without change. */ - cmdc = rcPtr->argc; if (argOneObj) { - rcPtr->argv[cmdc] = argOneObj; - cmdc++; + Tcl_ListObjAppendElement(NULL, cmd, argOneObj); if (argTwoObj) { - rcPtr->argv[cmdc] = argTwoObj; - cmdc++; + Tcl_ListObjAppendElement(NULL, cmd, argTwoObj); } } @@ -2409,9 +2287,10 @@ InvokeTclMethod( * existing state intact. */ + Tcl_IncrRefCount(cmd); sr = Tcl_SaveInterpState(rcPtr->interp, 0 /* Dummy */); Tcl_Preserve(rcPtr->interp); - result = Tcl_EvalObjv(rcPtr->interp, cmdc, rcPtr->argv, TCL_EVAL_GLOBAL); + result = Tcl_EvalObjEx(rcPtr->interp, cmd, TCL_EVAL_GLOBAL); /* * We do not try to extract the result information if the caller has no @@ -2437,7 +2316,6 @@ InvokeTclMethod( */ if (result != TCL_ERROR) { - Tcl_Obj *cmd = Tcl_NewListObj(cmdc, rcPtr->argv); int cmdLen; const char *cmdString = Tcl_GetStringFromObj(cmd, &cmdLen); @@ -2451,25 +2329,17 @@ InvokeTclMethod( result = TCL_ERROR; } Tcl_AppendObjToErrorInfo(rcPtr->interp, Tcl_ObjPrintf( - "\n (chan handler subcommand \"%s\")", method)); + "\n (chan handler subcommand \"%s\")", + methodNames[method])); resObj = MarshallError(rcPtr->interp); } Tcl_IncrRefCount(resObj); } + Tcl_DecrRefCount(cmd); Tcl_RestoreInterpState(rcPtr->interp, sr); Tcl_Release(rcPtr->interp); /* - * Cleanup of the dynamic parts of the command. - * - * The detail objects survived the Tcl_EvalObjv without change because of - * the contract. Therefore there is no need to decrement the refcounts. Only - * the internal method object has to be disposed of. - */ - - Tcl_DecrRefCount(methObj); - - /* * The resObj has a ref count of 1 at this location. This means that the * caller of InvokeTclMethod has to dispose of it (but only if it was * returned to it). @@ -2657,6 +2527,11 @@ DeleteReflectedChannelMap( /* * The receiver for the event exited, before processing the event. We * detach the result now, wake the originator up and signal failure. + * + * Attention: Results may have been detached already, by either the + * receiver, or this thread, as part of other parts in the thread + * teardown. Such results are ignored. See ticket [b47b176adf] for the + * identical race condition in Tcl 8.6 IORTrans. */ evPtr = resultPtr->evPtr; @@ -2666,6 +2541,9 @@ DeleteReflectedChannelMap( continue; } paramPtr = evPtr->param; + if (!evPtr) { + continue; + } evPtr->resultPtr = NULL; resultPtr->evPtr = NULL; @@ -2700,7 +2578,6 @@ DeleteReflectedChannelMap( } rcPtr->dead = 1; - FreeReflectedChannelArgs(rcPtr); Tcl_DeleteHashEntry(hPtr); } #endif @@ -2797,6 +2674,11 @@ DeleteThreadReflectedChannelMap( /* * The receiver for the event exited, before processing the event. We * detach the result now, wake the originator up and signal failure. + * + * Attention: Results may have been detached already, by either the + * receiver, or this thread, as part of other parts in the thread + * teardown. Such results are ignored. See ticket [b47b176adf] for the + * identical race condition in Tcl 8.6 IORTrans. */ evPtr = resultPtr->evPtr; @@ -2806,6 +2688,9 @@ DeleteThreadReflectedChannelMap( continue; } paramPtr = evPtr->param; + if (!evPtr) { + continue; + } evPtr->resultPtr = NULL; resultPtr->evPtr = NULL; @@ -2840,7 +2725,6 @@ DeleteThreadReflectedChannelMap( ReflectedChannel *rcPtr = Tcl_GetChannelInstanceData(chan); rcPtr->dead = 1; - FreeReflectedChannelArgs(rcPtr); Tcl_DeleteHashEntry(hPtr); } ckfree(rcmPtr); @@ -3018,17 +2902,19 @@ ForwardProc( * call upon for the driver. */ - case ForwardedClose: + case ForwardedClose: { /* * No parameters/results. */ - if (InvokeTclMethod(rcPtr, "finalize", NULL, NULL, &resObj)!=TCL_OK) { + const Tcl_ChannelType *tctPtr; + + if (InvokeTclMethod(rcPtr, METH_FINAL, NULL, NULL, &resObj)!=TCL_OK) { ForwardSetObjError(paramPtr, resObj); } /* - * Freeing is done here, in the origin thread, because the argv[] + * Freeing is done here, in the origin thread, callback command * objects belong to this thread. Deallocating them in a different * thread is not allowed * @@ -3047,15 +2933,21 @@ ForwardProc( Tcl_GetChannelName(rcPtr->chan)); Tcl_DeleteHashEntry(hPtr); - FreeReflectedChannelArgs(rcPtr); + tctPtr = ((Channel *)rcPtr->chan)->typePtr; + if (tctPtr && tctPtr != &tclRChannelType) { + ckfree((char *)tctPtr); + ((Channel *)rcPtr->chan)->typePtr = NULL; + } + Tcl_EventuallyFree(rcPtr, (Tcl_FreeProc *) FreeReflectedChannel); break; + } case ForwardedInput: { Tcl_Obj *toReadObj = Tcl_NewIntObj(paramPtr->input.toRead); Tcl_IncrRefCount(toReadObj); Tcl_Preserve(rcPtr); - if (InvokeTclMethod(rcPtr, "read", toReadObj, NULL, &resObj)!=TCL_OK){ + if (InvokeTclMethod(rcPtr, METH_READ, toReadObj, NULL, &resObj)!=TCL_OK){ int code = ErrnoReturn(rcPtr, resObj); if (code < 0) { @@ -3095,7 +2987,7 @@ ForwardProc( Tcl_IncrRefCount(bufObj); Tcl_Preserve(rcPtr); - if (InvokeTclMethod(rcPtr, "write", bufObj, NULL, &resObj) != TCL_OK) { + if (InvokeTclMethod(rcPtr, METH_WRITE, bufObj, NULL, &resObj) != TCL_OK) { int code = ErrnoReturn(rcPtr, resObj); if (code < 0) { @@ -3138,7 +3030,7 @@ ForwardProc( Tcl_IncrRefCount(baseObj); Tcl_Preserve(rcPtr); - if (InvokeTclMethod(rcPtr, "seek", offObj, baseObj, &resObj)!=TCL_OK){ + if (InvokeTclMethod(rcPtr, METH_SEEK, offObj, baseObj, &resObj)!=TCL_OK){ ForwardSetObjError(paramPtr, resObj); paramPtr->seek.offset = -1; } else { @@ -3174,7 +3066,7 @@ ForwardProc( /* assert maskObj.refCount == 1 */ Tcl_Preserve(rcPtr); - (void) InvokeTclMethod(rcPtr, "watch", maskObj, NULL, NULL); + (void) InvokeTclMethod(rcPtr, METH_WATCH, maskObj, NULL, NULL); Tcl_DecrRefCount(maskObj); Tcl_Release(rcPtr); break; @@ -3185,7 +3077,7 @@ ForwardProc( Tcl_IncrRefCount(blockObj); Tcl_Preserve(rcPtr); - if (InvokeTclMethod(rcPtr, "blocking", blockObj, NULL, + if (InvokeTclMethod(rcPtr, METH_BLOCKING, blockObj, NULL, &resObj) != TCL_OK) { ForwardSetObjError(paramPtr, resObj); } @@ -3201,7 +3093,7 @@ ForwardProc( Tcl_IncrRefCount(optionObj); Tcl_IncrRefCount(valueObj); Tcl_Preserve(rcPtr); - if (InvokeTclMethod(rcPtr, "configure", optionObj, valueObj, + if (InvokeTclMethod(rcPtr, METH_CONFIGURE, optionObj, valueObj, &resObj) != TCL_OK) { ForwardSetObjError(paramPtr, resObj); } @@ -3220,7 +3112,7 @@ ForwardProc( Tcl_IncrRefCount(optionObj); Tcl_Preserve(rcPtr); - if (InvokeTclMethod(rcPtr, "cget", optionObj, NULL, &resObj)!=TCL_OK){ + if (InvokeTclMethod(rcPtr, METH_CGET, optionObj, NULL, &resObj)!=TCL_OK){ ForwardSetObjError(paramPtr, resObj); } else { TclDStringAppendObj(paramPtr->getOpt.value, resObj); @@ -3236,7 +3128,7 @@ ForwardProc( */ Tcl_Preserve(rcPtr); - if (InvokeTclMethod(rcPtr, "cgetall", NULL, NULL, &resObj) != TCL_OK){ + if (InvokeTclMethod(rcPtr, METH_CGETALL, NULL, NULL, &resObj) != TCL_OK){ ForwardSetObjError(paramPtr, resObj); } else { /* diff --git a/generic/tclIORTrans.c b/generic/tclIORTrans.c index 1de635f..d2707a1 100644 --- a/generic/tclIORTrans.c +++ b/generic/tclIORTrans.c @@ -457,8 +457,7 @@ static void TimerKill(ReflectedTransform *rtPtr); static void TimerSetup(ReflectedTransform *rtPtr); static void TimerRun(ClientData clientData); static int TransformRead(ReflectedTransform *rtPtr, - int *errorCodePtr, unsigned char *buf, - int toRead); + int *errorCodePtr, Tcl_Obj *bufObj); static int TransformWrite(ReflectedTransform *rtPtr, int *errorCodePtr, unsigned char *buf, int toWrite); @@ -1063,6 +1062,7 @@ ReflectInput( { ReflectedTransform *rtPtr = clientData; int gotBytes, copied, readBytes; + Tcl_Obj *bufObj; /* * The following check can be done before thread redirection, because we @@ -1078,6 +1078,9 @@ ReflectInput( Tcl_Preserve(rtPtr); + /* TODO: Consider a more appropriate buffer size. */ + bufObj = Tcl_NewByteArrayObj(NULL, toRead); + Tcl_IncrRefCount(bufObj); gotBytes = 0; while (toRead > 0) { /* @@ -1129,52 +1132,40 @@ ReflectInput( goto stop; } - readBytes = Tcl_ReadRaw(rtPtr->parent, buf, toRead); + + readBytes = Tcl_ReadRaw(rtPtr->parent, + (char *) Tcl_SetByteArrayLength(bufObj, toRead), toRead); if (readBytes < 0) { - /* - * Report errors to caller. The state of the seek system is - * unchanged! - */ + if (Tcl_InputBlocked(rtPtr->parent) && (gotBytes > 0)) { - if ((Tcl_GetErrno() == EAGAIN) && (gotBytes > 0)) { /* - * EAGAIN is a special situation. If we had some data before - * we report that instead of the request to re-try. + * Down channel is blocked and offers zero additional bytes. + * The nonzero gotBytes already returned makes the total + * operation a valid short read. Return to caller. */ goto stop; } + /* + * Either the down channel is not blocked (a real error) + * or it is and there are gotBytes==0 byte copied so far. + * In either case, pass up the error, so we either report + * any real error, or do not mistakenly signal EOF by + * returning 0 to the caller. + */ + *errorCodePtr = Tcl_GetErrno(); goto error; } if (readBytes == 0) { + /* - * Check wether we hit on EOF in 'parent' or not. If not - * differentiate between blocking and non-blocking modes. In - * non-blocking mode we ran temporarily out of data. Signal this - * to the caller via EWOULDBLOCK and error return (-1). In the - * other cases we simply return what we got and let the caller - * wait for more. On the other hand, if we got an EOF we have to - * convert and flush all waiting partial data. + * Zero returned from Tcl_ReadRaw() always indicates EOF + * on the down channel. */ - - if (!Tcl_Eof(rtPtr->parent)) { - /* - * The state of the seek system is unchanged! - */ - - if ((gotBytes == 0) && rtPtr->nonblocking) { - *errorCodePtr = EWOULDBLOCK; - goto error; - } - goto stop; - } else { - /* - * Eof in parent. - */ - + if (rtPtr->readIsDrained) { goto stop; } @@ -1198,13 +1189,7 @@ ReflectInput( goto stop; } - /* - * Reset eof, force caller to drain result buffer. - */ - - ((Channel *) rtPtr->parent)->state->flags &= ~CHANNEL_EOF; continue; /* at: while (toRead > 0) */ - } } /* readBytes == 0 */ /* @@ -1213,12 +1198,20 @@ ReflectInput( * iteration will put it into the result. */ - if (!TransformRead(rtPtr, errorCodePtr, UCHARP(buf), readBytes)) { + Tcl_SetByteArrayLength(bufObj, readBytes); + if (!TransformRead(rtPtr, errorCodePtr, bufObj)) { goto error; } + if (Tcl_IsShared(bufObj)) { + Tcl_DecrRefCount(bufObj); + bufObj = Tcl_NewObj(); + Tcl_IncrRefCount(bufObj); + } + Tcl_SetByteArrayLength(bufObj, 0); } /* while toRead > 0 */ stop: + Tcl_DecrRefCount(bufObj); Tcl_Release(rtPtr); return gotBytes; @@ -2010,6 +2003,7 @@ InvokeTclMethod( sr = Tcl_SaveInterpState(rtPtr->interp, 0 /* Dummy */); Tcl_Preserve(rtPtr); + Tcl_Preserve(rtPtr->interp); result = Tcl_EvalObjv(rtPtr->interp, cmdc, rtPtr->argv, TCL_EVAL_GLOBAL); /* @@ -2054,6 +2048,7 @@ InvokeTclMethod( Tcl_IncrRefCount(resObj); } Tcl_RestoreInterpState(rtPtr->interp, sr); + Tcl_Release(rtPtr->interp); Tcl_Release(rtPtr); /* @@ -2230,6 +2225,9 @@ DeleteReflectedTransformMap( */ evPtr = resultPtr->evPtr; + if (evPtr == NULL) { + continue; + } paramPtr = evPtr->param; evPtr->resultPtr = NULL; @@ -2355,6 +2353,9 @@ DeleteThreadReflectedTransformMap( */ evPtr = resultPtr->evPtr; + if (evPtr == NULL) { + continue; + } paramPtr = evPtr->param; evPtr->resultPtr = NULL; @@ -3065,10 +3066,8 @@ static int TransformRead( ReflectedTransform *rtPtr, int *errorCodePtr, - unsigned char *buf, - int toRead) + Tcl_Obj *bufObj) { - Tcl_Obj *bufObj; Tcl_Obj *resObj; int bytec; /* Number of returned bytes */ unsigned char *bytev; /* Array of returned bytes */ @@ -3081,8 +3080,8 @@ TransformRead( if (rtPtr->thread != Tcl_GetCurrentThread()) { ForwardParam p; - p.transform.buf = (char *) buf; - p.transform.size = toRead; + p.transform.buf = (char *) Tcl_GetByteArrayFromObj(bufObj, + &(p.transform.size)); ForwardOpToOwnerThread(rtPtr, ForwardedInput, &p); @@ -3102,12 +3101,8 @@ TransformRead( /* ASSERT: rtPtr->method & FLAG(METH_READ) */ /* ASSERT: rtPtr->mode & TCL_READABLE */ - bufObj = Tcl_NewByteArrayObj((unsigned char *) buf, toRead); - Tcl_IncrRefCount(bufObj); - if (InvokeTclMethod(rtPtr, "read", bufObj, NULL, &resObj) != TCL_OK) { Tcl_SetChannelError(rtPtr->chan, resObj); - Tcl_DecrRefCount(bufObj); Tcl_DecrRefCount(resObj); /* Remove reference held from invoke */ *errorCodePtr = EINVAL; return 0; @@ -3116,7 +3111,6 @@ TransformRead( bytev = Tcl_GetByteArrayFromObj(resObj, &bytec); ResultAdd(&rtPtr->result, bytev, bytec); - Tcl_DecrRefCount(bufObj); Tcl_DecrRefCount(resObj); /* Remove reference held from invoke */ return 1; } diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c index 6259216..d2919fc 100644 --- a/generic/tclIOUtil.c +++ b/generic/tclIOUtil.c @@ -19,11 +19,17 @@ */ #include "tclInt.h" -#ifdef __WIN32__ +#ifdef _WIN32 # include "tclWinInt.h" #endif #include "tclFileSystem.h" +#ifdef TCL_TEMPLOAD_NO_UNLINK +#ifndef NO_FSTATFS +#include <sys/statfs.h> +#endif +#endif + /* * struct FilesystemRecord -- * @@ -792,7 +798,7 @@ TclFinalizeFilesystem(void) * filesystem is likely to fail. */ -#ifdef __WIN32__ +#ifdef _WIN32 TclWinEncodingsCleanup(); #endif } @@ -819,7 +825,7 @@ TclResetFilesystem(void) filesystemList = &nativeFilesystemRecord; theFilesystemEpoch++; -#ifdef __WIN32__ +#ifdef _WIN32 /* * Cleans up the win32 API filesystem proc lookup table. This must happen * very late in finalization so that deleting of copied dlls can occur. @@ -3110,6 +3116,82 @@ Tcl_FSLoadFile( *---------------------------------------------------------------------- */ +/* + * Workaround for issue with modern HPUX which do allow the unlink (no ETXTBSY + * error) yet somehow trash some internal data structures which prevents the + * second and further shared libraries from getting properly loaded. Only the + * first is ok. We try to get around the issue by not unlinking, + * i.e. emulating the behaviour of the older HPUX which denied removal. + * + * Doing the unlink is also an issue within docker containers, whose AUFS + * bungles this as well, see + * https://github.com/dotcloud/docker/issues/1911 + * + * For these situations the change below makes the execution of the unlink + * semi-controllable at runtime. + * + * An AUFS filesystem (if it can be detected) will force avoidance of + * unlink. The env variable TCL_TEMPLOAD_NO_UNLINK allows detection of a + * users general request (unlink and not. + * + * By default the unlink is done (if not in AUFS). However if the variable is + * present and set to true (any integer > 0) then the unlink is skipped. + */ + +int +TclSkipUnlink (Tcl_Obj* shlibFile) +{ + /* Order of testing: + * 1. On hpux we generally want to skip unlink in general + * + * Outside of hpux then: + * 2. For a general user request (TCL_TEMPLOAD_NO_UNLINK present, non-empty, => int) + * 3. For general AUFS environment (statfs, if available). + * + * Ad 2: This variable can disable/override the AUFS detection, i.e. for + * testing if a newer AUFS does not have the bug any more. + * + * Ad 3: This is conditionally compiled in. Condition currently must be set manually. + * This part needs proper tests in the configure(.in). + */ + +#ifdef hpux + return 1; +#else + char* skipstr; + + skipstr = getenv ("TCL_TEMPLOAD_NO_UNLINK"); + if (skipstr && (skipstr[0] != '\0')) { + return atoi(skipstr); + } + +#ifdef TCL_TEMPLOAD_NO_UNLINK +#ifndef NO_FSTATFS + { + struct statfs fs; + /* Have fstatfs. May not have the AUFS super magic ... Indeed our build + * box is too old to have it directly in the headers. Define taken from + * http://mooon.googlecode.com/svn/trunk/linux_include/linux/aufs_type.h + * http://aufs.sourceforge.net/ + * Better reference will be gladly taken. + */ +#ifndef AUFS_SUPER_MAGIC +#define AUFS_SUPER_MAGIC ('a' << 24 | 'u' << 16 | 'f' << 8 | 's') +#endif /* AUFS_SUPER_MAGIC */ + if ((statfs(Tcl_GetString (shlibFile), &fs) == 0) && + (fs.f_type == AUFS_SUPER_MAGIC)) { + return 1; + } + } +#endif /* ... NO_FSTATFS */ +#endif /* ... TCL_TEMPLOAD_NO_UNLINK */ + + /* Fallback: !hpux, no EV override, no AUFS (detection, nor detected): + * Don't skip */ + return 0; +#endif /* hpux */ +} + int Tcl_LoadFile( Tcl_Interp *interp, /* Used for error reporting. */ @@ -3255,7 +3337,7 @@ Tcl_LoadFile( return TCL_ERROR; } -#ifndef __WIN32__ +#ifndef _WIN32 /* * Do we need to set appropriate permissions on the file? This may be * required on some systems. On Unix we could loop over the file @@ -3300,7 +3382,9 @@ Tcl_LoadFile( * avoids any worries about leaving the copy laying around on exit. */ - if (Tcl_FSDeleteFile(copyToPtr) == TCL_OK) { + if ( + !TclSkipUnlink (copyToPtr) && + (Tcl_FSDeleteFile(copyToPtr) == TCL_OK)) { Tcl_DecrRefCount(copyToPtr); /* diff --git a/generic/tclInt.h b/generic/tclInt.h index 2aa1725..9a2e8dd 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2453,6 +2453,30 @@ typedef struct List { #endif /* + * Macro used to save a function call for common uses of + * Tcl_GetWideIntFromObj(). The ANSI C "prototype" is: + * + * MODULE_SCOPE int TclGetWideIntFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, + * Tcl_WideInt *wideIntPtr); + */ + +#ifdef TCL_WIDE_INT_IS_LONG +#define TclGetWideIntFromObj(interp, objPtr, wideIntPtr) \ + (((objPtr)->typePtr == &tclIntType) \ + ? (*(wideIntPtr) = (Tcl_WideInt) \ + ((objPtr)->internalRep.longValue), TCL_OK) : \ + Tcl_GetWideIntFromObj((interp), (objPtr), (wideIntPtr))) +#else /* !TCL_WIDE_INT_IS_LONG */ +#define TclGetWideIntFromObj(interp, objPtr, wideIntPtr) \ + (((objPtr)->typePtr == &tclWideIntType) \ + ? (*(wideIntPtr) = (objPtr)->internalRep.wideValue, TCL_OK) : \ + ((objPtr)->typePtr == &tclIntType) \ + ? (*(wideIntPtr) = (Tcl_WideInt) \ + ((objPtr)->internalRep.longValue), TCL_OK) : \ + Tcl_GetWideIntFromObj((interp), (objPtr), (wideIntPtr))) +#endif /* TCL_WIDE_INT_IS_LONG */ + +/* * Flag values for TclTraceDictPath(). * * DICT_PATH_READ indicates that all entries on the path must exist but no @@ -2857,6 +2881,10 @@ MODULE_SCOPE void TclContinuationsCopy(Tcl_Obj *objPtr, MODULE_SCOPE int TclConvertElement(const char *src, int length, char *dst, int flags); MODULE_SCOPE void TclDeleteNamespaceVars(Namespace *nsPtr); +MODULE_SCOPE int TclFindDictElement(Tcl_Interp *interp, + const char *dict, int dictLength, + const char **elementPtr, const char **nextPtr, + int *sizePtr, int *literalPtr); /* TIP #280 - Modified token based evulation, with line information. */ MODULE_SCOPE int TclEvalEx(Tcl_Interp *interp, const char *script, int numBytes, int flags, int line, @@ -2896,6 +2924,7 @@ MODULE_SCOPE void TclFinalizeObjects(void); MODULE_SCOPE void TclFinalizePreserve(void); MODULE_SCOPE void TclFinalizeSynchronization(void); MODULE_SCOPE void TclFinalizeThreadAlloc(void); +MODULE_SCOPE void TclFinalizeThreadAllocThread(void); MODULE_SCOPE void TclFinalizeThreadData(void); MODULE_SCOPE void TclFinalizeThreadObjects(void); MODULE_SCOPE double TclFloor(const mp_int *a); @@ -2921,6 +2950,8 @@ MODULE_SCOPE int TclGetOpenModeEx(Tcl_Interp *interp, MODULE_SCOPE Tcl_Obj * TclGetProcessGlobalValue(ProcessGlobalValue *pgvPtr); MODULE_SCOPE Tcl_Obj * TclGetSourceFromFrame(CmdFrame *cfPtr, int objc, Tcl_Obj *const objv[]); +MODULE_SCOPE char * TclGetStringStorage(Tcl_Obj *objPtr, + unsigned int *sizePtr); MODULE_SCOPE int TclGlob(Tcl_Interp *interp, char *pattern, Tcl_Obj *unquotedPrefix, int globFlags, Tcl_GlobTypeData *types); diff --git a/generic/tclIntPlatDecls.h b/generic/tclIntPlatDecls.h index 72719fe..ac06787 100644 --- a/generic/tclIntPlatDecls.h +++ b/generic/tclIntPlatDecls.h @@ -13,7 +13,7 @@ #ifndef _TCLINTPLATDECLS #define _TCLINTPLATDECLS -#ifdef __WIN32__ +#ifdef _WIN32 # define Tcl_DirEntry void # define DIR void #endif @@ -45,7 +45,7 @@ extern "C" { * Exported function declarations: */ -#if !defined(__WIN32__) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */ +#if !defined(_WIN32) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */ /* 0 */ EXTERN void TclGetAndDetachPids(Tcl_Interp *interp, Tcl_Channel chan); @@ -104,7 +104,7 @@ EXTERN int TclUnixOpenTemporaryFile(Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj); #endif /* UNIX */ -#if defined(__WIN32__) || defined(__CYGWIN__) /* WIN */ +#if defined(_WIN32) || defined(__CYGWIN__) /* WIN */ /* 0 */ EXTERN void TclWinConvertError(DWORD errCode); /* 1 */ @@ -258,7 +258,7 @@ typedef struct TclIntPlatStubs { int magic; void *hooks; -#if !defined(__WIN32__) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */ +#if !defined(_WIN32) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */ void (*tclGetAndDetachPids) (Tcl_Interp *interp, Tcl_Channel chan); /* 0 */ int (*tclpCloseFile) (TclFile file); /* 1 */ Tcl_Channel (*tclpCreateCommandChannel) (TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); /* 2 */ @@ -291,7 +291,7 @@ typedef struct TclIntPlatStubs { int (*tclWinCPUID) (unsigned int index, unsigned int *regs); /* 29 */ int (*tclUnixOpenTemporaryFile) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj); /* 30 */ #endif /* UNIX */ -#if defined(__WIN32__) || defined(__CYGWIN__) /* WIN */ +#if defined(_WIN32) || defined(__CYGWIN__) /* WIN */ void (*tclWinConvertError) (DWORD errCode); /* 0 */ void (*tclWinConvertWSAError) (DWORD errCode); /* 1 */ struct servent * (*tclWinGetServByName) (const char *nm, const char *proto); /* 2 */ @@ -371,7 +371,7 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr; * Inline function declarations: */ -#if !defined(__WIN32__) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */ +#if !defined(_WIN32) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */ #define TclGetAndDetachPids \ (tclIntPlatStubsPtr->tclGetAndDetachPids) /* 0 */ #define TclpCloseFile \ @@ -420,7 +420,7 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr; #define TclUnixOpenTemporaryFile \ (tclIntPlatStubsPtr->tclUnixOpenTemporaryFile) /* 30 */ #endif /* UNIX */ -#if defined(__WIN32__) || defined(__CYGWIN__) /* WIN */ +#if defined(_WIN32) || defined(__CYGWIN__) /* WIN */ #define TclWinConvertError \ (tclIntPlatStubsPtr->tclWinConvertError) /* 0 */ #define TclWinConvertWSAError \ @@ -550,9 +550,15 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr; #undef TclpInetNtoa #define TclpInetNtoa inet_ntoa -#if defined(__WIN32__) || defined(__CYGWIN__) +#if defined(_WIN32) # undef TclWinNToHS +# undef TclWinGetServByName +# undef TclWinGetSockOpt +# undef TclWinSetSockOpt # define TclWinNToHS ntohs +# define TclWinGetServByName getservbyname +# define TclWinGetSockOpt getsockopt +# define TclWinSetSockOpt setsockopt #else # undef TclpGetPid # define TclpGetPid(pid) ((unsigned long) (pid)) diff --git a/generic/tclLoad.c b/generic/tclLoad.c index 5cacab1..7c70e03 100644 --- a/generic/tclLoad.c +++ b/generic/tclLoad.c @@ -830,7 +830,7 @@ Tcl_UnloadObjCmd( * Unload the shared library from the application memory... */ -#if defined(TCL_UNLOAD_DLLS) || defined(__WIN32__) +#if defined(TCL_UNLOAD_DLLS) || defined(_WIN32) /* * Some Unix dlls are poorly behaved - registering things like atexit * calls that can't be unregistered. If you unload such dlls, you get @@ -1151,7 +1151,7 @@ TclFinalizeLoad(void) pkgPtr = firstPackagePtr; firstPackagePtr = pkgPtr->nextPtr; -#if defined(TCL_UNLOAD_DLLS) || defined(__WIN32__) +#if defined(TCL_UNLOAD_DLLS) || defined(_WIN32) /* * Some Unix dlls are poorly behaved - registering things like atexit * calls that can't be unregistered. If you unload such dlls, you get diff --git a/generic/tclMain.c b/generic/tclMain.c index faea75a..360f5e9 100644 --- a/generic/tclMain.c +++ b/generic/tclMain.c @@ -47,7 +47,7 @@ * we have to translate that to strcmp here. */ -#ifndef __WIN32__ +#ifndef _WIN32 # define TCHAR char # define TEXT(arg) arg # define _tcscmp strcmp diff --git a/generic/tclOO.decls b/generic/tclOO.decls index 5d6f2c2..265ba88 100644 --- a/generic/tclOO.decls +++ b/generic/tclOO.decls @@ -18,6 +18,7 @@ library tclOO interface tclOO hooks tclOOInt +scspec TCLAPI declare 0 { Tcl_Object Tcl_CopyObjectInstance(Tcl_Interp *interp, diff --git a/generic/tclOODecls.h b/generic/tclOODecls.h index d3b9e59..9fd62ec 100644 --- a/generic/tclOODecls.h +++ b/generic/tclOODecls.h @@ -5,19 +5,19 @@ #ifndef _TCLOODECLS #define _TCLOODECLS -#undef TCL_STORAGE_CLASS -#ifdef BUILD_tcl -# define TCL_STORAGE_CLASS DLLEXPORT -#else -# ifdef USE_TCL_STUBS -# undef USE_TCLOO_STUBS -# define USE_TCLOO_STUBS -# define TCL_STORAGE_CLASS +#ifndef TCLAPI +# ifdef BUILD_tcl +# define TCLAPI extern DLLEXPORT # else -# define TCL_STORAGE_CLASS DLLIMPORT +# define TCLAPI extern DLLIMPORT # endif #endif +#ifdef USE_TCL_STUBS +# undef USE_TCLOO_STUBS +# define USE_TCLOO_STUBS +#endif + /* !BEGIN!: Do not edit below this line. */ #ifdef __cplusplus @@ -29,92 +29,92 @@ extern "C" { */ /* 0 */ -EXTERN Tcl_Object Tcl_CopyObjectInstance(Tcl_Interp *interp, +TCLAPI Tcl_Object Tcl_CopyObjectInstance(Tcl_Interp *interp, Tcl_Object sourceObject, const char *targetName, const char *targetNamespaceName); /* 1 */ -EXTERN Tcl_Object Tcl_GetClassAsObject(Tcl_Class clazz); +TCLAPI Tcl_Object Tcl_GetClassAsObject(Tcl_Class clazz); /* 2 */ -EXTERN Tcl_Class Tcl_GetObjectAsClass(Tcl_Object object); +TCLAPI Tcl_Class Tcl_GetObjectAsClass(Tcl_Object object); /* 3 */ -EXTERN Tcl_Command Tcl_GetObjectCommand(Tcl_Object object); +TCLAPI Tcl_Command Tcl_GetObjectCommand(Tcl_Object object); /* 4 */ -EXTERN Tcl_Object Tcl_GetObjectFromObj(Tcl_Interp *interp, +TCLAPI Tcl_Object Tcl_GetObjectFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr); /* 5 */ -EXTERN Tcl_Namespace * Tcl_GetObjectNamespace(Tcl_Object object); +TCLAPI Tcl_Namespace * Tcl_GetObjectNamespace(Tcl_Object object); /* 6 */ -EXTERN Tcl_Class Tcl_MethodDeclarerClass(Tcl_Method method); +TCLAPI Tcl_Class Tcl_MethodDeclarerClass(Tcl_Method method); /* 7 */ -EXTERN Tcl_Object Tcl_MethodDeclarerObject(Tcl_Method method); +TCLAPI Tcl_Object Tcl_MethodDeclarerObject(Tcl_Method method); /* 8 */ -EXTERN int Tcl_MethodIsPublic(Tcl_Method method); +TCLAPI int Tcl_MethodIsPublic(Tcl_Method method); /* 9 */ -EXTERN int Tcl_MethodIsType(Tcl_Method method, +TCLAPI int Tcl_MethodIsType(Tcl_Method method, const Tcl_MethodType *typePtr, ClientData *clientDataPtr); /* 10 */ -EXTERN Tcl_Obj * Tcl_MethodName(Tcl_Method method); +TCLAPI Tcl_Obj * Tcl_MethodName(Tcl_Method method); /* 11 */ -EXTERN Tcl_Method Tcl_NewInstanceMethod(Tcl_Interp *interp, +TCLAPI Tcl_Method Tcl_NewInstanceMethod(Tcl_Interp *interp, Tcl_Object object, Tcl_Obj *nameObj, int isPublic, const Tcl_MethodType *typePtr, ClientData clientData); /* 12 */ -EXTERN Tcl_Method Tcl_NewMethod(Tcl_Interp *interp, Tcl_Class cls, +TCLAPI Tcl_Method Tcl_NewMethod(Tcl_Interp *interp, Tcl_Class cls, Tcl_Obj *nameObj, int isPublic, const Tcl_MethodType *typePtr, ClientData clientData); /* 13 */ -EXTERN Tcl_Object Tcl_NewObjectInstance(Tcl_Interp *interp, +TCLAPI Tcl_Object Tcl_NewObjectInstance(Tcl_Interp *interp, Tcl_Class cls, const char *nameStr, const char *nsNameStr, int objc, Tcl_Obj *const *objv, int skip); /* 14 */ -EXTERN int Tcl_ObjectDeleted(Tcl_Object object); +TCLAPI int Tcl_ObjectDeleted(Tcl_Object object); /* 15 */ -EXTERN int Tcl_ObjectContextIsFiltering( +TCLAPI int Tcl_ObjectContextIsFiltering( Tcl_ObjectContext context); /* 16 */ -EXTERN Tcl_Method Tcl_ObjectContextMethod(Tcl_ObjectContext context); +TCLAPI Tcl_Method Tcl_ObjectContextMethod(Tcl_ObjectContext context); /* 17 */ -EXTERN Tcl_Object Tcl_ObjectContextObject(Tcl_ObjectContext context); +TCLAPI Tcl_Object Tcl_ObjectContextObject(Tcl_ObjectContext context); /* 18 */ -EXTERN int Tcl_ObjectContextSkippedArgs( +TCLAPI int Tcl_ObjectContextSkippedArgs( Tcl_ObjectContext context); /* 19 */ -EXTERN ClientData Tcl_ClassGetMetadata(Tcl_Class clazz, +TCLAPI ClientData Tcl_ClassGetMetadata(Tcl_Class clazz, const Tcl_ObjectMetadataType *typePtr); /* 20 */ -EXTERN void Tcl_ClassSetMetadata(Tcl_Class clazz, +TCLAPI void Tcl_ClassSetMetadata(Tcl_Class clazz, const Tcl_ObjectMetadataType *typePtr, ClientData metadata); /* 21 */ -EXTERN ClientData Tcl_ObjectGetMetadata(Tcl_Object object, +TCLAPI ClientData Tcl_ObjectGetMetadata(Tcl_Object object, const Tcl_ObjectMetadataType *typePtr); /* 22 */ -EXTERN void Tcl_ObjectSetMetadata(Tcl_Object object, +TCLAPI void Tcl_ObjectSetMetadata(Tcl_Object object, const Tcl_ObjectMetadataType *typePtr, ClientData metadata); /* 23 */ -EXTERN int Tcl_ObjectContextInvokeNext(Tcl_Interp *interp, +TCLAPI int Tcl_ObjectContextInvokeNext(Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv, int skip); /* 24 */ -EXTERN Tcl_ObjectMapMethodNameProc * Tcl_ObjectGetMethodNameMapper( +TCLAPI Tcl_ObjectMapMethodNameProc * Tcl_ObjectGetMethodNameMapper( Tcl_Object object); /* 25 */ -EXTERN void Tcl_ObjectSetMethodNameMapper(Tcl_Object object, +TCLAPI void Tcl_ObjectSetMethodNameMapper(Tcl_Object object, Tcl_ObjectMapMethodNameProc *mapMethodNameProc); /* 26 */ -EXTERN void Tcl_ClassSetConstructor(Tcl_Interp *interp, +TCLAPI void Tcl_ClassSetConstructor(Tcl_Interp *interp, Tcl_Class clazz, Tcl_Method method); /* 27 */ -EXTERN void Tcl_ClassSetDestructor(Tcl_Interp *interp, +TCLAPI void Tcl_ClassSetDestructor(Tcl_Interp *interp, Tcl_Class clazz, Tcl_Method method); /* 28 */ -EXTERN Tcl_Obj * Tcl_GetObjectName(Tcl_Interp *interp, +TCLAPI Tcl_Obj * Tcl_GetObjectName(Tcl_Interp *interp, Tcl_Object object); typedef struct { @@ -231,6 +231,4 @@ extern const TclOOStubs *tclOOStubsPtr; /* !END!: Do not edit above this line. */ -#undef TCL_STORAGE_CLASS -#define TCL_STORAGE_CLASS DLLIMPORT #endif /* _TCLOODECLS */ diff --git a/generic/tclOOIntDecls.h b/generic/tclOOIntDecls.h index 4f70e5b..74a8d81 100644 --- a/generic/tclOOIntDecls.h +++ b/generic/tclOOIntDecls.h @@ -5,17 +5,6 @@ #ifndef _TCLOOINTDECLS #define _TCLOOINTDECLS -#undef TCL_STORAGE_CLASS -#ifdef BUILD_tcl -# define TCL_STORAGE_CLASS DLLEXPORT -#else -# ifdef USE_TCL_STUBS -# define TCL_STORAGE_CLASS -# else -# define TCL_STORAGE_CLASS DLLIMPORT -# endif -#endif - /* !BEGIN!: Do not edit below this line. */ #ifdef __cplusplus @@ -27,46 +16,46 @@ extern "C" { */ /* 0 */ -EXTERN Tcl_Object TclOOGetDefineCmdContext(Tcl_Interp *interp); +TCLAPI Tcl_Object TclOOGetDefineCmdContext(Tcl_Interp *interp); /* 1 */ -EXTERN Tcl_Method TclOOMakeProcInstanceMethod(Tcl_Interp *interp, +TCLAPI Tcl_Method TclOOMakeProcInstanceMethod(Tcl_Interp *interp, Object *oPtr, int flags, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, const Tcl_MethodType *typePtr, ClientData clientData, Proc **procPtrPtr); /* 2 */ -EXTERN Tcl_Method TclOOMakeProcMethod(Tcl_Interp *interp, +TCLAPI Tcl_Method TclOOMakeProcMethod(Tcl_Interp *interp, Class *clsPtr, int flags, Tcl_Obj *nameObj, const char *namePtr, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, const Tcl_MethodType *typePtr, ClientData clientData, Proc **procPtrPtr); /* 3 */ -EXTERN Method * TclOONewProcInstanceMethod(Tcl_Interp *interp, +TCLAPI Method * TclOONewProcInstanceMethod(Tcl_Interp *interp, Object *oPtr, int flags, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, ProcedureMethod **pmPtrPtr); /* 4 */ -EXTERN Method * TclOONewProcMethod(Tcl_Interp *interp, Class *clsPtr, +TCLAPI Method * TclOONewProcMethod(Tcl_Interp *interp, Class *clsPtr, int flags, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, ProcedureMethod **pmPtrPtr); /* 5 */ -EXTERN int TclOOObjectCmdCore(Object *oPtr, Tcl_Interp *interp, +TCLAPI int TclOOObjectCmdCore(Object *oPtr, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv, int publicOnly, Class *startCls); /* 6 */ -EXTERN int TclOOIsReachable(Class *targetPtr, Class *startPtr); +TCLAPI int TclOOIsReachable(Class *targetPtr, Class *startPtr); /* 7 */ -EXTERN Method * TclOONewForwardMethod(Tcl_Interp *interp, +TCLAPI Method * TclOONewForwardMethod(Tcl_Interp *interp, Class *clsPtr, int isPublic, Tcl_Obj *nameObj, Tcl_Obj *prefixObj); /* 8 */ -EXTERN Method * TclOONewForwardInstanceMethod(Tcl_Interp *interp, +TCLAPI Method * TclOONewForwardInstanceMethod(Tcl_Interp *interp, Object *oPtr, int isPublic, Tcl_Obj *nameObj, Tcl_Obj *prefixObj); /* 9 */ -EXTERN Tcl_Method TclOONewProcInstanceMethodEx(Tcl_Interp *interp, +TCLAPI Tcl_Method TclOONewProcInstanceMethodEx(Tcl_Interp *interp, Tcl_Object oPtr, TclOO_PreCallProc *preCallPtr, TclOO_PostCallProc *postCallPtr, @@ -75,7 +64,7 @@ EXTERN Tcl_Method TclOONewProcInstanceMethodEx(Tcl_Interp *interp, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, int flags, void **internalTokenPtr); /* 10 */ -EXTERN Tcl_Method TclOONewProcMethodEx(Tcl_Interp *interp, +TCLAPI Tcl_Method TclOONewProcMethodEx(Tcl_Interp *interp, Tcl_Class clsPtr, TclOO_PreCallProc *preCallPtr, TclOO_PostCallProc *postCallPtr, @@ -84,22 +73,22 @@ EXTERN Tcl_Method TclOONewProcMethodEx(Tcl_Interp *interp, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, int flags, void **internalTokenPtr); /* 11 */ -EXTERN int TclOOInvokeObject(Tcl_Interp *interp, +TCLAPI int TclOOInvokeObject(Tcl_Interp *interp, Tcl_Object object, Tcl_Class startCls, int publicPrivate, int objc, Tcl_Obj *const *objv); /* 12 */ -EXTERN void TclOOObjectSetFilters(Object *oPtr, int numFilters, +TCLAPI void TclOOObjectSetFilters(Object *oPtr, int numFilters, Tcl_Obj *const *filters); /* 13 */ -EXTERN void TclOOClassSetFilters(Tcl_Interp *interp, +TCLAPI void TclOOClassSetFilters(Tcl_Interp *interp, Class *classPtr, int numFilters, Tcl_Obj *const *filters); /* 14 */ -EXTERN void TclOOObjectSetMixins(Object *oPtr, int numMixins, +TCLAPI void TclOOObjectSetMixins(Object *oPtr, int numMixins, Class *const *mixins); /* 15 */ -EXTERN void TclOOClassSetMixins(Tcl_Interp *interp, +TCLAPI void TclOOClassSetMixins(Tcl_Interp *interp, Class *classPtr, int numMixins, Class *const *mixins); @@ -174,6 +163,4 @@ extern const TclOOIntStubs *tclOOIntStubsPtr; /* !END!: Do not edit above this line. */ -#undef TCL_STORAGE_CLASS -#define TCL_STORAGE_CLASS DLLIMPORT #endif /* _TCLOOINTDECLS */ diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c index b7f3dcf..fe6063f 100644 --- a/generic/tclPathObj.c +++ b/generic/tclPathObj.c @@ -512,7 +512,7 @@ TclFSGetPathType( if (PATHFLAGS(pathPtr) == 0) { /* The path is not absolute... */ -#ifdef __WIN32__ +#ifdef _WIN32 /* ... on Windows we must make another call to determine whether * it's relative or volumerelative [Bug 2571597]. */ return TclGetPathType(pathPtr, filesystemPtrPtr, driveNameLengthPtr, @@ -1956,7 +1956,7 @@ Tcl_FSGetNormalizedPath( /* * We have a refCount on the cwd. */ -#ifdef __WIN32__ +#ifdef _WIN32 } else if (type == TCL_PATH_VOLUME_RELATIVE) { /* * Only Windows has volume-relative paths. @@ -1969,7 +1969,7 @@ Tcl_FSGetNormalizedPath( return NULL; } pureNormalized = 0; -#endif /* __WIN32__ */ +#endif /* _WIN32 */ } } diff --git a/generic/tclPlatDecls.h b/generic/tclPlatDecls.h index 681854d..abc8ee8 100644 --- a/generic/tclPlatDecls.h +++ b/generic/tclPlatDecls.h @@ -50,7 +50,7 @@ extern "C" { * Exported function declarations: */ -#if defined(__WIN32__) || defined(__CYGWIN__) /* WIN */ +#if defined(_WIN32) || defined(__CYGWIN__) /* WIN */ /* 0 */ EXTERN TCHAR * Tcl_WinUtfToTChar(const char *str, int len, Tcl_DString *dsPtr); @@ -75,7 +75,7 @@ typedef struct TclPlatStubs { int magic; void *hooks; -#if defined(__WIN32__) || defined(__CYGWIN__) /* WIN */ +#if defined(_WIN32) || defined(__CYGWIN__) /* WIN */ TCHAR * (*tcl_WinUtfToTChar) (const char *str, int len, Tcl_DString *dsPtr); /* 0 */ char * (*tcl_WinTCharToUtf) (const TCHAR *str, int len, Tcl_DString *dsPtr); /* 1 */ #endif /* WIN */ @@ -97,7 +97,7 @@ extern const TclPlatStubs *tclPlatStubsPtr; * Inline function declarations: */ -#if defined(__WIN32__) || defined(__CYGWIN__) /* WIN */ +#if defined(_WIN32) || defined(__CYGWIN__) /* WIN */ #define Tcl_WinUtfToTChar \ (tclPlatStubsPtr->tcl_WinUtfToTChar) /* 0 */ #define Tcl_WinTCharToUtf \ diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index dffa38c..c04944d 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -1123,7 +1123,8 @@ Tcl_AppendLimitedToObj( if (ellipsis == NULL) { ellipsis = "..."; } - toCopy = Tcl_UtfPrev(bytes+limit+1-strlen(ellipsis), bytes) - bytes; + toCopy = (bytes == NULL) ? limit + : Tcl_UtfPrev(bytes+limit+1-strlen(ellipsis), bytes) - bytes; } /* @@ -1435,7 +1436,7 @@ AppendUnicodeToUnicodeRep( * the reallocs below. */ - if (unicode >= stringPtr->unicode + if (unicode && unicode >= stringPtr->unicode && unicode <= stringPtr->unicode + stringPtr->maxChars) { offset = unicode - stringPtr->unicode; } @@ -1457,8 +1458,10 @@ AppendUnicodeToUnicodeRep( * trailing null. */ - memmove(stringPtr->unicode + stringPtr->numChars, unicode, - appendNumChars * sizeof(Tcl_UniChar)); + if (unicode) { + memmove(stringPtr->unicode + stringPtr->numChars, unicode, + appendNumChars * sizeof(Tcl_UniChar)); + } stringPtr->unicode[numChars] = 0; stringPtr->numChars = numChars; stringPtr->allocated = 0; @@ -1597,7 +1600,7 @@ AppendUtfToUtfRep( * the reallocs below. */ - if (bytes >= objPtr->bytes + if (bytes && bytes >= objPtr->bytes && bytes <= objPtr->bytes + objPtr->length) { offset = bytes - objPtr->bytes; } @@ -1625,7 +1628,9 @@ AppendUtfToUtfRep( stringPtr->numChars = -1; stringPtr->hasUnicode = 0; - memmove(objPtr->bytes + oldLength, bytes, numBytes); + if (bytes) { + memmove(objPtr->bytes + oldLength, bytes, numBytes); + } objPtr->bytes[newLength] = 0; objPtr->length = newLength; } @@ -2658,6 +2663,38 @@ Tcl_ObjPrintf( /* *--------------------------------------------------------------------------- * + * TclGetStringStorage -- + * + * Returns the string storage space of a Tcl_Obj. + * + * Results: + * The pointer value objPtr->bytes is returned and the number of bytes + * allocated there is written to *sizePtr (if known). + * + * Side effects: + * May set objPtr->bytes. + * + *--------------------------------------------------------------------------- + */ + +char * +TclGetStringStorage( + Tcl_Obj *objPtr, + unsigned int *sizePtr) +{ + String *stringPtr; + + if (objPtr->typePtr != &tclStringType || objPtr->bytes == NULL) { + return TclGetStringFromObj(objPtr, (int *)sizePtr); + } + + stringPtr = GET_STRING(objPtr); + *sizePtr = stringPtr->allocated; + return objPtr->bytes; +} +/* + *--------------------------------------------------------------------------- + * * TclStringObjReverse -- * * Implements the [string reverse] operation. @@ -2848,7 +2885,11 @@ ExtendUnicodeRepWithString( } stringPtr->hasUnicode = 1; - stringPtr->numChars = needed; + if (bytes) { + stringPtr->numChars = needed; + } else { + numAppendChars = 0; + } for (dst=stringPtr->unicode + numOrigChars; numAppendChars-- > 0; dst++) { bytes += TclUtfToUniChar(bytes, dst); } diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index e1918ef..7a84cba 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -44,6 +44,9 @@ #define TclBackgroundException Tcl_BackgroundException #undef Tcl_SetIntObj #undef TclpInetNtoa +#undef TclWinGetServByName +#undef TclWinGetSockOpt +#undef TclWinSetSockOpt /* See bug 510001: TclSockMinimumBuffers needs plat imp */ #ifdef _WIN64 @@ -90,7 +93,7 @@ static unsigned short TclWinNToHS(unsigned short ns) { } #endif -#ifdef __WIN32__ +#ifdef _WIN32 # define TclUnixWaitForFile 0 # define TclUnixCopyFile 0 # define TclUnixOpenTemporaryFile 0 @@ -111,7 +114,8 @@ TclpIsAtty(int fd) return isatty(fd); } -int +#define TclWinGetPlatformId winGetPlatformId +static int TclWinGetPlatformId() { /* Don't bother to determine the real platform on cygwin, @@ -127,27 +131,31 @@ void *TclWinGetTclInstance() return hInstance; } -int +#define TclWinSetSockOpt winSetSockOpt +static int TclWinSetSockOpt(SOCKET s, int level, int optname, const char *optval, int optlen) { return setsockopt((int) s, level, optname, optval, optlen); } -int +#define TclWinGetSockOpt winGetSockOpt +static int TclWinGetSockOpt(SOCKET s, int level, int optname, char *optval, int *optlen) { return getsockopt((int) s, level, optname, optval, optlen); } -struct servent * +#define TclWinGetServByName winGetServByName +static struct servent * TclWinGetServByName(const char *name, const char *proto) { return getservbyname(name, proto); } -char * +#define TclWinNoBackslash winNoBackslash +static char * TclWinNoBackslash(char *path) { char *p; @@ -557,7 +565,7 @@ static const TclIntStubs tclIntStubs = { static const TclIntPlatStubs tclIntPlatStubs = { TCL_STUB_MAGIC, 0, -#if !defined(__WIN32__) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */ +#if !defined(_WIN32) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */ TclGetAndDetachPids, /* 0 */ TclpCloseFile, /* 1 */ TclpCreateCommandChannel, /* 2 */ @@ -590,7 +598,7 @@ static const TclIntPlatStubs tclIntPlatStubs = { TclWinCPUID, /* 29 */ TclUnixOpenTemporaryFile, /* 30 */ #endif /* UNIX */ -#if defined(__WIN32__) || defined(__CYGWIN__) /* WIN */ +#if defined(_WIN32) || defined(__CYGWIN__) /* WIN */ TclWinConvertError, /* 0 */ TclWinConvertWSAError, /* 1 */ TclWinGetServByName, /* 2 */ @@ -661,7 +669,7 @@ static const TclIntPlatStubs tclIntPlatStubs = { static const TclPlatStubs tclPlatStubs = { TCL_STUB_MAGIC, 0, -#if defined(__WIN32__) || defined(__CYGWIN__) /* WIN */ +#if defined(_WIN32) || defined(__CYGWIN__) /* WIN */ Tcl_WinUtfToTChar, /* 0 */ Tcl_WinTCharToUtf, /* 1 */ #endif /* WIN */ @@ -758,19 +766,19 @@ const TclStubs tclStubs = { Tcl_DbCkalloc, /* 6 */ Tcl_DbCkfree, /* 7 */ Tcl_DbCkrealloc, /* 8 */ -#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */ +#if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */ Tcl_CreateFileHandler, /* 9 */ #endif /* UNIX */ -#if defined(__WIN32__) /* WIN */ +#if defined(_WIN32) /* WIN */ 0, /* 9 */ #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ Tcl_CreateFileHandler, /* 9 */ #endif /* MACOSX */ -#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */ +#if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */ Tcl_DeleteFileHandler, /* 10 */ #endif /* UNIX */ -#if defined(__WIN32__) /* WIN */ +#if defined(_WIN32) /* WIN */ 0, /* 10 */ #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ @@ -932,10 +940,10 @@ const TclStubs tclStubs = { Tcl_GetMaster, /* 164 */ Tcl_GetNameOfExecutable, /* 165 */ Tcl_GetObjResult, /* 166 */ -#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */ +#if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */ Tcl_GetOpenFile, /* 167 */ #endif /* UNIX */ -#if defined(__WIN32__) /* WIN */ +#if defined(_WIN32) /* WIN */ 0, /* 167 */ #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ diff --git a/generic/tclTest.c b/generic/tclTest.c index f121d0d..a27c95a 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -414,7 +414,7 @@ static int TestNRELevels(ClientData clientData, static int TestInterpResolverCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -#if defined(HAVE_CPUID) || defined(__WIN32__) +#if defined(HAVE_CPUID) || defined(_WIN32) static int TestcpuidCmd(ClientData dummy, Tcl_Interp* interp, int objc, Tcl_Obj *const objv[]); @@ -681,7 +681,7 @@ Tcltest_Init( NULL, NULL); Tcl_CreateCommand(interp, "testexitmainloop", TestexitmainloopCmd, NULL, NULL); -#if defined(HAVE_CPUID) || defined(__WIN32__) +#if defined(HAVE_CPUID) || defined(_WIN32) Tcl_CreateObjCommand(interp, "testcpuid", TestcpuidCmd, (ClientData) 0, NULL); #endif @@ -6648,7 +6648,7 @@ TestNumUtfCharsCmd( return TCL_OK; } -#if defined(HAVE_CPUID) || defined(__WIN32__) +#if defined(HAVE_CPUID) || defined(_WIN32) /* *---------------------------------------------------------------------- * diff --git a/generic/tclThread.c b/generic/tclThread.c index d1f2691..8c972a8 100644 --- a/generic/tclThread.c +++ b/generic/tclThread.c @@ -339,8 +339,9 @@ Tcl_ConditionFinalize( * * TclFinalizeThreadData -- * - * This function cleans up the thread-local storage. This is called once - * for each thread. + * This function cleans up the thread-local storage. Secondary, it cleans + * thread alloc cache. + * This is called once for each thread before thread exits. * * Results: * None. @@ -355,6 +356,9 @@ void TclFinalizeThreadData(void) { TclFinalizeThreadDataThread(); +#if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC) + TclFinalizeThreadAllocThread(); +#endif } /* diff --git a/generic/tclThreadAlloc.c b/generic/tclThreadAlloc.c index abd5af5..ddf888a 100644 --- a/generic/tclThreadAlloc.c +++ b/generic/tclThreadAlloc.c @@ -1023,6 +1023,33 @@ TclFinalizeThreadAlloc(void) TclpFreeAllocCache(NULL); } +/* + *---------------------------------------------------------------------- + * + * TclFinalizeThreadAllocThread -- + * + * This procedure is used to destroy single thread private resources used + * in this file. + * Called in TclpFinalizeThreadData when a thread exits (Tcl_FinalizeThread). + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +TclFinalizeThreadAllocThread(void) +{ + Cache *cachePtr = TclpGetAllocCache(); + if (cachePtr != NULL) { + TclpFreeAllocCache(cachePtr); + } +} + #else /* !(TCL_THREADS && USE_THREAD_ALLOC) */ /* *---------------------------------------------------------------------- diff --git a/generic/tclThreadJoin.c b/generic/tclThreadJoin.c index 4b09e1c..5c70a62 100644 --- a/generic/tclThreadJoin.c +++ b/generic/tclThreadJoin.c @@ -14,7 +14,7 @@ #include "tclInt.h" -#ifdef WIN32 +#ifdef _WIN32 /* * The information about each joinable thread is remembered in a structure as @@ -305,7 +305,7 @@ TclSignalExitThread( Tcl_MutexUnlock(&threadPtr->threadMutex); } -#endif /* WIN32 */ +#endif /* _WIN32 */ /* * Local Variables: diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 2d00adf..ae3adae 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -111,7 +111,11 @@ static Tcl_HashTable * GetThreadHash(Tcl_ThreadDataKey *keyPtr); static int SetEndOffsetFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); static void UpdateStringOfEndOffset(Tcl_Obj *objPtr); - +static int FindElement(Tcl_Interp *interp, const char *string, + int stringLength, const char *typeStr, + const char *typeCode, const char **elementPtr, + const char **nextPtr, int *sizePtr, + int *literalPtr); /* * The following is the Tcl object type definition for an object that * represents a list index in the form, "end-offset". It is used as a @@ -237,7 +241,7 @@ const Tcl_ObjType tclEndOffsetType = { * of either braces or quotes to delimit it. * * This collection of parsing rules is implemented in the routine - * TclFindElement(). + * FindElement(). * * In order to produce lists that can be parsed by these rules, we need the * ability to distinguish between characters that are part of a list element @@ -505,9 +509,70 @@ TclFindElement( * does not/does require a call to * TclCopyAndCollapse() by the caller. */ { - const char *p = list; + return FindElement(interp, list, listLength, "list", "LIST", elementPtr, + nextPtr, sizePtr, literalPtr); +} + +int +TclFindDictElement( + Tcl_Interp *interp, /* Interpreter to use for error reporting. If + * NULL, then no error message is left after + * errors. */ + const char *dict, /* Points to the first byte of a string + * containing a Tcl dictionary with zero or + * more keys and values (possibly in + * braces). */ + int dictLength, /* Number of bytes in the dict's string. */ + const char **elementPtr, /* Where to put address of first significant + * character in the first element (i.e., key + * or value) of dict. */ + const char **nextPtr, /* Fill in with location of character just + * after all white space following end of + * element (next arg or end of list). */ + int *sizePtr, /* If non-zero, fill in with size of + * element. */ + int *literalPtr) /* If non-zero, fill in with non-zero/zero to + * indicate that the substring of *sizePtr + * bytes starting at **elementPtr is/is not + * the literal key or value and therefore + * does not/does require a call to + * TclCopyAndCollapse() by the caller. */ +{ + return FindElement(interp, dict, dictLength, "dict", "DICTIONARY", + elementPtr, nextPtr, sizePtr, literalPtr); +} + +static int +FindElement( + Tcl_Interp *interp, /* Interpreter to use for error reporting. If + * NULL, then no error message is left after + * errors. */ + const char *string, /* Points to the first byte of a string + * containing a Tcl list or dictionary with + * zero or more elements (possibly in + * braces). */ + int stringLength, /* Number of bytes in the string. */ + const char *typeStr, /* The name of the type of thing we are + * parsing, for error messages. */ + const char *typeCode, /* The type code for thing we are parsing, for + * error messages. */ + const char **elementPtr, /* Where to put address of first significant + * character in first element. */ + const char **nextPtr, /* Fill in with location of character just + * after all white space following end of + * argument (next arg or end of list/dict). */ + int *sizePtr, /* If non-zero, fill in with size of + * element. */ + int *literalPtr) /* If non-zero, fill in with non-zero/zero to + * indicate that the substring of *sizePtr + * bytes starting at **elementPtr is/is not + * the literal list/dict element and therefore + * does not/does require a call to + * TclCopyAndCollapse() by the caller. */ +{ + const char *p = string; const char *elemStart; /* Points to first byte of first element. */ - const char *limit; /* Points just after list's last byte. */ + const char *limit; /* Points just after list/dict's last byte. */ int openBraces = 0; /* Brace nesting level during parse. */ int inQuotes = 0; int size = 0; /* lint. */ @@ -517,11 +582,11 @@ TclFindElement( /* * Skim off leading white space and check for an opening brace or quote. - * We treat embedded NULLs in the list as bytes belonging to a list - * element. + * We treat embedded NULLs in the list/dict as bytes belonging to a list + * element (or dictionary key or value). */ - limit = (list + listLength); + limit = (string + stringLength); while ((p < limit) && (TclIsSpaceProc(*p))) { p++; } @@ -582,9 +647,9 @@ TclFindElement( p2++; } Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "list element in braces followed by \"%.*s\" " - "instead of space", (int) (p2-p), p)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "LIST", "JUNK", + "%s element in braces followed by \"%.*s\" " + "instead of space", typeStr, (int) (p2-p), p)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", typeCode, "JUNK", NULL); } return TCL_ERROR; @@ -651,9 +716,9 @@ TclFindElement( p2++; } Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "list element in quotes followed by \"%.*s\" " - "instead of space", (int) (p2-p), p)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "LIST", "JUNK", + "%s element in quotes followed by \"%.*s\" " + "instead of space", typeStr, (int) (p2-p), p)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", typeCode, "JUNK", NULL); } return TCL_ERROR; @@ -664,23 +729,23 @@ TclFindElement( } /* - * End of list: terminate element. + * End of list/dict: terminate element. */ if (p == limit) { if (openBraces != 0) { if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "unmatched open brace in list", -1)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "LIST", "BRACE", + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unmatched open brace in %s", typeStr)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", typeCode, "BRACE", NULL); } return TCL_ERROR; } else if (inQuotes) { if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "unmatched open quote in list", -1)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "LIST", "QUOTE", + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unmatched open quote in %s", typeStr)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", typeCode, "QUOTE", NULL); } return TCL_ERROR; diff --git a/generic/tclZlib.c b/generic/tclZlib.c index 9bceb4c..2e27303 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -2994,47 +2994,18 @@ ZlibTransformInput( */ if (readBytes < 0) { - /* - * Report errors to caller. The state of the seek system is - * unchanged! - */ - - if ((Tcl_GetErrno() == EAGAIN) && (gotBytes > 0)) { - /* - * EAGAIN is a special situation. If we had some data before - * we report that instead of the request to re-try. - */ + /* See ReflectInput() in tclIORTrans.c */ + if (Tcl_InputBlocked(cd->parent) && (gotBytes > 0)) { return gotBytes; } *errorCodePtr = Tcl_GetErrno(); return -1; - } else if (readBytes == 0) { - /* - * Check wether we hit on EOF in 'parent' or not. If not, - * differentiate between blocking and non-blocking modes. In - * non-blocking mode we ran temporarily out of data. Signal this - * to the caller via EWOULDBLOCK and error return (-1). In the - * other cases we simply return what we got and let the caller - * wait for more. On the other hand, if we got an EOF we have to - * convert and flush all waiting partial data. - */ - - if (!Tcl_Eof(cd->parent)) { - /* - * The state of the seek system is unchanged! - */ - - if ((gotBytes == 0) && (cd->flags & ASYNC)) { - *errorCodePtr = EWOULDBLOCK; - return -1; - } - return gotBytes; - } - + } + if (readBytes == 0) { /* - * (Semi-)Eof in parent. + * Eof in parent. * * Now this is a bit different. The partial data waiting is * converted and returned. @@ -3052,12 +3023,6 @@ ZlibTransformInput( return gotBytes; } - - /* - * Reset eof, force caller to drain result buffer. - */ - - ((Channel *) cd->parent)->state->flags &= ~CHANNEL_EOF; } else /* readBytes > 0 */ { /* * Transform the read chunk, which was not empty. Anything we get diff --git a/library/clock.tcl b/library/clock.tcl index 1e652b4..67d15b1 100644 --- a/library/clock.tcl +++ b/library/clock.tcl @@ -1227,8 +1227,8 @@ proc ::tcl::clock::scan { args } { } default { return -code error \ - -errorcode [list CLOCK badSwitch $flag] \ - "bad switch \"$flag\",\ + -errorcode [list CLOCK badOption $flag] \ + "bad option \"$flag\",\ must be -base, -format, -gmt, -locale or -timezone" } } @@ -4295,8 +4295,8 @@ proc ::tcl::clock::add { clockval args } { set timezone $b } default { - throw [list CLOCK badSwitch $a] \ - "bad switch \"$a\",\ + throw [list CLOCK badOption $a] \ + "bad option \"$a\",\ must be -gmt, -locale or -timezone" } } diff --git a/library/init.tcl b/library/init.tcl index f63eedf..bb17319 100644 --- a/library/init.tcl +++ b/library/init.tcl @@ -398,7 +398,8 @@ proc unknown args { return -code error "ambiguous command name \"$name\": [lsort $cmds]" } } - return -code error "invalid command name \"$name\"" + return -code error -errorcode [list TCL LOOKUP COMMAND $name] \ + "invalid command name \"$name\"" } # auto_load -- diff --git a/library/tcltest/pkgIndex.tcl b/library/tcltest/pkgIndex.tcl index c99ad2a..987725f 100644 --- a/library/tcltest/pkgIndex.tcl +++ b/library/tcltest/pkgIndex.tcl @@ -9,4 +9,4 @@ # full path name of this file's directory. if {![package vsatisfies [package provide Tcl] 8.5]} {return} -package ifneeded tcltest 2.3.7 [list source [file join $dir tcltest.tcl]] +package ifneeded tcltest 2.3.8 [list source [file join $dir tcltest.tcl]] diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl index 4b94312..8e43859 100644 --- a/library/tcltest/tcltest.tcl +++ b/library/tcltest/tcltest.tcl @@ -22,7 +22,7 @@ namespace eval tcltest { # When the version number changes, be sure to update the pkgIndex.tcl file, # and the install directory in the Makefiles. When the minor version # changes (new feature) be sure to update the man page as well. - variable Version 2.3.7 + variable Version 2.3.8 # Compatibility support for dumb variables defined in tcltest 1 # Do not use these. Call [package provide Tcl] and [info patchlevel] @@ -1991,47 +1991,6 @@ proc tcltest::test {name description args} { } } - # Always run the cleanup script - set code [catch {uplevel 1 $cleanup} cleanupMsg] - if {$code == 1} { - set errorInfo(cleanup) $::errorInfo - set errorCode(cleanup) $::errorCode - } - set cleanupFailure [expr {$code != 0}] - - set coreFailure 0 - set coreMsg "" - # check for a core file first - if one was created by the test, - # then the test failed - if {[preserveCore]} { - if {[file exists [file join [workingDirectory] core]]} { - # There's only a test failure if there is a core file - # and (1) there previously wasn't one or (2) the new - # one is different from the old one. - if {[info exists coreModTime]} { - if {$coreModTime != [file mtime \ - [file join [workingDirectory] core]]} { - set coreFailure 1 - } - } else { - set coreFailure 1 - } - - if {([preserveCore] > 1) && ($coreFailure)} { - append coreMsg "\nMoving file to:\ - [file join [temporaryDirectory] core-$name]" - catch {file rename -force -- \ - [file join [workingDirectory] core] \ - [file join [temporaryDirectory] core-$name] - } msg - if {$msg ne {}} { - append coreMsg "\nError:\ - Problem renaming core file: $msg" - } - } - } - } - # check if the return code matched the expected return code set codeFailure 0 if {!$setupFailure && ($returnCode ni $returnCodes)} { @@ -2076,6 +2035,47 @@ proc tcltest::test {name description args} { set scriptFailure 1 } + # Always run the cleanup script + set code [catch {uplevel 1 $cleanup} cleanupMsg] + if {$code == 1} { + set errorInfo(cleanup) $::errorInfo + set errorCode(cleanup) $::errorCode + } + set cleanupFailure [expr {$code != 0}] + + set coreFailure 0 + set coreMsg "" + # check for a core file first - if one was created by the test, + # then the test failed + if {[preserveCore]} { + if {[file exists [file join [workingDirectory] core]]} { + # There's only a test failure if there is a core file + # and (1) there previously wasn't one or (2) the new + # one is different from the old one. + if {[info exists coreModTime]} { + if {$coreModTime != [file mtime \ + [file join [workingDirectory] core]]} { + set coreFailure 1 + } + } else { + set coreFailure 1 + } + + if {([preserveCore] > 1) && ($coreFailure)} { + append coreMsg "\nMoving file to:\ + [file join [temporaryDirectory] core-$name]" + catch {file rename -force -- \ + [file join [workingDirectory] core] \ + [file join [temporaryDirectory] core-$name] + } msg + if {$msg ne {}} { + append coreMsg "\nError:\ + Problem renaming core file: $msg" + } + } + } + } + # if we didn't experience any failures, then we passed variable numTests if {!($setupFailure || $cleanupFailure || $coreFailure diff --git a/tests/chanio.test b/tests/chanio.test index 999d0bb..e53f059 100644 --- a/tests/chanio.test +++ b/tests/chanio.test @@ -44,7 +44,7 @@ namespace eval ::tcl::test::io { # You need a *very* special environment to do some tests. In particular, # many file systems do not support large-files... - testConstraint largefileSupport 0 + testConstraint largefileSupport [expr {$::tcl_platform(os) ne "Darwin"}] # some tests can only be run is umask is 2 if "umask" cannot be run, the # tests will be skipped. @@ -4520,10 +4520,10 @@ test chan-io-34.21 {Tcl_Seek and Tcl_Tell on large files} -setup { chan puts -nonewline $f abcdef lappend l [chan tell $f] chan close $f - lappend l [file size $f] + lappend l [file size $path(test3)] # truncate... chan close [open $path(test3) w] - lappend l [file size $f] + lappend l [file size $path(test3)] } -result {0 6 6 4294967296 4294967302 4294967302 0} # Test Tcl_Eof diff --git a/tests/clock.test b/tests/clock.test index 0202fc7..2abeab9 100644 --- a/tests/clock.test +++ b/tests/clock.test @@ -273,7 +273,7 @@ test clock-1.4 "clock format - bad flag" {*}{ list [catch {clock format 0 -oops badflag} msg] $msg $::errorCode } -match glob - -result {1 {bad switch "-oops": must be -format, -gmt, -locale, or -timezone} {CLOCK badSwitch -oops}} + -result {1 {bad option "-oops": must be -format, -gmt, -locale, or -timezone} {CLOCK badOption -oops}} } test clock-1.5 "clock format - bad timezone" { @@ -35450,7 +35450,7 @@ test clock-33.2 {clock clicks tests} { } {1} test clock-33.3 {clock clicks tests} { list [catch {clock clicks foo} msg] $msg -} {1 {bad switch "foo": must be -milliseconds or -microseconds}} +} {1 {bad option "foo": must be -milliseconds or -microseconds}} test clock-33.4 {clock clicks tests} { expr [clock clicks -milliseconds]+1 concat {} @@ -35485,10 +35485,10 @@ test clock-33.5a {clock tests, millisecond timing test} { } {ok} test clock-33.6 {clock clicks, milli with too much abbreviation} { list [catch { clock clicks ? } msg] $msg -} {1 {bad switch "?": must be -milliseconds or -microseconds}} +} {1 {bad option "?": must be -milliseconds or -microseconds}} test clock-33.7 {clock clicks, milli with too much abbreviation} { list [catch { clock clicks - } msg] $msg -} {1 {ambiguous switch "-": must be -milliseconds or -microseconds}} +} {1 {ambiguous option "-": must be -milliseconds or -microseconds}} test clock-33.8 {clock clicks test, microsecond timing test} { # This test can fail on a system that is so heavily loaded that @@ -35607,7 +35607,7 @@ test clock-34.8 {clock scan tests} { } {Oct 23,1992 15:00 GMT} test clock-34.9 {clock scan tests} { list [catch {clock scan "Jan 12" -bad arg} msg] $msg -} {1 {bad switch "-bad", must be -base, -format, -gmt, -locale or -timezone}} +} {1 {bad option "-bad", must be -base, -format, -gmt, -locale or -timezone}} # The following two two tests test the two year date policy test clock-34.10 {clock scan tests} { set time [clock scan "1/1/71" -gmt true] @@ -36907,7 +36907,7 @@ test clock-65.1 {clock add, bad option [Bug 2481670]} {*}{ } -match glob -returnCodes error - -result {bad switch "-foo"*} + -result {bad option "-foo"*} } test clock-66.1 {clock scan, no date, never-before-seen timezone} {*}{ @@ -36927,6 +36927,15 @@ test clock-67.1 {clock format, %% with a letter following [Bug 2819334]} { clock format [clock seconds] -format %%r } %r +test clock-67.2 {Bug d19a30db57} -body { + # error, not segfault + tcl::clock::GetJulianDayFromEraYearMonthDay {} 2361222 +} -returnCodes error -match glob -result * +test clock-67.3 {Bug d19a30db57} -body { + # error, not segfault + tcl::clock::GetJulianDayFromEraYearWeekDay {} 2361222 +} -returnCodes error -match glob -result * + # cleanup namespace delete ::testClock diff --git a/tests/cmdAH.test b/tests/cmdAH.test index 39e9ece..04a86fa 100644 --- a/tests/cmdAH.test +++ b/tests/cmdAH.test @@ -141,6 +141,9 @@ test cmdAH-2.6.2 {cd} -constraints {unix nonPortable} -setup { } -cleanup { cd $dir } -result {/} +test cmdAH-2.6.3 {Tcl_CdObjCmd, bug #3118489} -returnCodes error -body { + cd .\0 +} -result "couldn't change working directory to \".\0\": no such file or directory" test cmdAH-2.7 {Tcl_ConcatObjCmd} { concat } {} diff --git a/tests/dict.test b/tests/dict.test index a583de8..d5406d0 100644 --- a/tests/dict.test +++ b/tests/dict.test @@ -167,6 +167,51 @@ test dict-4.8 {dict replace command} -returnCodes error -body { } -result {missing value to go with key} test dict-4.9 {dict replace command} {dict replace [list a a] a b} {a b} test dict-4.10 {dict replace command} {dict replace [list a a] a b a c} {a c} +test dict-4.11 {dict replace command: canonicality is forced} { + dict replace { a b c d } +} {a b c d} +test dict-4.12 {dict replace command: canonicality is forced} { + dict replace {a b c d a e} +} {a e c d} +test dict-4.13 {dict replace command: type check is mandatory} -body { + dict replace { a b c d e } +} -returnCodes error -result {missing value to go with key} +test dict-4.13a {dict replace command: type check is mandatory} { + catch {dict replace { a b c d e }} -> opt + dict get $opt -errorcode +} {TCL VALUE DICTIONARY} +test dict-4.14 {dict replace command: type check is mandatory} -body { + dict replace { a b {}c d } +} -returnCodes error -result {dict element in braces followed by "c" instead of space} +test dict-4.14a {dict replace command: type check is mandatory} { + catch {dict replace { a b {}c d }} -> opt + dict get $opt -errorcode +} {TCL VALUE DICTIONARY JUNK} +test dict-4.15 {dict replace command: type check is mandatory} -body { + dict replace { a b ""c d } +} -returnCodes error -result {dict element in quotes followed by "c" instead of space} +test dict-4.15a {dict replace command: type check is mandatory} { + catch {dict replace { a b ""c d }} -> opt + dict get $opt -errorcode +} {TCL VALUE DICTIONARY JUNK} +test dict-4.16 {dict replace command: type check is mandatory} -body { + dict replace " a b \"c d " +} -returnCodes error -result {unmatched open quote in dict} +test dict-4.16a {dict replace command: type check is mandatory} { + catch {dict replace " a b \"c d "} -> opt + dict get $opt -errorcode +} {TCL VALUE DICTIONARY QUOTE} +test dict-4.17 {dict replace command: type check is mandatory} -body { + dict replace " a b \{c d " +} -returnCodes error -result {unmatched open brace in dict} +test dict-4.17a {dict replace command: type check is mandatory} { + catch {dict replace " a b \{c d "} -> opt + dict get $opt -errorcode +} {TCL VALUE DICTIONARY BRACE} +test dict-4.18 {dict replace command: canonicality forcing doesn't leak} { + set example { a b c d } + list $example [dict replace $example] +} {{ a b c d } {a b c d}} test dict-5.1 {dict remove command} {dict remove {a b c d} a} {c d} test dict-5.2 {dict remove command} {dict remove {a b c d} c} {a b} @@ -179,6 +224,25 @@ test dict-5.6 {dict remove command} {dict remove {a b} c} {a b} test dict-5.7 {dict remove command} -returnCodes error -body { dict remove } -result {wrong # args: should be "dict remove dictionary ?key ...?"} +test dict-5.8 {dict remove command: canonicality is forced} { + dict remove { a b c d } +} {a b c d} +test dict-5.9 {dict remove command: canonicality is forced} { + dict remove {a b c d a e} +} {a e c d} +test dict-5.10 {dict remove command: canonicality forced by update} { + dict remove { a b c d } c +} {a b} +test dict-5.11 {dict remove command: type check is mandatory} -body { + dict remove { a b c d e } +} -returnCodes error -result {missing value to go with key} +test dict-5.12 {dict remove command: type check is mandatory} -body { + dict remove { a b {}c d } +} -returnCodes error -result {dict element in braces followed by "c" instead of space} +test dict-5.13 {dict remove command: canonicality forcing doesn't leak} { + set example { a b c d } + list $example [dict remove $example] +} {{ a b c d } {a b c d}} test dict-6.1 {dict keys command} {dict keys {a b}} a test dict-6.2 {dict keys command} {dict keys {c d}} c @@ -345,13 +409,13 @@ test dict-11.13 {dict incr command} -returnCodes error -body { dict incr dictv a a a } -cleanup { unset dictv -} -result {wrong # args: should be "dict incr varName key ?increment?"} +} -result {wrong # args: should be "dict incr dictVarName key ?increment?"} test dict-11.14 {dict incr command} -returnCodes error -body { set dictv a dict incr dictv } -cleanup { unset dictv -} -result {wrong # args: should be "dict incr varName key ?increment?"} +} -result {wrong # args: should be "dict incr dictVarName key ?increment?"} test dict-11.15 {dict incr command: write failure} -setup { unset -nocomplain dictVar } -body { @@ -422,10 +486,10 @@ test dict-12.6 {dict lappend command} -returnCodes error -body { } -result {missing value to go with key} test dict-12.7 {dict lappend command} -returnCodes error -body { dict lappend -} -result {wrong # args: should be "dict lappend varName key ?value ...?"} +} -result {wrong # args: should be "dict lappend dictVarName key ?value ...?"} test dict-12.8 {dict lappend command} -returnCodes error -body { dict lappend dictv -} -result {wrong # args: should be "dict lappend varName key ?value ...?"} +} -result {wrong # args: should be "dict lappend dictVarName key ?value ...?"} test dict-12.9 {dict lappend command} -returnCodes error -body { set dictv [dict create a "\{"] dict lappend dictv a a @@ -489,10 +553,10 @@ test dict-13.6 {dict append command} -returnCodes error -body { } -result {missing value to go with key} test dict-13.7 {dict append command} -returnCodes error -body { dict append -} -result {wrong # args: should be "dict append varName key ?value ...?"} +} -result {wrong # args: should be "dict append dictVarName key ?value ...?"} test dict-13.8 {dict append command} -returnCodes error -body { dict append dictv -} -result {wrong # args: should be "dict append varName key ?value ...?"} +} -result {wrong # args: should be "dict append dictVarName key ?value ...?"} test dict-13.9 {dict append command: write failure} -setup { unset -nocomplain dictVar } -body { @@ -510,16 +574,16 @@ test dict-13.11 {compiled dict append: invalidate string rep - Bug 3079830} { test dict-14.1 {dict for command: syntax} -returnCodes error -body { dict for -} -result {wrong # args: should be "dict for {keyVar valueVar} dictionary script"} +} -result {wrong # args: should be "dict for {keyVarName valueVarName} dictionary script"} test dict-14.2 {dict for command: syntax} -returnCodes error -body { dict for x -} -result {wrong # args: should be "dict for {keyVar valueVar} dictionary script"} +} -result {wrong # args: should be "dict for {keyVarName valueVarName} dictionary script"} test dict-14.3 {dict for command: syntax} -returnCodes error -body { dict for x x -} -result {wrong # args: should be "dict for {keyVar valueVar} dictionary script"} +} -result {wrong # args: should be "dict for {keyVarName valueVarName} dictionary script"} test dict-14.4 {dict for command: syntax} -returnCodes error -body { dict for x x x x -} -result {wrong # args: should be "dict for {keyVar valueVar} dictionary script"} +} -result {wrong # args: should be "dict for {keyVarName valueVarName} dictionary script"} test dict-14.5 {dict for command: syntax} -returnCodes error -body { dict for x x x } -result {must have exactly two variable names} @@ -749,13 +813,13 @@ test dict-15.9 {dict set command: write failure} -setup { } -result {can't set "dictVar": variable is array} test dict-15.10 {dict set command: syntax} -returnCodes error -body { dict set -} -result {wrong # args: should be "dict set varName key ?key ...? value"} +} -result {wrong # args: should be "dict set dictVarName key ?key ...? value"} test dict-15.11 {dict set command: syntax} -returnCodes error -body { dict set a -} -result {wrong # args: should be "dict set varName key ?key ...? value"} +} -result {wrong # args: should be "dict set dictVarName key ?key ...? value"} test dict-15.12 {dict set command: syntax} -returnCodes error -body { dict set a a -} -result {wrong # args: should be "dict set varName key ?key ...? value"} +} -result {wrong # args: should be "dict set dictVarName key ?key ...? value"} test dict-15.13 {dict set command} -returnCodes error -body { set dictVar a dict set dictVar b c @@ -808,7 +872,7 @@ test dict-16.7 {dict unset command} -setup { } -result {0 {} 1} test dict-16.8 {dict unset command} -returnCodes error -body { dict unset dictVar -} -result {wrong # args: should be "dict unset varName key ?key ...?"} +} -result {wrong # args: should be "dict unset dictVarName key ?key ...?"} test dict-16.9 {dict unset command: write failure} -setup { unset -nocomplain dictVar } -body { @@ -859,7 +923,7 @@ test dict-16.16 {dict unset command} -body { } -result {0 {} 1} test dict-16.17 {dict unset command} -returnCodes error -body { apply {{} {dict unset dictVar}} -} -result {wrong # args: should be "dict unset varName key ?key ...?"} +} -result {wrong # args: should be "dict unset dictVarName key ?key ...?"} test dict-16.18 {dict unset command: write failure} -body { apply {{} { set dictVar(block) {} @@ -988,7 +1052,7 @@ test dict-17.17 {dict filter command: script} -body { } -result b test dict-17.18 {dict filter command: script} -returnCodes error -body { dict filter {a b} script {k k} -} -result {wrong # args: should be "dict filter dictionary script {keyVar valueVar} filterScript"} +} -result {wrong # args: should be "dict filter dictionary script {keyVarName valueVarName} filterScript"} test dict-17.19 {dict filter command: script} -returnCodes error -body { dict filter {a b} script k {continue} } -result {must have exactly two variable names} @@ -1226,19 +1290,34 @@ test dict-20.19 {dict merge command} { test dict-20.20 {dict merge command} { apply {{} {dict merge {a b c d e f} {a x 1 2 3 4} {a - 1 -}}} } {a - c d e f 1 - 3 4} +test dict-20.21 {dict merge command: canonicality not forced} { + dict merge { a b c d } +} { a b c d } +test dict-20.22 {dict merge command: canonicality not forced} { + dict merge { a b c d } {} +} { a b c d } +test dict-20.23 {dict merge command: canonicality forced by update} { + dict merge { a b c d } {a b} +} {a b c d} +test dict-20.24 {dict merge command: type check is mandatory} -body { + dict merge { a b c d e } +} -returnCodes error -result {missing value to go with key} +test dict-20.25 {dict merge command: type check is mandatory} -body { + dict merge { a b {}c d } +} -returnCodes error -result {dict element in braces followed by "c" instead of space} test dict-21.1 {dict update command} -returnCodes 1 -body { dict update -} -result {wrong # args: should be "dict update varName key varName ?key varName ...? script"} +} -result {wrong # args: should be "dict update dictVarName key varName ?key varName ...? script"} test dict-21.2 {dict update command} -returnCodes 1 -body { dict update v -} -result {wrong # args: should be "dict update varName key varName ?key varName ...? script"} +} -result {wrong # args: should be "dict update dictVarName key varName ?key varName ...? script"} test dict-21.3 {dict update command} -returnCodes 1 -body { dict update v k -} -result {wrong # args: should be "dict update varName key varName ?key varName ...? script"} +} -result {wrong # args: should be "dict update dictVarName key varName ?key varName ...? script"} test dict-21.4 {dict update command} -returnCodes 1 -body { dict update v k v -} -result {wrong # args: should be "dict update varName key varName ?key varName ...? script"} +} -result {wrong # args: should be "dict update dictVarName key varName ?key varName ...? script"} test dict-21.5 {dict update command} -body { set a {b c} set result {} @@ -1376,10 +1455,10 @@ test dict-21.17 {dict update command: no recursive structures [Bug 1786481]} { test dict-22.1 {dict with command} -body { dict with -} -returnCodes 1 -result {wrong # args: should be "dict with dictVar ?key ...? script"} +} -returnCodes 1 -result {wrong # args: should be "dict with dictVarName ?key ...? script"} test dict-22.2 {dict with command} -body { dict with v -} -returnCodes 1 -result {wrong # args: should be "dict with dictVar ?key ...? script"} +} -returnCodes 1 -result {wrong # args: should be "dict with dictVarName ?key ...? script"} test dict-22.3 {dict with command} -body { unset -nocomplain v dict with v {error "in body"} @@ -1639,16 +1718,16 @@ rename linenumber {} test dict-24.1 {dict map command: syntax} -returnCodes error -body { dict map -} -result {wrong # args: should be "dict map {keyVar valueVar} dictionary script"} +} -result {wrong # args: should be "dict map {keyVarName valueVarName} dictionary script"} test dict-24.2 {dict map command: syntax} -returnCodes error -body { dict map x -} -result {wrong # args: should be "dict map {keyVar valueVar} dictionary script"} +} -result {wrong # args: should be "dict map {keyVarName valueVarName} dictionary script"} test dict-24.3 {dict map command: syntax} -returnCodes error -body { dict map x x -} -result {wrong # args: should be "dict map {keyVar valueVar} dictionary script"} +} -result {wrong # args: should be "dict map {keyVarName valueVarName} dictionary script"} test dict-24.4 {dict map command: syntax} -returnCodes error -body { dict map x x x x -} -result {wrong # args: should be "dict map {keyVar valueVar} dictionary script"} +} -result {wrong # args: should be "dict map {keyVarName valueVarName} dictionary script"} test dict-24.5 {dict map command: syntax} -returnCodes error -body { dict map x x x } -result {must have exactly two variable names} diff --git a/tests/exec.test b/tests/exec.test index 871c0c5..16a8320 100644 --- a/tests/exec.test +++ b/tests/exec.test @@ -370,7 +370,7 @@ err} test exec-10.1 {errors in exec invocation} -constraints {exec} -body { exec -} -returnCodes error -result {wrong # args: should be "exec ?-switch ...? arg ?arg ...?"} +} -returnCodes error -result {wrong # args: should be "exec ?-option ...? arg ?arg ...?"} test exec-10.2 {errors in exec invocation} -constraints {exec} -body { exec | cat } -returnCodes error -result {illegal use of | or |& in command} @@ -545,10 +545,10 @@ test exec-14.1 {-keepnewline switch} {exec} { } "foo\n" test exec-14.2 {-keepnewline switch} -constraints {exec} -body { exec -keepnewline -} -returnCodes error -result {wrong # args: should be "exec ?-switch ...? arg ?arg ...?"} +} -returnCodes error -result {wrong # args: should be "exec ?-option ...? arg ?arg ...?"} test exec-14.3 {unknown switch} -constraints {exec} -body { exec -gorp -} -returnCodes error -result {bad switch "-gorp": must be -ignorestderr, -keepnewline, or --} +} -returnCodes error -result {bad option "-gorp": must be -ignorestderr, -keepnewline, or --} test exec-14.4 {-- switch} -constraints {exec} -body { exec -- -gorp } -returnCodes error -result {couldn't execute "-gorp": no such file or directory} diff --git a/tests/fCmd.test b/tests/fCmd.test index 8f27ad4..5836e00 100644 --- a/tests/fCmd.test +++ b/tests/fCmd.test @@ -511,12 +511,6 @@ test fCmd-6.6 {CopyRenameOneFile: errno != ENOENT} -setup { } -returnCodes error -cleanup { testchmod 755 td1 } -result {error renaming "tf1" to "td1/tf1": permission denied} -test fCmd-6.7 {CopyRenameOneFile: errno != ENOENT} -setup { - cleanup -} -constraints {win 95} -returnCodes error -body { - createfile tf1 - file rename tf1 $long -} -result [subst {error renaming "tf1" to "$long": file name too long}] test fCmd-6.9 {CopyRenameOneFile: errno == ENOENT} -setup { cleanup } -constraints {unix notRoot} -body { @@ -2330,10 +2324,10 @@ test fCmd-28.2 {file link} -returnCodes error -body { } -result {wrong # args: should be "file link ?-linktype? linkname ?target?"} test fCmd-28.3 {file link} -returnCodes error -body { file link abc b c -} -result {bad switch "abc": must be -symbolic or -hard} +} -result {bad option "abc": must be -symbolic or -hard} test fCmd-28.4 {file link} -returnCodes error -body { file link -abc b c -} -result {bad switch "-abc": must be -symbolic or -hard} +} -result {bad option "-abc": must be -symbolic or -hard} cd [workingDirectory] makeDirectory abc.dir makeDirectory abc2.dir diff --git a/tests/http.test b/tests/http.test index a52cfb1..a0a26de 100644 --- a/tests/http.test +++ b/tests/http.test @@ -492,14 +492,10 @@ proc myProgress {token total current} { } set progress [list $total $current] } -if 0 { - # This test hangs on Windows95 because the client never gets EOF - set httpLog 1 - test http-4.6.1 {http::Event} knownBug { - set token [http::geturl $url -blocksize 50 -progress myProgress] - return $progress - } {111 111} -} +test http-4.6.1 {http::Event} knownBug { + set token [http::geturl $url -blocksize 50 -progress myProgress] + return $progress +} {111 111} test http-4.7 {http::Event} -body { set token [http::geturl $url -keepalive 0 -progress myProgress] return $progress diff --git a/tests/io.test b/tests/io.test index 0688c14..cf38a1b 100644 --- a/tests/io.test +++ b/tests/io.test @@ -45,7 +45,7 @@ testConstraint thread [expr {0 == [catch {package require Thread 2.7-}]}] # You need a *very* special environment to do some tests. In # particular, many file systems do not support large-files... -testConstraint largefileSupport 0 +testConstraint largefileSupport [expr {$::tcl_platform(os) ne "Darwin"}] # some tests can only be run is umask is 2 # if "umask" cannot be run, the tests will be skipped. @@ -1449,6 +1449,39 @@ test io-12.5 {ReadChars: fileevents on partial characters} {stdio openpipe filee lappend x [catch {close $f} msg] $msg set x } "{} timeout {} timeout \u7266 {} eof 0 {}" +test io-12.6 {ReadChars: too many chars read} { + proc driver {cmd args} { + variable buffer + variable index + set chan [lindex $args 0] + switch -- $cmd { + initialize { + set index($chan) 0 + set buffer($chan) [encoding convertto utf-8 \ + [string repeat \uBEEF 20][string repeat . 20]] + return {initialize finalize watch read} + } + finalize { + unset index($chan) buffer($chan) + return + } + watch {} + read { + set n [lindex $args 1] + set new [expr {$index($chan) + $n}] + set result [string range $buffer($chan) $index($chan) $new-1] + set index($chan) $new + return $result + } + } + } + set c [chan create read [namespace which driver]] + chan configure $c -encoding utf-8 + while {![eof $c]} { + read $c 15 + } + close $c +} {} test io-13.1 {TranslateInputEOL: cr mode} {} { set f [open $path(test1) w] @@ -1563,6 +1596,45 @@ test io-13.8 {TranslateInputEOL: auto mode: \r\n} { close $f set x } "abcd\ndef" +test io-13.8.1 {TranslateInputEOL: auto mode: \r\n} { + set f [open $path(test1) w] + fconfigure $f -translation lf + puts -nonewline $f "abcd\r\ndef" + close $f + set f [open $path(test1)] + fconfigure $f -translation auto + set x {} + lappend x [read $f 5] + lappend x [read $f] + close $f + set x +} [list "abcd\n" "def"] +test io-13.8.2 {TranslateInputEOL: auto mode: \r\n} { + set f [open $path(test1) w] + fconfigure $f -translation lf + puts -nonewline $f "abcd\r\ndef" + close $f + set f [open $path(test1)] + fconfigure $f -translation auto -buffersize 6 + set x {} + lappend x [read $f 5] + lappend x [read $f] + close $f + set x +} [list "abcd\n" "def"] +test io-13.8.3 {TranslateInputEOL: auto mode: \r\n} { + set f [open $path(test1) w] + fconfigure $f -translation lf + puts -nonewline $f "abcd\r\n\r\ndef" + close $f + set f [open $path(test1)] + fconfigure $f -translation auto -buffersize 7 + set x {} + lappend x [read $f 5] + lappend x [read $f] + close $f + set x +} [list "abcd\n" "\ndef"] test io-13.9 {TranslateInputEOL: auto mode: \r followed by not \n} { set f [open $path(test1) w] fconfigure $f -translation lf @@ -2771,7 +2843,7 @@ test io-29.34 {Tcl_Close, async flush on close, using sockets} {socket tempNotMa variable x running set l abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyz proc writelots {s l} { - for {set i 0} {$i < 2000} {incr i} { + for {set i 0} {$i < 9000} {incr i} { puts $s $l } } @@ -2802,7 +2874,7 @@ test io-29.34 {Tcl_Close, async flush on close, using sockets} {socket tempNotMa close $ss vwait [namespace which -variable x] set c -} 2000 +} 9000 test io-29.35 {Tcl_Close vs fileevent vs multiple interpreters} {socket tempNotMac fileevent} { # On Mac, this test screws up sockets such that subsequent tests using port 2828 # either cause errors or panic(). @@ -3984,6 +4056,46 @@ test io-32.11 {Tcl_Read from a pipe} {stdio openpipe} { } {{hello } {hello }} +test io-32.11.1 {Tcl_Read from a pipe} {stdio openpipe} { + file delete $path(pipe) + set f1 [open $path(pipe) w] + puts $f1 {chan configure stdout -translation crlf} + puts $f1 {puts [gets stdin]} + puts $f1 {puts [gets stdin]} + close $f1 + set f1 [open "|[list [interpreter] $path(pipe)]" r+] + puts $f1 hello + flush $f1 + set x "" + lappend x [read $f1 6] + puts $f1 hello + flush $f1 + lappend x [read $f1] + close $f1 + set x +} {{hello +} {hello +}} +test io-32.11.1 {Tcl_Read from a pipe} {stdio openpipe} { + file delete $path(pipe) + set f1 [open $path(pipe) w] + puts $f1 {chan configure stdout -translation crlf} + puts $f1 {puts [gets stdin]} + puts $f1 {puts [gets stdin]} + close $f1 + set f1 [open "|[list [interpreter] $path(pipe)]" r+] + puts $f1 hello + flush $f1 + set x "" + lappend x [read $f1 6] + puts $f1 hello + flush $f1 + lappend x [read $f1] + close $f1 + set x +} {{hello +} {hello +}} test io-32.12 {Tcl_Read, -nonewline} { file delete $path(test1) set f1 [open $path(test1) w] @@ -4457,10 +4569,10 @@ test io-34.21 {Tcl_Seek and Tcl_Tell on large files} {largefileSupport} { puts -nonewline $f abcdef lappend l [tell $f] close $f - lappend l [file size $f] + lappend l [file size $path(test3)] # truncate... close [open $path(test3) w] - lappend l [file size $f] + lappend l [file size $path(test3)] set l } {0 6 6 4294967296 4294967302 4294967302 0} @@ -4725,6 +4837,92 @@ test io-35.17 {Tcl_Eof, eof char in middle, crlf write, crlf read} { close $f list $c $l $e } {21 8 1} +test io-35.18 {Tcl_Eof, eof char, cr write, crlf read} -body { + file delete $path(test1) + set f [open $path(test1) w] + fconfigure $f -translation cr + puts $f abc\ndef + close $f + set s [file size $path(test1)] + set f [open $path(test1) r] + fconfigure $f -translation crlf + set l [string length [set in [read $f]]] + set e [eof $f] + close $f + list $s $l $e [scan [string index $in end] %c] +} -result {8 8 1 13} +test io-35.18a {Tcl_Eof, eof char, cr write, crlf read} -body { + file delete $path(test1) + set f [open $path(test1) w] + fconfigure $f -translation cr -eofchar \x1a + puts $f abc\ndef + close $f + set s [file size $path(test1)] + set f [open $path(test1) r] + fconfigure $f -translation crlf -eofchar \x1a + set l [string length [set in [read $f]]] + set e [eof $f] + close $f + list $s $l $e [scan [string index $in end] %c] +} -result {9 8 1 13} +test io-35.18b {Tcl_Eof, eof char, cr write, crlf read} -body { + file delete $path(test1) + set f [open $path(test1) w] + fconfigure $f -translation cr -eofchar \x1a + puts $f {} + close $f + set s [file size $path(test1)] + set f [open $path(test1) r] + fconfigure $f -translation crlf -eofchar \x1a + set l [string length [set in [read $f]]] + set e [eof $f] + close $f + list $s $l $e [scan [string index $in end] %c] +} -result {2 1 1 13} +test io-35.18c {Tcl_Eof, eof char, cr write, crlf read} -body { + file delete $path(test1) + set f [open $path(test1) w] + fconfigure $f -translation cr + puts $f {} + close $f + set s [file size $path(test1)] + set f [open $path(test1) r] + fconfigure $f -translation crlf + set l [string length [set in [read $f]]] + set e [eof $f] + close $f + list $s $l $e [scan [string index $in end] %c] +} -result {1 1 1 13} +test io-35.19 {Tcl_Eof, eof char in middle, cr write, crlf read} -body { + file delete $path(test1) + set f [open $path(test1) w] + fconfigure $f -translation cr -eofchar {} + set i [format abc\ndef\n%cqrs\nuvw 26] + puts $f $i + close $f + set c [file size $path(test1)] + set f [open $path(test1) r] + fconfigure $f -translation crlf -eofchar \x1a + set l [string length [set in [read $f]]] + set e [eof $f] + close $f + list $c $l $e [scan [string index $in end] %c] +} -result {17 8 1 13} +test io-35.20 {Tcl_Eof, eof char in middle, cr write, crlf read} { + file delete $path(test1) + set f [open $path(test1) w] + fconfigure $f -translation cr -eofchar {} + set i [format \n%cqrsuvw 26] + puts $f $i + close $f + set c [file size $path(test1)] + set f [open $path(test1) r] + fconfigure $f -translation crlf -eofchar \x1a + set l [string length [set in [read $f]]] + set e [eof $f] + close $f + list $c $l $e [scan [string index $in end] %c] +} {9 1 1 13} # Test Tcl_InputBlocked @@ -6564,11 +6762,23 @@ test io-52.4 {TclCopyChannel} {fcopy} { fconfigure $f1 -translation lf -blocking 0 fconfigure $f2 -translation cr -blocking 0 fcopy $f1 $f2 -size 40 - set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]] + set result [list [fblocked $f1] [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]] close $f1 close $f2 lappend result [file size $path(test1)] -} {0 0 40} +} {0 0 0 40} +test io-52.4.1 {TclCopyChannel} {fcopy} { + file delete $path(test1) + set f1 [open $thisScript] + set f2 [open $path(test1) w] + fconfigure $f1 -translation lf -blocking 0 -buffersize 10000000 + fconfigure $f2 -translation cr -blocking 0 + fcopy $f1 $f2 -size 40 + set result [list [fblocked $f1] [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]] + close $f1 + close $f2 + lappend result [file size $path(test1)] +} {0 0 0 40} test io-52.5 {TclCopyChannel, all} {fcopy} { file delete $path(test1) set f1 [open $thisScript] @@ -6754,6 +6964,150 @@ test io-52.11 {TclCopyChannel & encodings} {fcopy} { file size $path(kyrillic.txt) } 3 +test io-52.12 {coverage of -translation auto} { + file delete $path(test1) $path(test2) + set out [open $path(test1) wb] + chan configure $out -translation lf + puts -nonewline $out abcdefg\rhijklmn\nopqrstu\r\nvwxyz + close $out + set in [open $path(test1)] + chan configure $in -buffersize 8 + set out [open $path(test2) w] + chan configure $out -translation lf + fcopy $in $out + close $in + close $out + file size $path(test2) +} 29 +test io-52.13 {coverage of -translation cr} { + file delete $path(test1) $path(test2) + set out [open $path(test1) wb] + chan configure $out -translation lf + puts -nonewline $out abcdefg\rhijklmn\nopqrstu\r\nvwxyz + close $out + set in [open $path(test1)] + chan configure $in -buffersize 8 -translation cr + set out [open $path(test2) w] + chan configure $out -translation lf + fcopy $in $out + close $in + close $out + file size $path(test2) +} 30 +test io-52.14 {coverage of -translation crlf} { + file delete $path(test1) $path(test2) + set out [open $path(test1) wb] + chan configure $out -translation lf + puts -nonewline $out abcdefg\rhijklmn\nopqrstu\r\nvwxyz + close $out + set in [open $path(test1)] + chan configure $in -buffersize 8 -translation crlf + set out [open $path(test2) w] + chan configure $out -translation lf + fcopy $in $out + close $in + close $out + file size $path(test2) +} 29 +test io-52.14.1 {coverage of -translation crlf} { + file delete $path(test1) $path(test2) + set out [open $path(test1) wb] + chan configure $out -translation lf + puts -nonewline $out abcdefg\rhijklmn\nopqrstu\r\nvwxyz + close $out + set in [open $path(test1)] + chan configure $in -buffersize 8 -translation crlf + set out [open $path(test2) w] + fcopy $in $out -size 2 + close $in + close $out + file size $path(test2) +} 2 +test io-52.14.2 {coverage of -translation crlf} { + file delete $path(test1) $path(test2) + set out [open $path(test1) wb] + chan configure $out -translation lf + puts -nonewline $out abcdefg\rhijklmn\nopqrstu\r\nvwxyz + close $out + set in [open $path(test1)] + chan configure $in -translation crlf + set out [open $path(test2) w] + fcopy $in $out -size 9 + close $in + close $out + file size $path(test2) +} 9 +test io-52.15 {coverage of -translation crlf} { + file delete $path(test1) $path(test2) + set out [open $path(test1) wb] + chan configure $out -translation lf + puts -nonewline $out abcdefg\r + close $out + set in [open $path(test1)] + chan configure $in -buffersize 8 -translation crlf + set out [open $path(test2) w] + fcopy $in $out + close $in + close $out + file size $path(test2) +} 8 +test io-52.16 {coverage of eofChar handling} { + file delete $path(test1) $path(test2) + set out [open $path(test1) wb] + chan configure $out -translation lf + puts -nonewline $out abcdefg\rhijklmn\nopqrstu\r\nvwxyz + close $out + set in [open $path(test1)] + chan configure $in -buffersize 8 -translation lf -eofchar a + set out [open $path(test2) w] + fcopy $in $out + close $in + close $out + file size $path(test2) +} 0 +test io-52.17 {coverage of eofChar handling} { + file delete $path(test1) $path(test2) + set out [open $path(test1) wb] + chan configure $out -translation lf + puts -nonewline $out abcdefg\rhijklmn\nopqrstu\r\nvwxyz + close $out + set in [open $path(test1)] + chan configure $in -buffersize 8 -translation lf -eofchar d + set out [open $path(test2) w] + fcopy $in $out + close $in + close $out + file size $path(test2) +} 3 +test io-52.18 {coverage of eofChar handling} { + file delete $path(test1) $path(test2) + set out [open $path(test1) wb] + chan configure $out -translation lf + puts -nonewline $out abcdefg\rhijklmn\nopqrstu\r\nvwxyz + close $out + set in [open $path(test1)] + chan configure $in -buffersize 8 -translation crlf -eofchar h + set out [open $path(test2) w] + fcopy $in $out + close $in + close $out + file size $path(test2) +} 8 +test io-52.19 {coverage of eofChar handling} { + file delete $path(test1) $path(test2) + set out [open $path(test1) wb] + chan configure $out -translation lf + puts -nonewline $out abcdefg\rhijklmn\nopqrstu\r\nvwxyz + close $out + set in [open $path(test1)] + chan configure $in -buffersize 10 -translation crlf -eofchar h + set out [open $path(test2) w] + fcopy $in $out + close $in + close $out + file size $path(test2) +} 8 + test io-53.1 {CopyData} {fcopy} { file delete $path(test1) set f1 [open $thisScript] @@ -6823,17 +7177,12 @@ test io-53.4 {CopyData: background write overflow} {stdio unix openpipe fileeven for {set x 0} {$x < 12} {incr x} { append big $big } - file delete $path(test1) file delete $path(pipe) set f1 [open $path(pipe) w] puts $f1 { puts ready fcopy stdin stdout -command { set x } vwait x - set f [open $path(test1) w] - fconfigure $f -translation lf - puts $f "done" - close $f } close $f1 set f1 [open "|[list [interpreter] $path(pipe)]" r+] @@ -6841,7 +7190,6 @@ test io-53.4 {CopyData: background write overflow} {stdio unix openpipe fileeven fconfigure $f1 -blocking 0 puts $f1 $big flush $f1 - after 500 set result "" fileevent $f1 read [namespace code { append result [read $f1 1024] @@ -7223,6 +7571,25 @@ test io-53.11 {Bug 2895565} -setup { removeFile out removeFile in } -result {40 bytes copied} +test io-53.12 {CopyData: foreground short reads, aka bug 3096275} {stdio unix openpipe fcopy} { + file delete $path(pipe) + set f1 [open $path(pipe) w] + puts -nonewline $f1 { + fconfigure stdin -translation binary -blocking 0 + fconfigure stdout -buffering none -translation binary + fcopy stdin stdout + } + close $f1 + set f1 [open "|[list [interpreter] $path(pipe)]" r+] + fconfigure $f1 -translation binary -buffering none + puts -nonewline $f1 A + after 2000 {set ::done timeout} + fileevent $f1 readable {set ::done ok} + vwait ::done + set ch [read $f1 1] + close $f1 + list $::done $ch +} {ok A} test io-54.1 {Recursive channel events} {socket fileevent} { # This test checks to see if file events are delivered during recursive diff --git a/tests/ioCmd.test b/tests/ioCmd.test index 03242be..8d35ec7 100644 --- a/tests/ioCmd.test +++ b/tests/ioCmd.test @@ -639,7 +639,7 @@ test iocmd-15.9 {Tcl_FcopyObjCmd} {fcopy} { } "1 {channel \"$rfile\" wasn't opened for writing}" test iocmd-15.10 {Tcl_FcopyObjCmd} {fcopy} { list [catch {fcopy $rfile $wfile foo bar} msg] $msg -} {1 {bad switch "foo": must be -size or -command}} +} {1 {bad option "foo": must be -size or -command}} test iocmd-15.11 {Tcl_FcopyObjCmd} {fcopy} { list [catch {fcopy $rfile $wfile -size foo} msg] $msg } {1 {expected integer but got "foo"}} @@ -793,6 +793,90 @@ test iocmd-21.19 {chan create, init failure -> no channel, no finalize} -match g rename foo {} set res } -result {{} {initialize rc* {read write}} 1 {*all required methods*} {}} +test iocmd-21.20 {Bug 88aef05cda} -setup { + proc foo {method chan args} { + switch -- $method blocking { + chan configure $chan -blocking [lindex $args 0] + return + } initialize { + return {initialize finalize watch blocking read write + configure cget cgetall} + } finalize { + return + } + } + set ch [chan create {read write} foo] +} -body { + list [catch {chan configure $ch -blocking 0} m] $m +} -cleanup { + close $ch + rename foo {} +} -match glob -result {1 {*nested eval*}} +test iocmd-21.21 {[close] in [read] segfaults} -setup { + proc foo {method chan args} { + switch -- $method initialize { + return {initialize finalize watch read} + } finalize {} watch {} read { + close $chan + return a + } + } + set ch [chan create read foo] +} -body { + read $ch 0 +} -cleanup { + close $ch + rename foo {} +} -result {} +test iocmd-21.22 {[close] in [read] segfaults} -setup { + proc foo {method chan args} { + switch -- $method initialize { + return {initialize finalize watch read} + } finalize {} watch {} read { + catch {close $chan} + return a + } + } + set ch [chan create read foo] +} -body { + read $ch 1 +} -returnCodes error -cleanup { + catch {close $ch} + rename foo {} +} -match glob -result {*invalid argument*} +test iocmd-21.23 {[close] in [gets] segfaults} -setup { + proc foo {method chan args} { + switch -- $method initialize { + return {initialize finalize watch read} + } finalize {} watch {} read { + catch {close $chan} + return \n + } + } + set ch [chan create read foo] +} -body { + gets $ch +} -cleanup { + catch {close $ch} + rename foo {} +} -result {} +test iocmd-21.24 {[close] in binary [gets] segfaults} -setup { + proc foo {method chan args} { + switch -- $method initialize { + return {initialize finalize watch read} + } finalize {} watch {} read { + catch {close $chan} + return \n + } + } + set ch [chan create read foo] +} -body { + chan configure $ch -translation binary + gets $ch +} -cleanup { + catch {close $ch} + rename foo {} +} -result {} # --- --- --- --------- --------- --------- # Helper commands to record the arguments to handler methods. @@ -1051,6 +1135,20 @@ test iocmd-23.10 {chan read, EAGAIN means no data, yet no eof either} -match glo rename foo {} unset res } -result {{read rc* 4096} {} 0} +test iocmd-23.11 {chan read, close pulls the rug out} -match glob -body { + set res {} + proc foo {args} { + oninit; onfinal; track + set args [lassign $args sub id] + if {$sub ne "read"} {return} + close $id + return {} + } + set c [chan create {r} foo] + note [read $c] + rename foo {} + set res +} -result {{read rc* 4096} {}} # --- === *** ########################### # method write @@ -1978,13 +2076,13 @@ test iocmd-32.1 {origin interpreter of moved channel destroyed during access} -m proc foo {args} { oninit; onfinal; track; # destroy interpreter during channel access - # Actually not possible for an interp to destroy itself. - interp delete {} - return} + suicide + } set chan [chan create {r w} foo] fconfigure $chan -buffering none set chan }] + interp alias $ida suicide {} interp delete $ida # Move channel to 2nd thread. interp eval $ida [list testchannel cut $chan] @@ -2002,8 +2100,7 @@ test iocmd-32.1 {origin interpreter of moved channel destroyed during access} -m set res }] set res -} -constraints {testchannel impossible} \ - -result {Owner lost} +} -constraints {testchannel} -result {Owner lost} test iocmd-32.2 {delete interp of reflected chan} { # Bug 3034840 @@ -2726,10 +2823,11 @@ test iocmd.tf-24.17.bug3522560 {postevent for transfered channel} \ set res } -cleanup { + after cancel $::timer rename LOG {} rename POST {} rename HANDLER {} - unset beat drive data forever res tid ch + unset beat drive data forever res tid ch timer } -match glob \ -result {{initialize rc* read} {watch rc* read} {read rc* 4096} {watch rc* {}} {watch rc* read} {read rc* 4096} {watch rc* {}} {finalize rc*}} diff --git a/tests/ioTrans.test b/tests/ioTrans.test index 5a8874c..c40621b 100644 --- a/tests/ioTrans.test +++ b/tests/ioTrans.test @@ -539,7 +539,46 @@ test iortrans-4.8 {chan read, read, bug 2921116} -setup { tempdone rename foo {} } -result {{read rt* {test data -}} file*} +}} {}} +test iortrans-4.8.1 {chan read, bug 721ec69271} -setup { + set res {} +} -match glob -body { + proc foo {fd args} { + handle.initialize + handle.finalize + lappend ::res $args + # Kill and recreate transform while it is operating + chan pop $fd + chan push $fd [list foo $fd] + } + set c [chan push [set c [tempchan]] [list foo $c]] + chan configure $c -buffersize 2 + lappend res [read $c] +} -cleanup { + tempdone + rename foo {} +} -result {{read rt* te} {read rt* st} {read rt* { d}} {read rt* at} {read rt* {a +}} {}} +test iortrans-4.8.2 {chan read, bug 721ec69271} -setup { + set res {} +} -match glob -body { + proc foo {fd args} { + handle.initialize + handle.finalize + lappend ::res $args + # Kill and recreate transform while it is operating + chan pop $fd + chan push $fd [list foo $fd] + return x + } + set c [chan push [set c [tempchan]] [list foo $c]] + chan configure $c -buffersize 1 + lappend res [read $c] +} -cleanup { + tempdone + rename foo {} +} -result {{read rt* t} {read rt* e} {read rt* s} {read rt* t} {read rt* { }} {read rt* d} {read rt* a} {read rt* t} {read rt* a} {read rt* { +}} {}} test iortrans-4.9 {chan read, gets, bug 2921116} -setup { set res {} } -match glob -body { @@ -557,7 +596,7 @@ test iortrans-4.9 {chan read, gets, bug 2921116} -setup { tempdone rename foo {} } -result {{read rt* {test data -}} file*} +}} {}} # --- === *** ########################### # method write (via puts) @@ -995,7 +1034,7 @@ test iortrans-11.1 {origin interpreter of moved transform destroyed during acces # Magic to get the test* commands in the slaves load {} Tcltest $ida load {} Tcltest $idb -} -constraints {testchannel impossible} -match glob -body { +} -constraints {testchannel} -match glob -body { # Set up channel in thread set chan [interp eval $ida $helperscript] set chan [interp eval $ida { @@ -1003,14 +1042,14 @@ test iortrans-11.1 {origin interpreter of moved transform destroyed during acces handle.initialize clear drain flush limit? read write handle.finalize lappend ::res $args - # Destroy interpreter during channel access. Actually not - # possible for an interp to destroy itself. - interp delete {} - return} + # Destroy interpreter during channel access. + suicide + } set chan [chan push [tempchan] foo] fconfigure $chan -buffering none set chan }] + interp alias $ida suicide {} interp delete $ida # Move channel to 2nd thread, transform goes with it. interp eval $ida [list testchannel cut $chan] interp eval $idb [list testchannel splice $chan] diff --git a/tests/iogt.test b/tests/iogt.test index d4c31d2..6cc0542 100644 --- a/tests/iogt.test +++ b/tests/iogt.test @@ -220,6 +220,36 @@ proc id_fulltrail {var op data} { return $res } +proc id_torture {chan op data} { + switch -- $op { + create/write - + create/read - + delete/write - + delete/read - + clear_read {;#ignore} + flush/write - + flush/read {} + write { + global level + if {$level} { + return + } + incr level + testchannel unstack $chan + testchannel transform $chan \ + -command [namespace code [list id_torture $chan]] + return $data + } + read { + testchannel unstack $chan + testchannel transform $chan \ + -command [namespace code [list id_torture $chan]] + return $data + } + query/maxRead {return -1} + } +} + proc counter {var op data} { namespace upvar [namespace current] $var n @@ -280,7 +310,7 @@ proc counter_audit {var vtrail op data} { } proc rblocks {var vtrail n op data} { - namespace upvar [namespace current] $var n $vtrail trail + namespace upvar [namespace current] $var buf $vtrail trail set res {} @@ -326,6 +356,11 @@ proc audit_ops {var -attach channel} { proc audit_flow {var -attach channel} { testchannel transform $channel -command [namespace code [list id_fulltrail $var]] } + +proc torture {-attach channel} { + testchannel transform $channel -command [namespace code [list id_torture $channel]] +} + proc stopafter {var n -attach channel} { namespace upvar [namespace current] $var vn set vn $n @@ -445,6 +480,7 @@ query/maxRead read query/maxRead flush/read +query/maxRead delete/read -------- create/write @@ -491,6 +527,7 @@ read { } query/maxRead {} -1 flush/read {} {} +query/maxRead {} -1 delete/read {} *ignored* -------- create/write {} *ignored* @@ -542,15 +579,35 @@ write %^&*()_+-= %^&*()_+-= write { } { } +query/maxRead {} -1 delete/read {} *ignored* flush/write {} {} delete/write {} *ignored*} +test iogt-2.4 {basic I/O, mixed trail} {testchannel} { + set fh [open $path(dummy) r] + torture -attach $fh + chan configure $fh -buffersize 2 + set x [read $fh] + testchannel unstack $fh + close $fh + set x +} {} +test iogt-2.5 {basic I/O, mixed trail} {testchannel} { + set ::level 0 + set fh [open $path(dummyout) w] + torture -attach $fh + puts -nonewline $fh abcdef + flush $fh + testchannel unstack $fh + close $fh +} {} + test iogt-3.0 {Tcl_Channel valid after stack/unstack, fevent handling} -setup { proc DoneCopy {n {err {}}} { variable copy 1 } -} -constraints {testchannel hangs} -body { +} -constraints {testchannel knownBug} -body { # This test to check the validity of aquired Tcl_Channel references is not # possible because even a backgrounded fcopy will immediately start to # copy data, without waiting for the event loop. This is done only in case @@ -561,6 +618,7 @@ test iogt-3.0 {Tcl_Channel valid after stack/unstack, fevent handling} -setup { # delay, causing the fcopy to underflow immediately. set fin [open $path(dummy) r] fevent 1000 500 {20 20 20 10 1 1} { + variable copy close $fin set fout [open dummyout w] flush $sock; # now, or fcopy will error us out @@ -594,23 +652,30 @@ test iogt-4.0 {fileevent readable, after transform} -setup { proc Done {args} { variable stop 1 } -} -constraints {testchannel hangs} -body { + proc Get {sock} { + variable trail + variable got + if {[eof $sock]} { + Done + lappend trail "xxxxxxxxxxxxx" + close $sock + return + } + lappend trail "vvvvvvvvvvvvv" + lappend trail "\tgot: [lappend got "\[\[[read $sock]\]\]"]" + lappend trail "=============" + #puts stdout $__ ; flush stdout + #read $sock + } + +} -constraints {testchannel knownBug} -body { fevent 1000 500 {20 20 20 10 1} { + variable stop audit_flow trail -attach $sock rblocks_t rbuf trail 23 -attach $sock - fileevent $sock readable [namespace code { - if {[eof $sock]} { - Done - lappend trail "xxxxxxxxxxxxx" - close $sock - } else { - lappend trail "vvvvvvvvvvvvv" - lappend trail "\tgot: [lappend got "\[\[[read $sock]\]\]"]" - lappend trail "=============" - #puts stdout $__; flush stdout - #read $sock - } - }] + + fileevent $sock readable [namespace code [list Get $sock]] + flush $sock; # Now, or fcopy will error us out # But the 1 second delay should be enough to initialize everything # else here. @@ -619,6 +684,7 @@ test iogt-4.0 {fileevent readable, after transform} -setup { join [list [join $got \n] ~~~~~~~~ [join $trail \n]] \n } -cleanup { rename Done {} + rename Get {} } -result {[[]] [[abcdefghijklmnopqrstuvw]] [[xyz0123456789,./?><;'\|]] @@ -706,7 +772,7 @@ test iogt-5.0 {EOF simulation} -setup { set fin [open $path(dummy) r] set fout [open $path(dummyout) w] set trail [list] -} -constraints {testchannel unknownFailure} -result { +} -constraints {testchannel knownBug} -result { audit_flow trail -attach $fin stopafter_audit d trail 20 -attach $fin audit_flow trail -attach $fout @@ -785,6 +851,15 @@ test iogt-6.0 {Push back} -constraints testchannel -body { close $f } -result {xxx} test iogt-6.1 {Push back and up} -constraints {testchannel knownBug} -body { + + # This test demonstrates the bug/misfeature in the stacked + # channel implementation that data can be discarded if it is + # read into the buffers of one channel in the stack, and then + # that channel is popped before anything above it reads. + # + # This bug can be worked around by always setting -buffersize + # to 1, but who wants to do that? + set f [open $path(dummy) r] # contents of dummy = "abcdefghi..." read $f 3; # skip behind "abc" diff --git a/tests/namespace.test b/tests/namespace.test index 8c4b81c..cded1f4 100644 --- a/tests/namespace.test +++ b/tests/namespace.test @@ -303,7 +303,7 @@ test namespace-9.4 {Tcl_Import, simple import} { } test_ns_import::p } {cmd1: 123} -test namespace-9.5 {Tcl_Import, can't redefine cmd unless allowOverwrite!=0} { +test namespace-9.5 {Tcl_Import, RFE 1230597} { list [catch {namespace eval test_ns_import {namespace import ::test_ns_export::*}} msg] $msg } {0 {}} test namespace-9.6 {Tcl_Import, cmd redefinition ok if allowOverwrite!=0} { @@ -2949,6 +2949,10 @@ test namespace-54.1 {leak on namespace deletion} -constraints {memory} \ rename getbytes {} unset i ns start end } -result 0 + +test namespace-55.1 {compiled ensembles inside compiled ensembles: Bug 6d2f249a01} { + info class [format %s constructor] oo::object +} "" # cleanup catch {rename cmd1 {}} diff --git a/tests/obj.test b/tests/obj.test index 71a39b4..151abfb 100644 --- a/tests/obj.test +++ b/tests/obj.test @@ -605,7 +605,7 @@ test obj-33.2 {integer overflow on input} {longIs32bit wideBiggerThanInt} { set x 0xffff; append x ffff list [string is integer $x] [expr { wide($x) }] } {1 4294967295} -test obj-33.3 {integer overflow on input} {longIs32bit wideBiggerThanInt} { +test obj-33.3 {integer overflow on input} { set x 0x10000; append x 0000 list [string is integer $x] [expr { wide($x) }] } {0 4294967296} @@ -621,7 +621,7 @@ test obj-33.6 {integer overflow on input} {longIs32bit wideBiggerThanInt} { set x -0xffff; append x ffff list [string is integer $x] [expr { wide($x) }] } {1 -4294967295} -test obj-33.7 {integer overflow on input} {longIs32bit wideBiggerThanInt} { +test obj-33.7 {integer overflow on input} { set x -0x10000; append x 0000 list [string is integer $x] [expr { wide($x) }] } {0 -4294967296} diff --git a/tests/regexp.test b/tests/regexp.test index 1b2bec9..a83c99b 100644 --- a/tests/regexp.test +++ b/tests/regexp.test @@ -241,13 +241,13 @@ test regexp-5.5 {exercise cache of compiled expressions} { test regexp-6.1 {regexp errors} { list [catch {regexp a} msg] $msg -} {1 {wrong # args: should be "regexp ?-switch ...? exp string ?matchVar? ?subMatchVar ...?"}} +} {1 {wrong # args: should be "regexp ?-option ...? exp string ?matchVar? ?subMatchVar ...?"}} test regexp-6.2 {regexp errors} { list [catch {regexp -nocase a} msg] $msg -} {1 {wrong # args: should be "regexp ?-switch ...? exp string ?matchVar? ?subMatchVar ...?"}} +} {1 {wrong # args: should be "regexp ?-option ...? exp string ?matchVar? ?subMatchVar ...?"}} test regexp-6.3 {regexp errors} { list [catch {regexp -gorp a} msg] $msg -} {1 {bad switch "-gorp": must be -all, -about, -indices, -inline, -expanded, -line, -linestop, -lineanchor, -nocase, -start, or --}} +} {1 {bad option "-gorp": must be -all, -about, -indices, -inline, -expanded, -line, -linestop, -lineanchor, -nocase, -start, or --}} test regexp-6.4 {regexp errors} { list [catch {regexp a( b} msg] $msg } {1 {couldn't compile regular expression pattern: parentheses () not balanced}} @@ -441,19 +441,19 @@ test regexp-10.5 {inverse partial newline sensitivity in regsub} { test regexp-11.1 {regsub errors} { list [catch {regsub a b} msg] $msg -} {1 {wrong # args: should be "regsub ?-switch ...? exp string subSpec ?varName?"}} +} {1 {wrong # args: should be "regsub ?-option ...? exp string subSpec ?varName?"}} test regexp-11.2 {regsub errors} { list [catch {regsub -nocase a b} msg] $msg -} {1 {wrong # args: should be "regsub ?-switch ...? exp string subSpec ?varName?"}} +} {1 {wrong # args: should be "regsub ?-option ...? exp string subSpec ?varName?"}} test regexp-11.3 {regsub errors} { list [catch {regsub -nocase -all a b} msg] $msg -} {1 {wrong # args: should be "regsub ?-switch ...? exp string subSpec ?varName?"}} +} {1 {wrong # args: should be "regsub ?-option ...? exp string subSpec ?varName?"}} test regexp-11.4 {regsub errors} { list [catch {regsub a b c d e f} msg] $msg -} {1 {wrong # args: should be "regsub ?-switch ...? exp string subSpec ?varName?"}} +} {1 {wrong # args: should be "regsub ?-option ...? exp string subSpec ?varName?"}} test regexp-11.5 {regsub errors} { list [catch {regsub -gorp a b c} msg] $msg -} {1 {bad switch "-gorp": must be -all, -nocase, -expanded, -line, -linestop, -lineanchor, -start, or --}} +} {1 {bad option "-gorp": must be -all, -nocase, -expanded, -line, -linestop, -lineanchor, -start, or --}} test regexp-11.6 {regsub errors} { list [catch {regsub -nocase a( b c d} msg] $msg } {1 {couldn't compile regular expression pattern: parentheses () not balanced}} diff --git a/tests/regexpComp.test b/tests/regexpComp.test index 94fb90e..7be1195 100644 --- a/tests/regexpComp.test +++ b/tests/regexpComp.test @@ -316,17 +316,17 @@ test regexpComp-6.1 {regexp errors} { evalInProc { list [catch {regexp a} msg] $msg } -} {1 {wrong # args: should be "regexp ?-switch ...? exp string ?matchVar? ?subMatchVar ...?"}} +} {1 {wrong # args: should be "regexp ?-option ...? exp string ?matchVar? ?subMatchVar ...?"}} test regexpComp-6.2 {regexp errors} { evalInProc { list [catch {regexp -nocase a} msg] $msg } -} {1 {wrong # args: should be "regexp ?-switch ...? exp string ?matchVar? ?subMatchVar ...?"}} +} {1 {wrong # args: should be "regexp ?-option ...? exp string ?matchVar? ?subMatchVar ...?"}} test regexpComp-6.3 {regexp errors} { evalInProc { list [catch {regexp -gorp a} msg] $msg } -} {1 {bad switch "-gorp": must be -all, -about, -indices, -inline, -expanded, -line, -linestop, -lineanchor, -nocase, -start, or --}} +} {1 {bad option "-gorp": must be -all, -about, -indices, -inline, -expanded, -line, -linestop, -lineanchor, -nocase, -start, or --}} test regexpComp-6.4 {regexp errors} { evalInProc { list [catch {regexp a( b} msg] $msg @@ -562,27 +562,27 @@ test regexpComp-11.1 {regsub errors} { evalInProc { list [catch {regsub a b} msg] $msg } -} {1 {wrong # args: should be "regsub ?-switch ...? exp string subSpec ?varName?"}} +} {1 {wrong # args: should be "regsub ?-option ...? exp string subSpec ?varName?"}} test regexpComp-11.2 {regsub errors} { evalInProc { list [catch {regsub -nocase a b} msg] $msg } -} {1 {wrong # args: should be "regsub ?-switch ...? exp string subSpec ?varName?"}} +} {1 {wrong # args: should be "regsub ?-option ...? exp string subSpec ?varName?"}} test regexpComp-11.3 {regsub errors} { evalInProc { list [catch {regsub -nocase -all a b} msg] $msg } -} {1 {wrong # args: should be "regsub ?-switch ...? exp string subSpec ?varName?"}} +} {1 {wrong # args: should be "regsub ?-option ...? exp string subSpec ?varName?"}} test regexpComp-11.4 {regsub errors} { evalInProc { list [catch {regsub a b c d e f} msg] $msg } -} {1 {wrong # args: should be "regsub ?-switch ...? exp string subSpec ?varName?"}} +} {1 {wrong # args: should be "regsub ?-option ...? exp string subSpec ?varName?"}} test regexpComp-11.5 {regsub errors} { evalInProc { list [catch {regsub -gorp a b c} msg] $msg } -} {1 {bad switch "-gorp": must be -all, -nocase, -expanded, -line, -linestop, -lineanchor, -start, or --}} +} {1 {bad option "-gorp": must be -all, -nocase, -expanded, -line, -linestop, -lineanchor, -start, or --}} test regexpComp-11.6 {regsub errors} { evalInProc { list [catch {regsub -nocase a( b c d} msg] $msg diff --git a/tests/socket.test b/tests/socket.test index 51219e6..2bd2731 100644 --- a/tests/socket.test +++ b/tests/socket.test @@ -86,8 +86,21 @@ puts $s2 test1; gets $s1 puts $s2 test2; gets $s1 close $s1; close $s2 set t2 [clock milliseconds] -set latency [expr {($t2-$t1)*2}]; # doubled as a safety margin -unset t1 t2 s1 s2 server +set lat1 [expr {($t2-$t1)*2}]; # doubled as a safety margin + +# Test the latency of failed connection attempts over the loopback +# interface. They can take more than a second under Windowos and requres +# additional [after]s in some tests that are not needed on systems that fail +# immediately. +set t1 [clock milliseconds] +catch {socket 127.0.0.1 [randport]} +set t2 [clock milliseconds] +set lat2 [expr {($t2-$t1)*3}] + +# Use the maximum of the two latency calculations, but at least 100ms +set latency [expr {$lat1 > $lat2 ? $lat1 : $lat2}] +set latency [expr {$latency > 100 ? $latency : 1000}] +unset t1 t2 s1 s2 lat1 lat2 server # If remoteServerIP or remoteServerPort are not set, check in the environment # variables for externally set values. @@ -124,7 +137,6 @@ foreach {af localhost} { testConstraint supported_$af [expr {![catch {socket -server foo -myaddr $localhost 0} sock]}] catch {close $sock} } -testConstraint supported_any [expr {[testConstraint supported_inet] || [testConstraint supported_inet6]}] set sock [socket -server foo -myaddr localhost 0] set sockname [fconfigure $sock -sockname] @@ -138,6 +150,9 @@ foreach {af localhost} { inet 127.0.0.1 inet6 ::1 } { + if {![testConstraint supported_$af]} { + continue + } set ::tcl::unsupported::socketAF $af # # Check if we're supposed to do tests against the remote server @@ -625,6 +640,86 @@ test socket_$af-2.11 {detecting new data} -constraints [list socket supported_$a close $s close $sock } -result {a:one b: c:two} +test socket_$af-2.12 {} [list socket stdio supported_$af] { + file delete $path(script) + set f [open $path(script) w] + puts $f { + set server [socket -server accept_client 0] + puts [lindex [chan configure $server -sockname] 2] + proc accept_client { client host port } { + chan configure $client -blocking 0 -buffering line + write_line $client + } + proc write_line client { + if { [catch { chan puts $client [string repeat . 720000]}] } { + puts [catch {chan close $client}] + } else { + puts signal1 + after 0 write_line $client + } + } + chan event stdin readable {set forever now} + vwait forever + exit + } + close $f + set f [open "|[list [interpreter] $path(script)]" r+] + gets $f port + set sock [socket $localhost $port] + chan event $sock readable [list read_lines $sock $f] + proc read_lines { sock pipe } { + gets $pipe + chan close $sock + chan event $pipe readable [list readpipe $pipe] + } + proc readpipe {pipe} { + while {![string is integer [set ::done [gets $pipe]]]} {} + } + vwait ::done + close $f + set ::done +} 0 +test socket_$af-2.13 {Bug 1758a0b603} {socket stdio} { + file delete $path(script) + set f [open $path(script) w] + puts $f { + set server [socket -server accept 0] + puts [lindex [chan configure $server -sockname] 2] + proc accept { client host port } { + chan configure $client -blocking 0 -buffering line -buffersize 1 + puts $client [string repeat . 720000] + puts ready + chan event $client writable [list setup $client] + } + proc setup client { + chan event $client writable {set forever write} + after 5 {set forever timeout} + } + vwait forever + puts $forever + } + close $f + set pipe [open |[list [interpreter] $path(script)] r] + gets $pipe port + set sock [socket $localhost $port] + chan configure $sock -blocking 0 -buffering line + chan event $sock readable [list read_lines $sock $pipe ] + proc read_lines { sock pipe } { + gets $pipe + gets $sock line + after idle [list stop $sock $pipe] + chan event $sock readable {} + } + proc stop {sock pipe} { + variable done + close $sock + set done [gets $pipe] + } + variable done + vwait [namespace which -variable done] + close $pipe + set done +} write test socket_$af-3.1 {socket conflict} -constraints [list socket supported_$af stdio] -setup { file delete $path(script) @@ -1560,8 +1655,8 @@ test socket_$af-12.2 {testing inheritance of client sockets} -setup { close $f # If the socket doesn't hit end-of-file in 10 seconds, the script1 process # must have inherited the client. - set failed 0 - set after [after 10000 [list set failed 1]] + set timeout 0 + set after [after 10000 {set x "client socket was inherited"}] } -constraints [list socket supported_$af stdio exec] -body { # Create the server socket set server [socket -server accept -myaddr $localhost 0] @@ -1571,26 +1666,20 @@ test socket_$af-12.2 {testing inheritance of client sockets} -setup { close $server fileevent $file readable [list getdata $file] fconfigure $file -buffering line -blocking 0 + set ::f $file } proc getdata { file } { # Read handler on the accepted socket. - global x failed + global x set status [catch {read $file} data] if {$status != 0} { - set x {read failed, error was $data} - catch { close $file } + set x "read failed, error was $data" } elseif {$data ne ""} { } elseif {[fblocked $file]} { } elseif {[eof $file]} { - if {$failed} { - set x {client socket was inherited} - } else { - set x {client socket was not inherited} - } - catch { close $file } + set x "client socket was not inherited" } else { - set x {impossible case} - catch { close $file } + set x "impossible case" } } # Launch the script2 process @@ -1600,6 +1689,8 @@ test socket_$af-12.2 {testing inheritance of client sockets} -setup { vwait x return $x } -cleanup { + fconfigure $f -blocking 1 + close $f after cancel $after close $p } -result {client socket was not inherited} @@ -1641,35 +1732,30 @@ test socket_$af-12.3 {testing inheritance of accepted sockets} -setup { # If the socket is still open after 5 seconds, the script1 process must # have inherited the accepted socket. set failed 0 - set after [after 5000 [list set failed 1]] + set after [after 5000 [list set x "accepted socket was inherited"]] proc getdata { file } { # Read handler on the client socket. global x global failed set status [catch {read $file} data] if {$status != 0} { - set x {read failed, error was $data} - catch { close $file } + set x "read failed, error was $data" } elseif {[string compare {} $data]} { } elseif {[fblocked $file]} { } elseif {[eof $file]} { - if {$failed} { - set x {accepted socket was inherited} - } else { - set x {accepted socket was not inherited} - } - catch { close $file } + set x "accepted socket was not inherited" } else { - set x {impossible case} - catch { close $file } + set x "impossible case" } return } vwait x - return $x + set x } -cleanup { + fconfigure $f -blocking 1 + close $f after cancel $after - catch {close $p} + close $p } -result {accepted socket was not inherited} test socket_$af-13.1 {Testing use of shared socket between two threads} -body { @@ -1723,8 +1809,8 @@ catch {close $commandSocket} catch {close $remoteProcChan} } unset ::tcl::unsupported::socketAF -test socket-14.0 {[socket -async] when server only listens on IPv4} \ - -constraints [list socket supported_any localhost_v4] \ +test socket-14.0.0 {[socket -async] when server only listens on IPv4} \ + -constraints {socket supported_inet localhost_v4} \ -setup { proc accept {s a p} { global x @@ -1736,7 +1822,29 @@ test socket-14.0 {[socket -async] when server only listens on IPv4} \ set port [lindex [fconfigure $server -sockname] 2] } -body { set client [socket -async localhost $port] - set after [after 1000 {set x [fconfigure $client -error]}] + set after [after $latency {set x [fconfigure $client -error]}] + vwait x + set x + } -cleanup { + after cancel $after + close $server + close $client + unset x + } -result ok +test socket-14.0.1 {[socket -async] when server only listens on IPv6} \ + -constraints {socket supported_inet6 localhost_v6} \ + -setup { + proc accept {s a p} { + global x + puts $s bye + close $s + set x ok + } + set server [socket -server accept -myaddr ::1 0] + set port [lindex [fconfigure $server -sockname] 2] + } -body { + set client [socket -async localhost $port] + set after [after $latency {set x [fconfigure $client -error]}] vwait x set x } -cleanup { @@ -1746,7 +1854,7 @@ test socket-14.0 {[socket -async] when server only listens on IPv4} \ unset x } -result ok test socket-14.1 {[socket -async] fileevent while still connecting} \ - -constraints [list socket supported_any] \ + -constraints {socket} \ -setup { proc accept {s a p} { global x @@ -1763,7 +1871,7 @@ test socket-14.1 {[socket -async] fileevent while still connecting} \ lappend x [fconfigure $client -error] fileevent $client writable {} } - set after [after 1000 {lappend x timeout}] + set after [after $latency {lappend x timeout}] while {[llength $x] < 2 && "timeout" ni $x} { vwait x } @@ -1775,26 +1883,21 @@ test socket-14.1 {[socket -async] fileevent while still connecting} \ unset x } -result {{} ok} test socket-14.2 {[socket -async] fileevent connection refused} \ - -constraints [list socket supported_any] \ + -constraints {socket} \ -body { - if {[catch {socket -async localhost [randport]} client]} { - regexp {[^:]*: (.*)} $client -> x - } else { - fileevent $client writable {set x [fconfigure $client -error]} - set after [after 1000 {set x timeout}] - vwait x - after cancel $after - if {$x eq "timeout"} { - append x ": [fconfigure $client -error]" - } - close $client - } - set x + set client [socket -async localhost [randport]] + fileevent $client writable {set x ok} + set after [after $latency {set x timeout}] + vwait x + after cancel $after + lappend x [fconfigure $client -error] } -cleanup { - unset x - } -result "connection refused" + after cancel $after + close $client + unset x after client + } -result {ok {connection refused}} test socket-14.3 {[socket -async] when server only listens on IPv6} \ - -constraints [list socket supported_any localhost_v6] \ + -constraints {socket supported_inet6 localhost_v6} \ -setup { proc accept {s a p} { global x @@ -1806,7 +1909,7 @@ test socket-14.3 {[socket -async] when server only listens on IPv6} \ set port [lindex [fconfigure $server -sockname] 2] } -body { set client [socket -async localhost $port] - set after [after 1000 {set x [fconfigure $client -error]}] + set after [after $latency {set x [fconfigure $client -error]}] vwait x set x } -cleanup { @@ -1816,7 +1919,7 @@ test socket-14.3 {[socket -async] when server only listens on IPv6} \ unset x } -result ok test socket-14.4 {[socket -async] and both, readdable and writable fileevents} \ - -constraints [list socket supported_any] \ + -constraints {socket} \ -setup { proc accept {s a p} { puts $s bye @@ -1832,7 +1935,7 @@ test socket-14.4 {[socket -async] and both, readdable and writable fileevents} \ fileevent $client writable {} } fileevent $client readable {lappend x [gets $client]} - set after [after 1000 {lappend x timeout}] + set after [after $latency {lappend x timeout}] while {[llength $x] < 2 && "timeout" ni $x} { vwait x } @@ -1843,20 +1946,23 @@ test socket-14.4 {[socket -async] and both, readdable and writable fileevents} \ close $server unset x } -result {{} bye} +# FIXME: we should also have an IPv6 counterpart of this test socket-14.5 {[socket -async] which fails before any connect() can be made} \ - -constraints [list socket supported_any] \ + -constraints {socket supported_inet} \ -body { # address from rfc5737 socket -async -myaddr 192.0.2.42 127.0.0.1 [randport] } \ -returnCodes 1 \ -result {couldn't open socket: cannot assign requested address} -test socket-14.6 {[socket -async] with no event loop and [fconfigure -error] before the socket is connected} \ - -constraints [list socket supported_inet supported_inet6] \ +test socket-14.6.0 {[socket -async] with no event loop and server listening on IPv4} \ + -constraints {socket supported_inet localhost_v4} \ -setup { proc accept {s a p} { + global x puts $s bye close $s + set x ok } set server [socket -server accept -myaddr 127.0.0.1 0] set port [lindex [fconfigure $server -sockname] 2] @@ -1864,19 +1970,390 @@ test socket-14.6 {[socket -async] with no event loop and [fconfigure -error] bef } \ -body { set client [socket -async localhost $port] - foreach _ {1 2} { - lappend x [lindex [fconfigure $client -sockname] 0] - lappend x [fconfigure $client -error] + for {set i 0} {$i < 50} {incr i } { update + if {$x ne ""} { + lappend x [gets $client] + break + } + after 100 } - lappend x [gets $client] + set x } \ -cleanup { close $server close $client unset x } \ - -result [list ::1 "connection refused" 127.0.0.1 "" bye] + -result {ok bye} +test socket-14.6.1 {[socket -async] with no event loop and server listening on IPv6} \ + -constraints {socket supported_inet6 localhost_v6} \ + -setup { + proc accept {s a p} { + global x + puts $s bye + close $s + set x ok + } + set server [socket -server accept -myaddr ::1 0] + set port [lindex [fconfigure $server -sockname] 2] + set x "" + } \ + -body { + set client [socket -async localhost $port] + for {set i 0} {$i < 50} {incr i } { + update + if {$x ne ""} { + lappend x [gets $client] + break + } + after 100 + } + set x + } \ + -cleanup { + close $server + close $client + unset x + } \ + -result {ok bye} +test socket-14.7.0 {pending [socket -async] and blocking [gets], server is IPv4} \ + -constraints {socket supported_inet localhost_v4} \ + -setup { + makeFile { + fileevent stdin readable exit + set server [socket -server accept -myaddr 127.0.0.1 0] + proc accept {s h p} {puts $s ok; close $s; set ::x 1} + puts [lindex [fconfigure $server -sockname] 2] + flush stdout + vwait x + } script + set fd [open |[list [interpreter] script] RDWR] + set port [gets $fd] + } -body { + set sock [socket -async localhost $port] + list [fconfigure $sock -error] [gets $sock] [fconfigure $sock -error] + } -cleanup { + close $fd + close $sock + } -result {{} ok {}} +test socket-14.7.1 {pending [socket -async] and blocking [gets], server is IPv6} \ + -constraints {socket supported_inet6 localhost_v6} \ + -setup { + makeFile { + fileevent stdin readable exit + set server [socket -server accept -myaddr ::1 0] + proc accept {s h p} {puts $s ok; close $s; set ::x 1} + puts [lindex [fconfigure $server -sockname] 2] + flush stdout + vwait x + } script + set fd [open |[list [interpreter] script] RDWR] + set port [gets $fd] + } -body { + set sock [socket -async localhost $port] + list [fconfigure $sock -error] [gets $sock] [fconfigure $sock -error] + } -cleanup { + close $fd + close $sock + } -result {{} ok {}} +test socket-14.7.2 {pending [socket -async] and blocking [gets], no listener} \ + -constraints {socket} \ + -body { + set sock [socket -async localhost [randport]] + catch {gets $sock} x + list $x [fconfigure $sock -error] [fconfigure $sock -error] + } -cleanup { + close $sock + } -match glob -result {{error reading "sock*": socket is not connected} {connection refused} {}} +test socket-14.8.0 {pending [socket -async] and nonblocking [gets], server is IPv4} \ + -constraints {socket supported_inet localhost_v4} \ + -setup { + makeFile { + fileevent stdin readable exit + set server [socket -server accept -myaddr 127.0.0.1 0] + proc accept {s h p} {puts $s ok; close $s; set ::x 1} + puts [lindex [fconfigure $server -sockname] 2] + flush stdout + vwait x + } script + set fd [open |[list [interpreter] script] RDWR] + set port [gets $fd] + } -body { + set sock [socket -async localhost $port] + fconfigure $sock -blocking 0 + for {set i 0} {$i < 50} {incr i } { + if {[catch {gets $sock} x] || $x ne "" || ![fblocked $sock]} break + after 200 + } + set x + } -cleanup { + close $fd + close $sock + } -result {ok} +test socket-14.8.1 {pending [socket -async] and nonblocking [gets], server is IPv6} \ + -constraints {socket supported_inet6 localhost_v6} \ + -setup { + makeFile { + fileevent stdin readable exit + set server [socket -server accept -myaddr ::1 0] + proc accept {s h p} {puts $s ok; close $s; set ::x 1} + puts [lindex [fconfigure $server -sockname] 2] + flush stdout + vwait x + } script + set fd [open |[list [interpreter] script] RDWR] + set port [gets $fd] + } -body { + set sock [socket -async localhost $port] + fconfigure $sock -blocking 0 + for {set i 0} {$i < 50} {incr i } { + if {[catch {gets $sock} x] || $x ne "" || ![fblocked $sock]} break + after 200 + } + set x + } -cleanup { + close $fd + close $sock + } -result {ok} +test socket-14.8.2 {pending [socket -async] and nonblocking [gets], no listener} \ + -constraints {socket} \ + -body { + set sock [socket -async localhost [randport]] + fconfigure $sock -blocking 0 + for {set i 0} {$i < 50} {incr i } { + if {[catch {gets $sock} x] || $x ne "" || ![fblocked $sock]} break + after 200 + } + list $x [fconfigure $sock -error] [fconfigure $sock -error] + } -cleanup { + close $sock + } -match glob -result {{error reading "sock*": socket is not connected} {connection refused} {}} +test socket-14.9.0 {pending [socket -async] and blocking [puts], server is IPv4} \ + -constraints {socket supported_inet localhost_v4} \ + -setup { + makeFile { + fileevent stdin readable exit + set server [socket -server accept -myaddr 127.0.0.1 0] + proc accept {s h p} {set ::x $s} + puts [lindex [fconfigure $server -sockname] 2] + flush stdout + vwait x + puts [gets $x] + } script + set fd [open |[list [interpreter] script] RDWR] + set port [gets $fd] + } -body { + set sock [socket -async localhost $port] + puts $sock ok + flush $sock + list [fconfigure $sock -error] [gets $fd] + } -cleanup { + close $fd + close $sock + } -result {{} ok} +test socket-14.9.1 {pending [socket -async] and blocking [puts], server is IPv6} \ + -constraints {socket supported_inet6 localhost_v6} \ + -setup { + makeFile { + fileevent stdin readable exit + set server [socket -server accept -myaddr ::1 0] + proc accept {s h p} {set ::x $s} + puts [lindex [fconfigure $server -sockname] 2] + flush stdout + vwait x + puts [gets $x] + } script + set fd [open |[list [interpreter] script] RDWR] + set port [gets $fd] + } -body { + set sock [socket -async localhost $port] + puts $sock ok + flush $sock + list [fconfigure $sock -error] [gets $fd] + } -cleanup { + close $fd + close $sock + } -result {{} ok} +test socket-14.10.0 {pending [socket -async] and nonblocking [puts], server is IPv4} \ + -constraints {socket supported_inet localhost_v4} \ + -setup { + makeFile { + fileevent stdin readable exit + set server [socket -server accept -myaddr 127.0.0.1 0] + proc accept {s h p} {set ::x $s} + puts [lindex [fconfigure $server -sockname] 2] + flush stdout + vwait x + puts [gets $x] + } script + set fd [open |[list [interpreter] script] RDWR] + set port [gets $fd] + } -body { + set sock [socket -async localhost $port] + fconfigure $sock -blocking 0 + puts $sock ok + flush $sock + fileevent $fd readable {set x 1} + vwait x + list [fconfigure $sock -error] [gets $fd] + } -cleanup { + close $fd + close $sock + } -result {{} ok} +test socket-14.10.1 {pending [socket -async] and nonblocking [puts], server is IPv6} \ + -constraints {socket supported_inet6 localhost_v6} \ + -setup { + makeFile { + fileevent stdin readable exit + set server [socket -server accept -myaddr ::1 0] + proc accept {s h p} {set ::x $s} + puts [lindex [fconfigure $server -sockname] 2] + flush stdout + vwait x + puts [gets $x] + } script + set fd [open |[list [interpreter] script] RDWR] + set port [gets $fd] + } -body { + set sock [socket -async localhost $port] + fconfigure $sock -blocking 0 + puts $sock ok + flush $sock + fileevent $fd readable {set x 1} + vwait x + list [fconfigure $sock -error] [gets $fd] + } -cleanup { + close $fd + close $sock + } -result {{} ok} +test socket-14.11.0 {pending [socket -async] and nonblocking [puts], no listener, no flush} \ + -constraints {socket} \ + -body { + set sock [socket -async localhost [randport]] + fconfigure $sock -blocking 0 + puts $sock ok + fileevent $sock writable {set x 1} + vwait x + close $sock + } -cleanup { + catch {close $sock} + unset x + } -result {socket is not connected} -returnCodes 1 +test socket-14.11.1 {pending [socket -async] and nonblocking [puts], no listener, flush} \ + -constraints {socket} \ + -body { + set sock [socket -async localhost [randport]] + fconfigure $sock -blocking 0 + puts $sock ok + flush $sock + fileevent $sock writable {set x 1} + vwait x + close $sock + } -cleanup { + catch {close $sock} + catch {unset x} + } -result {socket is not connected} -returnCodes 1 +test socket-14.12 {[socket -async] background progress triggered by [fconfigure -error]} \ + -constraints {socket} \ + -body { + set s [socket -async localhost [randport]] + for {set i 0} {$i < 50} {incr i} { + set x [fconfigure $s -error] + if {$x != ""} break + after 200 + } + set x + } -cleanup { + close $s + unset x s + } -result {connection refused} + +test socket-14.13 {testing writable event when quick failure} \ + -constraints {socket win supported_inet} \ + -body { + # Test for bug 336441ed59 where a quick background fail was ignored + + # Test only for windows as socket -async 255.255.255.255 fails + # directly on unix + + # The following connect should fail very quickly + set a1 [after 2000 {set x timeout}] + set s [socket -async 255.255.255.255 43434] + fileevent $s writable {set x writable} + vwait x + set x +} -cleanup { + catch {close $s} + after cancel $a1 +} -result writable + +test socket-14.14 {testing fileevent readable on failed async socket connect} \ + -constraints {socket} -body { + # Test for bug 581937ab1e + + set a1 [after 5000 {set x timeout}] + # This connect should fail + set s [socket -async localhost [randport]] + fileevent $s readable {set x readable} + vwait x + set x +} -cleanup { + catch {close $s} + after cancel $a1 +} -result readable + +test socket-14.15 {blocking read on async socket should not trigger event handlers} \ + -constraints socket -body { + set s [socket -async localhost [randport]] + set x ok + fileevent $s writable {set x fail} + catch {read $s} + set x + } -result ok + +set num 0 + +set x {localhost {socket} 127.0.0.1 {supported_inet} ::1 {supported_inet6}} +set resultok {-result "sock*" -match glob} +set resulterr { + -result {couldn't open socket: connection refused} + -returnCodes 1 +} +foreach {servip sc} $x { + foreach {cliip cc} $x { + set constraints socket + lappend constraints $sc $cc + set result $resulterr + switch -- [lsort -unique [list $servip $cliip]] { + localhost - 127.0.0.1 - ::1 { + set result $resultok + } + {127.0.0.1 localhost} { + if {[testConstraint localhost_v4]} { + set result $resultok + } + } + {::1 localhost} { + if {[testConstraint localhost_v6]} { + set result $resultok + } + } + } + test socket-15.1.$num "Connect to $servip from $cliip" \ + -constraints $constraints -setup { + set server [socket -server accept -myaddr $servip 0] + proc accept {s h p} { close $s } + set port [lindex [fconfigure $server -sockname] 2] + } -body { + set s [socket $cliip $port] + } -cleanup { + close $server + catch {close $s} + } {*}$result + incr num + } +} ::tcltest::cleanupTests flush stdout diff --git a/tests/string.test b/tests/string.test index 740cdc6..a8a83d9 100644 --- a/tests/string.test +++ b/tests/string.test @@ -1398,6 +1398,9 @@ test string-15.9 {string tolower} { test string-15.10 {string tolower, unicode} { string tolower ABCabc\xc7\xe7 } "abcabc\xe7\xe7" +test string-15.11 {string tolower, compiled} { + lindex [string tolower [list A B [list C]]] 1 +} b test string-16.1 {string toupper} { list [catch {string toupper} msg] $msg @@ -1429,6 +1432,9 @@ test string-16.9 {string toupper} { test string-16.10 {string toupper, unicode} { string toupper ABCabc\xc7\xe7 } "ABCABC\xc7\xc7" +test string-16.11 {string toupper, compiled} { + lindex [string toupper [list a b [list c]]] 1 +} B test string-17.1 {string totitle} { list [catch {string totitle} msg] $msg @@ -1451,6 +1457,9 @@ test string-17.6 {string totitle, unicode} { test string-17.7 {string totitle, unicode} { string totitle \u01f3BCabc\xc7\xe7 } "\u01f2bcabc\xe7\xe7" +test string-17.8 {string totitle, compiled} { + lindex [string totitle [list aa bb [list cc]]] 0 +} Aa test string-18.1 {string trim} { list [catch {string trim} msg] $msg @@ -1792,8 +1801,8 @@ test string-26.7 {tcl::prefix} -body { tcl::prefix match -exact {apa bepa cepa depa} be } -returnCodes 1 -result {bad option "be": must be apa, bepa, cepa, or depa} test string-26.8 {tcl::prefix} -body { - tcl::prefix match -message switch {apa bepa bear depa} be -} -returnCodes 1 -result {ambiguous switch "be": must be apa, bepa, bear, or depa} + tcl::prefix match -message wombat {apa bepa bear depa} be +} -returnCodes 1 -result {ambiguous wombat "be": must be apa, bepa, bear, or depa} test string-26.9 {tcl::prefix} -body { tcl::prefix match -error {} {apa bepa bear depa} be } -returnCodes 0 -result {} diff --git a/tests/stringComp.test b/tests/stringComp.test index 9e00ce7..165ef20 100644 --- a/tests/stringComp.test +++ b/tests/stringComp.test @@ -26,6 +26,22 @@ catch [list package require -exact Tcltest [info patchlevel]] # Some tests require the testobj command testConstraint testobj [expr {[info commands testobj] != {}}] +testConstraint memory [llength [info commands memory]] +if {[testConstraint memory]} { + proc getbytes {} { + set lines [split [memory info] \n] + return [lindex $lines 3 3] + } + proc leaktest {script {iterations 3}} { + set end [getbytes] + for {set i 0} {$i < $iterations} {incr i} { + uplevel 1 $script + set tmp $end + set end [getbytes] + } + return [expr {$end - $tmp}] + } +} test stringComp-1.1 {error conditions} { proc foo {} {string gorp a b} @@ -687,7 +703,23 @@ test stringComp-12.1 {Bug 3588366: end-offsets before start} { ## not yet bc ## string replace -## not yet bc +test stringComp-14.1 {Bug 82e7f67325} { + apply {x { + set a [join $x {}] + lappend b [string length [string replace ___! 0 2 $a]] + lappend b [string length [string replace ___! 0 2 $a[unset a]]] + }} {a b} +} {3 3} +test stringComp-14.2 {Bug 82e7f67325} memory { + # As in stringComp-14.1, but make sure we don't retain too many refs + leaktest { + apply {x { + set a [join $x {}] + lappend b [string length [string replace ___! 0 2 $a]] + lappend b [string length [string replace ___! 0 2 $a[unset a]]] + }} {a b} + } +} {0} ## string tolower ## not yet bc diff --git a/tests/subst.test b/tests/subst.test index 7466895..498512d 100644 --- a/tests/subst.test +++ b/tests/subst.test @@ -21,7 +21,7 @@ test subst-1.1 {basics} -returnCodes error -body { } -result {wrong # args: should be "subst ?-nobackslashes? ?-nocommands? ?-novariables? string"} test subst-1.2 {basics} -returnCodes error -body { subst a b c -} -result {bad switch "a": must be -nobackslashes, -nocommands, or -novariables} +} -result {bad option "a": must be -nobackslashes, -nocommands, or -novariables} test subst-2.1 {simple strings} { subst {} @@ -119,13 +119,13 @@ test subst-6.1 {clear the result after command substitution} -body { test subst-7.1 {switches} -returnCodes error -body { subst foo bar -} -result {bad switch "foo": must be -nobackslashes, -nocommands, or -novariables} +} -result {bad option "foo": must be -nobackslashes, -nocommands, or -novariables} test subst-7.2 {switches} -returnCodes error -body { subst -no bar -} -result {ambiguous switch "-no": must be -nobackslashes, -nocommands, or -novariables} +} -result {ambiguous option "-no": must be -nobackslashes, -nocommands, or -novariables} test subst-7.3 {switches} -returnCodes error -body { subst -bogus bar -} -result {bad switch "-bogus": must be -nobackslashes, -nocommands, or -novariables} +} -result {bad option "-bogus": must be -nobackslashes, -nocommands, or -novariables} test subst-7.4 {switches} { set x 123 subst -nobackslashes {abc $x [expr 1+2] \\\x41} diff --git a/tests/switch.test b/tests/switch.test index a03948b..4d204bb 100644 --- a/tests/switch.test +++ b/tests/switch.test @@ -169,7 +169,7 @@ test switch-4.1 {error in executed command} { "switch a a {error "Just a test"} default {subst 1}"}} test switch-4.2 {error: not enough args} -returnCodes error -body { switch -} -result {wrong # args: should be "switch ?-switch ...? string ?pattern body ...? ?default body?"} +} -result {wrong # args: should be "switch ?-option ...? string ?pattern body ...? ?default body?"} test switch-4.3 {error: pattern with no body} -body { switch a b } -returnCodes error -result {extra switch pattern with no body} @@ -269,16 +269,16 @@ test switch-8.3 {weird body text, variable} { test switch-9.1 {empty pattern/body list} -returnCodes error -body { switch x -} -result {wrong # args: should be "switch ?-switch ...? string ?pattern body ...? ?default body?"} +} -result {wrong # args: should be "switch ?-option ...? string ?pattern body ...? ?default body?"} test switch-9.2 {unpaired pattern} -returnCodes error -body { switch -- x } -result {extra switch pattern with no body} test switch-9.3 {empty pattern/body list} -body { switch x {} -} -returnCodes error -result {wrong # args: should be "switch ?-switch ...? string {?pattern body ...? ?default body?}"} +} -returnCodes error -result {wrong # args: should be "switch ?-option ...? string {?pattern body ...? ?default body?}"} test switch-9.4 {empty pattern/body list} -body { switch -- x {} -} -returnCodes error -result {wrong # args: should be "switch ?-switch ...? string {?pattern body ...? ?default body?}"} +} -returnCodes error -result {wrong # args: should be "switch ?-option ...? string {?pattern body ...? ?default body?}"} test switch-9.5 {unpaired pattern} -body { switch x a {} b } -returnCodes error -result {extra switch pattern with no body} diff --git a/tests/winFCmd.test b/tests/winFCmd.test index 28a0e9f..28257c6 100644 --- a/tests/winFCmd.test +++ b/tests/winFCmd.test @@ -208,22 +208,11 @@ test winFCmd-1.13 {TclpRenameFile: errno: EACCES} -setup { } -constraints {win win2000orXP testfile} -body { testfile mv nul tf1 } -returnCodes error -result EINVAL -test winFCmd-1.13.1 {TclpRenameFile: errno: EACCES} -setup { +test winFCmd-1.14 {TclpRenameFile: errno: EACCES} -setup { cleanup } -constraints {win nt winOlderThan2000 testfile} -body { testfile mv nul tf1 } -returnCodes error -result EACCES -test winFCmd-1.13.2 {TclpRenameFile: errno: ENOENT} -setup { - cleanup -} -constraints {win 95 testfile} -body { - testfile mv nul tf1 -} -returnCodes error -result ENOENT -test winFCmd-1.14 {TclpRenameFile: errno: EACCES} -setup { - cleanup -} -constraints {win 95 testfile} -body { - createfile tf1 - testfile mv tf1 nul -} -returnCodes error -result EACCES test winFCmd-1.15 {TclpRenameFile: errno: EEXIST} -setup { cleanup } -constraints {win nt testfile} -body { @@ -257,11 +246,6 @@ test winFCmd-1.19.1 {TclpRenameFile: errno == EACCES} -setup { } -constraints {win nt winOlderThan2000 testfile} -body { testfile mv nul tf1 } -returnCodes error -result EACCES -test winFCmd-1.19.2 {TclpRenameFile: errno == ENOENT} -setup { - cleanup -} -constraints {win 95 testfile} -body { - testfile mv nul tf1 -} -returnCodes error -result ENOENT test winFCmd-1.20 {TclpRenameFile: src is dir} -setup { cleanup } -constraints {win nt testfile} -body { @@ -474,29 +458,14 @@ test winFCmd-2.6 {TclpCopyFile: errno: ENOENT} -setup { } -returnCodes error -result ENOENT test winFCmd-2.7 {TclpCopyFile: errno: EACCES} -setup { cleanup -} -constraints {win 95 testfile} -body { - createfile tf1 - set fd [open tf2 w] - testfile cp tf1 tf2 -} -cleanup { - close $fd - cleanup -} -returnCodes error -result EACCES -test winFCmd-2.8 {TclpCopyFile: errno: EACCES} -setup { - cleanup } -constraints {win win2000orXP testfile} -body { testfile cp nul tf1 } -returnCodes error -result EINVAL -test winFCmd-2.8.1 {TclpCopyFile: errno: EACCES} -setup { +test winFCmd-2.8 {TclpCopyFile: errno: EACCES} -setup { cleanup } -constraints {win nt winOlderThan2000 testfile} -body { testfile cp nul tf1 } -returnCodes error -result EACCES -test winFCmd-2.9 {TclpCopyFile: errno: ENOENT} -setup { - cleanup -} -constraints {win 95 testfile} -body { - testfile cp nul tf1 -} -returnCodes error -result ENOENT test winFCmd-2.10 {TclpCopyFile: CopyFile succeeds} -setup { cleanup } -constraints {win testfile} -body { @@ -573,17 +542,6 @@ test winFCmd-2.17 {TclpCopyFile: dst is readonly} -setup { catch {testchmod 666 tf2} cleanup } -result {1 tf1} -test winFCmd-2.18 {TclpCopyFile: still can't copy onto dst} -setup { - cleanup -} -constraints {win 95 testfile testchmod} -body { - createfile tf1 - createfile tf2 - testchmod 000 tf2 - set fd [open tf2] - set msg [list [catch {testfile cp tf1 tf2} msg] $msg] - close $fd - lappend msg [file writable tf2] -} -result {1 EACCES 0} test winFCmd-3.1 {TclpDeleteFile: errno: EACCES} -body { testfile rm $cdfile $cdrom/dummy~~.fil @@ -666,9 +624,6 @@ test winFCmd-3.11 {TclpDeleteFile: still can't remove path} -setup { test winFCmd-4.1 {TclpCreateDirectory: errno: EACCES} -body { testfile mkdir $cdrom/dummy~~.dir } -constraints {win nt cdrom testfile} -returnCodes error -result EACCES -test winFCmd-4.2 {TclpCreateDirectory: errno: EACCES} -body { - testfile mkdir $cdrom/dummy~~.dir -} -constraints {win 95 cdrom testfile} -returnCodes error -result ENOSPC test winFCmd-4.3 {TclpCreateDirectory: errno: EEXIST} -setup { cleanup } -constraints {win testfile} -body { @@ -764,11 +719,6 @@ test winFCmd-6.9 {TclpRemoveDirectory: errno == EACCES} -setup { catch {testchmod 666 td1} cleanup } -result {td1 EACCES} -test winFCmd-6.10 {TclpRemoveDirectory: attr == -1} -setup { - cleanup -} -constraints {win 95 testfile} -body { - testfile rmdir nul -} -returnCodes error -result {nul EACCES} test winFCmd-6.11 {TclpRemoveDirectory: attr == -1} -setup { cleanup } -constraints {win nt testfile} -body { @@ -776,16 +726,6 @@ test winFCmd-6.11 {TclpRemoveDirectory: attr == -1} -setup { # WinXP returns EEXIST, WinNT seems to return EACCES. No policy # decision has been made as to which is correct. } -returnCodes error -match regexp -result {^/ E(ACCES|EXIST)$} -# This next test has a very hokey way of matching... -test winFCmd-6.12 {TclpRemoveDirectory: errno == EACCES} -setup { - cleanup -} -constraints {win 95 testfile} -body { - createfile tf1 - set res [catch {testfile rmdir tf1} msg] - # get rid of path - set msg [list [file tail [lindex $msg 0]] [lindex $msg 1]] - list $res $msg -} -result {1 {tf1 ENOTDIR}} test winFCmd-6.13 {TclpRemoveDirectory: write-protected} -setup { cleanup } -constraints {winVista testfile testchmod} -body { @@ -798,16 +738,6 @@ test winFCmd-6.13 {TclpRemoveDirectory: write-protected} -setup { cleanup } -returnCodes error -result {td1 EACCES} # This next test has a very hokey way of matching... -test winFCmd-6.14 {TclpRemoveDirectory: check if empty dir} -setup { - cleanup -} -constraints {win 95 testfile} -body { - file mkdir td1/td2 - set res [catch {testfile rmdir td1} msg] - # get rid of path - set msg [list [file tail [lindex $msg 0]] [lindex $msg 1]] - list $res $msg -} -result {1 {td1 EEXIST}} -# This next test has a very hokey way of matching... test winFCmd-6.15 {TclpRemoveDirectory: !recursive} -setup { cleanup } -constraints {win testfile} -body { @@ -887,11 +817,6 @@ test winFCmd-7.7 {TraverseWinTree: append \ to source if necessary} -setup { } -cleanup { cleanup } -result {tf1} -test winFCmd-7.8 {TraverseWinTree: append \ to source if necessary} -body { - # cdrom can return either d:\ or D:/, but we only care about the errcode - testfile rmdir $cdrom/ -} -constraints {win 95 cdrom testfile} -returnCodes error -match glob \ - -result {* EACCES} ; # was EEXIST, but changed for win98. test winFCmd-7.9 {TraverseWinTree: append \ to source if necessary} -body { testfile rmdir $cdrom/ } -constraints {win nt cdrom testfile} -returnCodes error -match glob \ @@ -930,14 +855,6 @@ test winFCmd-7.13 {TraverseWinTree: append \ to target if necessary} -setup { } -cleanup { cleanup } -result {tf1} -test winFCmd-7.14 {TraverseWinTree: append \ to target if necessary} -setup { - cleanup -} -constraints {win 95 testfile} -body { - file mkdir td1 - testfile cpdir td1 / -} -cleanup { - cleanup -} -returnCodes error -result {/ EEXIST} test winFCmd-7.15 {TraverseWinTree: append \ to target if necessary} -setup { cleanup } -constraints {win nt testfile} -body { @@ -1038,15 +955,6 @@ test winFCmd-9.1 {TraversalDelete: DOTREE_F} -setup { createfile td1/tf1 testfile rmdir -force td1 } -result {} -test winFCmd-9.2 {TraversalDelete: DOTREE_F} -setup { - cleanup -} -constraints {win 95 testfile} -body { - file mkdir td1 - set fd [open td1/tf1 w] - testfile rmdir -force td1 -} -cleanup { - close $fd -} -returnCodes error -result {td1\tf1 EACCES} test winFCmd-9.3 {TraversalDelete: DOTREE_PRED} -setup { cleanup } -constraints {winVista testfile testchmod} -body { @@ -1477,10 +1385,10 @@ test winFCmd-19.5 {Windows extended path names} -constraints nt -setup { list [catch { set f [open $tmpfile [list WRONLY CREAT]] close $f - } res] errormsg ;#$res + } res] $res } -cleanup { catch {file delete $tmpfile} -} -result [list 1 errormsg] +} -result [list 0 {}] test winFCmd-19.6 {Windows extended path names} -constraints nt -setup { set tmpfile [file join $::env(TEMP) tcl[string repeat x 248].tmp] set tmpfile //?/[file normalize $tmpfile] diff --git a/tests/winFile.test b/tests/winFile.test index fba9bcb..2c47f5f 100644 --- a/tests/winFile.test +++ b/tests/winFile.test @@ -37,24 +37,6 @@ test winFile-1.2 {TclpGetUserHome} -constraints {win nt nonPortable} -body { # The administrator account should always exist. glob ~administrator } -match glob -result * -test winFile-1.3 {TclpGetUserHome} -constraints {win 95} -body { - # Find some user in system.ini and then see if they have a home. - - set f [open $::env(windir)/system.ini] - while {[gets $f line] >= 0} { - if {$line ne {[Password Lists]}} { - continue - } - gets $f - set name [lindex [split [gets $f] =] 0] - if {$name ne ""} { - return [catch {glob ~$name}] - } - } - return 0 ;# didn't find anything... -} -cleanup { - catch {close $f} -} -result {0} test winFile-1.4 {TclpGetUserHome} {win nt nonPortable} { catch {glob ~stanton@workgroup} } {0} diff --git a/tests/winPipe.test b/tests/winPipe.test index d2e804d..9c6f94d 100644 --- a/tests/winPipe.test +++ b/tests/winPipe.test @@ -82,10 +82,6 @@ test winpipe-1.4 {32 bit comprehensive tests: a lot from pipe} {win nt exec cat3 exec [interpreter] $path(more) < $path(big) | $cat32 > $path(stdout) 2> $path(stderr) list [contents $path(stdout)] [contents $path(stderr)] } "{$big} stderr32" -test winpipe-1.5 {32 bit comprehensive tests: a lot from pipe} {win 95 exec cat32} { - exec command /c type $path(big) |& $cat32 > $path(stdout) 2> $path(stderr) - list [contents $path(stdout)] [contents $path(stderr)] -} "{$big} stderr32" test winpipe-1.6 {32 bit comprehensive tests: from console} \ {win cat32 AllocConsole} { # would block waiting for human input @@ -174,10 +170,6 @@ test winpipe-1.21 {32 bit comprehensive tests: read/write application} \ catch {close $f} set r } "bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb" -test winpipe-1.22 {Checking command.com for Win95/98 hanging} {win 95 exec} { - exec command.com /c dir /b - set result 1 -} 1 test winpipe-4.1 {Tcl_WaitPid} {win nt exec cat32} { proc readResults {f} { diff --git a/tests/zlib.test b/tests/zlib.test index 4e51ebb..2346ec7 100644 --- a/tests/zlib.test +++ b/tests/zlib.test @@ -215,7 +215,7 @@ test zlib-8.5 {transformation and flushing and fileevents: Bug 3525907} -setup { set ::res } -cleanup { catch {close $r} -} -result {qwertyuiop MIDDLE asdfghjkl} +} -result {qwertyuiop MIDDLE asdfghjkl {}} test zlib-8.6 {transformation and fconfigure} -setup { set file [makeFile {} test.z] set fd [open $file wb] diff --git a/tools/genStubs.tcl b/tools/genStubs.tcl index b45e560..7a75dc6 100644 --- a/tools/genStubs.tcl +++ b/tools/genStubs.tcl @@ -283,7 +283,7 @@ proc genStubs::addPlatformGuard {plat iftxt {eltxt {}} {withCygwin 0}} { set text "" switch $plat { win { - append text "#if defined(__WIN32__)" + append text "#if defined(_WIN32)" if {$withCygwin} { append text " || defined(__CYGWIN__)" } @@ -294,7 +294,7 @@ proc genStubs::addPlatformGuard {plat iftxt {eltxt {}} {withCygwin 0}} { append text "#endif /* WIN */\n" } unix { - append text "#if !defined(__WIN32__)" + append text "#if !defined(_WIN32)" if {$withCygwin} { append text " && !defined(__CYGWIN__)" } @@ -320,7 +320,7 @@ proc genStubs::addPlatformGuard {plat iftxt {eltxt {}} {withCygwin 0}} { append text "#endif /* AQUA */\n" } x11 { - append text "#if !(defined(__WIN32__)" + append text "#if !(defined(_WIN32)" if {$withCygwin} { append text " || defined(__CYGWIN__)" } diff --git a/unix/Makefile.in b/unix/Makefile.in index 58e0074..1571ad2 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -853,8 +853,8 @@ install-libraries: libraries done; @echo "Installing package msgcat 1.5.2 as a Tcl Module"; @$(INSTALL_DATA) $(TOP_DIR)/library/msgcat/msgcat.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/msgcat-1.5.2.tm; - @echo "Installing package tcltest 2.3.7 as a Tcl Module"; - @$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/tcltest-2.3.7.tm; + @echo "Installing package tcltest 2.3.8 as a Tcl Module"; + @$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/tcltest-2.3.8.tm; @echo "Installing package platform 1.0.12 as a Tcl Module"; @$(INSTALL_DATA) $(TOP_DIR)/library/platform/platform.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.4/platform-1.0.12.tm; @@ -2092,9 +2092,11 @@ alldist: dist html: ${NATIVE_TCLSH} $(BUILD_HTML) @EXTRA_BUILD_HTML@ + html-tcl: ${NATIVE_TCLSH} $(BUILD_HTML) --tcl @EXTRA_BUILD_HTML@ + html-tk: ${NATIVE_TCLSH} $(BUILD_HTML) --tk @EXTRA_BUILD_HTML@ diff --git a/unix/configure b/unix/configure index d3951b6..bd85ba4 100755 --- a/unix/configure +++ b/unix/configure @@ -1338,6 +1338,9 @@ TCL_MINOR_VERSION=6 TCL_PATCH_LEVEL=".1" VERSION=${TCL_VERSION} +EXTRA_INSTALL_BINARIES=${EXTRA_INSTALL_BINARIES:-"@:"} +EXTRA_BUILD_HTML=${EXTRA_BUILD_HTML:-"@:"} + #------------------------------------------------------------------------ # Setup configure arguments for bundled packages #------------------------------------------------------------------------ @@ -7079,9 +7082,9 @@ echo "$as_me: error: CYGWIN compile is only supported with --enable-threads" >&2 fi do64bit_ok=yes if test "x${SHARED_BUILD}" = "x1"; then - echo "running cd ../win; ${CONFIG_SHELL-/bin/sh} ./configure $ac_configure_args" + echo "running cd ${TCL_SRC_DIR}/win; ${CONFIG_SHELL-/bin/sh} ./configure $ac_configure_args" # The eval makes quoting arguments work. - if cd ../win; eval ${CONFIG_SHELL-/bin/sh} ./configure $ac_configure_args; cd ../unix + if cd ${TCL_SRC_DIR}/win; eval ${CONFIG_SHELL-/bin/sh} ./configure $ac_configure_args; cd ../unix then : else { echo "configure: error: configure failed for ../win" 1>&2; exit 1; } @@ -7761,11 +7764,15 @@ fi LDFLAGS="$LDFLAGS $PTHREAD_LIBS" fi - # Version numbers are dot-stripped by system policy. - TCL_TRIM_DOTS=`echo ${VERSION} | tr -d .` - UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.a' - SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.so.1' - TCL_LIB_VERSIONS_OK=nodots + case $system in + FreeBSD-3.*) + # Version numbers are dot-stripped by system policy. + TCL_TRIM_DOTS=`echo ${VERSION} | tr -d .` + UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.a' + SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.so' + TCL_LIB_VERSIONS_OK=nodots + ;; + esac ;; Darwin-*) CFLAGS_OPTIMIZE="-Os" diff --git a/unix/configure.in b/unix/configure.in index 61ad30f..cb6cf82 100644 --- a/unix/configure.in +++ b/unix/configure.in @@ -28,6 +28,9 @@ TCL_MINOR_VERSION=6 TCL_PATCH_LEVEL=".1" VERSION=${TCL_VERSION} +EXTRA_INSTALL_BINARIES=${EXTRA_INSTALL_BINARIES:-"@:"} +EXTRA_BUILD_HTML=${EXTRA_BUILD_HTML:-"@:"} + #------------------------------------------------------------------------ # Setup configure arguments for bundled packages #------------------------------------------------------------------------ diff --git a/unix/tcl.m4 b/unix/tcl.m4 index cb6704b..b23b9ac 100644 --- a/unix/tcl.m4 +++ b/unix/tcl.m4 @@ -1237,9 +1237,9 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ fi do64bit_ok=yes if test "x${SHARED_BUILD}" = "x1"; then - echo "running cd ../win; ${CONFIG_SHELL-/bin/sh} ./configure $ac_configure_args" + echo "running cd ${TCL_SRC_DIR}/win; ${CONFIG_SHELL-/bin/sh} ./configure $ac_configure_args" # The eval makes quoting arguments work. - if cd ../win; eval ${CONFIG_SHELL-/bin/sh} ./configure $ac_configure_args; cd ../unix + if cd ${TCL_SRC_DIR}/win; eval ${CONFIG_SHELL-/bin/sh} ./configure $ac_configure_args; cd ../unix then : else { echo "configure: error: configure failed for ../win" 1>&2; exit 1; } @@ -1545,11 +1545,15 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ LIBS=`echo $LIBS | sed s/-pthread//` CFLAGS="$CFLAGS $PTHREAD_CFLAGS" LDFLAGS="$LDFLAGS $PTHREAD_LIBS"]) - # Version numbers are dot-stripped by system policy. - TCL_TRIM_DOTS=`echo ${VERSION} | tr -d .` - UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.a' - SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.so.1' - TCL_LIB_VERSIONS_OK=nodots + case $system in + FreeBSD-3.*) + # Version numbers are dot-stripped by system policy. + TCL_TRIM_DOTS=`echo ${VERSION} | tr -d .` + UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.a' + SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.so' + TCL_LIB_VERSIONS_OK=nodots + ;; + esac ;; Darwin-*) CFLAGS_OPTIMIZE="-Os" diff --git a/unix/tcl.pc.in b/unix/tcl.pc.in index 8bf67cd..846cb11 100644 --- a/unix/tcl.pc.in +++ b/unix/tcl.pc.in @@ -8,8 +8,8 @@ includedir=@includedir@ Name: Tool Command Language Description: Tcl is a powerful, easy-to-learn dynamic programming language, suitable for a wide range of uses. URL: http://www.tcl.tk/ -Version: @TCL_VERSION@ -Requires: -Conflicts: -Libs: -L${libdir} @TCL_LIBS@ +Version: @TCL_VERSION@@TCL_PATCH_LEVEL@ +Requires.private: zlib >= 1.2.3 +Libs: -L${libdir} @TCL_LIB_FLAG@ @TCL_STUB_LIB_FLAG@ +Libs.private: @TCL_LIBS@ Cflags: -I${includedir} diff --git a/unix/tclConfig.sh.in b/unix/tclConfig.sh.in index d47e686..b58e9fd 100644 --- a/unix/tclConfig.sh.in +++ b/unix/tclConfig.sh.in @@ -165,5 +165,5 @@ TCL_BUILD_STUB_LIB_PATH='@TCL_BUILD_STUB_LIB_PATH@' # Path to the Tcl stub library in the install directory. TCL_STUB_LIB_PATH='@TCL_STUB_LIB_PATH@' -# Flag, 1: we built Tcl with threads enables, 0 we didn't +# Flag, 1: we built Tcl with threads enabled, 0 we didn't TCL_THREADS=@TCL_THREADS@ diff --git a/unix/tclUnixFCmd.c b/unix/tclUnixFCmd.c index e270b6a..3b1b6ca 100644 --- a/unix/tclUnixFCmd.c +++ b/unix/tclUnixFCmd.c @@ -91,10 +91,10 @@ static int SetPermissionsAttribute(Tcl_Interp *interp, Tcl_Obj *attributePtr); static int GetModeFromPermString(Tcl_Interp *interp, const char *modeStringPtr, mode_t *modePtr); -#if defined(HAVE_CHFLAGS) && defined(UF_IMMUTABLE) -static int GetReadOnlyAttribute(Tcl_Interp *interp, int objIndex, +#if defined(HAVE_CHFLAGS) && defined(UF_IMMUTABLE) || defined(__CYGWIN__) +static int GetUnixFileAttributes(Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj **attributePtrPtr); -static int SetReadOnlyAttribute(Tcl_Interp *interp, int objIndex, +static int SetUnixFileAttributes(Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj *attributePtr); #endif @@ -124,10 +124,20 @@ extern const char *const tclpFileAttrStrings[]; #else /* !DJGPP */ enum { - UNIX_GROUP_ATTRIBUTE, UNIX_OWNER_ATTRIBUTE, UNIX_PERMISSIONS_ATTRIBUTE, -#if defined(HAVE_CHFLAGS) && defined(UF_IMMUTABLE) +#if defined(__CYGWIN__) + UNIX_ARCHIVE_ATTRIBUTE, +#endif + UNIX_GROUP_ATTRIBUTE, +#if defined(__CYGWIN__) + UNIX_HIDDEN_ATTRIBUTE, +#endif + UNIX_OWNER_ATTRIBUTE, UNIX_PERMISSIONS_ATTRIBUTE, +#if defined(HAVE_CHFLAGS) && defined(UF_IMMUTABLE) || defined(__CYGWIN__) UNIX_READONLY_ATTRIBUTE, #endif +#if defined(__CYGWIN__) + UNIX_SYSTEM_ATTRIBUTE, +#endif #ifdef MAC_OSX_TCL MACOSX_CREATOR_ATTRIBUTE, MACOSX_TYPE_ATTRIBUTE, MACOSX_HIDDEN_ATTRIBUTE, MACOSX_RSRCLENGTH_ATTRIBUTE, @@ -137,10 +147,20 @@ enum { MODULE_SCOPE const char *const tclpFileAttrStrings[]; const char *const tclpFileAttrStrings[] = { - "-group", "-owner", "-permissions", -#if defined(HAVE_CHFLAGS) && defined(UF_IMMUTABLE) +#if defined(__CYGWIN__) + "-archive", +#endif + "-group", +#if defined(__CYGWIN__) + "-hidden", +#endif + "-owner", "-permissions", +#if defined(HAVE_CHFLAGS) && defined(UF_IMMUTABLE) || defined(__CYGWIN__) "-readonly", #endif +#if defined(__CYGWIN__) + "-system", +#endif #ifdef MAC_OSX_TCL "-creator", "-type", "-hidden", "-rsrclength", #endif @@ -149,11 +169,20 @@ const char *const tclpFileAttrStrings[] = { MODULE_SCOPE const TclFileAttrProcs tclpFileAttrProcs[]; const TclFileAttrProcs tclpFileAttrProcs[] = { +#if defined(__CYGWIN__) + {GetUnixFileAttributes, SetUnixFileAttributes}, +#endif {GetGroupAttribute, SetGroupAttribute}, +#if defined(__CYGWIN__) + {GetUnixFileAttributes, SetUnixFileAttributes}, +#endif {GetOwnerAttribute, SetOwnerAttribute}, {GetPermissionsAttribute, SetPermissionsAttribute}, -#if defined(HAVE_CHFLAGS) && defined(UF_IMMUTABLE) - {GetReadOnlyAttribute, SetReadOnlyAttribute}, +#if defined(HAVE_CHFLAGS) && defined(UF_IMMUTABLE) || defined(__CYGWIN__) + {GetUnixFileAttributes, SetUnixFileAttributes}, +#endif +#if defined(__CYGWIN__) + {GetUnixFileAttributes, SetUnixFileAttributes}, #endif #ifdef MAC_OSX_TCL {TclMacOSXGetFileAttribute, TclMacOSXSetFileAttribute}, @@ -2246,11 +2275,138 @@ DefaultTempDir(void) return TCL_TEMPORARY_FILE_DIRECTORY; } -#if defined(HAVE_CHFLAGS) && defined(UF_IMMUTABLE) +#if defined(__CYGWIN__) + +static void +StatError( + Tcl_Interp *interp, /* The interp that has the error */ + Tcl_Obj *fileName) /* The name of the file which caused the + * error. */ +{ + TclWinConvertError(GetLastError()); + Tcl_SetObjResult(interp, Tcl_ObjPrintf("could not read \"%s\": %s", + TclGetString(fileName), Tcl_PosixError(interp))); +} + +static WCHAR * +winPathFromObj( + Tcl_Obj *fileName) +{ + int size; + const char *native = Tcl_FSGetNativePath(fileName); + WCHAR *winPath; + + size = cygwin_conv_path(1, native, NULL, 0); + winPath = ckalloc(size); + cygwin_conv_path(1, native, winPath, size); + + return winPath; +} + +static const int attributeArray[] = { + 0x20, 0, 2, 0, 0, 1, 4}; + +/* + *---------------------------------------------------------------------- + * + * GetUnixFileAttributes + * + * Gets the readonly attribute of a file. + * + * Results: + * Standard TCL result. Returns a new Tcl_Obj in attributePtrPtr if there + * is no error. The object will have ref count 0. + * + * Side effects: + * A new object is allocated. + * + *---------------------------------------------------------------------- + */ + +static int +GetUnixFileAttributes( + Tcl_Interp *interp, /* The interp we are using for errors. */ + int objIndex, /* The index of the attribute. */ + Tcl_Obj *fileName, /* The name of the file (UTF-8). */ + Tcl_Obj **attributePtrPtr) /* A pointer to return the object with. */ +{ + int fileAttributes; + WCHAR *winPath = winPathFromObj(fileName); + + fileAttributes = GetFileAttributesW(winPath); + ckfree(winPath); + + if (fileAttributes == -1) { + StatError(interp, fileName); + return TCL_ERROR; + } + + *attributePtrPtr = Tcl_NewIntObj((fileAttributes&attributeArray[objIndex])!=0); + + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * SetUnixFileAttributes + * + * Sets the readonly attribute of a file. + * + * Results: + * Standard TCL result. + * + * Side effects: + * The readonly attribute of the file is changed. + * + *--------------------------------------------------------------------------- + */ + +static int +SetUnixFileAttributes( + Tcl_Interp *interp, /* The interp we are using for errors. */ + int objIndex, /* The index of the attribute. */ + Tcl_Obj *fileName, /* The name of the file (UTF-8). */ + Tcl_Obj *attributePtr) /* The attribute to set. */ +{ + int yesNo, fileAttributes, old; + WCHAR *winPath; + + if (Tcl_GetBooleanFromObj(interp, attributePtr, &yesNo) != TCL_OK) { + return TCL_ERROR; + } + + winPath = winPathFromObj(fileName); + + fileAttributes = old = GetFileAttributesW(winPath); + + if (fileAttributes == -1) { + ckfree(winPath); + StatError(interp, fileName); + return TCL_ERROR; + } + + if (yesNo) { + fileAttributes |= attributeArray[objIndex]; + } else { + fileAttributes &= ~attributeArray[objIndex]; + } + + if ((fileAttributes != old) + && !SetFileAttributesW(winPath, fileAttributes)) { + ckfree(winPath); + StatError(interp, fileName); + return TCL_ERROR; + } + + ckfree(winPath); + return TCL_OK; +} +#elif defined(HAVE_CHFLAGS) && defined(UF_IMMUTABLE) /* *---------------------------------------------------------------------- * - * GetReadOnlyAttribute + * GetUnixFileAttributes * * Gets the readonly attribute (user immutable flag) of a file. * @@ -2265,7 +2421,7 @@ DefaultTempDir(void) */ static int -GetReadOnlyAttribute( +GetUnixFileAttributes( Tcl_Interp *interp, /* The interp we are using for errors. */ int objIndex, /* The index of the attribute. */ Tcl_Obj *fileName, /* The name of the file (UTF-8). */ @@ -2293,7 +2449,7 @@ GetReadOnlyAttribute( /* *--------------------------------------------------------------------------- * - * SetReadOnlyAttribute + * SetUnixFileAttributes * * Sets the readonly attribute (user immutable flag) of a file. * @@ -2307,7 +2463,7 @@ GetReadOnlyAttribute( */ static int -SetReadOnlyAttribute( +SetUnixFileAttributes( Tcl_Interp *interp, /* The interp we are using for errors. */ int objIndex, /* The index of the attribute. */ Tcl_Obj *fileName, /* The name of the file (UTF-8). */ diff --git a/unix/tclUnixFile.c b/unix/tclUnixFile.c index 5bfe5d9..2cb0027 100644 --- a/unix/tclUnixFile.c +++ b/unix/tclUnixFile.c @@ -1105,6 +1105,12 @@ TclNativeCreateNativeRep( str = Tcl_GetStringFromObj(validPathPtr, &len); Tcl_UtfToExternalDString(NULL, str, len, &ds); len = Tcl_DStringLength(&ds) + sizeof(char); + if (strlen(Tcl_DStringValue(&ds)) < len - sizeof(char)) { + /* See bug [3118489]: NUL in filenames */ + Tcl_DecrRefCount(validPathPtr); + Tcl_DStringFree(&ds); + return NULL; + } Tcl_DecrRefCount(validPathPtr); nativePathPtr = ckalloc(len); memcpy(nativePathPtr, Tcl_DStringValue(&ds), (size_t) len); diff --git a/unix/tclUnixPipe.c b/unix/tclUnixPipe.c index 9c21b28..a02044e 100644 --- a/unix/tclUnixPipe.c +++ b/unix/tclUnixPipe.c @@ -1143,7 +1143,7 @@ PipeWatchProc( if (psPtr->inFile) { newmask = mask & (TCL_READABLE | TCL_EXCEPTION); if (newmask) { - Tcl_CreateFileHandler(GetFd(psPtr->inFile), mask, + Tcl_CreateFileHandler(GetFd(psPtr->inFile), newmask, (Tcl_FileProc *) Tcl_NotifyChannel, psPtr->channel); } else { Tcl_DeleteFileHandler(GetFd(psPtr->inFile)); @@ -1152,7 +1152,7 @@ PipeWatchProc( if (psPtr->outFile) { newmask = mask & (TCL_WRITABLE | TCL_EXCEPTION); if (newmask) { - Tcl_CreateFileHandler(GetFd(psPtr->outFile), mask, + Tcl_CreateFileHandler(GetFd(psPtr->outFile), newmask, (Tcl_FileProc *) Tcl_NotifyChannel, psPtr->channel); } else { Tcl_DeleteFileHandler(GetFd(psPtr->outFile)); diff --git a/unix/tclUnixPort.h b/unix/tclUnixPort.h index 2ade1c0..f64d453 100644 --- a/unix/tclUnixPort.h +++ b/unix/tclUnixPort.h @@ -93,6 +93,9 @@ typedef off_t Tcl_SeekOffset; WCHAR *, int); __declspec(dllimport) extern __stdcall void OutputDebugStringW(const WCHAR *); __declspec(dllimport) extern __stdcall int IsDebuggerPresent(); + __declspec(dllimport) extern __stdcall int GetLastError(); + __declspec(dllimport) extern __stdcall int GetFileAttributesW(const WCHAR *); + __declspec(dllimport) extern __stdcall int SetFileAttributesW(const WCHAR *, int); __declspec(dllimport) extern int cygwin_conv_path(int, const void *, void *, int); __declspec(dllimport) extern int cygwin_conv_path_list(int, const void *, void *, int); diff --git a/unix/tclUnixSock.c b/unix/tclUnixSock.c index 49a6460..96700ce 100644 --- a/unix/tclUnixSock.c +++ b/unix/tclUnixSock.c @@ -55,6 +55,8 @@ struct TcpState { TcpFdList fds; /* The file descriptors of the sockets. */ int flags; /* ORed combination of the bitfields defined * below. */ + int interest; /* Event types of interest */ + /* * Only needed for server sockets */ @@ -73,7 +75,7 @@ struct TcpState { struct addrinfo *myaddr; /* Iterator over myaddrlist. */ int filehandlers; /* Caches FileHandlers that get set up while * an async socket is not yet connected. */ - int status; /* Cache status of async socket. */ + int connectError; /* Cache SO_ERROR of async socket. */ int cachedBlocking; /* Cache blocking mode of async socket. */ }; @@ -82,8 +84,13 @@ struct TcpState { * structure. */ -#define TCP_ASYNC_SOCKET (1<<0) /* Asynchronous socket. */ +#define TCP_NONBLOCKING (1<<0) /* Socket with non-blocking I/O */ #define TCP_ASYNC_CONNECT (1<<1) /* Async connect in progress. */ +#define TCP_ASYNC_PENDING (1<<4) /* TcpConnect was called to + * process an async connect. This + * flag indicates that reentry is + * still pending */ +#define TCP_ASYNC_FAILED (1<<5) /* An async connect finally failed */ /* * The following defines the maximum length of the listen queue. This is the @@ -110,7 +117,7 @@ struct TcpState { * Static routines for this file: */ -static int CreateClientSocket(Tcl_Interp *interp, +static int TcpConnect(Tcl_Interp *interp, TcpState *state); static void TcpAccept(ClientData data, int mask); static int TcpBlockModeProc(ClientData data, int mode); @@ -129,6 +136,7 @@ static int TcpOutputProc(ClientData instanceData, const char *buf, int toWrite, int *errorCode); static void TcpWatchProc(ClientData instanceData, int mask); static int WaitForConnect(TcpState *statePtr, int *errorCodePtr); +static void WrapNotify(ClientData clientData, int mask); /* * This structure describes the channel type structure for TCP socket @@ -163,6 +171,21 @@ static TclInitProcessGlobalValueProc InitializeHostName; static ProcessGlobalValue hostName = {0, 0, NULL, NULL, InitializeHostName, NULL, NULL}; +#if 0 +/* printf debugging */ +void printaddrinfo(struct addrinfo *addrlist, char *prefix) +{ + char host[NI_MAXHOST], port[NI_MAXSERV]; + struct addrinfo *ai; + for (ai = addrlist; ai != NULL; ai = ai->ai_next) { + getnameinfo(ai->ai_addr, ai->ai_addrlen, + host, sizeof(host), + port, sizeof(port), + NI_NUMERICHOST|NI_NUMERICSERV); + fprintf(stderr,"%s: %s:%s\n", prefix, host, port); + } +} +#endif /* *---------------------------------------------------------------------- * @@ -349,9 +372,9 @@ TcpBlockModeProc( TcpState *statePtr = instanceData; if (mode == TCL_MODE_BLOCKING) { - CLEAR_BITS(statePtr->flags, TCP_ASYNC_SOCKET); + CLEAR_BITS(statePtr->flags, TCP_NONBLOCKING); } else { - SET_BITS(statePtr->flags, TCP_ASYNC_SOCKET); + SET_BITS(statePtr->flags, TCP_NONBLOCKING); } if (statePtr->flags & TCP_ASYNC_CONNECT) { statePtr->cachedBlocking = mode; @@ -368,48 +391,80 @@ TcpBlockModeProc( * * WaitForConnect -- * - * Wait for a connection on an asynchronously opened socket to be - * completed. In nonblocking mode, just test if the connection - * has completed without blocking. + * Check the state of an async connect process. If a connection + * attempt terminated, process it, which may finalize it or may + * start the next attempt. If a connect error occures, it is saved + * in statePtr->connectError to be reported by 'fconfigure -error'. + * + * There are two modes of operation, defined by errorCodePtr: + * * non-NULL: Called by explicite read/write command. block if + * socket is blocking. + * May return two error codes: + * * EWOULDBLOCK: if connect is still in progress + * * ENOTCONN: if connect failed. This would be the error + * message of a rect or sendto syscall so this is + * emulated here. + * * NULL: Called by a backround operation. Do not block and + * don't return any error code. * * Results: * 0 if the connection has completed, -1 if still in progress * or there is an error. * + * Side effects: + * Processes socket events off the system queue. + * May process asynchroneous connect. + * *---------------------------------------------------------------------- */ static int WaitForConnect( TcpState *statePtr, /* State of the socket. */ - int *errorCodePtr) /* Where to store errors? */ + int *errorCodePtr) { - int timeOut; /* How long to wait. */ - int state; /* Of calling TclWaitForFile. */ + int timeout; /* - * If an asynchronous connect is in progress, attempt to wait for it to - * complete before reading. + * Check if an async connect failed already and error reporting is demanded, + * return the error ENOTCONN */ - if (statePtr->flags & TCP_ASYNC_CONNECT) { - if (statePtr->flags & TCP_ASYNC_SOCKET) { - timeOut = 0; - } else { - timeOut = -1; - } - errno = 0; - state = TclUnixWaitForFile(statePtr->fds.fd, - TCL_WRITABLE | TCL_EXCEPTION, timeOut); - if (state & TCL_EXCEPTION) { - return -1; - } - if (state & TCL_WRITABLE) { - CLEAR_BITS(statePtr->flags, TCP_ASYNC_CONNECT); - } else if (timeOut == 0) { - *errorCodePtr = errno = EWOULDBLOCK; - return -1; - } + if (errorCodePtr != NULL && (statePtr->flags & TCP_ASYNC_FAILED)) { + *errorCodePtr = ENOTCONN; + return -1; + } + + /* + * Check if an async connect is running. If not return ok + */ + + if (!(statePtr->flags & TCP_ASYNC_PENDING)) { + return 0; + } + + if (errorCodePtr == NULL || (statePtr->flags & TCP_NONBLOCKING)) { + timeout = 0; + } else { + timeout = -1; + } + do { + if (TclUnixWaitForFile(statePtr->fds.fd, + TCL_WRITABLE | TCL_EXCEPTION, timeout) != 0) { + TcpConnect(NULL, statePtr); + } + /* Do this only once in the nonblocking case and repeat it until the + * socket is final when blocking */ + } while (timeout == -1 && statePtr->flags & TCP_ASYNC_CONNECT); + + if (errorCodePtr != NULL) { + if (statePtr->flags & TCP_ASYNC_PENDING) { + *errorCodePtr = EAGAIN; + return -1; + } else if (statePtr->connectError != 0) { + *errorCodePtr = ENOTCONN; + return -1; + } } return 0; } @@ -503,6 +558,7 @@ TcpOutputProc( return -1; } written = send(statePtr->fds.fd, buf, (size_t) toWrite, 0); + if (written > -1) { return written; } @@ -726,6 +782,8 @@ TcpGetOptionProc( TcpState *statePtr = instanceData; size_t len = 0; + WaitForConnect(statePtr, NULL); + if (optionName != NULL) { len = strlen(optionName); } @@ -733,27 +791,33 @@ TcpGetOptionProc( if ((len > 1) && (optionName[1] == 'e') && (strncmp(optionName, "-error", len) == 0)) { socklen_t optlen = sizeof(int); - int err, ret; - if (statePtr->status == 0) { - ret = getsockopt(statePtr->fds.fd, SOL_SOCKET, SO_ERROR, - (char *) &err, &optlen); - if (statePtr->flags & TCP_ASYNC_CONNECT) { - statePtr->status = err; - } - if (ret < 0) { - err = errno; - } + if (statePtr->flags & TCP_ASYNC_CONNECT) { + /* Suppress errors as long as we are not done */ + errno = 0; + } else if (statePtr->connectError != 0) { + errno = statePtr->connectError; + statePtr->connectError = 0; } else { - err = statePtr->status; - statePtr->status = 0; + int err; + getsockopt(statePtr->fds.fd, SOL_SOCKET, SO_ERROR, + (char *) &err, &optlen); + errno = err; + } + if (errno != 0) { + Tcl_DStringAppend(dsPtr, Tcl_ErrnoMsg(errno), -1); } - if (err != 0) { - Tcl_DStringAppend(dsPtr, Tcl_ErrnoMsg(err), -1); - } return TCL_OK; } + if ((len > 1) && (optionName[1] == 'c') && + (strncmp(optionName, "-connecting", len) == 0)) { + + Tcl_DStringAppend(dsPtr, + (statePtr->flags & TCP_ASYNC_CONNECT) ? "1" : "0", -1); + return TCL_OK; + } + if ((len == 0) || ((len > 1) && (optionName[1] == 'p') && (strncmp(optionName, "-peername", len) == 0))) { address peername; @@ -845,6 +909,35 @@ TcpGetOptionProc( */ static void +WrapNotify( + ClientData clientData, + int mask) +{ + TcpState *statePtr = (TcpState *) clientData; + int newmask = mask & statePtr->interest; + + if (newmask == 0) { + /* + * There was no overlap between the states the channel is + * interested in notifications for, and the states that are + * reported present on the file descriptor by select(). The + * only way that can happen is when the channel is interested + * in a writable condition, and only a readable state is reported + * present (see TcpWatchProc() below). In that case, signal back + * to the caller the writable state, which is really an error + * condition. As an extra check on that assumption, check for + * a non-zero value of errno before reporting an artificial + * writable state. + */ + if (errno == 0) { + return; + } + newmask = TCL_WRITABLE; + } + Tcl_NotifyChannel(statePtr->channel, newmask); +} + +static void TcpWatchProc( ClientData instanceData, /* The socket state. */ int mask) /* Events of interest; an OR-ed combination of @@ -862,13 +955,35 @@ TcpWatchProc( return; } - if (statePtr->flags & TCP_ASYNC_CONNECT) { + if (statePtr->flags & TCP_ASYNC_PENDING) { /* Async sockets use a FileHandler internally while connecting, so we * need to cache this request until the connection has succeeded. */ statePtr->filehandlers = mask; } else if (mask) { - Tcl_CreateFileHandler(statePtr->fds.fd, mask, - (Tcl_FileProc *) Tcl_NotifyChannel, statePtr->channel); + + /* + * Whether it is a bug or feature or otherwise, it is a fact + * of life that on at least some Linux kernels select() fails + * to report that a socket file descriptor is writable when + * the other end of the socket is closed. This is in contrast + * to the guarantees Tcl makes that its channels become + * writable and fire writable events on an error conditon. + * This has caused a leak of file descriptors in a state of + * background flushing. See Tcl ticket 1758a0b603. + * + * As a workaround, when our caller indicates an interest in + * writable notifications, we must tell the notifier built + * around select() that we are interested in the readable state + * of the file descriptor as well, as that is the only reliable + * means to get notified of error conditions. Then it is the + * task of WrapNotify() above to untangle the meaning of these + * channel states and report the chan events as best it can. + * We save a copy of the mask passed in to assist with that. + */ + + statePtr->interest = mask; + Tcl_CreateFileHandler(statePtr->fds.fd, mask|TCL_READABLE, + (Tcl_FileProc *) WrapNotify, statePtr); } else { Tcl_DeleteFileHandler(statePtr->fds.fd); } @@ -910,7 +1025,7 @@ TcpGetHandleProc( * * TcpAsyncCallback -- * - * Called by the event handler that CreateClientSocket sets up + * Called by the event handler that TcpConnect sets up * internally for [socket -async] to get notified when the * asyncronous connection attempt has succeeded or failed. * @@ -923,13 +1038,13 @@ TcpAsyncCallback( * TCL_READABLE, TCL_WRITABLE and * TCL_EXCEPTION. */ { - CreateClientSocket(NULL, clientData); + TcpConnect(NULL, clientData); } /* *---------------------------------------------------------------------- * - * CreateClientSocket -- + * TcpConnect -- * * This function opens a new socket in client mode. * @@ -957,33 +1072,32 @@ TcpAsyncCallback( */ static int -CreateClientSocket( +TcpConnect( Tcl_Interp *interp, /* For error reporting; can be NULL. */ - TcpState *state) + TcpState *statePtr) { socklen_t optlen; - int async_callback = (state->addr != NULL); - int status; - int async = state->flags & TCP_ASYNC_CONNECT; + int async_callback = statePtr->flags & TCP_ASYNC_PENDING; + int ret = -1, error = errno; + int async = statePtr->flags & TCP_ASYNC_CONNECT; if (async_callback) { goto reenter; } - for (state->addr = state->addrlist; state->addr != NULL; - state->addr = state->addr->ai_next) { - status = -1; + for (statePtr->addr = statePtr->addrlist; statePtr->addr != NULL; + statePtr->addr = statePtr->addr->ai_next) { - for (state->myaddr = state->myaddrlist; state->myaddr != NULL; - state->myaddr = state->myaddr->ai_next) { - int reuseaddr; + for (statePtr->myaddr = statePtr->myaddrlist; statePtr->myaddr != NULL; + statePtr->myaddr = statePtr->myaddr->ai_next) { + int reuseaddr = 1; /* * No need to try combinations of local and remote addresses of * different families. */ - if (state->myaddr->ai_family != state->addr->ai_family) { + if (statePtr->myaddr->ai_family != statePtr->addr->ai_family) { continue; } @@ -992,13 +1106,14 @@ CreateClientSocket( * iteration. */ - if (state->fds.fd >= 0) { - close(state->fds.fd); - state->fds.fd = -1; + if (statePtr->fds.fd >= 0) { + close(statePtr->fds.fd); + statePtr->fds.fd = -1; + errno = 0; } - state->fds.fd = socket(state->addr->ai_family, SOCK_STREAM, 0); - if (state->fds.fd < 0) { + statePtr->fds.fd = socket(statePtr->addr->ai_family, SOCK_STREAM, 0); + if (statePtr->fds.fd < 0) { continue; } @@ -1007,28 +1122,31 @@ CreateClientSocket( * inherited by child processes. */ - fcntl(state->fds.fd, F_SETFD, FD_CLOEXEC); + fcntl(statePtr->fds.fd, F_SETFD, FD_CLOEXEC); /* * Set kernel space buffering */ - TclSockMinimumBuffers(INT2PTR(state->fds.fd), SOCKET_BUFSIZE); + TclSockMinimumBuffers(INT2PTR(statePtr->fds.fd), SOCKET_BUFSIZE); if (async) { - status = TclUnixSetBlockingMode(state->fds.fd, - TCL_MODE_NONBLOCKING); - if (status < 0) { + ret = TclUnixSetBlockingMode(statePtr->fds.fd,TCL_MODE_NONBLOCKING); + if (ret < 0) { continue; - } - } + } + } - reuseaddr = 1; - (void) setsockopt(state->fds.fd, SOL_SOCKET, SO_REUSEADDR, + /* Gotta reset the error variable here, before we use it for the + * first time in this iteration. */ + error = 0; + + (void) setsockopt(statePtr->fds.fd, SOL_SOCKET, SO_REUSEADDR, (char *) &reuseaddr, sizeof(reuseaddr)); - status = bind(state->fds.fd, state->myaddr->ai_addr, - state->myaddr->ai_addrlen); - if (status < 0) { + ret = bind(statePtr->fds.fd, statePtr->myaddr->ai_addr, + statePtr->myaddr->ai_addrlen); + if (ret < 0) { + error = errno; continue; } @@ -1039,15 +1157,19 @@ CreateClientSocket( * in being informed when the connect completes. */ - status = connect(state->fds.fd, state->addr->ai_addr, - state->addr->ai_addrlen); - if (status < 0 && errno == EINPROGRESS) { - Tcl_CreateFileHandler(state->fds.fd, - TCL_WRITABLE|TCL_EXCEPTION, TcpAsyncCallback, state); + ret = connect(statePtr->fds.fd, statePtr->addr->ai_addr, + statePtr->addr->ai_addrlen); + if (ret < 0) error = errno; + if (ret < 0 && errno == EINPROGRESS) { + Tcl_CreateFileHandler(statePtr->fds.fd, + TCL_WRITABLE|TCL_EXCEPTION, TcpAsyncCallback, statePtr); + errno = EWOULDBLOCK; + SET_BITS(statePtr->flags, TCP_ASYNC_PENDING); return TCL_OK; reenter: - Tcl_DeleteFileHandler(state->fds.fd); + CLEAR_BITS(statePtr->flags, TCP_ASYNC_PENDING); + Tcl_DeleteFileHandler(statePtr->fds.fd); /* * Read the error state from the socket to see if the async @@ -1058,31 +1180,30 @@ CreateClientSocket( optlen = sizeof(int); - if (state->status == 0) { - getsockopt(state->fds.fd, SOL_SOCKET, SO_ERROR, - (char *) &status, &optlen); - state->status = status; - } else { - status = state->status; - state->status = 0; - } + getsockopt(statePtr->fds.fd, SOL_SOCKET, SO_ERROR, + (char *) &error, &optlen); + errno = error; } - if (status == 0) { + if (error == 0) { goto out; } } } out: - - CLEAR_BITS(state->flags, TCP_ASYNC_CONNECT); + statePtr->connectError = error; + CLEAR_BITS(statePtr->flags, TCP_ASYNC_CONNECT); if (async_callback) { /* * An asynchonous connection has finally succeeded or failed. */ - TcpWatchProc(state, state->filehandlers); - TclUnixSetBlockingMode(state->fds.fd, state->cachedBlocking); + TcpWatchProc(statePtr, statePtr->filehandlers); + TclUnixSetBlockingMode(statePtr->fds.fd, statePtr->cachedBlocking); + + if (error != 0) { + SET_BITS(statePtr->flags, TCP_ASYNC_FAILED); + } /* * We need to forward the writable event that brought us here, bcasue @@ -1093,8 +1214,11 @@ out: * the event mechanism one roundtrip through select(). */ - Tcl_NotifyChannel(state->channel, TCL_WRITABLE); - } else if (status != 0) { + if (statePtr->cachedBlocking == TCL_MODE_NONBLOCKING) { + Tcl_NotifyChannel(statePtr->channel, TCL_WRITABLE); + } + } + if (error != 0) { /* * Failure for either a synchronous connection, or an async one that * failed before it could enter background mode, e.g. because an @@ -1102,6 +1226,7 @@ out: */ if (interp != NULL) { + errno = error; Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't open socket: %s", Tcl_PosixError(interp))); } @@ -1138,7 +1263,7 @@ Tcl_OpenTcpClient( * connect. Otherwise we do a blocking * connect. */ { - TcpState *state; + TcpState *statePtr; const char *errorMsg = NULL; struct addrinfo *addrlist = NULL, *myaddrlist = NULL; char channelName[SOCK_CHAN_LENGTH]; @@ -1163,32 +1288,32 @@ Tcl_OpenTcpClient( /* * Allocate a new TcpState for this socket. */ - state = ckalloc(sizeof(TcpState)); - memset(state, 0, sizeof(TcpState)); - state->flags = async ? TCP_ASYNC_CONNECT : 0; - state->cachedBlocking = TCL_MODE_BLOCKING; - state->addrlist = addrlist; - state->myaddrlist = myaddrlist; - state->fds.fd = -1; + statePtr = ckalloc(sizeof(TcpState)); + memset(statePtr, 0, sizeof(TcpState)); + statePtr->flags = async ? TCP_ASYNC_CONNECT : 0; + statePtr->cachedBlocking = TCL_MODE_BLOCKING; + statePtr->addrlist = addrlist; + statePtr->myaddrlist = myaddrlist; + statePtr->fds.fd = -1; /* * Create a new client socket and wrap it in a channel. */ - if (CreateClientSocket(interp, state) != TCL_OK) { - TcpCloseProc(state, NULL); + if (TcpConnect(interp, statePtr) != TCL_OK) { + TcpCloseProc(statePtr, NULL); return NULL; } - sprintf(channelName, SOCK_TEMPLATE, (long) state); + sprintf(channelName, SOCK_TEMPLATE, (long) statePtr); - state->channel = Tcl_CreateChannel(&tcpChannelType, channelName, state, + statePtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName, statePtr, (TCL_READABLE | TCL_WRITABLE)); - if (Tcl_SetChannelOption(interp, state->channel, "-translation", + if (Tcl_SetChannelOption(interp, statePtr->channel, "-translation", "auto crlf") == TCL_ERROR) { - Tcl_Close(NULL, state->channel); + Tcl_Close(NULL, statePtr->channel); return NULL; } - return state->channel; + return statePtr->channel; } /* diff --git a/unix/tclUnixThrd.c b/unix/tclUnixThrd.c index f469341..d34bc88 100644 --- a/unix/tclUnixThrd.c +++ b/unix/tclUnixThrd.c @@ -727,6 +727,7 @@ TclpFreeAllocCache( */ TclFreeAllocCache(ptr); + pthread_setspecific(key, NULL); } else if (initialized) { /* diff --git a/win/Makefile.in b/win/Makefile.in index eecab5e..0e22de0 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -651,8 +651,8 @@ install-libraries: libraries install-tzdata install-msgs done; @echo "Installing package msgcat 1.5.2 as a Tcl Module"; @$(COPY) $(ROOT_DIR)/library/msgcat/msgcat.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/msgcat-1.5.2.tm; - @echo "Installing package tcltest 2.3.7 as a Tcl Module"; - @$(COPY) $(ROOT_DIR)/library/tcltest/tcltest.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/tcltest-2.3.7.tm; + @echo "Installing package tcltest 2.3.8 as a Tcl Module"; + @$(COPY) $(ROOT_DIR)/library/tcltest/tcltest.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/tcltest-2.3.8.tm; @echo "Installing package platform 1.0.12 as a Tcl Module"; @$(COPY) $(ROOT_DIR)/library/platform/platform.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.4/platform-1.0.12.tm; @echo "Installing package platform::shell 1.1.4 as a Tcl Module"; @@ -851,8 +851,10 @@ TOOL_DIR=$(ROOT_DIR)/tools HTML_INSTALL_DIR=$(ROOT_DIR)/html html: $(MAKE) shell SCRIPT="$(TOOL_DIR)/tcltk-man2html.tcl --htmldir=$(HTML_INSTALL_DIR) --srcdir=$(ROOT_DIR)/.. $(BUILD_HTML_FLAGS)" + html-tcl: $(TCLSH) $(MAKE) shell SCRIPT="$(TOOL_DIR)/tcltk-man2html.tcl --htmldir=$(HTML_INSTALL_DIR) --srcdir=$(ROOT_DIR)/.. $(BUILD_HTML_FLAGS) --tcl" + html-tk: $(TCLSH) $(MAKE) shell SCRIPT="$(TOOL_DIR)/tcltk-man2html.tcl --htmldir=$(HTML_INSTALL_DIR) --srcdir=$(ROOT_DIR)/.. $(BUILD_HTML_FLAGS) --tk" diff --git a/win/configure b/win/configure index 569172e..2affd38 100755 --- a/win/configure +++ b/win/configure @@ -3340,7 +3340,7 @@ cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ - #ifndef __WIN32__ + #ifndef _WIN32 #error cross-compiler #endif @@ -3463,7 +3463,7 @@ cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ - #ifdef __WIN32__ + #ifdef _WIN32 #error win32 #endif @@ -572,7 +572,7 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ AC_CACHE_CHECK(for cross-compile version of gcc, ac_cv_cross, AC_TRY_COMPILE([ - #ifndef __WIN32__ + #ifndef _WIN32 #error cross-compiler #endif ], [], @@ -639,7 +639,7 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ AC_CACHE_CHECK(for mingw32 version of gcc, ac_cv_win32, AC_TRY_COMPILE([ - #ifdef __WIN32__ + #ifdef _WIN32 #error win32 #endif ], [], diff --git a/win/tclConfig.sh.in b/win/tclConfig.sh.in index 65bc5c5..00a8790 100644 --- a/win/tclConfig.sh.in +++ b/win/tclConfig.sh.in @@ -175,6 +175,6 @@ TCL_BUILD_STUB_LIB_PATH='@TCL_BUILD_STUB_LIB_PATH@' # Path to the Tcl stub library in the install directory. TCL_STUB_LIB_PATH='@TCL_STUB_LIB_PATH@' -# Flag, 1: we built Tcl with threads enables, 0 we didn't +# Flag, 1: we built Tcl with threads enabled, 0 we didn't TCL_THREADS=@TCL_THREADS@ diff --git a/win/tclWin32Dll.c b/win/tclWin32Dll.c index 634e1d2..688fa8d 100644 --- a/win/tclWin32Dll.c +++ b/win/tclWin32Dll.c @@ -69,7 +69,7 @@ TCL_DECLARE_MUTEX(mountPointMap) * We will need this below. */ -#ifdef __WIN32__ +#ifdef _WIN32 #ifndef STATIC_BUILD /* @@ -137,7 +137,7 @@ DllMain( return TRUE; } #endif /* !STATIC_BUILD */ -#endif /* __WIN32__ */ +#endif /* _WIN32 */ /* *---------------------------------------------------------------------- diff --git a/win/tclWinChan.c b/win/tclWinChan.c index 21115f7..48acacb 100644 --- a/win/tclWinChan.c +++ b/win/tclWinChan.c @@ -95,7 +95,7 @@ static void FileThreadActionProc(ClientData instanceData, static int FileTruncateProc(ClientData instanceData, Tcl_WideInt length); static DWORD FileGetType(HANDLE handle); - +static int NativeIsComPort(CONST TCHAR *nativeName); /* * This structure describes the channel type structure for file based IO. */ @@ -662,6 +662,10 @@ FileInputProc( *errorCode = 0; /* + * TODO: This comment appears to be out of date. We *do* have a + * console driver, over in tclWinConsole.c. After some Windows + * developer confirms, this comment should be revised. + * * Note that we will block on reads from a console buffer until a full * line has been entered. The only way I know of to get around this is to * write a console driver. We should probably do this at some point, but @@ -885,6 +889,33 @@ TclpOpenFileChannel( } /* + * [2413550] Avoid double-open of serial ports on Windows + * Special handling for Windows serial ports by a "name-hint" + * to directly open it with the OVERLAPPED flag set. + */ + + if( NativeIsComPort(nativeName) ) { + + handle = TclWinSerialOpen(INVALID_HANDLE_VALUE, nativeName, accessMode); + if (handle == INVALID_HANDLE_VALUE) { + TclWinConvertError(GetLastError()); + if (interp != (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "couldn't open serial \"", + TclGetString(pathPtr), "\": ", + Tcl_PosixError(interp), NULL); + } + return NULL; + } + + /* + * For natively named Windows serial ports we are done. + */ + channel = TclWinOpenSerialChannel(handle, channelName, + channelPermissions); + + return channel; + } + /* * If the file is being created, get the file attributes from the * permissions argument, else use the existing file attributes. */ @@ -935,11 +966,15 @@ TclpOpenFileChannel( switch (FileGetType(handle)) { case FILE_TYPE_SERIAL: /* + * Natively named serial ports "com1-9", "\\\\.\\comXX" are + * already done with the code above. + * Here we handle all other serial port names. + * * Reopen channel for OVERLAPPED operation. Normally this shouldn't * fail, because the channel exists. */ - handle = TclWinSerialReopen(handle, nativeName, accessMode); + handle = TclWinSerialOpen(handle, nativeName, accessMode); if (handle == INVALID_HANDLE_VALUE) { TclWinConvertError(GetLastError()); if (interp != (Tcl_Interp *) NULL) { @@ -1479,6 +1514,74 @@ FileGetType( return type; } + /* + *---------------------------------------------------------------------- + * + * NativeIsComPort -- + * + * Determines if a path refers to a Windows serial port. + * A simple and efficient solution is to use a "name hint" to detect + * COM ports by their filename instead of resorting to a syscall + * to detect serialness after the fact. + * The following patterns cover common serial port names: + * COM[1-9]:? + * //./COM[0-9]+ + * \\.\COM[0-9]+ + * + * Results: + * 1 = serial port, 0 = not. + * + *---------------------------------------------------------------------- + */ + +static int +NativeIsComPort( + const TCHAR *nativePath) /* Path of file to access, native encoding. */ +{ + const WCHAR *p = (const WCHAR *) nativePath; + int i, len = wcslen(p); + + /* + * 1. Look for com[1-9]:? + */ + + if ( (len >= 4) && (len <= 5) + && (_wcsnicmp(p, L"com", 3) == 0) ) { + /* + * The 4th character must be a digit 1..9 optionally followed by a ":" + */ + + if ( (p[3] < L'1') || (p[3] > L'9') ) { + return 0; + } + if ( (len == 5) && (p[4] != L':') ) { + return 0; + } + return 1; + } + + /* + * 2. Look for //./com[0-9]+ or \\.\com[0-9]+ + */ + + if ( (len >= 8) && ( + (_wcsnicmp(p, L"//./com", 7) == 0) + || (_wcsnicmp(p, L"\\\\.\\com", 7) == 0) ) ) + { + /* + * Charaters 8..end must be a digits 0..9 + */ + + for ( i=7; i<len; i++ ) { + if ( (p[i] < '0') || (p[i] > '9') ) { + return 0; + } + } + return 1; + } + return 0; +} + /* * Local Variables: * mode: c diff --git a/win/tclWinConsole.c b/win/tclWinConsole.c index 0ec22c5..6630083 100644 --- a/win/tclWinConsole.c +++ b/win/tclWinConsole.c @@ -756,6 +756,13 @@ ConsoleInputProc( if (ReadConsoleBytes(infoPtr->handle, (LPVOID) buf, (DWORD) bufSize, &count) == TRUE) { + /* + * TODO: This potentially writes beyond the limits specified + * by the caller. In practice this is harmless, since all writes + * are into ChannelBuffers, and those have padding, but still + * ought to remove this, unless some Windows wizard can give + * a reason not to. + */ buf[count] = '\0'; return count; } diff --git a/win/tclWinFCmd.c b/win/tclWinFCmd.c index 2700cb3..52ea8c6 100644 --- a/win/tclWinFCmd.c +++ b/win/tclWinFCmd.c @@ -1108,7 +1108,12 @@ DoRemoveJustDirectory( end: if (errorPtr != NULL) { + char *p; Tcl_WinTCharToUtf(nativePath, -1, errorPtr); + p = Tcl_DStringValue(errorPtr); + for (; *p; ++p) { + if (*p == '\\') *p = '/'; + } } return TCL_ERROR; @@ -1825,12 +1830,12 @@ SetWinFileAttributes( Tcl_Obj *fileName, /* The name of the file. */ Tcl_Obj *attributePtr) /* The new value of the attribute. */ { - DWORD fileAttributes; + DWORD fileAttributes, old; int yesNo, result; const TCHAR *nativeName; nativeName = Tcl_FSGetNativePath(fileName); - fileAttributes = GetFileAttributes(nativeName); + fileAttributes = old = GetFileAttributes(nativeName); if (fileAttributes == 0xffffffff) { StatError(interp, fileName); @@ -1848,7 +1853,8 @@ SetWinFileAttributes( fileAttributes &= ~(attributeArray[objIndex]); } - if (!SetFileAttributes(nativeName, fileAttributes)) { + if ((fileAttributes != old) + && !SetFileAttributes(nativeName, fileAttributes)) { StatError(interp, fileName); return TCL_ERROR; } diff --git a/win/tclWinFile.c b/win/tclWinFile.c index f69ad23..ad4a5c4 100644 --- a/win/tclWinFile.c +++ b/win/tclWinFile.c @@ -1816,6 +1816,9 @@ TclpObjChdir( nativePath = Tcl_FSGetNativePath(pathPtr); + if (!nativePath) { + return -1; + } result = SetCurrentDirectory(nativePath); if (result == 0) { @@ -2894,10 +2897,11 @@ ClientData TclNativeCreateNativeRep( Tcl_Obj *pathPtr) { - char *nativePathPtr, *str; - Tcl_DString ds; + WCHAR *nativePathPtr; + const char *str; Tcl_Obj *validPathPtr; int len; + WCHAR *wp; if (TclFSCwdIsNative()) { /* @@ -2923,22 +2927,71 @@ TclNativeCreateNativeRep( } str = Tcl_GetStringFromObj(validPathPtr, &len); - if (str[0] == '/' && str[1] == '/' && str[2] == '?' && str[3] == '/') { - char *p; - for (p = str; p && *p; ++p) { - if (*p == '/') { - *p = '\\'; - } + if (strlen(str)!=len) { + /* String contains NUL-bytes. This is invalid. */ + return 0; + } + /* Let MultiByteToWideChar check for other invalid sequences, like + * 0xC0 0x80 (== overlong NUL). See bug [3118489]: NUL in filenames */ + len = MultiByteToWideChar(CP_UTF8, MB_ERR_INVALID_CHARS, str, -1, 0, 0); + if (len==0) { + return 0; + } + /* Overallocate 6 chars, making some room for extended paths */ + wp = nativePathPtr = ckalloc( (len+6) * sizeof(WCHAR) ); + if (nativePathPtr==0) { + return 0; + } + MultiByteToWideChar(CP_UTF8, MB_ERR_INVALID_CHARS, str, -1, nativePathPtr, len); + /* + ** If path starts with "//?/" or "\\?\" (extended path), translate + ** any slashes to backslashes but leave the '?' intact + */ + if ((str[0]=='\\' || str[0]=='/') && (str[1]=='\\' || str[1]=='/') + && str[2]=='?' && (str[3]=='\\' || str[3]=='/')) { + wp[0] = wp[1] = wp[3] = '\\'; + str += 4; + wp += 4; + } + /* + ** If there is no "\\?\" prefix but there is a drive or UNC + ** path prefix and the path is larger than MAX_PATH chars, + ** no Win32 API function can handle that unless it is + ** prefixed with the extended path prefix. See: + ** <http://msdn.microsoft.com/en-us/library/aa365247(VS.85).aspx#maxpath> + **/ + if (((str[0]>='A'&&str[0]<='Z') || (str[0]>='a'&&str[0]<='z')) + && str[1]==':') { + if (wp==nativePathPtr && len>MAX_PATH && (str[2]=='\\' || str[2]=='/')) { + memmove(wp+4, wp, len*sizeof(WCHAR)); + memcpy(wp, L"\\\\?\\", 4*sizeof(WCHAR)); + wp += 4; } + /* + ** If (remainder of) path starts with "<drive>:", + ** leave the ':' intact. + */ + wp += 2; + } else if (wp==nativePathPtr && len>MAX_PATH + && (str[0]=='\\' || str[0]=='/') + && (str[1]=='\\' || str[1]=='/') && str[2]!='?') { + memmove(wp+6, wp, len*sizeof(WCHAR)); + memcpy(wp, L"\\\\?\\UNC", 7*sizeof(WCHAR)); + wp += 7; + } + /* + ** In the remainder of the path, translate invalid characters to + ** characters in the Unicode private use area. + */ + while (*wp != '\0') { + if ((*wp < ' ') || wcschr(L"\"*:<>?|", *wp)) { + *wp |= 0xF000; + } else if (*wp == '/') { + *wp = '\\'; + } + ++wp; } - Tcl_WinUtfToTChar(str, len, &ds); - len = Tcl_DStringLength(&ds) + sizeof(WCHAR); - Tcl_DecrRefCount(validPathPtr); - nativePathPtr = ckalloc(len); - memcpy(nativePathPtr, Tcl_DStringValue(&ds), (size_t) len); - - Tcl_DStringFree(&ds); return nativePathPtr; } diff --git a/win/tclWinInit.c b/win/tclWinInit.c index 2c21d38..8b600f6 100644 --- a/win/tclWinInit.c +++ b/win/tclWinInit.c @@ -113,8 +113,8 @@ static int ToUtf(const WCHAR *wSrc, char *dst); * * TclpInitPlatform -- * - * Initialize all the platform-dependant things like signals and - * floating-point error handling. + * Initialize all the platform-dependant things like signals, + * floating-point error handling and sockets. * * Called at process initialization time. * @@ -130,20 +130,16 @@ static int ToUtf(const WCHAR *wSrc, char *dst); void TclpInitPlatform(void) { + WSADATA wsaData; + WORD wVersionRequested = MAKEWORD(2, 2); + tclPlatform = TCL_PLATFORM_WINDOWS; /* - * The following code stops Windows 3.X and Windows NT 3.51 from - * automatically putting up Sharing Violation dialogs, e.g, when someone - * tries to access a file that is locked or a drive with no disk in it. - * Tcl already returns the appropriate error to the caller, and they can - * decide to put up their own dialog in response to that failure. - * - * Under 95 and NT 4.0, this is a NOOP because the system doesn't - * automatically put up dialogs when the above operations fail. + * Initialize the winsock library. On Windows XP and higher this + * can never fail. */ - - SetErrorMode(SetErrorMode(0) | SEM_FAILCRITICALERRORS); + WSAStartup(wVersionRequested, &wsaData); #ifdef STATIC_BUILD /* diff --git a/win/tclWinInt.h b/win/tclWinInt.h index c7066bb..9df424f 100644 --- a/win/tclWinInt.h +++ b/win/tclWinInt.h @@ -66,7 +66,7 @@ MODULE_SCOPE Tcl_Channel TclWinOpenFileChannel(HANDLE handle, char *channelName, int permissions, int appendMode); MODULE_SCOPE Tcl_Channel TclWinOpenSerialChannel(HANDLE handle, char *channelName, int permissions); -MODULE_SCOPE HANDLE TclWinSerialReopen(HANDLE handle, const TCHAR *name, +MODULE_SCOPE HANDLE TclWinSerialOpen(HANDLE handle, const TCHAR *name, DWORD access); MODULE_SCOPE int TclWinSymLinkCopyDirectory(const TCHAR *LinkOriginal, const TCHAR *LinkCopy); diff --git a/win/tclWinPipe.c b/win/tclWinPipe.c index 77fc776..a9eec6d 100644 --- a/win/tclWinPipe.c +++ b/win/tclWinPipe.c @@ -82,6 +82,12 @@ static ProcInfo *procList; #define PIPE_EXTRABYTE (1<<3) /* The reader thread has consumed one byte. */ /* + * TODO: It appears the whole EXTRABYTE machinery is in place to support + * outdated Win 95 systems. If this can be confirmed, much code can be + * deleted. + */ + +/* * This structure describes per-instance data for a pipe based channel. */ diff --git a/win/tclWinPort.h b/win/tclWinPort.h index 61f149b..652cd06 100644 --- a/win/tclWinPort.h +++ b/win/tclWinPort.h @@ -528,15 +528,6 @@ typedef DWORD_PTR * PDWORD_PTR; #define TclpSysRealloc(ptr, size) ((void*)HeapReAlloc(GetProcessHeap(), \ (DWORD)0, (LPVOID)ptr, (DWORD)size)) -/* - * The following defines map from standard socket names to our internal - * wrappers that redirect through the winSock function table (see the - * file tclWinSock.c). - */ - -#define getservbyname TclWinGetServByName -#define getsockopt TclWinGetSockOpt -#define setsockopt TclWinSetSockOpt /* This type is not defined in the Windows headers */ #define socklen_t int diff --git a/win/tclWinSerial.c b/win/tclWinSerial.c index b9c9a9f..6487fe4 100644 --- a/win/tclWinSerial.c +++ b/win/tclWinSerial.c @@ -1410,23 +1410,22 @@ SerialWriterThread( /* *---------------------------------------------------------------------- * - * TclWinSerialReopen -- + * TclWinSerialOpen -- * - * Reopens the serial port with the OVERLAPPED FLAG set + * Opens or Reopens the serial port with the OVERLAPPED FLAG set * * Results: - * Returns the new handle, or INVALID_HANDLE_VALUE. Normally there - * shouldn't be any error, because the same channel has previously been - * succeesfully opened. + * Returns the new handle, or INVALID_HANDLE_VALUE. + * If an existing channel is specified it is closed and reopened. * * Side effects: - * May close the original handle + * May close/reopen the original handle * *---------------------------------------------------------------------- */ HANDLE -TclWinSerialReopen( +TclWinSerialOpen( HANDLE handle, const TCHAR *name, DWORD access) @@ -1434,16 +1433,22 @@ TclWinSerialReopen( SerialInit(); /* + * If an open channel is specified, close it + */ + + if ( handle != INVALID_HANDLE_VALUE && CloseHandle(handle) == FALSE) { + return INVALID_HANDLE_VALUE; + } + + /* * Multithreaded I/O needs the overlapped flag set otherwise * ClearCommError blocks under Windows NT/2000 until serial output is * finished */ - if (CloseHandle(handle) == FALSE) { - return INVALID_HANDLE_VALUE; - } handle = CreateFile(name, access, 0, 0, OPEN_EXISTING, FILE_FLAG_OVERLAPPED, 0); + return handle; } diff --git a/win/tclWinSock.c b/win/tclWinSock.c index 11b4162..f343f82 100644 --- a/win/tclWinSock.c +++ b/win/tclWinSock.c @@ -9,6 +9,9 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. * * ----------------------------------------------------------------------- + * The order and naming of functions in this file should minimize + * the file diff to tclUnixSock.c. + * ----------------------------------------------------------------------- * * General information on how this module works. * @@ -47,13 +50,6 @@ #include "tclWinInt.h" -/* - * Which version of the winsock API do we want? - */ - -#define WSA_VERSION_MAJOR 1 -#define WSA_VERSION_MINOR 1 - #ifdef _MSC_VER # pragma comment (lib, "ws2_32") #endif @@ -75,6 +71,19 @@ #undef setsockopt /* + * Helper macros to make parts of this file clearer. The macros do exactly + * what they say on the tin. :-) They also only ever refer to their arguments + * once, and so can be used without regard to side effects. + */ + +#define SET_BITS(var, bits) ((var) |= (bits)) +#define CLEAR_BITS(var, bits) ((var) &= ~(bits)) + +/* "sock" + a pointer in hex + \0 */ +#define SOCK_CHAN_LENGTH (4 + sizeof(void *) * 2 + 1) +#define SOCK_TEMPLATE "sock%p" + +/* * The following variable is used to tell whether this module has been * initialized. If 1, initialization of sockets was successful, if -1 then * socket initialization failed (WSAStartup failed). @@ -85,15 +94,6 @@ static const TCHAR classname[] = TEXT("TclSocket"); TCL_DECLARE_MUTEX(socketMutex) /* - * The following variable holds the network name of this host. - */ - -static TclInitProcessGlobalValueProc InitializeHostName; -static ProcessGlobalValue hostName = { - 0, 0, NULL, NULL, InitializeHostName, NULL, NULL -}; - -/* * The following defines declare the messages used on socket windows. */ @@ -119,20 +119,19 @@ typedef union { #define IN6_ARE_ADDR_EQUAL IN6_ADDR_EQUAL #endif -typedef struct SocketInfo SocketInfo; +/* + * This structure describes per-instance state of a tcp based channel. + */ + +typedef struct TcpState TcpState; typedef struct TcpFdList { - SocketInfo *infoPtr; + TcpState *statePtr; SOCKET fd; struct TcpFdList *next; } TcpFdList; -/* - * The following structure is used to store the data associated with each - * socket. - */ - -struct SocketInfo { +struct TcpState { Tcl_Channel channel; /* Channel associated with this socket. */ struct TcpFdList *sockets; /* Windows SOCKET handle. */ int flags; /* Bit field comprised of the flags described @@ -140,24 +139,60 @@ struct SocketInfo { int watchEvents; /* OR'ed combination of FD_READ, FD_WRITE, * FD_CLOSE, FD_ACCEPT and FD_CONNECT that * indicate which events are interesting. */ - int readyEvents; /* OR'ed combination of FD_READ, FD_WRITE, + volatile int readyEvents; /* OR'ed combination of FD_READ, FD_WRITE, * FD_CLOSE, FD_ACCEPT and FD_CONNECT that - * indicate which events have occurred. */ + * indicate which events have occurred. + * Set by notifier thread, access must be + * protected by semaphore */ int selectEvents; /* OR'ed combination of FD_READ, FD_WRITE, * FD_CLOSE, FD_ACCEPT and FD_CONNECT that * indicate which events are currently being * selected. */ - int acceptEventCount; /* Count of the current number of FD_ACCEPTs - * that have arrived and not yet processed. */ + volatile int acceptEventCount; + /* Count of the current number of FD_ACCEPTs + * that have arrived and not yet processed. + * Set by notifier thread, access must be + * protected by semaphore */ Tcl_TcpAcceptProc *acceptProc; /* Proc to call on accept. */ ClientData acceptProcData; /* The data for the accept proc. */ - int lastError; /* Error code from last message. */ - struct SocketInfo *nextPtr; /* The next socket on the per-thread socket + + /* + * Only needed for client sockets + */ + + struct addrinfo *addrlist; /* Addresses to connect to. */ + struct addrinfo *addr; /* Iterator over addrlist. */ + struct addrinfo *myaddrlist;/* Local address. */ + struct addrinfo *myaddr; /* Iterator over myaddrlist. */ + int connectError; /* Cache status of async socket. */ + int cachedBlocking; /* Cache blocking mode of async socket. */ + volatile int notifierConnectError; + /* Async connect error set by notifier thread. + * This error is still a windows error code. + * Access must be protected by semaphore */ + struct TcpState *nextPtr; /* The next socket on the per-thread socket * list. */ }; /* + * These bits may be ORed together into the "flags" field of a TcpState + * structure. + */ + +#define TCP_NONBLOCKING (1<<0) /* Socket with non-blocking I/O */ +#define TCP_ASYNC_CONNECT (1<<1) /* Async connect in progress. */ +#define SOCKET_EOF (1<<2) /* A zero read happened on the + * socket. */ +#define SOCKET_PENDING (1<<3) /* A message has been sent for this + * socket */ +#define TCP_ASYNC_PENDING (1<<4) /* TcpConnect was called to + * process an async connect. This + * flag indicates that reentry is + * still pending */ +#define TCP_ASYNC_FAILED (1<<5) /* An async connect finally failed */ + +/* * The following structure is what is added to the Tcl event queue when a * socket event occurs. */ @@ -166,8 +201,8 @@ typedef struct { Tcl_Event header; /* Information that is standard for all * events. */ SOCKET socket; /* Socket descriptor that is ready. Used to - * find the SocketInfo structure for the file - * (can't point directly to the SocketInfo + * find the TcpState structure for the file + * (can't point directly to the TcpState * structure because it could go away while * the event is queued). */ } SocketEvent; @@ -178,17 +213,6 @@ typedef struct { #define TCP_BUFFER_SIZE 4096 -/* - * The following macros may be used to set the flags field of a SocketInfo - * structure. - */ - -#define SOCKET_ASYNC (1<<0) /* The socket is in blocking mode. */ -#define SOCKET_EOF (1<<1) /* A zero read happened on the - * socket. */ -#define SOCKET_ASYNC_CONNECT (1<<2) /* This socket uses async connect. */ -#define SOCKET_PENDING (1<<3) /* A message has been sent for this - * socket */ typedef struct { HWND hwnd; /* Handle to window for socket messages. */ @@ -199,7 +223,11 @@ typedef struct { * socketThread has been initialized and has * started. */ HANDLE socketListLock; /* Win32 Event to lock the socketList */ - SocketInfo *socketList; /* Every open socket in this thread has an + TcpState *pendingTcpState; + /* This socket is opened but not jet in the + * list. This value is also checked by + * the event structure. */ + TcpState *socketList; /* Every open socket in this thread has an * entry on this list. */ } ThreadSpecificData; @@ -207,21 +235,23 @@ static Tcl_ThreadDataKey dataKey; static WNDCLASS windowClass; /* - * Static functions defined in this file. + * Static routines for this file: */ -static SocketInfo * CreateSocket(Tcl_Interp *interp, int port, - const char *host, int server, const char *myaddr, - int myport, int async); +static int TcpConnect(Tcl_Interp *interp, + TcpState *state); static void InitSockets(void); -static SocketInfo * NewSocketInfo(SOCKET socket); +static TcpState * NewSocketInfo(SOCKET socket); static void SocketExitHandler(ClientData clientData); static LRESULT CALLBACK SocketProc(HWND hwnd, UINT message, WPARAM wParam, LPARAM lParam); static int SocketsEnabled(void); static void TcpAccept(TcpFdList *fds, SOCKET newSocket, address addr); -static int WaitForSocketEvent(SocketInfo *infoPtr, int events, +static int WaitForConnect(TcpState *statePtr, int *errorCodePtr); +static int WaitForSocketEvent(TcpState *statePtr, int events, int *errorCodePtr); +static void AddSocketInfoFd(TcpState *statePtr, SOCKET socket); +static int FindFDInList(TcpState *statePtr, SOCKET socket); static DWORD WINAPI SocketThread(LPVOID arg); static void TcpThreadActionProc(ClientData instanceData, int action); @@ -229,7 +259,7 @@ static void TcpThreadActionProc(ClientData instanceData, static Tcl_EventCheckProc SocketCheckProc; static Tcl_EventProc SocketEventProc; static Tcl_EventSetupProc SocketSetupProc; -static Tcl_DriverBlockModeProc TcpBlockProc; +static Tcl_DriverBlockModeProc TcpBlockModeProc; static Tcl_DriverCloseProc TcpCloseProc; static Tcl_DriverClose2Proc TcpClose2Proc; static Tcl_DriverSetOptionProc TcpSetOptionProc; @@ -241,227 +271,180 @@ static Tcl_DriverGetHandleProc TcpGetHandleProc; /* * This structure describes the channel type structure for TCP socket - * based IO. + * based IO: */ static const Tcl_ChannelType tcpChannelType = { - "tcp", /* Type name. */ - TCL_CHANNEL_VERSION_5, /* v5 channel */ - TcpCloseProc, /* Close proc. */ - TcpInputProc, /* Input proc. */ - TcpOutputProc, /* Output proc. */ - NULL, /* Seek proc. */ - TcpSetOptionProc, /* Set option proc. */ - TcpGetOptionProc, /* Get option proc. */ - TcpWatchProc, /* Set up notifier to watch this channel. */ - TcpGetHandleProc, /* Get an OS handle from channel. */ - TcpClose2Proc, /* Close2proc. */ - TcpBlockProc, /* Set socket into (non-)blocking mode. */ - NULL, /* flush proc. */ - NULL, /* handler proc. */ - NULL, /* wide seek proc */ - TcpThreadActionProc, /* thread action proc */ - NULL /* truncate */ + "tcp", /* Type name. */ + TCL_CHANNEL_VERSION_5, /* v5 channel */ + TcpCloseProc, /* Close proc. */ + TcpInputProc, /* Input proc. */ + TcpOutputProc, /* Output proc. */ + NULL, /* Seek proc. */ + TcpSetOptionProc, /* Set option proc. */ + TcpGetOptionProc, /* Get option proc. */ + TcpWatchProc, /* Initialize notifier. */ + TcpGetHandleProc, /* Get OS handles out of channel. */ + TcpClose2Proc, /* Close2 proc. */ + TcpBlockModeProc, /* Set blocking or non-blocking mode.*/ + NULL, /* flush proc. */ + NULL, /* handler proc. */ + NULL, /* wide seek proc. */ + TcpThreadActionProc, /* thread action proc. */ + NULL /* truncate proc. */ }; + +/* + * The following variable holds the network name of this host. + */ + +static TclInitProcessGlobalValueProc InitializeHostName; +static ProcessGlobalValue hostName = + {0, 0, NULL, NULL, InitializeHostName, NULL, NULL}; + +/* + * Address print debug functions + */ +#if 0 +void printaddrinfo(struct addrinfo *ai, char *prefix) +{ + char host[NI_MAXHOST], port[NI_MAXSERV]; + getnameinfo(ai->ai_addr, ai->ai_addrlen, + host, sizeof(host), + port, sizeof(port), + NI_NUMERICHOST|NI_NUMERICSERV); +} +void printaddrinfolist(struct addrinfo *addrlist, char *prefix) +{ + struct addrinfo *ai; + for (ai = addrlist; ai != NULL; ai = ai->ai_next) { + printaddrinfo(ai, prefix); + } +} +#endif /* *---------------------------------------------------------------------- * - * InitSockets -- - * - * Initialize the socket module. If winsock startup is successful, - * registers the event window for the socket notifier code. + * InitializeHostName -- * - * Assumes socketMutex is held. + * This routine sets the process global value of the name of the local + * host on which the process is running. * * Results: * None. * - * Side effects: - * Initializes winsock, registers a new window class and creates a - * window for use in asynchronous socket notification. - * *---------------------------------------------------------------------- */ -static void -InitSockets(void) +void +InitializeHostName( + char **valuePtr, + int *lengthPtr, + Tcl_Encoding *encodingPtr) { - DWORD id, err; - WSADATA wsaData; - ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey); - - if (!initialized) { - initialized = 1; - TclCreateLateExitHandler(SocketExitHandler, NULL); + TCHAR tbuf[MAX_COMPUTERNAME_LENGTH + 1]; + DWORD length = MAX_COMPUTERNAME_LENGTH + 1; + Tcl_DString ds; + if (GetComputerName(tbuf, &length) != 0) { /* - * Create the async notification window with a new class. We must - * create a new class to avoid a Windows 95 bug that causes us to get - * the wrong message number for socket events if the message window is - * a subclass of a static control. + * Convert string from native to UTF then change to lowercase. */ - windowClass.style = 0; - windowClass.cbClsExtra = 0; - windowClass.cbWndExtra = 0; - windowClass.hInstance = TclWinGetTclInstance(); - windowClass.hbrBackground = NULL; - windowClass.lpszMenuName = NULL; - windowClass.lpszClassName = classname; - windowClass.lpfnWndProc = SocketProc; - windowClass.hIcon = NULL; - windowClass.hCursor = NULL; - - if (!RegisterClass(&windowClass)) { - TclWinConvertError(GetLastError()); - goto initFailure; - } - - /* - * Initialize the winsock library and check the interface version - * actually loaded. We only ask for the 1.1 interface and do require - * that it not be less than 1.1. - */ + Tcl_UtfToLower(Tcl_WinTCharToUtf(tbuf, -1, &ds)); - err = WSAStartup((WORD) MAKEWORD(WSA_VERSION_MAJOR,WSA_VERSION_MINOR), - &wsaData); - if (err != 0) { - TclWinConvertError(err); - goto initFailure; - } + } else { + Tcl_DStringInit(&ds); + if (TclpHasSockets(NULL) == TCL_OK) { + /* + * The buffer size of 256 is recommended by the MSDN page that + * documents gethostname() as being always adequate. + */ - /* - * Note the byte positions ae swapped for the comparison, so that - * 0x0002 (2.0, MAKEWORD(2,0)) doesn't look less than 0x0101 (1.1). We - * want the comparison to be 0x0200 < 0x0101. - */ + Tcl_DString inDs; - if (MAKEWORD(HIBYTE(wsaData.wVersion), LOBYTE(wsaData.wVersion)) - < MAKEWORD(WSA_VERSION_MINOR, WSA_VERSION_MAJOR)) { - TclWinConvertError(WSAVERNOTSUPPORTED); - WSACleanup(); - goto initFailure; + Tcl_DStringInit(&inDs); + Tcl_DStringSetLength(&inDs, 256); + if (gethostname(Tcl_DStringValue(&inDs), + Tcl_DStringLength(&inDs)) == 0) { + Tcl_ExternalToUtfDString(NULL, Tcl_DStringValue(&inDs), -1, + &ds); + } + Tcl_DStringFree(&inDs); } } - /* - * Check for per-thread initialization. - */ - - if (tsdPtr != NULL) { - return; - } - - /* - * OK, this thread has never done anything with sockets before. Construct - * a worker thread to handle asynchronous events related to sockets - * assigned to _this_ thread. - */ - - tsdPtr = TCL_TSD_INIT(&dataKey); - tsdPtr->socketList = NULL; - tsdPtr->hwnd = NULL; - tsdPtr->threadId = Tcl_GetCurrentThread(); - tsdPtr->readyEvent = CreateEvent(NULL, FALSE, FALSE, NULL); - if (tsdPtr->readyEvent == NULL) { - goto initFailure; - } - tsdPtr->socketListLock = CreateEvent(NULL, FALSE, TRUE, NULL); - if (tsdPtr->socketListLock == NULL) { - goto initFailure; - } - tsdPtr->socketThread = CreateThread(NULL, 256, SocketThread, tsdPtr, 0, - &id); - if (tsdPtr->socketThread == NULL) { - goto initFailure; - } - - SetThreadPriority(tsdPtr->socketThread, THREAD_PRIORITY_HIGHEST); - - /* - * Wait for the thread to signal when the window has been created and if - * it is ready to go. - */ - - WaitForSingleObject(tsdPtr->readyEvent, INFINITE); - - if (tsdPtr->hwnd == NULL) { - goto initFailure; /* Trouble creating the window. */ - } - - Tcl_CreateEventSource(SocketSetupProc, SocketCheckProc, NULL); - return; - - initFailure: - TclpFinalizeSockets(); - initialized = -1; - return; + *encodingPtr = Tcl_GetEncoding(NULL, "utf-8"); + *lengthPtr = Tcl_DStringLength(&ds); + *valuePtr = ckalloc((*lengthPtr) + 1); + memcpy(*valuePtr, Tcl_DStringValue(&ds), (size_t)(*lengthPtr)+1); + Tcl_DStringFree(&ds); } /* *---------------------------------------------------------------------- * - * SocketsEnabled -- + * Tcl_GetHostName -- * - * Check that the WinSock was successfully initialized. + * Returns the name of the local host. * * Results: - * 1 if it is. + * A string containing the network name for this machine, or an empty + * string if we can't figure out the name. The caller must not modify or + * free this string. * * Side effects: - * None. + * Caches the name to return for future calls. * *---------------------------------------------------------------------- */ - /* ARGSUSED */ -static int -SocketsEnabled(void) +const char * +Tcl_GetHostName(void) { - int enabled; - - Tcl_MutexLock(&socketMutex); - enabled = (initialized == 1); - Tcl_MutexUnlock(&socketMutex); - return enabled; + return Tcl_GetString(TclGetProcessGlobalValue(&hostName)); } - /* *---------------------------------------------------------------------- * - * SocketExitHandler -- + * TclpHasSockets -- * - * Callback invoked during exit clean up to delete the socket - * communication window and to release the WinSock DLL. + * This function determines whether sockets are available on the current + * system and returns an error in interp if they are not. Note that + * interp may be NULL. * * Results: - * None. + * Returns TCL_OK if the system supports sockets, or TCL_ERROR with an + * error in interp (if non-NULL). * * Side effects: - * None. + * If not already prepared, initializes the TSD structure and socket + * message handling thread associated to the calling thread for the + * subsystem of the driver. * *---------------------------------------------------------------------- */ - /* ARGSUSED */ -static void -SocketExitHandler( - ClientData clientData) /* Not used. */ +int +TclpHasSockets( + Tcl_Interp *interp) /* Where to write an error message if sockets + * are not present, or NULL if no such message + * is to be written. */ { Tcl_MutexLock(&socketMutex); - - /* - * Make sure the socket event handling window is cleaned-up for, at - * most, this thread. - */ - - TclpFinalizeSockets(); - UnregisterClass(classname, TclWinGetTclInstance()); - WSACleanup(); - initialized = 0; + InitSockets(); Tcl_MutexUnlock(&socketMutex); + + if (SocketsEnabled()) { + return TCL_OK; + } + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "sockets are not available on this system", -1)); + } + return TCL_ERROR; } /* @@ -525,365 +508,451 @@ TclpFinalizeSockets(void) /* *---------------------------------------------------------------------- * - * TclpHasSockets -- + * TcpBlockModeProc -- * - * This function determines whether sockets are available on the current - * system and returns an error in interp if they are not. Note that - * interp may be NULL. + * This function is invoked by the generic IO level to set blocking and + * nonblocking mode on a TCP socket based channel. * * Results: - * Returns TCL_OK if the system supports sockets, or TCL_ERROR with an - * error in interp (if non-NULL). + * 0 if successful, errno when failed. * * Side effects: - * If not already prepared, initializes the TSD structure and socket - * message handling thread associated to the calling thread for the - * subsystem of the driver. + * Sets the device into blocking or nonblocking mode. * *---------------------------------------------------------------------- */ -int -TclpHasSockets( - Tcl_Interp *interp) /* Where to write an error message if sockets - * are not present, or NULL if no such message - * is to be written. */ + /* ARGSUSED */ +static int +TcpBlockModeProc( + ClientData instanceData, /* Socket state. */ + int mode) /* The mode to set. Can be one of + * TCL_MODE_BLOCKING or + * TCL_MODE_NONBLOCKING. */ { - Tcl_MutexLock(&socketMutex); - InitSockets(); - Tcl_MutexUnlock(&socketMutex); + TcpState *statePtr = instanceData; - if (SocketsEnabled()) { - return TCL_OK; - } - if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "sockets are not available on this system", -1)); + if (mode == TCL_MODE_NONBLOCKING) { + statePtr->flags |= TCP_NONBLOCKING; + } else { + statePtr->flags &= ~(TCP_NONBLOCKING); } - return TCL_ERROR; + return 0; } /* *---------------------------------------------------------------------- * - * SocketSetupProc -- + * WaitForConnect -- * - * This function is invoked before Tcl_DoOneEvent blocks waiting for an - * event. + * Check the state of an async connect process. If a connection + * attempt terminated, process it, which may finalize it or may + * start the next attempt. If a connect error occures, it is saved + * in statePtr->connectError to be reported by 'fconfigure -error'. + * + * There are two modes of operation, defined by errorCodePtr: + * * non-NULL: Called by explicite read/write command. block if + * socket is blocking. + * May return two error codes: + * * EWOULDBLOCK: if connect is still in progress + * * ENOTCONN: if connect failed. This would be the error + * message of a rect or sendto syscall so this is + * emulated here. + * * Null: Called by a backround operation. Do not block and + * don't return any error code. * * Results: - * None. + * 0 if the connection has completed, -1 if still in progress + * or there is an error. * * Side effects: - * Adjusts the block time if needed. + * Processes socket events off the system queue. + * May process asynchroneous connect. * *---------------------------------------------------------------------- */ -void -SocketSetupProc( - ClientData data, /* Not used. */ - int flags) /* Event flags as passed to Tcl_DoOneEvent. */ +static int +WaitForConnect( + TcpState *statePtr, /* State of the socket. */ + int *errorCodePtr) /* Where to store errors? + * A passed null-pointer activates background mode. + */ { - SocketInfo *infoPtr; - Tcl_Time blockTime = { 0, 0 }; - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + int result; + int oldMode; + ThreadSpecificData *tsdPtr; - if (!(flags & TCL_FILE_EVENTS)) { - return; + /* + * Check if an async connect failed already and error reporting is demanded, + * return the error ENOTCONN + */ + + if (errorCodePtr != NULL && (statePtr->flags & TCP_ASYNC_FAILED)) { + *errorCodePtr = ENOTCONN; + return -1; } /* - * Check to see if there is a ready socket. If so, poll. + * Check if an async connect is running. If not return ok */ - - WaitForSingleObject(tsdPtr->socketListLock, INFINITE); - for (infoPtr = tsdPtr->socketList; infoPtr != NULL; - infoPtr = infoPtr->nextPtr) { - if (infoPtr->readyEvents & infoPtr->watchEvents) { - Tcl_SetMaxBlockTime(&blockTime); - break; - } + + if (!(statePtr->flags & TCP_ASYNC_CONNECT)) { + return 0; } - SetEvent(tsdPtr->socketListLock); -} - -/* - *---------------------------------------------------------------------- - * - * SocketCheckProc -- - * - * This function is called by Tcl_DoOneEvent to check the socket event - * source for events. - * - * Results: - * None. - * - * Side effects: - * May queue an event. - * - *---------------------------------------------------------------------- - */ -static void -SocketCheckProc( - ClientData data, /* Not used. */ - int flags) /* Event flags as passed to Tcl_DoOneEvent. */ -{ - SocketInfo *infoPtr; - SocketEvent *evPtr; - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + /* + * Be sure to disable event servicing so we are truly modal. + */ - if (!(flags & TCL_FILE_EVENTS)) { - return; - } + oldMode = Tcl_SetServiceMode(TCL_SERVICE_NONE); /* - * Queue events for any ready sockets that don't already have events - * queued (caused by persistent states that won't generate WinSock - * events). + * Loop in the blocking case until the connect signal is present */ - WaitForSingleObject(tsdPtr->socketListLock, INFINITE); - for (infoPtr = tsdPtr->socketList; infoPtr != NULL; - infoPtr = infoPtr->nextPtr) { - if ((infoPtr->readyEvents & infoPtr->watchEvents) - && !(infoPtr->flags & SOCKET_PENDING)) { - infoPtr->flags |= SOCKET_PENDING; - evPtr = ckalloc(sizeof(SocketEvent)); - evPtr->header.proc = SocketEventProc; - evPtr->socket = infoPtr->sockets->fd; - Tcl_QueueEvent((Tcl_Event *) evPtr, TCL_QUEUE_TAIL); + while (1) { + + /* get statePtr lock */ + tsdPtr = TclThreadDataKeyGet(&dataKey); + WaitForSingleObject(tsdPtr->socketListLock, INFINITE); + + /* Check for connect event */ + if (statePtr->readyEvents & FD_CONNECT) { + + /* Consume the connect event */ + statePtr->readyEvents &= ~(FD_CONNECT); + + /* + * For blocking sockets and foreground processing + * disable async connect as we continue now synchoneously + */ + if ( errorCodePtr != NULL && + ! (statePtr->flags & TCP_NONBLOCKING) ) { + CLEAR_BITS(statePtr->flags, TCP_ASYNC_CONNECT); + } + + /* Free list lock */ + SetEvent(tsdPtr->socketListLock); + + /* + * Continue connect. + * If switched to synchroneous connect, the connect is terminated. + */ + result = TcpConnect(NULL, statePtr); + + /* Restore event service mode */ + (void) Tcl_SetServiceMode(oldMode); + + /* + * Check for Succesfull connect or async connect restart + */ + + if (result == TCL_OK) { + /* + * Check for async connect restart + * (not possible for foreground blocking operation) + */ + if ( statePtr->flags & TCP_ASYNC_PENDING ) { + if (errorCodePtr != NULL) { + *errorCodePtr = EWOULDBLOCK; + } + return -1; + } + return 0; + } + + /* + * Connect finally failed. + * For foreground operation return ENOTCONN. + */ + + if (errorCodePtr != NULL) { + *errorCodePtr = ENOTCONN; + } + return -1; + } + + /* Free list lock */ + SetEvent(tsdPtr->socketListLock); + + /* + * Background operation returns with no action as there was no connect + * event + */ + + if ( errorCodePtr == NULL ) { + return -1; } + + /* + * A non blocking socket waiting for an asyncronous connect + * returns directly the error EWOULDBLOCK + */ + + if (statePtr->flags & TCP_NONBLOCKING) { + *errorCodePtr = EWOULDBLOCK; + return -1; + } + + /* + * Wait until something happens. + */ + + WaitForSingleObject(tsdPtr->readyEvent, INFINITE); } - SetEvent(tsdPtr->socketListLock); } /* *---------------------------------------------------------------------- * - * SocketEventProc -- + * TcpInputProc -- * - * This function is called by Tcl_ServiceEvent when a socket event - * reaches the front of the event queue. This function is responsible for - * notifying the generic channel code. + * This function is invoked by the generic IO level to read input from a + * TCP socket based channel. * * Results: - * Returns 1 if the event was handled, meaning it should be removed from - * the queue. Returns 0 if the event was not handled, meaning it should - * stay on the queue. The only time the event isn't handled is if the - * TCL_FILE_EVENTS flag bit isn't set. + * The number of bytes read is returned or -1 on error. An output + * argument contains the POSIX error code on error, or zero if no error + * occurred. * * Side effects: - * Whatever the channel callback functions do. + * Reads input from the input device of the channel. * *---------------------------------------------------------------------- */ + /* ARGSUSED */ static int -SocketEventProc( - Tcl_Event *evPtr, /* Event to service. */ - int flags) /* Flags that indicate what events to handle, - * such as TCL_FILE_EVENTS. */ +TcpInputProc( + ClientData instanceData, /* Socket state. */ + char *buf, /* Where to store data read. */ + int bufSize, /* How much space is available in the + * buffer? */ + int *errorCodePtr) /* Where to store error code. */ { - SocketInfo *infoPtr; - SocketEvent *eventPtr = (SocketEvent *) evPtr; - int mask = 0, events; - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - TcpFdList *fds; - SOCKET newSocket; - address addr; - int len; + TcpState *statePtr = instanceData; + int bytesRead; + DWORD error; + ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey); - if (!(flags & TCL_FILE_EVENTS)) { - return 0; - } + *errorCodePtr = 0; /* - * Find the specified socket on the socket list. + * Check that WinSock is initialized; do not call it if not, to prevent + * system crashes. This can happen at exit time if the exit handler for + * WinSock ran before other exit handlers that want to use sockets. */ - WaitForSingleObject(tsdPtr->socketListLock, INFINITE); - for (infoPtr = tsdPtr->socketList; infoPtr != NULL; - infoPtr = infoPtr->nextPtr) { - if (infoPtr->sockets->fd == eventPtr->socket) { - break; - } + if (!SocketsEnabled()) { + *errorCodePtr = EFAULT; + return -1; } /* - * Discard events that have gone stale. + * First check to see if EOF was already detected, to prevent calling the + * socket stack after the first time EOF is detected. */ - if (!infoPtr) { - SetEvent(tsdPtr->socketListLock); - return 1; + if (statePtr->flags & SOCKET_EOF) { + return 0; } - infoPtr->flags &= ~SOCKET_PENDING; - /* - * Handle connection requests directly. + * Check if there is an async connect running. + * For blocking sockets terminate connect, otherwise do one step. + * For a non blocking socket return EWOULDBLOCK if connect not terminated */ - if (infoPtr->readyEvents & FD_ACCEPT) { - for (fds = infoPtr->sockets; fds != NULL; fds = fds->next) { - - /* - * Accept the incoming connection request. - */ - len = sizeof(address); - - newSocket = accept(fds->fd, &(addr.sa), &len); - - /* On Tcl server sockets with multiple OS fds we loop over the fds trying - * an accept() on each, so we expect INVALID_SOCKET. There are also other - * network stack conditions that can result in FD_ACCEPT but a subsequent - * failure on accept() by the time we get around to it. - * Access to sockets (acceptEventCount, readyEvents) in socketList - * is still protected by the lock (prevents reintroduction of - * SF Tcl Bug 3056775. - */ - - if (newSocket == INVALID_SOCKET) { - /* int err = WSAGetLastError(); */ - continue; - } + if (WaitForConnect(statePtr, errorCodePtr) != 0) { + return -1; + } - /* - * It is possible that more than one FD_ACCEPT has been sent, so an extra - * count must be kept. Decrement the count, and reset the readyEvent bit - * if the count is no longer > 0. - */ - infoPtr->acceptEventCount--; + /* + * No EOF, and it is connected, so try to read more from the socket. Note + * that we clear the FD_READ bit because read events are level triggered + * so a new event will be generated if there is still data available to be + * read. We have to simulate blocking behavior here since we are always + * using non-blocking sockets. + */ - if (infoPtr->acceptEventCount <= 0) { - infoPtr->readyEvents &= ~(FD_ACCEPT); - } + while (1) { + SendMessage(tsdPtr->hwnd, SOCKET_SELECT, + (WPARAM) UNSELECT, (LPARAM) statePtr); + /* single fd operation: this proc is only called for a connected socket. */ + bytesRead = recv(statePtr->sockets->fd, buf, bufSize, 0); + statePtr->readyEvents &= ~(FD_READ); - SetEvent(tsdPtr->socketListLock); + /* + * Check for end-of-file condition or successful read. + */ - /* Caution: TcpAccept() has the side-effect of evaluating the server - * accept script (via AcceptCallbackProc() in tclIOCmd.c), which can - * close the server socket and invalidate infoPtr and fds. - * If TcpAccept() accepts a socket we must return immediately and let - * SocketCheckProc queue additional FD_ACCEPT events. - */ - TcpAccept(fds, newSocket, addr); - return 1; + if (bytesRead == 0) { + statePtr->flags |= SOCKET_EOF; + } + if (bytesRead != SOCKET_ERROR) { + break; } - /* Loop terminated with no sockets accepted; clear the ready mask so - * we can detect the next connection request. Note that connection - * requests are level triggered, so if there is a request already - * pending, a new event will be generated. + /* + * If an error occurs after the FD_CLOSE has arrived, then ignore the + * error and report an EOF. */ - infoPtr->acceptEventCount = 0; - infoPtr->readyEvents &= ~(FD_ACCEPT); - SetEvent(tsdPtr->socketListLock); - return 1; - } - - SetEvent(tsdPtr->socketListLock); - - /* - * Mask off unwanted events and compute the read/write mask so we can - * notify the channel. - */ + if (statePtr->readyEvents & FD_CLOSE) { + statePtr->flags |= SOCKET_EOF; + bytesRead = 0; + break; + } - events = infoPtr->readyEvents & infoPtr->watchEvents; + error = WSAGetLastError(); - if (events & FD_CLOSE) { /* - * If the socket was closed and the channel is still interested in - * read events, then we need to ensure that we keep polling for this - * event until someone does something with the channel. Note that we - * do this before calling Tcl_NotifyChannel so we don't have to watch - * out for the channel being deleted out from under us. This may cause - * a redundant trip through the event loop, but it's simpler than - * trying to do unwind protection. + * If an RST comes, then ignore the error and report an EOF just like + * on unix. */ - Tcl_Time blockTime = { 0, 0 }; - - Tcl_SetMaxBlockTime(&blockTime); - mask |= TCL_READABLE|TCL_WRITABLE; - } else if (events & FD_READ) { - fd_set readFds; - struct timeval timeout; + if (error == WSAECONNRESET) { + statePtr->flags |= SOCKET_EOF; + bytesRead = 0; + break; + } /* - * We must check to see if data is really available, since someone - * could have consumed the data in the meantime. Turn off async - * notification so select will work correctly. If the socket is still - * readable, notify the channel driver, otherwise reset the async - * select handler and keep waiting. + * Check for error condition or underflow in non-blocking case. */ - SendMessage(tsdPtr->hwnd, SOCKET_SELECT, - (WPARAM) UNSELECT, (LPARAM) infoPtr); + if ((statePtr->flags & TCP_NONBLOCKING) || (error != WSAEWOULDBLOCK)) { + TclWinConvertError(error); + *errorCodePtr = Tcl_GetErrno(); + bytesRead = -1; + break; + } - FD_ZERO(&readFds); - FD_SET(infoPtr->sockets->fd, &readFds); - timeout.tv_usec = 0; - timeout.tv_sec = 0; + /* + * In the blocking case, wait until the file becomes readable or + * closed and try again. + */ - if (select(0, &readFds, NULL, NULL, &timeout) != 0) { - mask |= TCL_READABLE; - } else { - infoPtr->readyEvents &= ~(FD_READ); - SendMessage(tsdPtr->hwnd, SOCKET_SELECT, - (WPARAM) SELECT, (LPARAM) infoPtr); + if (!WaitForSocketEvent(statePtr, FD_READ|FD_CLOSE, errorCodePtr)) { + bytesRead = -1; + break; } } - if (events & (FD_WRITE | FD_CONNECT)) { - mask |= TCL_WRITABLE; - if (events & FD_CONNECT && infoPtr->lastError != NO_ERROR) { - /* - * Connect errors should also fire the readable handler. - */ - mask |= TCL_READABLE; - } - } + SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM)SELECT, (LPARAM)statePtr); - if (mask) { - Tcl_NotifyChannel(infoPtr->channel, mask); - } - return 1; + return bytesRead; } /* *---------------------------------------------------------------------- * - * TcpBlockProc -- + * TcpOutputProc -- * - * Sets a socket into blocking or non-blocking mode. + * This function is called by the generic IO level to write data to a + * socket based channel. * * Results: - * 0 if successful, errno if there was an error. + * The number of bytes written or -1 on failure. * * Side effects: - * None. + * Produces output on the socket. * *---------------------------------------------------------------------- */ static int -TcpBlockProc( - ClientData instanceData, /* The socket to block/un-block. */ - int mode) /* TCL_MODE_BLOCKING or - * TCL_MODE_NONBLOCKING. */ +TcpOutputProc( + ClientData instanceData, /* Socket state. */ + const char *buf, /* The data buffer. */ + int toWrite, /* How many bytes to write? */ + int *errorCodePtr) /* Where to store error code. */ { - SocketInfo *infoPtr = instanceData; + TcpState *statePtr = instanceData; + int written; + DWORD error; + ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey); - if (mode == TCL_MODE_NONBLOCKING) { - infoPtr->flags |= SOCKET_ASYNC; - } else { - infoPtr->flags &= ~(SOCKET_ASYNC); + *errorCodePtr = 0; + + /* + * Check that WinSock is initialized; do not call it if not, to prevent + * system crashes. This can happen at exit time if the exit handler for + * WinSock ran before other exit handlers that want to use sockets. + */ + + if (!SocketsEnabled()) { + *errorCodePtr = EFAULT; + return -1; } - return 0; + + /* + * Check if there is an async connect running. + * For blocking sockets terminate connect, otherwise do one step. + * For a non blocking socket return EWOULDBLOCK if connect not terminated + */ + + if (WaitForConnect(statePtr, errorCodePtr) != 0) { + return -1; + } + + while (1) { + SendMessage(tsdPtr->hwnd, SOCKET_SELECT, + (WPARAM) UNSELECT, (LPARAM) statePtr); + + /* single fd operation: this proc is only called for a connected socket. */ + written = send(statePtr->sockets->fd, buf, toWrite, 0); + if (written != SOCKET_ERROR) { + /* + * Since Windows won't generate a new write event until we hit an + * overflow condition, we need to force the event loop to poll + * until the condition changes. + */ + + if (statePtr->watchEvents & FD_WRITE) { + Tcl_Time blockTime = { 0, 0 }; + Tcl_SetMaxBlockTime(&blockTime); + } + break; + } + + /* + * Check for error condition or overflow. In the event of overflow, we + * need to clear the FD_WRITE flag so we can detect the next writable + * event. Note that Windows only sends a new writable event after a + * send fails with WSAEWOULDBLOCK. + */ + + error = WSAGetLastError(); + if (error == WSAEWOULDBLOCK) { + statePtr->readyEvents &= ~(FD_WRITE); + if (statePtr->flags & TCP_NONBLOCKING) { + *errorCodePtr = EWOULDBLOCK; + written = -1; + break; + } + } else { + TclWinConvertError(error); + *errorCodePtr = Tcl_GetErrno(); + written = -1; + break; + } + + /* + * In the blocking case, wait until the file becomes writable or + * closed and try again. + */ + + if (!WaitForSocketEvent(statePtr, FD_WRITE|FD_CLOSE, errorCodePtr)) { + written = -1; + break; + } + } + + SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM)SELECT, (LPARAM)statePtr); + + return written; } /* @@ -910,10 +979,10 @@ TcpCloseProc( ClientData instanceData, /* The socket to close. */ Tcl_Interp *interp) /* Unused. */ { - SocketInfo *infoPtr = instanceData; + TcpState *statePtr = instanceData; /* TIP #218 */ int errorCode = 0; - /* ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); */ + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); /* * Check that WinSock is initialized; do not call it if not, to prevent @@ -928,9 +997,9 @@ TcpCloseProc( * background. */ - while ( infoPtr->sockets != NULL ) { - TcpFdList *thisfd = infoPtr->sockets; - infoPtr->sockets = thisfd->next; + while ( statePtr->sockets != NULL ) { + TcpFdList *thisfd = statePtr->sockets; + statePtr->sockets = thisfd->next; if (closesocket(thisfd->fd) == SOCKET_ERROR) { TclWinConvertError((DWORD) WSAGetLastError()); @@ -940,6 +1009,30 @@ TcpCloseProc( } } + if (statePtr->addrlist != NULL) { + freeaddrinfo(statePtr->addrlist); + } + if (statePtr->myaddrlist != NULL) { + freeaddrinfo(statePtr->myaddrlist); + } + + /* + * Clear an eventual tsd info list pointer. + * This may be called, if an async socket connect fails or is closed + * between connect and thread action callback. + */ + if (tsdPtr->pendingTcpState != NULL + && tsdPtr->pendingTcpState == statePtr) { + + /* get infoPtr lock, because this concerns the notifier thread */ + WaitForSingleObject(tsdPtr->socketListLock, INFINITE); + + tsdPtr->pendingTcpState = NULL; + + /* Free list lock */ + SetEvent(tsdPtr->socketListLock); + } + /* * TIP #218. Removed the code removing the structure from the global * socket list. This is now done by the thread action callbacks, and only @@ -947,7 +1040,7 @@ TcpCloseProc( * fear of damaging the list. */ - ckfree(infoPtr); + ckfree(statePtr); return errorCode; } @@ -974,14 +1067,15 @@ TcpClose2Proc( Tcl_Interp *interp, /* For error reporting. */ int flags) /* Flags that indicate which side to close. */ { - SocketInfo *infoPtr = instanceData; - int errorCode = 0, sd; + TcpState *statePtr = instanceData; + int errorCode = 0; + int sd; /* * Shutdown the OS socket handle. */ - switch (flags) { + switch(flags) { case TCL_CLOSE_READ: sd = SD_RECEIVE; break; @@ -991,14 +1085,14 @@ TcpClose2Proc( default: if (interp) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "Socket close2proc called bidirectionally", -1)); + "socket close2proc called bidirectionally", -1)); } return TCL_ERROR; } /* single fd operation: Tcl_OpenTcpServer() does not set TCL_READABLE or * TCL_WRITABLE so this should never be called for a server socket. */ - if (shutdown(infoPtr->sockets->fd, sd) == SOCKET_ERROR) { + if (shutdown(statePtr->sockets->fd, sd) == SOCKET_ERROR) { TclWinConvertError((DWORD) WSAGetLastError()); errorCode = Tcl_GetErrno(); } @@ -1009,136 +1103,138 @@ TcpClose2Proc( /* *---------------------------------------------------------------------- * - * AddSocketInfoFd -- + * TcpSetOptionProc -- * - * This function adds a SOCKET file descriptor to the 'sockets' linked - * list of a SocketInfo structure. + * Sets Tcp channel specific options. * * Results: - * None. + * None, unless an error happens. * * Side effects: - * None, except for allocation of memory. + * Changes attributes of the socket at the system level. * *---------------------------------------------------------------------- */ -static void -AddSocketInfoFd( - SocketInfo *infoPtr, - SOCKET socket) +static int +TcpSetOptionProc( + ClientData instanceData, /* Socket state. */ + Tcl_Interp *interp, /* For error reporting - can be NULL. */ + const char *optionName, /* Name of the option to set. */ + const char *value) /* New value for option. */ { - TcpFdList *fds = infoPtr->sockets; +#ifdef TCL_FEATURE_KEEPALIVE_NAGLE + TcpState *statePtr = instanceData; + SOCKET sock; +#endif /*TCL_FEATURE_KEEPALIVE_NAGLE*/ - if ( fds == NULL ) { - /* Add the first FD */ - infoPtr->sockets = ckalloc(sizeof(TcpFdList)); - fds = infoPtr->sockets; - } else { - /* Find end of list and append FD */ - while ( fds->next != NULL ) { - fds = fds->next; + /* + * Check that WinSock is initialized; do not call it if not, to prevent + * system crashes. This can happen at exit time if the exit handler for + * WinSock ran before other exit handlers that want to use sockets. + */ + + if (!SocketsEnabled()) { + if (interp) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "winsock is not initialized", -1)); } - - fds->next = ckalloc(sizeof(TcpFdList)); - fds = fds->next; + return TCL_ERROR; } - /* Populate new FD */ - fds->fd = socket; - fds->infoPtr = infoPtr; - fds->next = NULL; -} - - -/* - *---------------------------------------------------------------------- - * - * NewSocketInfo -- - * - * This function allocates and initializes a new SocketInfo structure. - * - * Results: - * Returns a newly allocated SocketInfo. - * - * Side effects: - * None, except for allocation of memory. - * - *---------------------------------------------------------------------- - */ - -static SocketInfo * -NewSocketInfo( - SOCKET socket) -{ - SocketInfo *infoPtr = ckalloc(sizeof(SocketInfo)); - - /* ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); */ - infoPtr->channel = 0; - infoPtr->sockets = NULL; - infoPtr->flags = 0; - infoPtr->watchEvents = 0; - infoPtr->readyEvents = 0; - infoPtr->selectEvents = 0; - infoPtr->acceptEventCount = 0; - infoPtr->acceptProc = NULL; - infoPtr->acceptProcData = NULL; - infoPtr->lastError = 0; +#ifdef TCL_FEATURE_KEEPALIVE_NAGLE + #error "TCL_FEATURE_KEEPALIVE_NAGLE not reviewed for whether to treat statePtr->sockets as single fd or list" + sock = statePtr->sockets->fd; - /* - * TIP #218. Removed the code inserting the new structure into the global - * list. This is now handled in the thread action callbacks, and only - * there. - */ + if (!strcasecmp(optionName, "-keepalive")) { + BOOL val = FALSE; + int boolVar, rtn; - infoPtr->nextPtr = NULL; + if (Tcl_GetBoolean(interp, value, &boolVar) != TCL_OK) { + return TCL_ERROR; + } + if (boolVar) { + val = TRUE; + } + rtn = setsockopt(sock, SOL_SOCKET, SO_KEEPALIVE, + (const char *) &val, sizeof(BOOL)); + if (rtn != 0) { + TclWinConvertError(WSAGetLastError()); + if (interp) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't set socket option: %s", + Tcl_PosixError(interp))); + } + return TCL_ERROR; + } + return TCL_OK; + } else if (!strcasecmp(optionName, "-nagle")) { + BOOL val = FALSE; + int boolVar, rtn; - AddSocketInfoFd(infoPtr, socket); + if (Tcl_GetBoolean(interp, value, &boolVar) != TCL_OK) { + return TCL_ERROR; + } + if (!boolVar) { + val = TRUE; + } + rtn = setsockopt(sock, IPPROTO_TCP, TCP_NODELAY, + (const char *) &val, sizeof(BOOL)); + if (rtn != 0) { + TclWinConvertError(WSAGetLastError()); + if (interp) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't set socket option: %s", + Tcl_PosixError(interp))); + } + return TCL_ERROR; + } + return TCL_OK; + } - return infoPtr; + return Tcl_BadChannelOption(interp, optionName, "keepalive nagle"); +#else + return Tcl_BadChannelOption(interp, optionName, ""); +#endif /*TCL_FEATURE_KEEPALIVE_NAGLE*/ } /* *---------------------------------------------------------------------- * - * CreateSocket -- + * TcpGetOptionProc -- + * + * Computes an option value for a TCP socket based channel, or a list of + * all options and their values. * - * This function opens a new socket and initializes the SocketInfo - * structure. + * Note: This code is based on code contributed by John Haxby. * * Results: - * Returns a new SocketInfo, or NULL with an error in interp. + * A standard Tcl result. The value of the specified option or a list of + * all options and their values is returned in the supplied DString. Sets + * Error message if needed. * * Side effects: - * None, except for allocation of memory. + * None. * *---------------------------------------------------------------------- */ -static SocketInfo * -CreateSocket( - Tcl_Interp *interp, /* For error reporting; can be NULL. */ - int port, /* Port number to open. */ - const char *host, /* Name of host on which to open port. */ - int server, /* 1 if socket should be a server socket, else - * 0 for a client socket. */ - const char *myaddr, /* Optional client-side address */ - int myport, /* Optional client-side port */ - int async) /* If nonzero, connect client socket - * asynchronously. */ +static int +TcpGetOptionProc( + ClientData instanceData, /* Socket state. */ + Tcl_Interp *interp, /* For error reporting - can be NULL. */ + const char *optionName, /* Name of the option to retrieve the value + * for, or NULL to get all options and their + * values. */ + Tcl_DString *dsPtr) /* Where to store the computed value; + * initialized by caller. */ { - u_long flag = 1; /* Indicates nonblocking mode. */ - int asyncConnect = 0; /* Will be 1 if async connect is in - * progress. */ - unsigned short chosenport = 0; - struct addrinfo *addrlist = NULL, *addrPtr; - /* Socket address to connect to. */ - struct addrinfo *myaddrlist = NULL, *myaddrPtr; - /* Socket address for our side. */ - const char *errorMsg = NULL; - SOCKET sock = INVALID_SOCKET; - SocketInfo *infoPtr = NULL; /* The returned value. */ - ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey); + TcpState *statePtr = instanceData; + char host[NI_MAXHOST], port[NI_MAXSERV]; + SOCKET sock; + size_t len = 0; + int reverseDNS = 0; +#define SUPPRESS_RDNS_VAR "::tcl::unsupported::noReverseDNS" /* * Check that WinSock is initialized; do not call it if not, to prevent @@ -1147,314 +1243,621 @@ CreateSocket( */ if (!SocketsEnabled()) { - return NULL; + if (interp) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "winsock is not initialized", -1)); + } + return TCL_ERROR; } - /* - * Construct the addresses for each end of the socket. + /* + * Go one step in async connect + * If any error is thrown save it as backround error to report eventually below */ + WaitForConnect(statePtr, NULL); - if (!TclCreateSocketAddress(interp, &addrlist, host, port, server, - &errorMsg)) { - goto error; - } - if (!TclCreateSocketAddress(interp, &myaddrlist, myaddr, myport, 1, - &errorMsg)) { - goto error; + sock = statePtr->sockets->fd; + if (optionName != NULL) { + len = strlen(optionName); } - if (server) { - - for (addrPtr = addrlist; addrPtr != NULL; addrPtr = addrPtr->ai_next) { - sock = socket(addrPtr->ai_family, SOCK_STREAM, 0); - if (sock == INVALID_SOCKET) { - TclWinConvertError((DWORD) WSAGetLastError()); - continue; - } - - /* - * Win-NT has a misfeature that sockets are inherited in child - * processes by default. Turn off the inherit bit. - */ - - SetHandleInformation((HANDLE) sock, HANDLE_FLAG_INHERIT, 0); - - /* - * Set kernel space buffering - */ - - TclSockMinimumBuffers((void *)sock, TCP_BUFFER_SIZE); - - /* - * Make sure we use the same port when opening two server sockets - * for IPv4 and IPv6. - * - * As sockaddr_in6 uses the same offset and size for the port - * member as sockaddr_in, we can handle both through the IPv4 API. - */ + if ((len > 1) && (optionName[1] == 'e') && + (strncmp(optionName, "-error", len) == 0)) { - if (port == 0 && chosenport != 0) { - ((struct sockaddr_in *) addrPtr->ai_addr)->sin_port = - htons(chosenport); - } + /* + * Do not return any errors if async connect is running + */ + if ( ! (statePtr->flags & TCP_ASYNC_PENDING) ) { - /* - * Bind to the specified port. Note that we must not call - * setsockopt with SO_REUSEADDR because Microsoft allows addresses - * to be reused even if they are still in use. - * - * Bind should not be affected by the socket having already been - * set into nonblocking mode. If there is trouble, this is one - * place to look for bugs. - */ - if (bind(sock, addrPtr->ai_addr, addrPtr->ai_addrlen) - == SOCKET_ERROR) { - TclWinConvertError((DWORD) WSAGetLastError()); - closesocket(sock); - continue; - } - if (port == 0 && chosenport == 0) { - address sockname; - socklen_t namelen = sizeof(sockname); + if ( statePtr->flags & TCP_ASYNC_FAILED ) { /* - * Synchronize port numbers when binding to port 0 of multiple - * addresses. + * In case of a failed async connect, eventually report the + * connect error only once. + * Do not report the system error, as this comes again and again. */ - if (getsockname(sock, &sockname.sa, &namelen) >= 0) { - chosenport = ntohs(sockname.sa4.sin_port); + if ( statePtr->connectError != 0 ) { + Tcl_DStringAppend(dsPtr, + Tcl_ErrnoMsg(statePtr->connectError), -1); + statePtr->connectError = 0; } - } - - /* - * Set the maximum number of pending connect requests to the max - * value allowed on each platform (Win32 and Win32s may be - * different, and there may be differences between TCP/IP stacks). - */ - if (listen(sock, SOMAXCONN) == SOCKET_ERROR) { - TclWinConvertError((DWORD) WSAGetLastError()); - closesocket(sock); - continue; - } + } else { - if (infoPtr == NULL) { /* - * Add this socket to the global list of sockets. + * Report an eventual last error of the socket system */ - infoPtr = NewSocketInfo(sock); + int optlen; + int ret; + DWORD err; /* - * Set up the select mask for connection request events. + * Populater the err Variable with a possix error */ - - infoPtr->selectEvents = FD_ACCEPT; - infoPtr->watchEvents |= FD_ACCEPT; - - } else { - AddSocketInfoFd( infoPtr, sock ); - } - } - } else { - for (addrPtr = addrlist; addrPtr != NULL; - addrPtr = addrPtr->ai_next) { - for (myaddrPtr = myaddrlist; myaddrPtr != NULL; - myaddrPtr = myaddrPtr->ai_next) { + optlen = sizeof(int); + ret = getsockopt(sock, SOL_SOCKET, SO_ERROR, + (char *)&err, &optlen); /* - * No need to try combinations of local and remote addresses - * of different families. + * The error was not returned directly but should be + * taken from WSA */ - - if (myaddrPtr->ai_family != addrPtr->ai_family) { - continue; - } - - sock = socket(myaddrPtr->ai_family, SOCK_STREAM, 0); - if (sock == INVALID_SOCKET) { - TclWinConvertError((DWORD) WSAGetLastError()); - continue; + if (ret == SOCKET_ERROR) { + err = WSAGetLastError(); } - /* - * Win-NT has a misfeature that sockets are inherited in child - * processes by default. Turn off the inherit bit. + * Return error message */ + if (err) { + TclWinConvertError(err); + Tcl_DStringAppend(dsPtr, Tcl_ErrnoMsg(Tcl_GetErrno()), -1); + } + } + } + return TCL_OK; + } - SetHandleInformation((HANDLE) sock, HANDLE_FLAG_INHERIT, 0); + if ((len > 1) && (optionName[1] == 'c') && + (strncmp(optionName, "-connecting", len) == 0)) { - /* - * Set kernel space buffering - */ + Tcl_DStringAppend(dsPtr, + (statePtr->flags & TCP_ASYNC_PENDING) + ? "1" : "0", -1); + return TCL_OK; + } - TclSockMinimumBuffers((void *) sock, TCP_BUFFER_SIZE); + if (interp != NULL && Tcl_GetVar(interp, SUPPRESS_RDNS_VAR, 0) != NULL) { + reverseDNS = NI_NUMERICHOST; + } - /* - * Try to bind to a local port. - */ + if ((len == 0) || ((len > 1) && (optionName[1] == 'p') && + (strncmp(optionName, "-peername", len) == 0))) { + address peername; + socklen_t size = sizeof(peername); - if (bind(sock, myaddrPtr->ai_addr, myaddrPtr->ai_addrlen) - == SOCKET_ERROR) { - TclWinConvertError((DWORD) WSAGetLastError()); - goto looperror; - } - /* - * Set the socket into nonblocking mode if the connect should - * be done in the background. - */ - if (async && ioctlsocket(sock, (long) FIONBIO, &flag) - == SOCKET_ERROR) { - TclWinConvertError((DWORD) WSAGetLastError()); - goto looperror; - } + if (getpeername(sock, (LPSOCKADDR) &(peername.sa), &size) == 0) { + if (len == 0) { + Tcl_DStringAppendElement(dsPtr, "-peername"); + Tcl_DStringStartSublist(dsPtr); + } - /* - * Attempt to connect to the remote socket. - */ + getnameinfo(&(peername.sa), size, host, sizeof(host), + NULL, 0, NI_NUMERICHOST); + Tcl_DStringAppendElement(dsPtr, host); + getnameinfo(&(peername.sa), size, host, sizeof(host), + port, sizeof(port), reverseDNS | NI_NUMERICSERV); + Tcl_DStringAppendElement(dsPtr, host); + Tcl_DStringAppendElement(dsPtr, port); + if (len == 0) { + Tcl_DStringEndSublist(dsPtr); + } else { + return TCL_OK; + } + } else { + /* + * getpeername failed - but if we were asked for all the options + * (len==0), don't flag an error at that point because it could be + * an fconfigure request on a server socket (such sockets have no + * peer). {Copied from unix/tclUnixChan.c} + */ - if (connect(sock, addrPtr->ai_addr, addrPtr->ai_addrlen) - == SOCKET_ERROR) { - DWORD error = (DWORD) WSAGetLastError(); - if (error != WSAEWOULDBLOCK) { - TclWinConvertError(error); - goto looperror; - } + if (len) { + TclWinConvertError((DWORD) WSAGetLastError()); + if (interp) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't get peername: %s", + Tcl_PosixError(interp))); + } + return TCL_ERROR; + } + } + } - /* - * The connection is progressing in the background. - */ + if ((len == 0) || ((len > 1) && (optionName[1] == 's') && + (strncmp(optionName, "-sockname", len) == 0))) { + TcpFdList *fds; + address sockname; + socklen_t size; + int found = 0; - asyncConnect = 1; - } - goto connected; + if (len == 0) { + Tcl_DStringAppendElement(dsPtr, "-sockname"); + Tcl_DStringStartSublist(dsPtr); + } + for (fds = statePtr->sockets; fds != NULL; fds = fds->next) { + sock = fds->fd; + size = sizeof(sockname); + if (getsockname(sock, &(sockname.sa), &size) >= 0) { + int flags = reverseDNS; - looperror: - if (sock != INVALID_SOCKET) { - closesocket(sock); - sock = INVALID_SOCKET; + found = 1; + getnameinfo(&sockname.sa, size, host, sizeof(host), + NULL, 0, NI_NUMERICHOST); + Tcl_DStringAppendElement(dsPtr, host); + + /* + * We don't want to resolve INADDR_ANY and sin6addr_any; they + * can sometimes cause problems (and never have a name). + */ + flags |= NI_NUMERICSERV; + if (sockname.sa.sa_family == AF_INET) { + if (sockname.sa4.sin_addr.s_addr == INADDR_ANY) { + flags |= NI_NUMERICHOST; + } + } else if (sockname.sa.sa_family == AF_INET6) { + if ((IN6_ARE_ADDR_EQUAL(&sockname.sa6.sin6_addr, + &in6addr_any)) || + (IN6_IS_ADDR_V4MAPPED(&sockname.sa6.sin6_addr) + && sockname.sa6.sin6_addr.s6_addr[12] == 0 + && sockname.sa6.sin6_addr.s6_addr[13] == 0 + && sockname.sa6.sin6_addr.s6_addr[14] == 0 + && sockname.sa6.sin6_addr.s6_addr[15] == 0)) { + flags |= NI_NUMERICHOST; + } } + getnameinfo(&sockname.sa, size, host, sizeof(host), + port, sizeof(port), flags); + Tcl_DStringAppendElement(dsPtr, host); + Tcl_DStringAppendElement(dsPtr, port); } } - goto error; + if (found) { + if (len == 0) { + Tcl_DStringEndSublist(dsPtr); + } else { + return TCL_OK; + } + } else { + if (interp) { + TclWinConvertError((DWORD) WSAGetLastError()); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't get sockname: %s", Tcl_PosixError(interp))); + } + return TCL_ERROR; + } + } - connected: - /* - * Add this socket to the global list of sockets. - */ +#ifdef TCL_FEATURE_KEEPALIVE_NAGLE + if (len == 0 || !strncmp(optionName, "-keepalive", len)) { + int optlen; + BOOL opt = FALSE; - infoPtr = NewSocketInfo(sock); + if (len == 0) { + Tcl_DStringAppendElement(dsPtr, "-keepalive"); + } + optlen = sizeof(BOOL); + getsockopt(sock, SOL_SOCKET, SO_KEEPALIVE, (char *)&opt, &optlen); + if (opt) { + Tcl_DStringAppendElement(dsPtr, "1"); + } else { + Tcl_DStringAppendElement(dsPtr, "0"); + } + if (len > 0) { + return TCL_OK; + } + } - /* - * Set up the select mask for read/write events. If the connect - * attempt has not completed, include connect events. - */ + if (len == 0 || !strncmp(optionName, "-nagle", len)) { + int optlen; + BOOL opt = FALSE; - infoPtr->selectEvents = FD_READ | FD_WRITE | FD_CLOSE; - if (asyncConnect) { - infoPtr->flags |= SOCKET_ASYNC_CONNECT; - infoPtr->selectEvents |= FD_CONNECT; + if (len == 0) { + Tcl_DStringAppendElement(dsPtr, "-nagle"); + } + optlen = sizeof(BOOL); + getsockopt(sock, IPPROTO_TCP, TCP_NODELAY, (char *)&opt, &optlen); + if (opt) { + Tcl_DStringAppendElement(dsPtr, "0"); + } else { + Tcl_DStringAppendElement(dsPtr, "1"); + } + if (len > 0) { + return TCL_OK; } } +#endif /*TCL_FEATURE_KEEPALIVE_NAGLE*/ - error: - if (addrlist != NULL) { - freeaddrinfo(addrlist); - } - if (myaddrlist != NULL) { - freeaddrinfo(myaddrlist); + if (len > 0) { +#ifdef TCL_FEATURE_KEEPALIVE_NAGLE + return Tcl_BadChannelOption(interp, optionName, + "peername sockname keepalive nagle"); +#else + return Tcl_BadChannelOption(interp, optionName, "peername sockname"); +#endif /*TCL_FEATURE_KEEPALIVE_NAGLE*/ } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TcpWatchProc -- + * + * Informs the channel driver of the events that the generic channel code + * wishes to receive on this socket. + * + * Results: + * None. + * + * Side effects: + * May cause the notifier to poll if any of the specified conditions are + * already true. + * + *---------------------------------------------------------------------- + */ + +static void +TcpWatchProc( + ClientData instanceData, /* The socket state. */ + int mask) /* Events of interest; an OR-ed combination of + * TCL_READABLE, TCL_WRITABLE and + * TCL_EXCEPTION. */ +{ + TcpState *statePtr = instanceData; + /* - * Register for interest in events in the select mask. Note that this - * automatically places the socket into non-blocking mode. + * Update the watch events mask. Only if the socket is not a server + * socket. [Bug 557878] */ - if (infoPtr != NULL) { - ioctlsocket(sock, (long) FIONBIO, &flag); - SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) SELECT, - (LPARAM) infoPtr); + if (!statePtr->acceptProc) { + statePtr->watchEvents = 0; + if (mask & TCL_READABLE) { + statePtr->watchEvents |= (FD_READ|FD_CLOSE); + } + if (mask & TCL_WRITABLE) { + statePtr->watchEvents |= (FD_WRITE|FD_CLOSE); + } - return infoPtr; - } + /* + * If there are any conditions already set, then tell the notifier to + * poll rather than block. + */ - if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "couldn't open socket: %s", - (errorMsg ? errorMsg : Tcl_PosixError(interp)))); - } + if (statePtr->readyEvents & statePtr->watchEvents) { + Tcl_Time blockTime = { 0, 0 }; - if (sock != INVALID_SOCKET) { - closesocket(sock); + Tcl_SetMaxBlockTime(&blockTime); + } } - return NULL; } /* *---------------------------------------------------------------------- * - * WaitForSocketEvent -- + * TcpGetHandleProc -- * - * Waits until one of the specified events occurs on a socket. + * Called from Tcl_GetChannelHandle to retrieve OS handles from inside a + * TCP socket based channel. * * Results: - * Returns 1 on success or 0 on failure, with an error code in - * errorCodePtr. + * Returns TCL_OK with the fd in handlePtr, or TCL_ERROR if there is no + * handle for the specified direction. * * Side effects: - * Processes socket events off the system queue. + * None. * *---------------------------------------------------------------------- */ + /* ARGSUSED */ static int -WaitForSocketEvent( - SocketInfo *infoPtr, /* Information about this socket. */ - int events, /* Events to look for. */ - int *errorCodePtr) /* Where to store errors? */ +TcpGetHandleProc( + ClientData instanceData, /* The socket state. */ + int direction, /* Not used. */ + ClientData *handlePtr) /* Where to store the handle. */ { - int result = 1; - int oldMode; - ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey); + TcpState *statePtr = instanceData; + + *handlePtr = INT2PTR(statePtr->sockets->fd); + return TCL_OK; +} + + + +/* + *---------------------------------------------------------------------- + * + * TcpConnect -- + * + * This function opens a new socket in client mode. + * + * This might be called in 3 circumstances: + * - By a regular socket command + * - By the event handler to continue an asynchroneous connect + * - By a blocking socket function (gets/puts) to terminate the + * connect synchroneously + * + * Results: + * TCL_OK, if the socket was successfully connected or an asynchronous + * connection is in progress. If an error occurs, TCL_ERROR is returned + * and an error message is left in interp. + * + * Side effects: + * Opens a socket. + * + * Remarks: + * A single host name may resolve to more than one IP address, e.g. for + * an IPv4/IPv6 dual stack host. For handling asyncronously connecting + * sockets in the background for such hosts, this function can act as a + * coroutine. On the first call, it sets up the control variables for the + * two nested loops over the local and remote addresses. Once the first + * connection attempt is in progress, it sets up itself as a writable + * event handler for that socket, and returns. When the callback occurs, + * control is transferred to the "reenter" label, right after the initial + * return and the loops resume as if they had never been interrupted. + * For syncronously connecting sockets, the loops work the usual way. + * + *---------------------------------------------------------------------- + */ +static int +TcpConnect( + Tcl_Interp *interp, /* For error reporting; can be NULL. */ + TcpState *statePtr) +{ + DWORD error; /* - * Be sure to disable event servicing so we are truly modal. + * We are started with async connect and the connect notification + * was not jet received */ + int async_connect = statePtr->flags & TCP_ASYNC_CONNECT; + /* We were called by the event procedure and continue our loop */ + int async_callback = statePtr->flags & TCP_ASYNC_PENDING; + ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey); + + if (async_callback) { + goto reenter; + } + + for (statePtr->addr = statePtr->addrlist; statePtr->addr != NULL; + statePtr->addr = statePtr->addr->ai_next) { + + for (statePtr->myaddr = statePtr->myaddrlist; statePtr->myaddr != NULL; + statePtr->myaddr = statePtr->myaddr->ai_next) { - oldMode = Tcl_SetServiceMode(TCL_SERVICE_NONE); + /* + * No need to try combinations of local and remote addresses + * of different families. + */ + + if (statePtr->myaddr->ai_family != statePtr->addr->ai_family) { + continue; + } + + /* + * Close the socket if it is still open from the last unsuccessful + * iteration. + */ + if (statePtr->sockets->fd != INVALID_SOCKET) { + closesocket(statePtr->sockets->fd); + } + /* get statePtr lock */ + WaitForSingleObject(tsdPtr->socketListLock, INFINITE); + + /* + * Reset last error from last try + */ + statePtr->notifierConnectError = 0; + Tcl_SetErrno(0); + + statePtr->sockets->fd = socket(statePtr->myaddr->ai_family, SOCK_STREAM, 0); + + /* Free list lock */ + SetEvent(tsdPtr->socketListLock); + + /* continue on socket creation error */ + if (statePtr->sockets->fd == INVALID_SOCKET) { + TclWinConvertError((DWORD) WSAGetLastError()); + continue; + } + + /* + * Win-NT has a misfeature that sockets are inherited in child + * processes by default. Turn off the inherit bit. + */ + + SetHandleInformation((HANDLE) statePtr->sockets->fd, HANDLE_FLAG_INHERIT, 0); + + /* + * Set kernel space buffering + */ + + TclSockMinimumBuffers((void *) statePtr->sockets->fd, TCP_BUFFER_SIZE); + + /* + * Try to bind to a local port. + */ + + if (bind(statePtr->sockets->fd, statePtr->myaddr->ai_addr, + statePtr->myaddr->ai_addrlen) == SOCKET_ERROR) { + TclWinConvertError((DWORD) WSAGetLastError()); + continue; + } + /* + * For asyncroneous connect set the socket in nonblocking mode + * and activate connect notification + */ + if (async_connect) { + TcpState *statePtr2; + int in_socket_list = 0; + /* get statePtr lock */ + WaitForSingleObject(tsdPtr->socketListLock, INFINITE); + + /* + * Bugfig for 336441ed59 to not ignore notifications until the + * infoPtr is in the list. + * Check if my statePtr is already in the tsdPtr->socketList + * It is set after this call by TcpThreadActionProc and is set + * on a second round. + * + * If not, we buffer my statePtr in the tsd memory so it is not + * lost by the event procedure + */ + + for (statePtr2 = tsdPtr->socketList; statePtr2 != NULL; + statePtr2 = statePtr->nextPtr) { + if (statePtr2 == statePtr) { + in_socket_list = 1; + break; + } + } + if (!in_socket_list) { + tsdPtr->pendingTcpState = statePtr; + } + /* + * Set connect mask to connect events + * This is activated by a SOCKET_SELECT message to the notifier + * thread. + */ + statePtr->selectEvents |= FD_CONNECT; + + /* + * Free list lock + */ + SetEvent(tsdPtr->socketListLock); + + /* activate accept notification */ + SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) SELECT, + (LPARAM) statePtr); + } + + /* + * Attempt to connect to the remote socket. + */ + + connect(statePtr->sockets->fd, statePtr->addr->ai_addr, + statePtr->addr->ai_addrlen); + + error = WSAGetLastError(); + TclWinConvertError(error); + + if (async_connect && error == WSAEWOULDBLOCK) { + /* + * Asynchroneous connect + */ + + /* + * Remember that we jump back behind this next round + */ + statePtr->flags |= TCP_ASYNC_PENDING; + return TCL_OK; + + reenter: + /* + * Re-entry point for async connect after connect event or + * blocking operation + * + * Clear the reenter flag + */ + statePtr->flags &= ~(TCP_ASYNC_PENDING); + /* get statePtr lock */ + WaitForSingleObject(tsdPtr->socketListLock, INFINITE); + /* Get signaled connect error */ + TclWinConvertError((DWORD) statePtr->notifierConnectError); + /* Clear eventual connect flag */ + statePtr->selectEvents &= ~(FD_CONNECT); + /* Free list lock */ + SetEvent(tsdPtr->socketListLock); + } + + /* + * Clear the tsd socket list pointer if we did not wait for + * the FD_CONNECT asyncroneously + */ + tsdPtr->pendingTcpState = NULL; + + if (Tcl_GetErrno() == 0) { + goto out; + } + } + } + +out: /* - * Reset WSAAsyncSelect so we have a fresh set of events pending. + * Socket connected or connection failed */ - SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) UNSELECT, - (LPARAM) infoPtr); - SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) SELECT, - (LPARAM) infoPtr); + /* + * Async connect terminated + */ - while (1) { - if (infoPtr->lastError) { - *errorCodePtr = infoPtr->lastError; - result = 0; - break; - } else if (infoPtr->readyEvents & events) { - break; - } else if (infoPtr->flags & SOCKET_ASYNC) { - *errorCodePtr = EWOULDBLOCK; - result = 0; - break; - } + CLEAR_BITS(statePtr->flags, TCP_ASYNC_CONNECT); + if ( Tcl_GetErrno() == 0 ) { /* - * Wait until something happens. + * Succesfully connected + */ + /* + * Set up the select mask for read/write events. + */ + statePtr->selectEvents = FD_READ | FD_WRITE | FD_CLOSE; + + /* + * Register for interest in events in the select mask. Note that this + * automatically places the socket into non-blocking mode. + */ + + SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) SELECT, + (LPARAM) statePtr); + } else { + /* + * Connect failed */ - WaitForSingleObject(tsdPtr->readyEvent, INFINITE); + /* + * For async connect schedule a writable event to report the fail. + */ + if (async_callback) { + /* + * Set up the select mask for read/write events. + */ + statePtr->selectEvents = FD_WRITE|FD_READ; + /* get statePtr lock */ + WaitForSingleObject(tsdPtr->socketListLock, INFINITE); + /* Signal ready readable and writable events */ + statePtr->readyEvents |= FD_WRITE | FD_READ; + /* Flag error to event routine */ + statePtr->flags |= TCP_ASYNC_FAILED; + /* Save connect error to be reported by 'fconfigure -error' */ + statePtr->connectError = Tcl_GetErrno(); + /* Free list lock */ + SetEvent(tsdPtr->socketListLock); + } + /* + * Error message on syncroneous connect + */ + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't open socket: %s", Tcl_PosixError(interp))); + } + return TCL_ERROR; } - - (void) Tcl_SetServiceMode(oldMode); - return result; + return TCL_OK; } /* @@ -1481,39 +1884,75 @@ Tcl_OpenTcpClient( const char *host, /* Host on which to open port. */ const char *myaddr, /* Client-side address */ int myport, /* Client-side port */ - int async) /* If nonzero, should connect client socket - * asynchronously. */ + int async) /* If nonzero, attempt to do an asynchronous + * connect. Otherwise we do a blocking + * connect. */ { - SocketInfo *infoPtr; - char channelName[16 + TCL_INTEGER_SPACE]; + TcpState *statePtr; + const char *errorMsg = NULL; + struct addrinfo *addrlist = NULL, *myaddrlist = NULL; + char channelName[SOCK_CHAN_LENGTH]; if (TclpHasSockets(interp) != TCL_OK) { return NULL; } /* - * Create a new client socket and wrap it in a channel. + * Check that WinSock is initialized; do not call it if not, to prevent + * system crashes. This can happen at exit time if the exit handler for + * WinSock ran before other exit handlers that want to use sockets. */ - infoPtr = CreateSocket(interp, port, host, 0, myaddr, myport, async); - if (infoPtr == NULL) { + if (!SocketsEnabled()) { + return NULL; + } + + /* + * Do the name lookups for the local and remote addresses. + */ + + if (!TclCreateSocketAddress(interp, &addrlist, host, port, 0, &errorMsg) + || !TclCreateSocketAddress(interp, &myaddrlist, myaddr, myport, 1, + &errorMsg)) { + if (addrlist != NULL) { + freeaddrinfo(addrlist); + } + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't open socket: %s", errorMsg)); + } + return NULL; + } + + statePtr = NewSocketInfo(INVALID_SOCKET); + statePtr->addrlist = addrlist; + statePtr->myaddrlist = myaddrlist; + if (async) { + statePtr->flags |= TCP_ASYNC_CONNECT; + } + + /* + * Create a new client socket and wrap it in a channel. + */ + if (TcpConnect(interp, statePtr) != TCL_OK) { + TcpCloseProc(statePtr, NULL); return NULL; } - sprintf(channelName, "sock%" TCL_I_MODIFIER "u", (size_t) infoPtr->sockets->fd); + sprintf(channelName, SOCK_TEMPLATE, statePtr); - infoPtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName, - infoPtr, (TCL_READABLE | TCL_WRITABLE)); - if (TCL_ERROR == Tcl_SetChannelOption(NULL, infoPtr->channel, + statePtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName, + statePtr, (TCL_READABLE | TCL_WRITABLE)); + if (TCL_ERROR == Tcl_SetChannelOption(NULL, statePtr->channel, "-translation", "auto crlf")) { - Tcl_Close(NULL, infoPtr->channel); + Tcl_Close(NULL, statePtr->channel); return NULL; - } else if (TCL_ERROR == Tcl_SetChannelOption(NULL, infoPtr->channel, + } else if (TCL_ERROR == Tcl_SetChannelOption(NULL, statePtr->channel, "-eofchar", "")) { - Tcl_Close(NULL, infoPtr->channel); + Tcl_Close(NULL, statePtr->channel); return NULL; } - return infoPtr->channel; + return statePtr->channel; } /* @@ -1529,8 +1968,6 @@ Tcl_OpenTcpClient( * Side effects: * None. * - * NOTE: Code contributed by Mark Diekhans (markd@grizzly.com) - * *---------------------------------------------------------------------- */ @@ -1538,8 +1975,8 @@ Tcl_Channel Tcl_MakeTcpClientChannel( ClientData sock) /* The socket to wrap up into a channel. */ { - SocketInfo *infoPtr; - char channelName[16 + TCL_INTEGER_SPACE]; + TcpState *statePtr; + char channelName[SOCK_CHAN_LENGTH]; ThreadSpecificData *tsdPtr; if (TclpHasSockets(NULL) != TCL_OK) { @@ -1554,20 +1991,20 @@ Tcl_MakeTcpClientChannel( TclSockMinimumBuffers(sock, TCP_BUFFER_SIZE); - infoPtr = NewSocketInfo((SOCKET) sock); + statePtr = NewSocketInfo((SOCKET) sock); /* * Start watching for read/write events on the socket. */ - infoPtr->selectEvents = FD_READ | FD_CLOSE | FD_WRITE; - SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM)SELECT, (LPARAM)infoPtr); + statePtr->selectEvents = FD_READ | FD_CLOSE | FD_WRITE; + SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM)SELECT, (LPARAM)statePtr); - sprintf(channelName, "sock%" TCL_I_MODIFIER "u", (size_t) infoPtr->sockets->fd); - infoPtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName, - infoPtr, (TCL_READABLE | TCL_WRITABLE)); - Tcl_SetChannelOption(NULL, infoPtr->channel, "-translation", "auto crlf"); - return infoPtr->channel; + sprintf(channelName, SOCK_TEMPLATE, statePtr); + statePtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName, + statePtr, (TCL_READABLE | TCL_WRITABLE)); + Tcl_SetChannelOption(NULL, statePtr->channel, "-translation", "auto crlf"); + return statePtr->channel; } /* @@ -1578,8 +2015,8 @@ Tcl_MakeTcpClientChannel( * Opens a TCP server socket and creates a channel around it. * * Results: - * The channel or NULL if failed. An error message is returned in the - * interpreter on failure. + * The channel or NULL if failed. If an error occurred, an error message + * is left in the interp's result if interp is not NULL. * * Side effects: * Opens a server socket and creates a new channel. @@ -1591,72 +2028,203 @@ Tcl_Channel Tcl_OpenTcpServer( Tcl_Interp *interp, /* For error reporting - may be NULL. */ int port, /* Port number to open. */ - const char *host, /* Name of local host. */ + const char *myHost, /* Name of local host. */ Tcl_TcpAcceptProc *acceptProc, /* Callback for accepting connections from new * clients. */ ClientData acceptProcData) /* Data for the callback. */ { - SocketInfo *infoPtr; - char channelName[16 + TCL_INTEGER_SPACE]; + SOCKET sock = INVALID_SOCKET; + unsigned short chosenport = 0; + struct addrinfo *addrlist = NULL; + struct addrinfo *addrPtr; /* Socket address to listen on. */ + TcpState *statePtr = NULL; /* The returned value. */ + char channelName[SOCK_CHAN_LENGTH]; + u_long flag = 1; /* Indicates nonblocking mode. */ + const char *errorMsg = NULL; + ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey); if (TclpHasSockets(interp) != TCL_OK) { return NULL; } /* - * Create a new client socket and wrap it in a channel. + * Check that WinSock is initialized; do not call it if not, to prevent + * system crashes. This can happen at exit time if the exit handler for + * WinSock ran before other exit handlers that want to use sockets. */ - infoPtr = CreateSocket(interp, port, host, 1, NULL, 0, 0); - if (infoPtr == NULL) { + if (!SocketsEnabled()) { return NULL; } - infoPtr->acceptProc = acceptProc; - infoPtr->acceptProcData = acceptProcData; + /* + * Construct the addresses for each end of the socket. + */ + + if (!TclCreateSocketAddress(interp, &addrlist, myHost, port, 1, &errorMsg)) { + goto error; + } + + for (addrPtr = addrlist; addrPtr != NULL; addrPtr = addrPtr->ai_next) { + sock = socket(addrPtr->ai_family, addrPtr->ai_socktype, + addrPtr->ai_protocol); + if (sock == INVALID_SOCKET) { + TclWinConvertError((DWORD) WSAGetLastError()); + continue; + } + + /* + * Win-NT has a misfeature that sockets are inherited in child + * processes by default. Turn off the inherit bit. + */ + + SetHandleInformation((HANDLE) sock, HANDLE_FLAG_INHERIT, 0); + + /* + * Set kernel space buffering + */ + + TclSockMinimumBuffers((void *)sock, TCP_BUFFER_SIZE); + + /* + * Make sure we use the same port when opening two server sockets + * for IPv4 and IPv6. + * + * As sockaddr_in6 uses the same offset and size for the port + * member as sockaddr_in, we can handle both through the IPv4 API. + */ + + if (port == 0 && chosenport != 0) { + ((struct sockaddr_in *) addrPtr->ai_addr)->sin_port = + htons(chosenport); + } + + /* + * Bind to the specified port. Note that we must not call + * setsockopt with SO_REUSEADDR because Microsoft allows addresses + * to be reused even if they are still in use. + * + * Bind should not be affected by the socket having already been + * set into nonblocking mode. If there is trouble, this is one + * place to look for bugs. + */ + + if (bind(sock, addrPtr->ai_addr, addrPtr->ai_addrlen) + == SOCKET_ERROR) { + TclWinConvertError((DWORD) WSAGetLastError()); + closesocket(sock); + continue; + } + if (port == 0 && chosenport == 0) { + address sockname; + socklen_t namelen = sizeof(sockname); + + /* + * Synchronize port numbers when binding to port 0 of multiple + * addresses. + */ + + if (getsockname(sock, &sockname.sa, &namelen) >= 0) { + chosenport = ntohs(sockname.sa4.sin_port); + } + } + + /* + * Set the maximum number of pending connect requests to the max + * value allowed on each platform (Win32 and Win32s may be + * different, and there may be differences between TCP/IP stacks). + */ + + if (listen(sock, SOMAXCONN) == SOCKET_ERROR) { + TclWinConvertError((DWORD) WSAGetLastError()); + closesocket(sock); + continue; + } + + if (statePtr == NULL) { + /* + * Add this socket to the global list of sockets. + */ + statePtr = NewSocketInfo(sock); + } else { + AddSocketInfoFd( statePtr, sock ); + } + } + +error: + if (addrlist != NULL) { + freeaddrinfo(addrlist); + } - sprintf(channelName, "sock%" TCL_I_MODIFIER "u", (size_t) infoPtr->sockets->fd); + if (statePtr != NULL) { - infoPtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName, - infoPtr, 0); - if (Tcl_SetChannelOption(interp, infoPtr->channel, "-eofchar", "") + statePtr->acceptProc = acceptProc; + statePtr->acceptProcData = acceptProcData; + sprintf(channelName, SOCK_TEMPLATE, statePtr); + statePtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName, + statePtr, 0); + /* + * Set up the select mask for connection request events. + */ + + statePtr->selectEvents = FD_ACCEPT; + + /* + * Register for interest in events in the select mask. Note that this + * automatically places the socket into non-blocking mode. + */ + + ioctlsocket(sock, (long) FIONBIO, &flag); + SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) SELECT, + (LPARAM) statePtr); + if (Tcl_SetChannelOption(interp, statePtr->channel, "-eofchar", "") == TCL_ERROR) { - Tcl_Close(NULL, infoPtr->channel); - return NULL; + Tcl_Close(NULL, statePtr->channel); + return NULL; + } + return statePtr->channel; } - return infoPtr->channel; + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't open socket: %s", + (errorMsg ? errorMsg : Tcl_PosixError(interp)))); + } + + if (sock != INVALID_SOCKET) { + closesocket(sock); + } + return NULL; } /* *---------------------------------------------------------------------- * * TcpAccept -- - * - * Creates a channel for a newly accepted socket connection. This is - * called by SocketEventProc and it in turns calls the registered - * accept function. + * Accept a TCP socket connection. This is called by the event loop. * * Results: * None. * * Side effects: - * Invokes the accept proc which may invoke arbitrary Tcl code. + * Creates a new connection socket. Calls the registered callback for the + * connection acceptance mechanism. * *---------------------------------------------------------------------- */ + /* ARGSUSED */ static void TcpAccept( TcpFdList *fds, /* Server socket that accepted newSocket. */ SOCKET newSocket, /* Newly accepted socket. */ address addr) /* Address of new socket. */ { - SocketInfo *newInfoPtr; - SocketInfo *infoPtr = fds->infoPtr; + TcpState *newInfoPtr; + TcpState *statePtr = fds->statePtr; int len = sizeof(addr); - char channelName[16 + TCL_INTEGER_SPACE]; + char channelName[SOCK_CHAN_LENGTH]; char host[NI_MAXHOST], port[NI_MAXSERV]; ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey); @@ -1681,7 +2249,7 @@ TcpAccept( SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) SELECT, (LPARAM) newInfoPtr); - sprintf(channelName, "sock%" TCL_I_MODIFIER "u", (size_t) newInfoPtr->sockets->fd); + sprintf(channelName, SOCK_TEMPLATE, newInfoPtr); newInfoPtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName, newInfoPtr, (TCL_READABLE | TCL_WRITABLE)); if (Tcl_SetChannelOption(NULL, newInfoPtr->channel, "-translation", @@ -1699,10 +2267,10 @@ TcpAccept( * Invoke the accept callback function. */ - if (infoPtr->acceptProc != NULL) { + if (statePtr->acceptProc != NULL) { getnameinfo(&(addr.sa), len, host, sizeof(host), port, sizeof(port), NI_NUMERICHOST|NI_NUMERICSERV); - infoPtr->acceptProc(infoPtr->acceptProcData, newInfoPtr->channel, + statePtr->acceptProc(statePtr->acceptProcData, newInfoPtr->channel, host, atoi(port)); } } @@ -1710,666 +2278,672 @@ TcpAccept( /* *---------------------------------------------------------------------- * - * TcpInputProc -- + * InitSockets -- * - * This function is called by the generic IO level to read data from a - * socket based channel. + * Registers the event window for the socket notifier code. + * + * Assumes socketMutex is held. * * Results: - * The number of bytes read or -1 on error. + * None. * * Side effects: - * Consumes input from the socket. + * Register a new window class and creates a + * window for use in asynchronous socket notification. * *---------------------------------------------------------------------- */ -static int -TcpInputProc( - ClientData instanceData, /* The socket state. */ - char *buf, /* Where to store data. */ - int toRead, /* Maximum number of bytes to read. */ - int *errorCodePtr) /* Where to store error codes. */ +static void +InitSockets(void) { - SocketInfo *infoPtr = instanceData; - int bytesRead; - DWORD error; + DWORD id; ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey); - *errorCodePtr = 0; + if (!initialized) { + initialized = 1; + TclCreateLateExitHandler(SocketExitHandler, NULL); - /* - * Check that WinSock is initialized; do not call it if not, to prevent - * system crashes. This can happen at exit time if the exit handler for - * WinSock ran before other exit handlers that want to use sockets. - */ + /* + * Create the async notification window with a new class. We must + * create a new class to avoid a Windows 95 bug that causes us to get + * the wrong message number for socket events if the message window is + * a subclass of a static control. + */ - if (!SocketsEnabled()) { - *errorCodePtr = EFAULT; - return -1; + windowClass.style = 0; + windowClass.cbClsExtra = 0; + windowClass.cbWndExtra = 0; + windowClass.hInstance = TclWinGetTclInstance(); + windowClass.hbrBackground = NULL; + windowClass.lpszMenuName = NULL; + windowClass.lpszClassName = classname; + windowClass.lpfnWndProc = SocketProc; + windowClass.hIcon = NULL; + windowClass.hCursor = NULL; + + if (!RegisterClass(&windowClass)) { + TclWinConvertError(GetLastError()); + goto initFailure; + } } /* - * First check to see if EOF was already detected, to prevent calling the - * socket stack after the first time EOF is detected. + * Check for per-thread initialization. */ - if (infoPtr->flags & SOCKET_EOF) { - return 0; + if (tsdPtr != NULL) { + return; } /* - * Check to see if the socket is connected before trying to read. + * OK, this thread has never done anything with sockets before. Construct + * a worker thread to handle asynchronous events related to sockets + * assigned to _this_ thread. */ - if ((infoPtr->flags & SOCKET_ASYNC_CONNECT) - && !WaitForSocketEvent(infoPtr, FD_CONNECT, errorCodePtr)) { - return -1; + tsdPtr = TCL_TSD_INIT(&dataKey); + tsdPtr->pendingTcpState = NULL; + tsdPtr->socketList = NULL; + tsdPtr->hwnd = NULL; + tsdPtr->threadId = Tcl_GetCurrentThread(); + tsdPtr->readyEvent = CreateEvent(NULL, FALSE, FALSE, NULL); + if (tsdPtr->readyEvent == NULL) { + goto initFailure; + } + tsdPtr->socketListLock = CreateEvent(NULL, FALSE, TRUE, NULL); + if (tsdPtr->socketListLock == NULL) { + goto initFailure; + } + tsdPtr->socketThread = CreateThread(NULL, 256, SocketThread, tsdPtr, 0, + &id); + if (tsdPtr->socketThread == NULL) { + goto initFailure; } + SetThreadPriority(tsdPtr->socketThread, THREAD_PRIORITY_HIGHEST); + /* - * No EOF, and it is connected, so try to read more from the socket. Note - * that we clear the FD_READ bit because read events are level triggered - * so a new event will be generated if there is still data available to be - * read. We have to simulate blocking behavior here since we are always - * using non-blocking sockets. + * Wait for the thread to signal when the window has been created and if + * it is ready to go. */ - while (1) { - SendMessage(tsdPtr->hwnd, SOCKET_SELECT, - (WPARAM) UNSELECT, (LPARAM) infoPtr); - /* single fd operation: this proc is only called for a connected socket. */ - bytesRead = recv(infoPtr->sockets->fd, buf, toRead, 0); - infoPtr->readyEvents &= ~(FD_READ); - - /* - * Check for end-of-file condition or successful read. - */ - - if (bytesRead == 0) { - infoPtr->flags |= SOCKET_EOF; - } - if (bytesRead != SOCKET_ERROR) { - break; - } - - /* - * If an error occurs after the FD_CLOSE has arrived, then ignore the - * error and report an EOF. - */ - - if (infoPtr->readyEvents & FD_CLOSE) { - infoPtr->flags |= SOCKET_EOF; - bytesRead = 0; - break; - } - - error = WSAGetLastError(); - - /* - * If an RST comes, then ignore the error and report an EOF just like - * on unix. - */ - - if (error == WSAECONNRESET) { - infoPtr->flags |= SOCKET_EOF; - bytesRead = 0; - break; - } - - /* - * Check for error condition or underflow in non-blocking case. - */ - - if ((infoPtr->flags & SOCKET_ASYNC) || (error != WSAEWOULDBLOCK)) { - TclWinConvertError(error); - *errorCodePtr = Tcl_GetErrno(); - bytesRead = -1; - break; - } - - /* - * In the blocking case, wait until the file becomes readable or - * closed and try again. - */ + WaitForSingleObject(tsdPtr->readyEvent, INFINITE); - if (!WaitForSocketEvent(infoPtr, FD_READ|FD_CLOSE, errorCodePtr)) { - bytesRead = -1; - break; - } + if (tsdPtr->hwnd == NULL) { + goto initFailure; /* Trouble creating the window. */ } - SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM)SELECT, (LPARAM)infoPtr); + Tcl_CreateEventSource(SocketSetupProc, SocketCheckProc, NULL); + return; - return bytesRead; + initFailure: + TclpFinalizeSockets(); + initialized = -1; + return; } /* *---------------------------------------------------------------------- * - * TcpOutputProc -- + * SocketsEnabled -- * - * This function is called by the generic IO level to write data to a - * socket based channel. + * Check that the WinSock was successfully initialized. + * + * Warning: + * This check was useful in times of Windows98 where WinSock may + * not be available. This is not the case any more. + * This function may be removed with TCL 9.0 * * Results: - * The number of bytes written or -1 on failure. + * 1 if it is. * * Side effects: - * Produces output on the socket. + * None. * *---------------------------------------------------------------------- */ + /* ARGSUSED */ static int -TcpOutputProc( - ClientData instanceData, /* The socket state. */ - const char *buf, /* Where to get data. */ - int toWrite, /* Maximum number of bytes to write. */ - int *errorCodePtr) /* Where to store error codes. */ +SocketsEnabled(void) { - SocketInfo *infoPtr = instanceData; - int bytesWritten; - DWORD error; - ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey); + int enabled; - *errorCodePtr = 0; + Tcl_MutexLock(&socketMutex); + enabled = (initialized == 1); + Tcl_MutexUnlock(&socketMutex); + return enabled; +} - /* - * Check that WinSock is initialized; do not call it if not, to prevent - * system crashes. This can happen at exit time if the exit handler for - * WinSock ran before other exit handlers that want to use sockets. - */ + +/* + *---------------------------------------------------------------------- + * + * SocketExitHandler -- + * + * Callback invoked during exit clean up to delete the socket + * communication window. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ - if (!SocketsEnabled()) { - *errorCodePtr = EFAULT; - return -1; - } + /* ARGSUSED */ +static void +SocketExitHandler( + ClientData clientData) /* Not used. */ +{ + Tcl_MutexLock(&socketMutex); /* - * Check to see if the socket is connected before trying to write. + * Make sure the socket event handling window is cleaned-up for, at + * most, this thread. */ - if ((infoPtr->flags & SOCKET_ASYNC_CONNECT) - && !WaitForSocketEvent(infoPtr, FD_CONNECT, errorCodePtr)) { - return -1; - } - - while (1) { - SendMessage(tsdPtr->hwnd, SOCKET_SELECT, - (WPARAM) UNSELECT, (LPARAM) infoPtr); - - /* single fd operation: this proc is only called for a connected socket. */ - bytesWritten = send(infoPtr->sockets->fd, buf, toWrite, 0); - if (bytesWritten != SOCKET_ERROR) { - /* - * Since Windows won't generate a new write event until we hit an - * overflow condition, we need to force the event loop to poll - * until the condition changes. - */ - - if (infoPtr->watchEvents & FD_WRITE) { - Tcl_Time blockTime = { 0, 0 }; - Tcl_SetMaxBlockTime(&blockTime); - } - break; - } - - /* - * Check for error condition or overflow. In the event of overflow, we - * need to clear the FD_WRITE flag so we can detect the next writable - * event. Note that Windows only sends a new writable event after a - * send fails with WSAEWOULDBLOCK. - */ + TclpFinalizeSockets(); + UnregisterClass(classname, TclWinGetTclInstance()); + initialized = 0; + Tcl_MutexUnlock(&socketMutex); +} + +/* + *---------------------------------------------------------------------- + * + * SocketSetupProc -- + * + * This function is invoked before Tcl_DoOneEvent blocks waiting for an + * event. + * + * Results: + * None. + * + * Side effects: + * Adjusts the block time if needed. + * + *---------------------------------------------------------------------- + */ - error = WSAGetLastError(); - if (error == WSAEWOULDBLOCK) { - infoPtr->readyEvents &= ~(FD_WRITE); - if (infoPtr->flags & SOCKET_ASYNC) { - *errorCodePtr = EWOULDBLOCK; - bytesWritten = -1; - break; - } - } else { - TclWinConvertError(error); - *errorCodePtr = Tcl_GetErrno(); - bytesWritten = -1; - break; - } +void +SocketSetupProc( + ClientData data, /* Not used. */ + int flags) /* Event flags as passed to Tcl_DoOneEvent. */ +{ + TcpState *statePtr; + Tcl_Time blockTime = { 0, 0 }; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - /* - * In the blocking case, wait until the file becomes writable or - * closed and try again. - */ + if (!(flags & TCL_FILE_EVENTS)) { + return; + } - if (!WaitForSocketEvent(infoPtr, FD_WRITE|FD_CLOSE, errorCodePtr)) { - bytesWritten = -1; + /* + * Check to see if there is a ready socket. If so, poll. + */ + WaitForSingleObject(tsdPtr->socketListLock, INFINITE); + for (statePtr = tsdPtr->socketList; statePtr != NULL; + statePtr = statePtr->nextPtr) { + if (statePtr->readyEvents & + (statePtr->watchEvents | FD_CONNECT | FD_ACCEPT) + ) { + Tcl_SetMaxBlockTime(&blockTime); break; } } - - SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM)SELECT, (LPARAM)infoPtr); - - return bytesWritten; + SetEvent(tsdPtr->socketListLock); } /* *---------------------------------------------------------------------- * - * TcpSetOptionProc -- + * SocketCheckProc -- * - * Sets Tcp channel specific options. + * This function is called by Tcl_DoOneEvent to check the socket event + * source for events. * * Results: - * None, unless an error happens. + * None. * * Side effects: - * Changes attributes of the socket at the system level. + * May queue an event. * *---------------------------------------------------------------------- */ -static int -TcpSetOptionProc( - ClientData instanceData, /* Socket state. */ - Tcl_Interp *interp, /* For error reporting - can be NULL. */ - const char *optionName, /* Name of the option to set. */ - const char *value) /* New value for option. */ +static void +SocketCheckProc( + ClientData data, /* Not used. */ + int flags) /* Event flags as passed to Tcl_DoOneEvent. */ { -#ifdef TCL_FEATURE_KEEPALIVE_NAGLE - SocketInfo *infoPtr = instanceData; - SOCKET sock; -#endif /*TCL_FEATURE_KEEPALIVE_NAGLE*/ - - /* - * Check that WinSock is initialized; do not call it if not, to prevent - * system crashes. This can happen at exit time if the exit handler for - * WinSock ran before other exit handlers that want to use sockets. - */ + TcpState *statePtr; + SocketEvent *evPtr; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - if (!SocketsEnabled()) { - if (interp) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "winsock is not initialized", -1)); - } - return TCL_ERROR; + if (!(flags & TCL_FILE_EVENTS)) { + return; } -#ifdef TCL_FEATURE_KEEPALIVE_NAGLE - #error "TCL_FEATURE_KEEPALIVE_NAGLE not reviewed for whether to treat infoPtr->sockets as single fd or list" - sock = infoPtr->sockets->fd; - - if (!strcasecmp(optionName, "-keepalive")) { - BOOL val = FALSE; - int boolVar, rtn; - - if (Tcl_GetBoolean(interp, value, &boolVar) != TCL_OK) { - return TCL_ERROR; - } - if (boolVar) { - val = TRUE; - } - rtn = setsockopt(sock, SOL_SOCKET, SO_KEEPALIVE, - (const char *) &val, sizeof(BOOL)); - if (rtn != 0) { - TclWinConvertError(WSAGetLastError()); - if (interp) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "couldn't set socket option: %s", - Tcl_PosixError(interp))); - } - return TCL_ERROR; - } - return TCL_OK; - } else if (!strcasecmp(optionName, "-nagle")) { - BOOL val = FALSE; - int boolVar, rtn; + /* + * Queue events for any ready sockets that don't already have events + * queued (caused by persistent states that won't generate WinSock + * events). + */ - if (Tcl_GetBoolean(interp, value, &boolVar) != TCL_OK) { - return TCL_ERROR; - } - if (!boolVar) { - val = TRUE; - } - rtn = setsockopt(sock, IPPROTO_TCP, TCP_NODELAY, - (const char *) &val, sizeof(BOOL)); - if (rtn != 0) { - TclWinConvertError(WSAGetLastError()); - if (interp) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "couldn't set socket option: %s", - Tcl_PosixError(interp))); - } - return TCL_ERROR; + WaitForSingleObject(tsdPtr->socketListLock, INFINITE); + for (statePtr = tsdPtr->socketList; statePtr != NULL; + statePtr = statePtr->nextPtr) { + if ((statePtr->readyEvents & + (statePtr->watchEvents | FD_CONNECT | FD_ACCEPT)) + && !(statePtr->flags & SOCKET_PENDING) + ) { + statePtr->flags |= SOCKET_PENDING; + evPtr = ckalloc(sizeof(SocketEvent)); + evPtr->header.proc = SocketEventProc; + evPtr->socket = statePtr->sockets->fd; + Tcl_QueueEvent((Tcl_Event *) evPtr, TCL_QUEUE_TAIL); } - return TCL_OK; } - - return Tcl_BadChannelOption(interp, optionName, "keepalive nagle"); -#else - return Tcl_BadChannelOption(interp, optionName, ""); -#endif /*TCL_FEATURE_KEEPALIVE_NAGLE*/ + SetEvent(tsdPtr->socketListLock); } /* *---------------------------------------------------------------------- * - * TcpGetOptionProc -- - * - * Computes an option value for a TCP socket based channel, or a list of - * all options and their values. + * SocketEventProc -- * - * Note: This code is based on code contributed by John Haxby. + * This function is called by Tcl_ServiceEvent when a socket event + * reaches the front of the event queue. This function is responsible for + * notifying the generic channel code. * * Results: - * A standard Tcl result. The value of the specified option or a list of - * all options and their values is returned in the supplied DString. + * Returns 1 if the event was handled, meaning it should be removed from + * the queue. Returns 0 if the event was not handled, meaning it should + * stay on the queue. The only time the event isn't handled is if the + * TCL_FILE_EVENTS flag bit isn't set. * * Side effects: - * None. + * Whatever the channel callback functions do. * *---------------------------------------------------------------------- */ static int -TcpGetOptionProc( - ClientData instanceData, /* Socket state. */ - Tcl_Interp *interp, /* For error reporting - can be NULL */ - const char *optionName, /* Name of the option to retrieve the value - * for, or NULL to get all options and their - * values. */ - Tcl_DString *dsPtr) /* Where to store the computed value; - * initialized by caller. */ +SocketEventProc( + Tcl_Event *evPtr, /* Event to service. */ + int flags) /* Flags that indicate what events to handle, + * such as TCL_FILE_EVENTS. */ { - SocketInfo *infoPtr = instanceData; - char host[NI_MAXHOST], port[NI_MAXSERV]; - SOCKET sock; - size_t len = 0; - int reverseDNS = 0; -#define SUPPRESS_RDNS_VAR "::tcl::unsupported::noReverseDNS" + TcpState *statePtr; + SocketEvent *eventPtr = (SocketEvent *) evPtr; + int mask = 0, events; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + TcpFdList *fds; + SOCKET newSocket; + address addr; + int len; + + if (!(flags & TCL_FILE_EVENTS)) { + return 0; + } /* - * Check that WinSock is initialized; do not call it if not, to prevent - * system crashes. This can happen at exit time if the exit handler for - * WinSock ran before other exit handlers that want to use sockets. + * Find the specified socket on the socket list. */ - if (!SocketsEnabled()) { - if (interp) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "winsock is not initialized", -1)); + WaitForSingleObject(tsdPtr->socketListLock, INFINITE); + for (statePtr = tsdPtr->socketList; statePtr != NULL; + statePtr = statePtr->nextPtr) { + if (statePtr->sockets->fd == eventPtr->socket) { + break; } - return TCL_ERROR; } - sock = infoPtr->sockets->fd; - if (optionName != NULL) { - len = strlen(optionName); + /* + * Discard events that have gone stale. + */ + + if (!statePtr) { + SetEvent(tsdPtr->socketListLock); + return 1; } - if ((len > 1) && (optionName[1] == 'e') && - (strncmp(optionName, "-error", len) == 0)) { - int optlen; - DWORD err; - int ret; + /* + * Clear flag that (this) event is pending + */ - optlen = sizeof(int); - ret = TclWinGetSockOpt(sock, SOL_SOCKET, SO_ERROR, - (char *)&err, &optlen); - if (ret == SOCKET_ERROR) { - err = WSAGetLastError(); - } - if (err) { - TclWinConvertError(err); - Tcl_DStringAppend(dsPtr, Tcl_ErrnoMsg(Tcl_GetErrno()), -1); - } - return TCL_OK; - } + statePtr->flags &= ~SOCKET_PENDING; - if (interp != NULL && Tcl_GetVar(interp, SUPPRESS_RDNS_VAR, 0) != NULL) { - reverseDNS = NI_NUMERICHOST; - } + /* + * Continue async connect if pending and ready + */ - if ((len == 0) || ((len > 1) && (optionName[1] == 'p') && - (strncmp(optionName, "-peername", len) == 0))) { - address peername; - socklen_t size = sizeof(peername); + if ( statePtr->readyEvents & FD_CONNECT ) { + if ( statePtr->flags & TCP_ASYNC_PENDING ) { - if (getpeername(sock, (LPSOCKADDR) &(peername.sa), &size) == 0) { - if (len == 0) { - Tcl_DStringAppendElement(dsPtr, "-peername"); - Tcl_DStringStartSublist(dsPtr); - } + /* + * Do one step and save eventual connect error + */ + + SetEvent(tsdPtr->socketListLock); + WaitForConnect(statePtr,NULL); - getnameinfo(&(peername.sa), size, host, sizeof(host), - NULL, 0, NI_NUMERICHOST); - Tcl_DStringAppendElement(dsPtr, host); - getnameinfo(&(peername.sa), size, host, sizeof(host), - port, sizeof(port), reverseDNS | NI_NUMERICSERV); - Tcl_DStringAppendElement(dsPtr, host); - Tcl_DStringAppendElement(dsPtr, port); - if (len == 0) { - Tcl_DStringEndSublist(dsPtr); - } else { - return TCL_OK; - } } else { + /* - * getpeername failed - but if we were asked for all the options - * (len==0), don't flag an error at that point because it could be - * an fconfigure request on a server socket (such sockets have no - * peer). {Copied from unix/tclUnixChan.c} + * No async connect reenter pending. Just clear event. */ - if (len) { - TclWinConvertError((DWORD) WSAGetLastError()); - if (interp) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "can't get peername: %s", - Tcl_PosixError(interp))); - } - return TCL_ERROR; - } + statePtr->readyEvents &= ~(FD_CONNECT); + SetEvent(tsdPtr->socketListLock); } + return 1; } - if ((len == 0) || ((len > 1) && (optionName[1] == 's') && - (strncmp(optionName, "-sockname", len) == 0))) { - TcpFdList *fds; - address sockname; - socklen_t size; - int found = 0; + /* + * Handle connection requests directly. + */ + if (statePtr->readyEvents & FD_ACCEPT) { + for (fds = statePtr->sockets; fds != NULL; fds = fds->next) { - if (len == 0) { - Tcl_DStringAppendElement(dsPtr, "-sockname"); - Tcl_DStringStartSublist(dsPtr); - } - for (fds = infoPtr->sockets; fds != NULL; fds = fds->next) { - sock = fds->fd; - size = sizeof(sockname); - if (getsockname(sock, &(sockname.sa), &size) >= 0) { - int flags = reverseDNS; + /* + * Accept the incoming connection request. + */ + len = sizeof(address); - found = 1; - getnameinfo(&sockname.sa, size, host, sizeof(host), - NULL, 0, NI_NUMERICHOST); - Tcl_DStringAppendElement(dsPtr, host); + newSocket = accept(fds->fd, &(addr.sa), &len); - /* - * We don't want to resolve INADDR_ANY and sin6addr_any; they - * can sometimes cause problems (and never have a name). - */ - flags |= NI_NUMERICSERV; - if (sockname.sa.sa_family == AF_INET) { - if (sockname.sa4.sin_addr.s_addr == INADDR_ANY) { - flags |= NI_NUMERICHOST; - } - } else if (sockname.sa.sa_family == AF_INET6) { - if ((IN6_ARE_ADDR_EQUAL(&sockname.sa6.sin6_addr, - &in6addr_any)) || - (IN6_IS_ADDR_V4MAPPED(&sockname.sa6.sin6_addr) - && sockname.sa6.sin6_addr.s6_addr[12] == 0 - && sockname.sa6.sin6_addr.s6_addr[13] == 0 - && sockname.sa6.sin6_addr.s6_addr[14] == 0 - && sockname.sa6.sin6_addr.s6_addr[15] == 0)) { - flags |= NI_NUMERICHOST; - } - } - getnameinfo(&sockname.sa, size, host, sizeof(host), - port, sizeof(port), flags); - Tcl_DStringAppendElement(dsPtr, host); - Tcl_DStringAppendElement(dsPtr, port); - } - } - if (found) { - if (len == 0) { - Tcl_DStringEndSublist(dsPtr); - } else { - return TCL_OK; + /* On Tcl server sockets with multiple OS fds we loop over the fds trying + * an accept() on each, so we expect INVALID_SOCKET. There are also other + * network stack conditions that can result in FD_ACCEPT but a subsequent + * failure on accept() by the time we get around to it. + * Access to sockets (acceptEventCount, readyEvents) in socketList + * is still protected by the lock (prevents reintroduction of + * SF Tcl Bug 3056775. + */ + + if (newSocket == INVALID_SOCKET) { + /* int err = WSAGetLastError(); */ + continue; } - } else { - if (interp) { - TclWinConvertError((DWORD) WSAGetLastError()); - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "can't get sockname: %s", Tcl_PosixError(interp))); + + /* + * It is possible that more than one FD_ACCEPT has been sent, so an extra + * count must be kept. Decrement the count, and reset the readyEvent bit + * if the count is no longer > 0. + */ + statePtr->acceptEventCount--; + + if (statePtr->acceptEventCount <= 0) { + statePtr->readyEvents &= ~(FD_ACCEPT); } - return TCL_ERROR; - } - } -#ifdef TCL_FEATURE_KEEPALIVE_NAGLE - if (len == 0 || !strncmp(optionName, "-keepalive", len)) { - int optlen; - BOOL opt = FALSE; + SetEvent(tsdPtr->socketListLock); - if (len == 0) { - Tcl_DStringAppendElement(dsPtr, "-keepalive"); - } - optlen = sizeof(BOOL); - getsockopt(sock, SOL_SOCKET, SO_KEEPALIVE, (char *)&opt, &optlen); - if (opt) { - Tcl_DStringAppendElement(dsPtr, "1"); - } else { - Tcl_DStringAppendElement(dsPtr, "0"); - } - if (len > 0) { - return TCL_OK; + /* Caution: TcpAccept() has the side-effect of evaluating the server + * accept script (via AcceptCallbackProc() in tclIOCmd.c), which can + * close the server socket and invalidate statePtr and fds. + * If TcpAccept() accepts a socket we must return immediately and let + * SocketCheckProc queue additional FD_ACCEPT events. + */ + TcpAccept(fds, newSocket, addr); + return 1; } + + /* Loop terminated with no sockets accepted; clear the ready mask so + * we can detect the next connection request. Note that connection + * requests are level triggered, so if there is a request already + * pending, a new event will be generated. + */ + statePtr->acceptEventCount = 0; + statePtr->readyEvents &= ~(FD_ACCEPT); + + SetEvent(tsdPtr->socketListLock); + return 1; } - if (len == 0 || !strncmp(optionName, "-nagle", len)) { - int optlen; - BOOL opt = FALSE; + SetEvent(tsdPtr->socketListLock); - if (len == 0) { - Tcl_DStringAppendElement(dsPtr, "-nagle"); - } - optlen = sizeof(BOOL); - getsockopt(sock, IPPROTO_TCP, TCP_NODELAY, (char *)&opt, &optlen); - if (opt) { - Tcl_DStringAppendElement(dsPtr, "0"); + /* + * Mask off unwanted events and compute the read/write mask so we can + * notify the channel. + */ + + events = statePtr->readyEvents & statePtr->watchEvents; + + if (events & FD_CLOSE) { + /* + * If the socket was closed and the channel is still interested in + * read events, then we need to ensure that we keep polling for this + * event until someone does something with the channel. Note that we + * do this before calling Tcl_NotifyChannel so we don't have to watch + * out for the channel being deleted out from under us. This may cause + * a redundant trip through the event loop, but it's simpler than + * trying to do unwind protection. + */ + + Tcl_Time blockTime = { 0, 0 }; + + Tcl_SetMaxBlockTime(&blockTime); + mask |= TCL_READABLE|TCL_WRITABLE; + } else if (events & FD_READ) { + + /* + * Throw the readable event if an async connect failed. + */ + + if ( statePtr->flags & TCP_ASYNC_FAILED ) { + + mask |= TCL_READABLE; + } else { - Tcl_DStringAppendElement(dsPtr, "1"); - } - if (len > 0) { - return TCL_OK; + fd_set readFds; + struct timeval timeout; + + /* + * We must check to see if data is really available, since someone + * could have consumed the data in the meantime. Turn off async + * notification so select will work correctly. If the socket is + * still readable, notify the channel driver, otherwise reset the + * async select handler and keep waiting. + */ + + SendMessage(tsdPtr->hwnd, SOCKET_SELECT, + (WPARAM) UNSELECT, (LPARAM) statePtr); + + FD_ZERO(&readFds); + FD_SET(statePtr->sockets->fd, &readFds); + timeout.tv_usec = 0; + timeout.tv_sec = 0; + + if (select(0, &readFds, NULL, NULL, &timeout) != 0) { + mask |= TCL_READABLE; + } else { + statePtr->readyEvents &= ~(FD_READ); + SendMessage(tsdPtr->hwnd, SOCKET_SELECT, + (WPARAM) SELECT, (LPARAM) statePtr); + } } } -#endif /*TCL_FEATURE_KEEPALIVE_NAGLE*/ - if (len > 0) { -#ifdef TCL_FEATURE_KEEPALIVE_NAGLE - return Tcl_BadChannelOption(interp, optionName, - "peername sockname keepalive nagle"); -#else - return Tcl_BadChannelOption(interp, optionName, "peername sockname"); -#endif /*TCL_FEATURE_KEEPALIVE_NAGLE*/ - } + /* + * writable event + */ - return TCL_OK; + if (events & FD_WRITE) { + mask |= TCL_WRITABLE; + } + + /* + * Call registered event procedures + */ + + if (mask) { + Tcl_NotifyChannel(statePtr->channel, mask); + } + return 1; } /* *---------------------------------------------------------------------- * - * TcpWatchProc -- + * AddSocketInfoFd -- * - * Informs the channel driver of the events that the generic channel code - * wishes to receive on this socket. + * This function adds a SOCKET file descriptor to the 'sockets' linked + * list of a TcpState structure. * * Results: * None. * * Side effects: - * May cause the notifier to poll if any of the specified conditions are - * already true. + * None, except for allocation of memory. * *---------------------------------------------------------------------- */ static void -TcpWatchProc( - ClientData instanceData, /* The socket state. */ - int mask) /* Events of interest; an OR-ed combination of - * TCL_READABLE, TCL_WRITABLE and - * TCL_EXCEPTION. */ +AddSocketInfoFd( + TcpState *statePtr, + SOCKET socket) { - SocketInfo *infoPtr = instanceData; - - /* - * Update the watch events mask. Only if the socket is not a server - * socket. [Bug 557878] - */ + TcpFdList *fds = statePtr->sockets; - if (!infoPtr->acceptProc) { - infoPtr->watchEvents = 0; - if (mask & TCL_READABLE) { - infoPtr->watchEvents |= (FD_READ|FD_CLOSE|FD_ACCEPT); - } - if (mask & TCL_WRITABLE) { - infoPtr->watchEvents |= (FD_WRITE|FD_CLOSE|FD_CONNECT); + if ( fds == NULL ) { + /* Add the first FD */ + statePtr->sockets = ckalloc(sizeof(TcpFdList)); + fds = statePtr->sockets; + } else { + /* Find end of list and append FD */ + while ( fds->next != NULL ) { + fds = fds->next; } + + fds->next = ckalloc(sizeof(TcpFdList)); + fds = fds->next; + } - /* - * If there are any conditions already set, then tell the notifier to - * poll rather than block. - */ + /* Populate new FD */ + fds->fd = socket; + fds->statePtr = statePtr; + fds->next = NULL; +} - if (infoPtr->readyEvents & infoPtr->watchEvents) { - Tcl_Time blockTime = { 0, 0 }; + +/* + *---------------------------------------------------------------------- + * + * NewSocketInfo -- + * + * This function allocates and initializes a new TcpState structure. + * + * Results: + * Returns a newly allocated TcpState. + * + * Side effects: + * None, except for allocation of memory. + * + *---------------------------------------------------------------------- + */ - Tcl_SetMaxBlockTime(&blockTime); - } - } +static TcpState * +NewSocketInfo(SOCKET socket) +{ + TcpState *statePtr = ckalloc(sizeof(TcpState)); + + memset(statePtr, 0, sizeof(TcpState)); + + /* + * TIP #218. Removed the code inserting the new structure into the global + * list. This is now handled in the thread action callbacks, and only + * there. + */ + + AddSocketInfoFd(statePtr, socket); + + return statePtr; } /* *---------------------------------------------------------------------- * - * TcpGetProc -- + * WaitForSocketEvent -- * - * Called from Tcl_GetChannelHandle to retrieve an OS handle from inside - * a TCP socket based channel. + * Waits until one of the specified events occurs on a socket. + * For event FD_CONNECT use WaitForConnect. * * Results: - * Returns TCL_OK with the socket in handlePtr. + * Returns 1 on success or 0 on failure, with an error code in + * errorCodePtr. * * Side effects: - * None. + * Processes socket events off the system queue. * *---------------------------------------------------------------------- */ static int -TcpGetHandleProc( - ClientData instanceData, /* The socket state. */ - int direction, /* Not used. */ - ClientData *handlePtr) /* Where to store the handle. */ +WaitForSocketEvent( + TcpState *statePtr, /* Information about this socket. */ + int events, /* Events to look for. May be one of + * FD_READ or FD_WRITE. + */ + int *errorCodePtr) /* Where to store errors? */ { - SocketInfo *statePtr = instanceData; + int result = 1; + int oldMode; + ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey); + /* + * Be sure to disable event servicing so we are truly modal. + */ - *handlePtr = INT2PTR(statePtr->sockets->fd); - return TCL_OK; + oldMode = Tcl_SetServiceMode(TCL_SERVICE_NONE); + + /* + * Reset WSAAsyncSelect so we have a fresh set of events pending. + */ + + SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) UNSELECT, + (LPARAM) statePtr); + SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) SELECT, + (LPARAM) statePtr); + + while (1) { + int event_found; + + /* get statePtr lock */ + WaitForSingleObject(tsdPtr->socketListLock, INFINITE); + + /* Check if event occured */ + event_found = (statePtr->readyEvents & events); + + /* Free list lock */ + SetEvent(tsdPtr->socketListLock); + + /* exit loop if event occured */ + if (event_found) { + break; + } + + /* Exit loop if event did not occur but this is a non-blocking channel */ + if (statePtr->flags & TCP_NONBLOCKING) { + *errorCodePtr = EWOULDBLOCK; + result = 0; + break; + } + + /* + * Wait until something happens. + */ + + WaitForSingleObject(tsdPtr->readyEvent, INFINITE); + } + + (void) Tcl_SetServiceMode(oldMode); + return result; } /* @@ -2463,7 +3037,8 @@ SocketProc( { int event, error; SOCKET socket; - SocketInfo *infoPtr; + TcpState *statePtr; + int info_found = 0; TcpFdList *fds = NULL; ThreadSpecificData *tsdPtr = (ThreadSpecificData *) #ifdef _WIN64 @@ -2501,80 +3076,76 @@ SocketProc( error = WSAGETSELECTERROR(lParam); socket = (SOCKET) wParam; + WaitForSingleObject(tsdPtr->socketListLock, INFINITE); + /* * Find the specified socket on the socket list and update its * eventState flag. */ - WaitForSingleObject(tsdPtr->socketListLock, INFINITE); - for (infoPtr = tsdPtr->socketList; infoPtr != NULL; - infoPtr = infoPtr->nextPtr) { - for (fds = infoPtr->sockets; fds != NULL; fds = fds->next) { - if (fds->fd == socket) { - /* - * Update the socket state. - * - * A count of FD_ACCEPTS is stored, so if an FD_CLOSE event - * happens, then clear the FD_ACCEPT count. Otherwise, - * increment the count if the current event is an FD_ACCEPT. - */ - - if (event & FD_CLOSE) { - infoPtr->acceptEventCount = 0; - infoPtr->readyEvents &= ~(FD_WRITE|FD_ACCEPT); - } else if (event & FD_ACCEPT) { - infoPtr->acceptEventCount++; - } - - if (event & FD_CONNECT) { - /* - * The socket is now connected, clear the async connect - * flag. - */ - - infoPtr->flags &= ~(SOCKET_ASYNC_CONNECT); - - /* - * Remember any error that occurred so we can report - * connection failures. - */ - - if (error != ERROR_SUCCESS) { - TclWinConvertError((DWORD) error); - infoPtr->lastError = Tcl_GetErrno(); - } - } + for (statePtr = tsdPtr->socketList; statePtr != NULL; + statePtr = statePtr->nextPtr) { + if ( FindFDInList(statePtr,socket) ) { + info_found = 1; + break; + } + } + /* + * Check if there is a pending info structure not jet in the + * list + */ + if ( !info_found + && tsdPtr->pendingTcpState != NULL + && FindFDInList(tsdPtr->pendingTcpState,socket) ) { + statePtr = tsdPtr->pendingTcpState; + info_found = 1; + } + if (info_found) { - if (infoPtr->flags & SOCKET_ASYNC_CONNECT) { - infoPtr->flags &= ~(SOCKET_ASYNC_CONNECT); - if (error != ERROR_SUCCESS) { - TclWinConvertError((DWORD) error); - infoPtr->lastError = Tcl_GetErrno(); - } - infoPtr->readyEvents |= FD_WRITE; - } - infoPtr->readyEvents |= event; + /* + * Update the socket state. + * + * A count of FD_ACCEPTS is stored, so if an FD_CLOSE event + * happens, then clear the FD_ACCEPT count. Otherwise, + * increment the count if the current event is an FD_ACCEPT. + */ - /* - * Wake up the Main Thread. - */ + if (event & FD_CLOSE) { + statePtr->acceptEventCount = 0; + statePtr->readyEvents &= ~(FD_WRITE|FD_ACCEPT); + } else if (event & FD_ACCEPT) { + statePtr->acceptEventCount++; + } - SetEvent(tsdPtr->readyEvent); - Tcl_ThreadAlert(tsdPtr->threadId); - break; + if (event & FD_CONNECT) { + /* + * Remember any error that occurred so we can report + * connection failures. + */ + if (error != ERROR_SUCCESS) { + statePtr->notifierConnectError = error; } } + /* + * Inform main thread about signaled events + */ + statePtr->readyEvents |= event; + + /* + * Wake up the Main Thread. + */ + SetEvent(tsdPtr->readyEvent); + Tcl_ThreadAlert(tsdPtr->threadId); } SetEvent(tsdPtr->socketListLock); break; case SOCKET_SELECT: - infoPtr = (SocketInfo *) lParam; - for (fds = infoPtr->sockets; fds != NULL; fds = fds->next) { - infoPtr = (SocketInfo *) lParam; + statePtr = (TcpState *) lParam; + for (fds = statePtr->sockets; fds != NULL; fds = fds->next) { if (wParam == SELECT) { WSAAsyncSelect(fds->fd, hwnd, - SOCKET_MESSAGE, infoPtr->selectEvents); + SOCKET_MESSAGE, statePtr->selectEvents); } else { /* * Clear the selection mask @@ -2596,83 +3167,31 @@ SocketProc( /* *---------------------------------------------------------------------- * - * Tcl_GetHostName -- + * FindFDInList -- * - * Returns the name of the local host. + * Return true, if the given file descriptior is contained in the + * file descriptor list. * * Results: - * A string containing the network name for this machine. The caller must - * not modify or free this string. + * true if found. * * Side effects: - * Caches the name to return for future calls. - * - *---------------------------------------------------------------------- - */ - -const char * -Tcl_GetHostName(void) -{ - return Tcl_GetString(TclGetProcessGlobalValue(&hostName)); -} - -/* - *---------------------------------------------------------------------- - * - * InitializeHostName -- - * - * This routine sets the process global value of the name of the local - * host on which the process is running. - * - * Results: - * None. * *---------------------------------------------------------------------- */ -void -InitializeHostName( - char **valuePtr, - int *lengthPtr, - Tcl_Encoding *encodingPtr) +static int +FindFDInList( + TcpState *statePtr, + SOCKET socket) { - TCHAR tbuf[MAX_COMPUTERNAME_LENGTH + 1]; - DWORD length = MAX_COMPUTERNAME_LENGTH + 1; - Tcl_DString ds; - - if (GetComputerName(tbuf, &length) != 0) { - /* - * Convert string from native to UTF then change to lowercase. - */ - - Tcl_UtfToLower(Tcl_WinTCharToUtf(tbuf, -1, &ds)); - - } else { - Tcl_DStringInit(&ds); - if (TclpHasSockets(NULL) == TCL_OK) { - /* - * The buffer size of 256 is recommended by the MSDN page that - * documents gethostname() as being always adequate. - */ - - Tcl_DString inDs; - - Tcl_DStringInit(&inDs); - Tcl_DStringSetLength(&inDs, 256); - if (gethostname(Tcl_DStringValue(&inDs), - Tcl_DStringLength(&inDs)) == 0) { - Tcl_ExternalToUtfDString(NULL, Tcl_DStringValue(&inDs), -1, - &ds); - } - Tcl_DStringFree(&inDs); + TcpFdList *fds; + for (fds = statePtr->sockets; fds != NULL; fds = fds->next) { + if (fds->fd == socket) { + return 1; } } - - *encodingPtr = Tcl_GetEncoding(NULL, "utf-8"); - *lengthPtr = Tcl_DStringLength(&ds); - *valuePtr = ckalloc((*lengthPtr) + 1); - memcpy(*valuePtr, Tcl_DStringValue(&ds), (size_t)(*lengthPtr)+1); - Tcl_DStringFree(&ds); + return 0; } /* @@ -2680,10 +3199,11 @@ InitializeHostName( * * TclWinGetSockOpt, et al. -- * - * These functions are wrappers that let us bind the WinSock API - * dynamically so we can run on systems that don't have the wsock32.dll. - * We need wrappers for these interfaces because they are called from the - * generic Tcl code. + * Those functions are historically exported by the stubs table and + * just use the original system calls now. + * + * Warning: + * Those functions are depreciated and will be removed with TCL 9.0. * * Results: * As defined for each function. @@ -2694,6 +3214,7 @@ InitializeHostName( *---------------------------------------------------------------------- */ +#undef TclWinGetSockOpt int TclWinGetSockOpt( SOCKET s, @@ -2702,19 +3223,10 @@ TclWinGetSockOpt( char *optval, int *optlen) { - /* - * Check that WinSock is initialized; do not call it if not, to prevent - * system crashes. This can happen at exit time if the exit handler for - * WinSock ran before other exit handlers that want to use sockets. - */ - - if (!SocketsEnabled()) { - return SOCKET_ERROR; - } return getsockopt(s, level, optname, optval, optlen); } - +#undef TclWinSetSockOpt int TclWinSetSockOpt( SOCKET s, @@ -2723,16 +3235,6 @@ TclWinSetSockOpt( const char *optval, int optlen) { - /* - * Check that WinSock is initialized; do not call it if not, to prevent - * system crashes. This can happen at exit time if the exit handler for - * WinSock ran before other exit handlers that want to use sockets. - */ - - if (!SocketsEnabled()) { - return SOCKET_ERROR; - } - return setsockopt(s, level, optname, optval, optlen); } @@ -2741,34 +3243,14 @@ char * TclpInetNtoa( struct in_addr addr) { - /* - * Check that WinSock is initialized; do not call it if not, to prevent - * system crashes. This can happen at exit time if the exit handler for - * WinSock ran before other exit handlers that want to use sockets. - */ - - if (!SocketsEnabled()) { - return NULL; - } - return inet_ntoa(addr); } - +#undef TclWinGetServByName struct servent * TclWinGetServByName( const char *name, const char *proto) { - /* - * Check that WinSock is initialized; do not call it if not, to prevent - * system crashes. This can happen at exit time if the exit handler for - * WinSock ran before other exit handlers that want to use sockets. - */ - - if (!SocketsEnabled()) { - return NULL; - } - return getservbyname(name, proto); } @@ -2794,7 +3276,7 @@ TcpThreadActionProc( int action) { ThreadSpecificData *tsdPtr; - SocketInfo *infoPtr = instanceData; + TcpState *statePtr = instanceData; int notifyCmd; if (action == TCL_CHANNEL_THREAD_INSERT) { @@ -2810,13 +3292,18 @@ TcpThreadActionProc( tsdPtr = TCL_TSD_INIT(&dataKey); WaitForSingleObject(tsdPtr->socketListLock, INFINITE); - infoPtr->nextPtr = tsdPtr->socketList; - tsdPtr->socketList = infoPtr; + statePtr->nextPtr = tsdPtr->socketList; + tsdPtr->socketList = statePtr; + + if (statePtr == tsdPtr->pendingTcpState) { + tsdPtr->pendingTcpState = NULL; + } + SetEvent(tsdPtr->socketListLock); notifyCmd = SELECT; } else { - SocketInfo **nextPtrPtr; + TcpState **nextPtrPtr; int removed = 0; tsdPtr = TCL_TSD_INIT(&dataKey); @@ -2829,8 +3316,8 @@ TcpThreadActionProc( WaitForSingleObject(tsdPtr->socketListLock, INFINITE); for (nextPtrPtr = &(tsdPtr->socketList); (*nextPtrPtr) != NULL; nextPtrPtr = &((*nextPtrPtr)->nextPtr)) { - if ((*nextPtrPtr) == infoPtr) { - (*nextPtrPtr) = infoPtr->nextPtr; + if ((*nextPtrPtr) == statePtr) { + (*nextPtrPtr) = statePtr->nextPtr; removed = 1; break; } @@ -2856,7 +3343,7 @@ TcpThreadActionProc( */ SendMessage(tsdPtr->hwnd, SOCKET_SELECT, - (WPARAM) notifyCmd, (LPARAM) infoPtr); + (WPARAM) notifyCmd, (LPARAM) statePtr); } /* @@ -2864,5 +3351,7 @@ TcpThreadActionProc( * mode: c * c-basic-offset: 4 * fill-column: 78 + * tab-width: 8 + * indent-tabs-mode: nil * End: */ diff --git a/win/tclWinTest.c b/win/tclWinTest.c index b83c0ba..6027e32 100644 --- a/win/tclWinTest.c +++ b/win/tclWinTest.c @@ -17,7 +17,7 @@ /* * For TestplatformChmod on Windows */ -#ifdef __WIN32__ +#ifdef _WIN32 #include <aclapi.h> #endif |