diff options
128 files changed, 4210 insertions, 3714 deletions
diff --git a/compat/fake-rfc2553.c b/compat/fake-rfc2553.c index cfe4c39..066f83f 100644 --- a/compat/fake-rfc2553.c +++ b/compat/fake-rfc2553.c @@ -43,32 +43,32 @@ TCL_DECLARE_MUTEX(netdbMutex) static size_t strlcpy(char *dst, const char *src, size_t siz) { - char *d = dst; - const char *s = src; - size_t n = siz; + char *d = dst; + const char *s = src; + size_t n = siz; - /* Copy as many bytes as will fit */ - if (n != 0 && --n != 0) { - do { - if ((*d++ = *s++) == 0) - break; - } while (--n != 0); - } + /* Copy as many bytes as will fit */ + if (n != 0 && --n != 0) { + do { + if ((*d++ = *s++) == 0) + break; + } while (--n != 0); + } - /* Not enough room in dst, add NUL and traverse rest of src */ - if (n == 0) { - if (siz != 0) - *d = '\0'; /* NUL-terminate dst */ - while (*s++) - ; - } + /* Not enough room in dst, add NUL and traverse rest of src */ + if (n == 0) { + if (siz != 0) + *d = '\0'; /* NUL-terminate dst */ + while (*s++) + ; + } - return(s - src - 1); /* count does not include NUL */ + return(s - src - 1); /* count does not include NUL */ } #endif int fake_getnameinfo(const struct sockaddr *sa, size_t salen, char *host, - size_t hostlen, char *serv, size_t servlen, int flags) + size_t hostlen, char *serv, size_t servlen, int flags) { struct sockaddr_in *sin = (struct sockaddr_in *)sa; struct hostent *hp; diff --git a/doc/Access.3 b/doc/Access.3 index 5a32e08..aaca223 100644 --- a/doc/Access.3 +++ b/doc/Access.3 @@ -33,7 +33,7 @@ The structure that contains the result. .BE .SH DESCRIPTION .PP -As of Tcl 8.4, the object-based APIs \fBTcl_FSAccess\fR and \fBTcl_FSStat\fR +The object-based APIs \fBTcl_FSAccess\fR and \fBTcl_FSStat\fR should be used in preference to \fBTcl_Access\fR and \fBTcl_Stat\fR, wherever possible. Those functions also support Tcl's virtual filesystem layer, which these do not. diff --git a/doc/AddErrInfo.3 b/doc/AddErrInfo.3 index 05b20b8..2ed5eee 100644 --- a/doc/AddErrInfo.3 +++ b/doc/AddErrInfo.3 @@ -28,7 +28,7 @@ int .sp \fBTcl_SetObjErrorCode\fR(\fIinterp, errorObjPtr\fR) .sp -\fBTcl_SetErrorCode\fR(\fIinterp, element, element, ... \fBNULL\fR) +\fBTcl_SetErrorCode\fR(\fIinterp, element, element, ... \fB(char *)NULL\fR) .sp int \fBTcl_GetErrorLine\fR(\fIinterp\fR) @@ -67,7 +67,7 @@ If negative, all bytes up to the first null byte are used. The \fB\-errorcode\fR return option will be set to this value. .AP "const char" *element in String to record as one element of the \fB\-errorcode\fR return option. -Last \fIelement\fR argument must be NULL. +Last \fIelement\fR argument must be (char *)NULL. .AP int lineNum The line number of a script where an error occurred. .AP "const char" *script in diff --git a/doc/Alloc.3 b/doc/Alloc.3 index 493eebc..999c1e8 100644 --- a/doc/Alloc.3 +++ b/doc/Alloc.3 @@ -13,7 +13,7 @@ Tcl_Alloc, Tcl_Free, Tcl_Realloc, Tcl_AttemptAlloc, Tcl_AttemptRealloc, Tcl_GetM .nf \fB#include <tcl.h>\fR .sp -char * +void * \fBTcl_Alloc\fR(\fIsize\fR) .sp \fBTcl_Free\fR(\fIptr\fR) @@ -33,7 +33,7 @@ void * .AS char *size .AP "size_t" size in Size in bytes of the memory block to allocate. -.AP char *ptr in +.AP void *ptr in Pointer to memory block to free or realloc. .AP Tcl_DString *dsPtr in Initialized DString pointer. @@ -37,7 +37,7 @@ int \fBTcl_GlobalEvalObj\fR(\fIinterp, objPtr\fR) .sp int -\fBTcl_VarEval\fR(\fIinterp, part, part, ... \fBNULL\fR) +\fBTcl_VarEval\fR(\fIinterp, part, part, ... \fB(char *)NULL\fR) .fi .SH ARGUMENTS .AS Tcl_Interp **termPtr @@ -138,7 +138,7 @@ of any length, concatenates them into a single string, then calls \fBTcl_Eval\fR to execute that string as a Tcl command. It returns the result of the command and also modifies the interpreter result in the same way as \fBTcl_Eval\fR. -The last argument to \fBTcl_VarEval\fR must be NULL to indicate the end +The last argument to \fBTcl_VarEval\fR must be (char *)NULL to indicate the end of arguments. .SH "FLAG BITS" diff --git a/doc/ObjectType.3 b/doc/ObjectType.3 index e9a38cc..ca9e0ce 100644 --- a/doc/ObjectType.3 +++ b/doc/ObjectType.3 @@ -154,7 +154,7 @@ This definition permits us to pass internal representations and pointers to them as arguments and results in public routines. .SH "THE TCL_OBJTYPE STRUCTURE" .PP -Extension writers can define new value types by defining four to eight +Extension writers can define new value types by defining four to twelve procedures and initializing a Tcl_ObjType structure to describe the type. Extension writers may also pass a pointer to their Tcl_ObjType structure to \fBTcl_RegisterObjType\fR if they wish to permit other diff --git a/doc/Preserve.3 b/doc/Preserve.3 index e01cf80..d676b9a 100644 --- a/doc/Preserve.3 +++ b/doc/Preserve.3 @@ -81,14 +81,11 @@ type \fBTcl_FreeProc\fR: .PP .CS typedef void \fBTcl_FreeProc\fR( - char *\fIblockPtr\fR); + void *\fIblockPtr\fR); .CE .PP The \fIblockPtr\fR argument to \fIfreeProc\fR will be the same as the \fIclientData\fR argument to \fBTcl_EventuallyFree\fR. -The type of \fIblockPtr\fR (\fBchar *\fR) is different than the type of the -\fIclientData\fR argument to \fBTcl_EventuallyFree\fR for historical -reasons, but the value is the same. .PP When the \fIclientData\fR argument to \fBTcl_EventuallyFree\fR refers to storage allocated and returned by a prior call to diff --git a/doc/SaveInterpState.3 b/doc/SaveInterpState.3 index 96fecdb..619ff0b 100644 --- a/doc/SaveInterpState.3 +++ b/doc/SaveInterpState.3 @@ -1,7 +1,6 @@ '\" '\" Copyright (c) 1997 Sun Microsystems, Inc. '\" Contributions from Don Porter, NIST, 2004. (not subject to US copyright) -'\" Copyright (c) 2018 Nathan Coulter. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -10,8 +9,7 @@ .so man.macros .BS .SH NAME -Tcl_SaveInterpState, Tcl_RestoreInterpState, Tcl_DiscardInterpState \- Save and restore the -state of an an interpreter. +Tcl_SaveInterpState, Tcl_RestoreInterpState, Tcl_DiscardInterpState \- save and restore an interpreter's state .SH SYNOPSIS .nf \fB#include <tcl.h>\fR @@ -27,29 +25,50 @@ int .SH ARGUMENTS .AS Tcl_InterpState savedPtr .AP Tcl_Interp *interp in -The interpreter for the operation. +Interpreter for which state should be saved. .AP int status in -The return code for the state. +Return code value to save as part of interpreter state. .AP Tcl_InterpState state in -A token for saved state. +Saved state token to be restored or discarded. .BE .SH DESCRIPTION .PP -These routines save the state of an interpreter before a call to a routine such -as \fBTcl_Eval\fR, and restore the state afterwards. +These routines allows a C procedure to take a snapshot of the current +state of an interpreter so that it can be restored after a call +to \fBTcl_Eval\fR or some other routine that modifies the interpreter +state. .PP -\fBTcl_SaveInterpState\fR saves the parts of \fIinterp\fR that comprise the -result of a script, including the resulting value, the return code passed as -\fIstatus\fR, and any options such as \fB\-errorinfo\fR and \fB\-errorcode\fR. -It returns a token for the saved state. The interpreter result is not reset -and no interpreter state is changed. +\fBTcl_SaveInterpState\fR stores a snapshot of the interpreter state in +an opaque token returned by \fBTcl_SaveInterpState\fR. That token +value may then be passed back to one of \fBTcl_RestoreInterpState\fR +or \fBTcl_DiscardInterpState\fR, depending on whether the interp +state is to be restored. So long as one of the latter two routines +is called, Tcl will take care of memory management. .PP -\fBTcl_RestoreInterpState\fR restores the state indicated by \fIstate\fR and -returns the \fIstatus\fR originally passed in the corresponding call to -\fBTcl_SaveInterpState\fR. +\fBTcl_SaveInterpState\fR takes a snapshot of those portions of +interpreter state that make up the full result of script evaluation. +This include the interpreter result, the return code (passed in +as the \fIstatus\fR argument, and any return options, including +\fB\-errorinfo\fR and \fB\-errorcode\fR when an error is in progress. +This snapshot is returned as an opaque token of type \fBTcl_InterpState\fR. +The call to \fBTcl_SaveInterpState\fR does not itself change the +state of the interpreter. .PP -If a saved state is not restored, \fBTcl_DiscardInterpState\fR must be called -to release it. A token used to discard or restore state must not be used -again. +\fBTcl_RestoreInterpState\fR accepts a \fBTcl_InterpState\fR token +previously returned by \fBTcl_SaveInterpState\fR and restores the +state of the interp to the state held in that snapshot. The return +value of \fBTcl_RestoreInterpState\fR is the status value originally +passed to \fBTcl_SaveInterpState\fR when the snapshot token was +created. +.PP +\fBTcl_DiscardInterpState\fR is called to release a \fBTcl_InterpState\fR +token previously returned by \fBTcl_SaveInterpState\fR when that +snapshot is not to be restored to an interp. +.PP +The \fBTcl_InterpState\fR token returned by \fBTcl_SaveInterpState\fR +must eventually be passed to either \fBTcl_RestoreInterpState\fR +or \fBTcl_DiscardInterpState\fR to avoid a memory leak. Once +the \fBTcl_InterpState\fR token is passed to one of them, the +token is no longer valid and should not be used anymore. .SH KEYWORDS result, state, interp diff --git a/doc/SetResult.3 b/doc/SetResult.3 index 4d0c9df..d3201aa 100644 --- a/doc/SetResult.3 +++ b/doc/SetResult.3 @@ -24,7 +24,7 @@ Tcl_Obj * const char * \fBTcl_GetStringResult\fR(\fIinterp\fR) .sp -\fBTcl_AppendResult\fR(\fIinterp, result, result, ... , \fBNULL\fR) +\fBTcl_AppendResult\fR(\fIinterp, result, result, ... , \fB(char *)NULL\fR) .sp \fBTcl_ResetResult\fR(\fIinterp\fR) .sp @@ -35,105 +35,210 @@ const char * .SH ARGUMENTS .AS Tcl_FreeProc sourceInterp out .AP Tcl_Interp *interp out -The interpreter get or set the result for. +Interpreter whose result is to be modified or read. .AP Tcl_Obj *objPtr in -A value to set the result to. +Tcl value to become result for \fIinterp\fR. .AP char *result in -The string value set the result to, or to append to the existing result. +String value to become result for \fIinterp\fR or to be +appended to the existing result. .AP "const char" *element in -The string value to append as a list element +String value to append as a list element to the existing result of \fIinterp\fR. .AP Tcl_FreeProc *freeProc in -Pointer to a procedure to call to release storage at -\fIresult\fR. +Address of procedure to call to release storage at +\fIresult\fR, or \fBTCL_STATIC\fR, \fBTCL_DYNAMIC\fR, or +\fBTCL_VOLATILE\fR. .AP Tcl_Interp *sourceInterp in -The interpreter to transfer the result and return options from. +Interpreter that the result and return options should be transferred from. .AP Tcl_Interp *targetInterp in -The interpreter to transfer the result and return options to. +Interpreter that the result and return options should be transferred to. .AP int code in Return code value that controls transfer of return options. .BE .SH DESCRIPTION .PP -These procedures manipulate the result of an interpreter. Some procedures -provide a Tcl_Obj interface while others provide a string interface. For -example, \fBTcl_SetObjResult\fR accepts a Tcl_Obj and \fBTcl_SetResult\fR -accepts a char *. Similarly, \fBTcl_GetObjResult\fR produces a Tcl_Obj * and -\fBTcl_GetStringResult\fR produces a char *. The procedures can be mixed and -matched. For example, if \fBTcl_SetObjResult\fR is called to set the result to -a Tcl_Obj value, and then \fBTcl_GetStringResult\fR is called, it returns a -char * (but see caveats below). +The procedures described here are utilities for manipulating the +result value in a Tcl interpreter. +The interpreter result may be either a Tcl value or a string. +For example, \fBTcl_SetObjResult\fR and \fBTcl_SetResult\fR +set the interpreter result to, respectively, a value and a string. +Similarly, \fBTcl_GetObjResult\fR and \fBTcl_GetStringResult\fR +return the interpreter result as a value and as a string. +The procedures always keep the string and value forms +of the interpreter result consistent. +For example, if \fBTcl_SetObjResult\fR is called to set +the result to a value, +then \fBTcl_GetStringResult\fR is called, +it will return the value's string representation. .PP -\fBTcl_SetObjResult\fR sets \fIobjPtr\fR as the result for \fIinterp\fR, +\fBTcl_SetObjResult\fR +arranges for \fIobjPtr\fR to be the result for \fIinterp\fR, replacing any existing result. +The result is left pointing to the value +referenced by \fIobjPtr\fR. +\fIobjPtr\fR's reference count is incremented +since there is now a new reference to it from \fIinterp\fR. +The reference count for any old result value +is decremented and the old result value is freed if no +references to it remain. .PP -\fBTcl_GetObjResult\fR returns the result for \fIinterp\fR, without -incrementing its reference count. -.PP -\fBTcl_SetResult\fR sets \fIresult\fR as the result for \fIinterp\fR, replacing -any existing result, and calls \fIfreeProc\fR to free \fIresult\fR. See \fBTHE -TCL_FREEPROC ARGUMENT TO TCL_SETRESULT\fR below. If \fIresult\fR is -\fBNULL\fR, ignores \fIfreeProc\fR and sets the result for \fIinterp\fR to -point to the empty string. -.PP -\fBTcl_GetStringResult\fR returns the result for \fIinterp\fR as a string, i.e. -the bytes of the Tcl_Obj for the result, which can be decoded using -\fBTcl_UtfToExternal\fR. This value is freed when its corresponding Tcl_Obj is -freed.Programmers are encouraged to use the newer Tcl_Obj API procedures, e.g. -to call \fBTcl_GetObjResult\fR instead. -.PP -\fBTcl_ResetResult\fR sets the empty string as the result for \fIinterp\fR and -clears the error state managed by \fBTcl_AddErrorInfo\fR, -\fBTcl_AddObjErrorInfo\fR, and \fBTcl_SetErrorCode\fR. -.PP -\fBTcl_AppendResult\fR builds up a result from smaller pieces, appending each -\fIresult\fR in order to the current result for \fIinterp\fR. It may be called -repeatedly as additional pieces of the result are produced, and manages the -storage for the \fIinterp\fR's result, allocating a larger result area if -necessary. It also manages conversion to and from the \fIresult\fR field of -the \fIinterp\fR to handle backward-compatibility with old-style extensions. -Any number of \fIresult\fR arguments may be passed in a single call; the last -argument in the list must be a NULL pointer. -.PP -\fBTcl_TransferResult\fR transfers interpreter state from \fIsourceInterp\fR to -\fItargetInterp\fR, both of which must have been created in the same thread, -resets the result in \fIsourceInterp\fR, and moves the return options -dictionary as controlled by the return code value \fIcode\fR in the same manner -as \fBTcl_GetReturnOptions\fR. +\fBTcl_GetObjResult\fR returns the result for \fIinterp\fR as a value. +The value's reference count is not incremented; +if the caller needs to retain a long-term pointer to the value +they should use \fBTcl_IncrRefCount\fR to increment its reference count +in order to keep it from being freed too early or accidentally changed. +.PP +\fBTcl_SetResult\fR +arranges for \fIresult\fR to be the result for the current Tcl +command in \fIinterp\fR, replacing any existing result. +The \fIfreeProc\fR argument specifies how to manage the storage +for the \fIresult\fR argument; +it is discussed in the section +\fBTHE TCL_FREEPROC ARGUMENT TO TCL_SETRESULT\fR below. +If \fIresult\fR is \fBNULL\fR, then \fIfreeProc\fR is ignored +and \fBTcl_SetResult\fR +re-initializes \fIinterp\fR's result to point to an empty string. +.PP +\fBTcl_GetStringResult\fR returns the result for \fIinterp\fR as a string. +If the result was set to a value by a \fBTcl_SetObjResult\fR call, +the value form will be converted to a string and returned. +If the value's string representation contains null bytes, +this conversion will lose information. +For this reason, programmers are encouraged to +write their code to use the new value API procedures +and to call \fBTcl_GetObjResult\fR instead. +.PP +\fBTcl_ResetResult\fR clears the result for \fIinterp\fR +and leaves the result in its normal empty initialized state. +If the result is a value, +its reference count is decremented and the result is left +pointing to an unshared value representing an empty string. +If the result is a dynamically allocated string, its memory is free*d +and the result is left as a empty string. +\fBTcl_ResetResult\fR also clears the error state managed by +\fBTcl_AddErrorInfo\fR, \fBTcl_AddObjErrorInfo\fR, +and \fBTcl_SetErrorCode\fR. .PP -If \fIsourceInterp\fR and \fItargetInterp\fR are the same, nothing is done. +\fBTcl_AppendResult\fR makes it easy to build up Tcl results in pieces. +It takes each of its \fIresult\fR arguments and appends them in order +to the current result associated with \fIinterp\fR. +If the result is in its initialized empty state (e.g. a command procedure +was just invoked or \fBTcl_ResetResult\fR was just called), +then \fBTcl_AppendResult\fR sets the result to the concatenation of +its \fIresult\fR arguments. +\fBTcl_AppendResult\fR may be called repeatedly as additional pieces +of the result are produced. +\fBTcl_AppendResult\fR takes care of all the +storage management issues associated with managing \fIinterp\fR's +result, such as allocating a larger result area if necessary. +It also manages conversion to and from the \fIresult\fR field of the +\fIinterp\fR so as to handle backward-compatibility with old-style +extensions. +Any number of \fIresult\fR arguments may be passed in a single +call; the last argument in the list must be (char *)NULL. +.PP +\fBTcl_TransferResult\fR transfers interpreter state from \fIsourceInterp\fR +to \fItargetInterp\fR. The two interpreters must have been created in the +same thread. If \fIsourceInterp\fR and \fItargetInterp\fR are the same, +nothing is done. Otherwise, \fBTcl_TransferResult\fR moves the result +from \fIsourceInterp\fR to \fItargetInterp\fR, and resets the result +in \fIsourceInterp\fR. It also moves the return options dictionary as +controlled by the return code value \fIcode\fR in the same manner +as \fBTcl_GetReturnOptions\fR. .SH "DEPRECATED INTERFACES" .SS "OLD STRING PROCEDURES" .PP -The following procedures are deprecated since they manipulate the Tcl result as -a string. Procedures such as \fBTcl_SetObjResult\fR can be significantly more -efficient. -.PP -\fBTcl_AppendElement\fR is like \fBTcl_AppendResult\fR, but it appends only one -piece, and also appends that piece as a list item. -\fBTcl_AppendElement\fR adds backslashes or braces as necessary to ensure that -\fIelement\fR is properly formatted as a list item. Under normal conditions, -\fBTcl_AppendElement\fR adds a space character to \fIinterp\fR's result just -before adding the new list element, so that the list elements in the result are -properly separated. However if the new list element is the first item in the -list or sublist (i.e. \fIinterp\fR's current result is empty, or consists of -the single character +Use of the following procedures is deprecated +since they manipulate the Tcl result as a string. +Procedures such as \fBTcl_SetObjResult\fR +that manipulate the result as a value +can be significantly more efficient. +.PP +\fBTcl_AppendElement\fR is similar to \fBTcl_AppendResult\fR in +that it allows results to be built up in pieces. +However, \fBTcl_AppendElement\fR takes only a single \fIelement\fR +argument and it appends that argument to the current result +as a proper Tcl list element. +\fBTcl_AppendElement\fR adds backslashes or braces if necessary +to ensure that \fIinterp\fR's result can be parsed as a list and that +\fIelement\fR will be extracted as a single element. +Under normal conditions, \fBTcl_AppendElement\fR will add a space +character to \fIinterp\fR's result just before adding the new +list element, so that the list elements in the result are properly +separated. +However if the new list element is the first in a list or sub-list +(i.e. \fIinterp\fR's current result is empty, or consists of the +single character .QW { , or ends in the characters .QW " {" ) then no space is added. .SH "THE TCL_FREEPROC ARGUMENT TO TCL_SETRESULT" .PP -\fIFreeProc\fR has the following type: +\fBTcl_SetResult\fR's \fIfreeProc\fR argument specifies how +the Tcl system is to manage the storage for the \fIresult\fR argument. +If \fBTcl_SetResult\fR or \fBTcl_SetObjResult\fR are called +at a time when \fIinterp\fR holds a string result, +they do whatever is necessary to dispose of the old string result +(see the \fBTcl_Interp\fR manual entry for details on this). +.PP +If \fIfreeProc\fR is \fBTCL_STATIC\fR it means that \fIresult\fR +refers to an area of static storage that is guaranteed not to be +modified until at least the next call to \fBTcl_Eval\fR. +If \fIfreeProc\fR +is \fBTCL_DYNAMIC\fR it means that \fIresult\fR was allocated with a call +to \fBTcl_Alloc\fR and is now the property of the Tcl system. +\fBTcl_SetResult\fR will arrange for the string's storage to be +released by calling \fBTcl_Free\fR when it is no longer needed. +If \fIfreeProc\fR is \fBTCL_VOLATILE\fR it means that \fIresult\fR +points to an area of memory that is likely to be overwritten when +\fBTcl_SetResult\fR returns (e.g. it points to something in a stack frame). +In this case \fBTcl_SetResult\fR will make a copy of the string in +dynamically allocated storage and arrange for the copy to be the +result for the current Tcl command. +.PP +If \fIfreeProc\fR is not one of the values \fBTCL_STATIC\fR, +\fBTCL_DYNAMIC\fR, and \fBTCL_VOLATILE\fR, then it is the address +of a procedure that Tcl should call to free the string. +This allows applications to use non-standard storage allocators. +When Tcl no longer needs the storage for the string, it will +call \fIfreeProc\fR. \fIFreeProc\fR should have arguments and +result that match the type \fBTcl_FreeProc\fR: .PP .CS typedef void \fBTcl_FreeProc\fR( - char *\fIblockPtr\fR); + void *\fIblockPtr\fR); .CE .PP -When \fIfreeProc\fR is called, \fIblockPtr\fR is the \fIresult\fR value passed -to \fBTcl_SetResult\fR. +When \fIfreeProc\fR is called, its \fIblockPtr\fR will be set to +the value of \fIresult\fR passed to \fBTcl_SetResult\fR. +.SH "REFERENCE COUNT MANAGEMENT" +.PP +The interpreter result is one of the main places that owns references to +values, along with the bytecode execution stack, argument lists, variables, +and the list and dictionary collection values. +.PP +\fBTcl_SetObjResult\fR takes a value with an arbitrary reference count +\fI(specifically including zero)\fR and guarantees to increment the reference +count. If code wishes to continue using the value after setting it as the +result, it should add its own reference to it with \fBTcl_IncrRefCount\fR. +.PP +\fBTcl_GetObjResult\fR returns the current interpreter result value. This will +have a reference count of at least 1. If the caller wishes to keep the +interpreter result value, it should increment its reference count. +.PP +\fBTcl_GetStringResult\fR does not manipulate reference counts, but the string +it returns is owned by (and has a lifetime controlled by) the current +interpreter result value; it should be copied instead of being relied upon to +persist after the next Tcl API call, as most Tcl operations can modify the +interpreter result. +.PP +\fBTcl_SetResult\fR, \fBTcl_AppendResult\fR, +\fBTcl_AppendElement\fR, and \fBTcl_ResetResult\fR all modify the interpreter +result. They may cause the old interpreter result to have its reference count +decremented and a new interpreter result to be allocated. After they have been +called, the reference count of the interpreter result is guaranteed to be 1. .SH "SEE ALSO" Tcl_AddErrorInfo, Tcl_CreateObjCommand, Tcl_SetErrorCode, Tcl_Interp, Tcl_GetReturnOptions diff --git a/doc/StringObj.3 b/doc/StringObj.3 index 6f7d359..4682cae 100644 --- a/doc/StringObj.3 +++ b/doc/StringObj.3 @@ -19,8 +19,10 @@ Tcl_Obj * Tcl_Obj * \fBTcl_NewUnicodeObj\fR(\fIunicode, numChars\fR) .sp +void \fBTcl_SetStringObj\fR(\fIobjPtr, bytes, length\fR) .sp +void \fBTcl_SetUnicodeObj\fR(\fIobjPtr, unicode, numChars\fR) .sp char * @@ -44,14 +46,19 @@ Tcl_Size Tcl_Obj * \fBTcl_GetRange\fR(\fIobjPtr, first, last\fR) .sp +void \fBTcl_AppendToObj\fR(\fIobjPtr, bytes, length\fR) .sp +void \fBTcl_AppendUnicodeToObj\fR(\fIobjPtr, unicode, numChars\fR) .sp +void \fBTcl_AppendObjToObj\fR(\fIobjPtr, appendObjPtr\fR) .sp -\fBTcl_AppendStringsToObj\fR(\fIobjPtr, string, string, ... \fBNULL\fR) +void +\fBTcl_AppendStringsToObj\fR(\fIobjPtr, string, string, ... \fB(char *)NULL\fR) .sp +void \fBTcl_AppendLimitedToObj\fR(\fIobjPtr, bytes, length, limit, ellipsis\fR) .sp Tcl_Obj * @@ -63,8 +70,10 @@ int Tcl_Obj * \fBTcl_ObjPrintf\fR(\fIformat, ...\fR) .sp +void \fBTcl_AppendPrintfToObj\fR(\fIobjPtr, format, ...\fR) .sp +void \fBTcl_SetObjLength\fR(\fIobjPtr, newLength\fR) .sp int @@ -242,7 +251,7 @@ except that it can be passed more than one value to append and each value must be a null-terminated string (i.e. none of the values may contain internal null characters). Any number of \fIstring\fR arguments may be provided, but the last argument -must be a NULL pointer to indicate the end of the list. +must be (char *)NULL to indicate the end of the list. .PP \fBTcl_AppendLimitedToObj\fR is similar to \fBTcl_AppendToObj\fR except that it imposes a limit on how many bytes are appended. diff --git a/doc/Thread.3 b/doc/Thread.3 index cb63570..2e5cd0a 100644 --- a/doc/Thread.3 +++ b/doc/Thread.3 @@ -76,10 +76,7 @@ waited upon into it. .SH INTRODUCTION Beginning with the 8.1 release, the Tcl core is thread safe, which allows you to incorporate Tcl into multithreaded applications without -customizing the Tcl core. Starting with the 8.6 release, Tcl -multithreading support is on by default. To disable Tcl multithreading -support, you must include the \fB\-\|\-disable-threads\fR option to -\fBconfigure\fR when you configure and compile your Tcl core. +customizing the Tcl core. .PP An important constraint of the Tcl threads implementation is that \fIonly the thread that created a Tcl interpreter can use that @@ -1,6 +1,5 @@ '\" '\" Copyright (c) 2005-2006 Donal K. Fellows -'\" Copyright (c) 2021 Nathan Coulter '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -9,68 +8,85 @@ .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME -chan \- Reads, writes and manipulates channels. +chan \- Read, write and manipulate channels .SH SYNOPSIS -\fBchan \fIoperation\fR ?\fIarg arg ...\fR? +\fBchan \fIoption\fR ?\fIarg arg ...\fR? .BE .SH DESCRIPTION .PP -\fBchan\fR provides several operations for reading from, writing to, and -otherwise manipulating channels, e.g. those created by \fBopen\fR and -\fBsocket\fR, or the default channels \fBstdin\fR, \fBstdout\fR or \fBstderr\fR -which correspond respectively to the standard input, output, and error streams -of the process. Any unique abbreviation for \fIoperation\fR is acceptable. -Available operations are: +This command provides several operations for reading from, writing to +and otherwise manipulating open channels (such as have been created +with the \fBopen\fR and \fBsocket\fR commands, or the default named +channels \fBstdin\fR, \fBstdout\fR or \fBstderr\fR which correspond to +the process's standard input, output and error streams respectively). +\fIOption\fR indicates what to do with the channel; any unique +abbreviation for \fIoption\fR is acceptable. Valid options are: .\" METHOD: blocked .TP -\fBchan blocked \fIchannelName\fR +\fBchan blocked \fIchannelId\fR . -Returns 1 when the channel is in non-blocking mode and the last input operation -on the channel failed because it would have otherwise caused the process to -block, and 0 otherwise. Each Tcl channel is in blocking mode unless configured -otherwise. +This tests whether the last input operation on the channel called +\fIchannelId\fR failed because it would have otherwise caused the +process to block, and returns 1 if that was the case. It returns 0 +otherwise. Note that this only ever returns 1 when the channel has +been configured to be non-blocking; all Tcl channels have blocking +turned on by default. .\" METHOD: close .TP -\fBchan close \fIchannelName\fR ?\fIdirection\fR? +\fBchan close \fIchannelId\fR ?\fIdirection\fR? . -Closes and destroys the named channel deleting any existing event handlers -established for the channel. The command returns the empty string. If -\fIdirection\fR is given, it is \fBread\fR, or \fBwrite\fR, or any unique -abbreviation of those words, and only that side of the channel is closed. I.e. a -read-write channel may become read-only or write-only. Closing a read-only -channel for reading, or closing a write-only channel for writing is the same as -simply closing the channel. It is an error to close a read-only channel for -writing or to close a write-only channel for reading. +Close and destroy the channel called \fIchannelId\fR. Note that this +deletes all existing file-events registered on the channel. +If the \fIdirection\fR argument (which must be \fBread\fR or \fBwrite\fR or +any unique abbreviation of them) is present, the channel will only be +half-closed, so that it can go from being read-write to write-only or +read-only respectively. If a read-only channel is closed for reading, it is +the same as if the channel is fully closed, and respectively similar for +write-only channels. Without the \fIdirection\fR argument, the channel is +closed for both reading and writing (but only if those directions are +currently open). It is an error to close a read-only channel for writing, or a +write-only channel for reading. .RS .PP -When a channel is closed for writing, any buffered output on the channel is -flushed. When a channel is closed for reading, any buffered input is discarded. -When a channel is destroyed the underlying resource is closed and the channel -is thereafter unavailable. -.PP -\fBchan close\fR fully flushes any output before closing the write side of a -channel unless it is non-blocking mode, where it returns immediately and the -channel is flushed in the background before finally being closed. -.PP -\fBchan close\fR may return an error if an error occurs while flushing -output. If a process in a command pipeline created by \fBopen\fR returns an -error (either by returning a non-zero exit code or writing to its standard -error file descriptor), \fBchan close\fR generates an error in the same -manner as \fBexec\fR. -.PP -Closing one side of a socket or command pipeline may lead to the shutdown() or -close() of the underlying system resource, leading to a reaction from whatever -is on the other side of the pipeline or socket. -.PP -If the channel for a command pipeline is in blocking mode, \fBchan close\fR -waits for the connected processes to complete. -.PP -\fBchan close\fR only affects the current interpreter. If the channel is open -in any other interpreter, its state is unchanged there. See \fBinterp\fR for a -description of channel sharing. -.PP -When the last interpreter sharing a channel is destroyed, the channel is -switched to blocking mode and fully flushed and then closed. +As part of closing the channel, all buffered output is flushed to the +channel's output device (only if the channel is ceasing to be writable), any +buffered input is discarded (only if the channel is ceasing to be readable), +the underlying operating system resource is closed and \fIchannelId\fR becomes +unavailable for future use (both only if the channel is being completely +closed). +.PP +If the channel is blocking and the channel is ceasing to be writable, the +command does not return until all output is flushed. If the channel is +non-blocking and there is unflushed output, the channel remains open and the +command returns immediately; output will be flushed in the background and the +channel will be closed when all the flushing is complete. +.PP +If \fIchannelId\fR is a blocking channel for a command pipeline then +\fBchan close\fR waits for the child processes to complete. +.PP +If the channel is shared between interpreters, then \fBchan close\fR +makes \fIchannelId\fR unavailable in the invoking interpreter but has +no other effect until all of the sharing interpreters have closed the +channel. When the last interpreter in which the channel is registered +invokes \fBchan close\fR (or \fBclose\fR), the cleanup actions +described above occur. With half-closing, the half-close of the channel only +applies to the current interpreter's view of the channel until all channels +have closed it in that direction (or completely). +See the \fBinterp\fR command for a description of channel sharing. +.PP +Channels are automatically fully closed when an interpreter is destroyed and +when the process exits. Channels are switched to blocking mode, to +ensure that all output is correctly flushed before the process exits. +.PP +The command returns an empty string, and may generate an error if +an error occurs while flushing output. If a command in a command +pipeline created with \fBopen\fR returns an error, \fBchan close\fR +generates an error (similar to the \fBexec\fR command.) +.PP +Note that half-closes of sockets and command pipelines can have important side +effects because they result in a shutdown() or close() of the underlying +system resource, which can change how other processes or systems respond to +the Tcl program. .PP Channels are automatically closed when an interpreter is destroyed and when the process exits. @@ -85,81 +101,105 @@ restores the previous behavior. .RE .\" METHOD: configure .TP -\fBchan configure \fIchannelName\fR ?\fIoptionName\fR? ?\fIvalue\fR? ?\fIoptionName value\fR?... +\fBchan configure \fIchannelId\fR ?\fIoptionName\fR? ?\fIvalue\fR? ?\fIoptionName value\fR?... . -Configures or retrieves the configuration of the channel \fIchannelName\fR. +Query or set the configuration options of the channel named +\fIchannelId\fR. .RS .PP -If no \fIoptionName\fR or \fIvalue\fR arguments are given, -\fBchan configure\fR returns a dictionary of option names and -values for the channel. If \fIoptionName\fR is supplied without a \fIvalue\fR, -\fBchan configure\fR returns the current value of the named option. If one or -more pairs of \fIoptionName\fR and \fIvalue\fR are supplied, -\fBchan configure\fR sets each of the named options to the corresponding -\fIvalue\fR and returns the empty string. -.PP -The options described below are supported for all channels. Each type of -channel may provide additional options. Those options are described in the -relevant documentation. For example, additional options are documented for -\fBsocket\fR, and also for serial devices at \fBopen\fR. +If no \fIoptionName\fR or \fIvalue\fR arguments are supplied, the +command returns a list containing alternating option names and values +for the channel. If \fIoptionName\fR is supplied but no \fIvalue\fR +then the command returns the current value of the given option. If +one or more pairs of \fIoptionName\fR and \fIvalue\fR are supplied, +the command sets each of the named options to the corresponding +\fIvalue\fR; in this case the return value is an empty string. +.PP +The options described below are supported for all channels. In +addition, each channel type may add options that only it supports. See +the manual entry for the command that creates each type of channel +for the options supported by that specific type of channel. For +example, see the manual entry for the \fBsocket\fR command for additional +options for sockets, and the \fBopen\fR command for additional options for +serial devices. +.RE .\" OPTION: -blocking .TP \fB\-blocking\fI boolean\fR . -If \fB\-blocking\fR is set to \fBtrue\fR (default), reading the channel -or writing to it may cause the process to block indefinitely. Otherwise, -operations such as \fBchan gets\fR, \fBchan read\fR, \fBchan puts\fR, \fBchan -flush\fR, and \fBchan close\fR take care not to block. Non-blocking mode in -general requires that the event loop is entered, e.g. by calling -\fBTcl_DoOneEvent\fR or \fBvwait\fR or by using Tk, to give Tcl a chance to -process events on the channel. +The \fB\-blocking\fR option determines whether I/O operations on the +channel can cause the process to block indefinitely. The value of the +option must be a proper boolean value. Channels are normally in +blocking mode; if a channel is placed into non-blocking mode it will +affect the operation of the \fBchan gets\fR, \fBchan read\fR, \fBchan +puts\fR, \fBchan flush\fR, and \fBchan close\fR commands; see the +documentation for those commands for details. For non-blocking mode to +work correctly, the application must be using the Tcl event loop +(e.g. by calling \fBTcl_DoOneEvent\fR or invoking the \fBvwait\fR +command). .\" OPTION: -buffering .TP \fB\-buffering\fI newValue\fR . -If \fInewValue\fR is \fBfull\fR, which is the default, output is buffered -until the internal buffer is full or until \fBchan flush\fR is called. If -\fInewValue\fR is \fBline\fR, output is flushed each time a end-of-line -character is written. If \fInewValue\fR is \fBnone\fR, output is flushed after -every output operation. For \fBstdin\fR, \fBstdout\fR, and channels that -connect to terminal-like devices, the default value is \fBline\fR. For -\fBstderr\fR the default value is \fBnone\fR. +If \fInewValue\fR is \fBfull\fR then the I/O system will buffer output +until its internal buffer is full or until the \fBchan flush\fR +command is invoked. If \fInewValue\fR is \fBline\fR, then the I/O +system will automatically flush output for the channel whenever a +newline character is output. If \fInewValue\fR is \fBnone\fR, the I/O +system will flush automatically after every output operation. The +default is for \fB\-buffering\fR to be set to \fBfull\fR except for +channels that connect to terminal-like devices; for these channels the +initial setting is \fBline\fR. Additionally, \fBstdin\fR and +\fBstdout\fR are initially set to \fBline\fR, and \fBstderr\fR is set +to \fBnone\fR. .\" OPTION: -buffersize .TP \fB\-buffersize\fI newSize\fR . -\fInewSize\fR, an integer no greater than one million, is the size in bytes of -any input or output buffers subsequently allocated for this channel. +\fInewSize\fR must be an integer; its value is used to set the size +of buffers, in bytes, subsequently allocated for this channel to store +input or output. \fInewSize\fR must be a number of no more than one +million, allowing buffers of up to one million bytes in size. .\" OPTION: -encoding .TP \fB\-encoding\fR \fIname\fR . -Sets the encoding of the channel to \fIname\fR which should be one of the names -returned by \fBencoding names\fR, or -.QW \fBbinary\fR -\&. Input is converted from the encoding into Unicode, and output is converted -from Unicode to the encoding. +This option is used to specify the encoding of the channel as one of +the named encodings returned by \fBencoding names\fR or the special +value \fBbinary\fR, so that the data can be converted to and from +Unicode for use in Tcl. For instance, in order for Tcl to read +characters from a Japanese file in \fBshiftjis\fR and properly process +and display the contents, the encoding would be set to \fBshiftjis\fR. +Thereafter, when reading from the channel, the bytes in the Japanese +file would be converted to Unicode as they are read. Writing is also +supported \- as Tcl strings are written to the channel they will +automatically be converted to the specified encoding on output. .RS .PP -\fBbinary\fR is an alias for \fBiso8859-1\fR. This alone is not sufficient for -working with binary data. Use \fB\-translation binary\fR instead. -.PP -The encoding of a new channel is the value of \fBencoding system\fR, -which returns the platform- and locale-dependent system encoding used to -interface with the operating system, +If a file contains pure binary data (for instance, a JPEG image), the +encoding for the channel should be configured to be \fBbinary\fR. Tcl +will then assign no interpretation to the data in the file and simply +read or write raw bytes. The Tcl \fBbinary\fR command can be used to +manipulate this byte-oriented data. It is usually better to set the +\fB\-translation\fR option to \fBbinary\fR when you want to transfer +binary data, as this turns off the other automatic interpretations of +the bytes in the stream as well. +.PP +The default encoding for newly opened channels is the same platform- +and locale-dependent system encoding used for interfacing with the +operating system, as returned by \fBencoding system\fR. .RE .\" OPTION: -eofchar .TP \fB\-eofchar\fI char\fR . -\fIchar\fR signals the end of the data when it is encountered in the input. -If \fIchar\fR is the empty string, there is no special character that marks -the end of the data. -.RS -.PP -The default value is the empty string. The acceptable range is \ex01 - -\ex7F. A value outside this range results in an error. -.RE +This option supports DOS file systems that use Control-z (\ex1A) as an +end of file marker. If \fIchar\fR is not an empty string, then this +character signals end-of-file when it is encountered during input. +Otherwise (the default) there is no special end of file character marker. +The acceptable range for \fB\-eofchar\fR values is \ex01 - \ex7f; +attempting to set \fB\-eofchar\fR to a value outside of this range will +generate an error. .VS "TCL8.7 TIP656" .\" OPTION: -profile .TP @@ -177,32 +217,41 @@ profiles. .TP \fB\-translation\fR \fB{\fIinTranslation outTranslation\fB}\fR . -In Tcl a single line feed (\en) represents the end of a line. However, -at the destination the end of a line may be represented differently on -different platforms, or even for different devices on the same platform. For -example, under UNIX line feed is used in files and a -carriage-return-linefeed sequence is normally used in network connections. -Therefore, on input, e.g. with \fBchan gets\fR and \fBchan read\fR, each -external end-of-line character is translated into a line feed. On -output, e.g. with \fBchan puts\fR, each line feed is translated to the external -end-of-line character. The default translation, \fBauto\fR, handles all the -common cases, and \fB\-translation\fR provides explicit control over the -end-of-line character. +In Tcl scripts the end of a line is always represented using a single +newline character (\en). However, in actual files and devices the end +of a line may be represented differently on different platforms, or +even for different devices on the same platform. For example, under +UNIX newlines are used in files, whereas carriage-return-linefeed +sequences are normally used in network connections. On input (i.e., +with \fBchan gets\fR and \fBchan read\fR) the Tcl I/O system +automatically translates the external end-of-line representation into +newline characters. Upon output (i.e., with \fBchan puts\fR), the I/O +system translates newlines to the external end-of-line representation. +The default translation mode, \fBauto\fR, handles all the common cases +automatically, but the \fB\-translation\fR option provides explicit +control over the end of line translations. .RS .PP -Returns the input translation for a read-only channel, the output translation -for a write-only channel, and both the input translation and the output -translation for a read-write channel. When two translations are given, they -are the input and output translation, respectively. When only one translation -is given for a read-write channel, it is the translation for both input and -output. The following values are currently supported: +The value associated with \fB\-translation\fR is a single item for +read-only and write-only channels. The value is a two-element list for +read-write channels; the read translation mode is the first element of +the list, and the write translation mode is the second element. As a +convenience, when setting the translation mode for a read-write channel +you can specify a single value that will apply to both reading and +writing. When querying the translation mode of a read-write channel, a +two-element list will always be returned. The following values are +currently supported: .IP \fBauto\fR -The default. For input each occurrence of a line feed (\fBlf\fR), carriage -return (\fBcr\fR), or carriage return followed by a line feed (\fBcrlf\fR) is -translated into a line feed. For output, each line feed is translated into a -platform-specific representation: For all Unix variants it is \fBlf\fR, and -for all Windows variants it is \fBcrlf\fR, except that for sockets on all -platforms it is \fBcrlf\fR for both input and output. +As the input translation mode, \fBauto\fR treats any of newline +(\fBlf\fR), carriage return (\fBcr\fR), or carriage return followed by +a newline (\fBcrlf\fR) as the end of line representation. The end of +line representation can even change from line-to-line, and all cases +are translated to a newline. As the output translation mode, +\fBauto\fR chooses a platform specific representation; for sockets on +all platforms Tcl chooses \fBcrlf\fR, for all Unix flavors, it chooses +\fBlf\fR, and for the various flavors of Windows it chooses +\fBcrlf\fR. The default setting for \fB\-translation\fR is \fBauto\fR +for both input and output. .IP \fBbinary\fR Like \fBlf\fR, no end-of-line translation is performed, but in addition, sets \fB\-eofchar\fR to the empty string to disable it, and sets \fB\-encoding\fR @@ -215,21 +264,24 @@ in the data remains in the range of 0 to 255 so that there is no distinction between binary data and text. For example, A JPEG image can be read from a such a channel, manipulated, and then written back to such a channel. .IP \fBcr\fR -The end of a line is represented in the external data by a single carriage -return character. For input, each carriage return is translated to a line -feed, and for output each line feed character is translated to a carriage -return. +The end of a line in the underlying file or device is represented by a +single carriage return character. As the input translation mode, +\fBcr\fR mode converts carriage returns to newline characters. As the +output translation mode, \fBcr\fR mode translates newline characters +to carriage returns. .IP \fBcrlf\fR -The end of a line is represented in the external data by a carriage return -character followed by a line feed. For input, each carriage-return-linefeed -sequence is translated to a line feed. For output, each line feed is -translated to a carriage-return-linefeed sequence. This translation is -typically used for network connections, and also on Windows systems. +The end of a line in the underlying file or device is represented by a +carriage return character followed by a linefeed character. As the +input translation mode, \fBcrlf\fR mode converts +carriage-return-linefeed sequences to newline characters. As the +output translation mode, \fBcrlf\fR mode translates newline characters +to carriage-return-linefeed sequences. This mode is typically used on +Windows platforms and for network connections. .IP \fBlf\fR -The end of a line in the external data is represented by a line feed so no -translations occur during either input or output. This translation is -typically used on UNIX platforms, -.RE +The end of a line in the underlying file or device is represented by a +single newline (linefeed) character. In this mode no translations +occur during either input or output. This mode is typically used on +UNIX platforms. .RE .\" METHOD: copy .TP @@ -274,81 +326,108 @@ error. .TP \fBchan create \fImode cmdPrefix\fR . -Creates a new channel, called a \fBreflected\fR channel, with \fIcmdPrefix\fR -as its handler, and returns the name of the channel. \fBcmdPrefix\fR is the -first words of a command that provides the interface for a \fBrefchan\fR. +This subcommand creates a new script level channel using the command +prefix \fIcmdPrefix\fR as its handler. Any such channel is called a +\fBreflected\fR channel. The specified command prefix, \fBcmdPrefix\fR, +must be a non-empty list, and should provide the API described in the +\fBrefchan\fR manual page. The handle of the new channel is +returned as the result of the \fBchan create\fR command, and the +channel is open. Use either \fBclose\fR or \fBchan close\fR to remove +the channel. .RS .PP -\fBImode\fR is a list of one or more of the strings +The argument \fImode\fR specifies if the new channel is opened for +reading, writing, or both. It has to be a list containing any of the +strings .QW \fBread\fR or .QW \fBwrite\fR , -indicating whether the channel is a read channel, a write channel, or both. -It is an error if the handler does not support the chosen mode. -.PP -The handler is called as needed from the global namespace at the top level, and -command resolution happens there at the time of the call. If the handler is -renamed or deleted any subsequent attempt to call it is an error, which may -not be able to describe the failure. -.PP -The handler is always called in the interpreter and thread it was created in, -even if the channel was shared with or moved into a different interpreter in a -different thread. This is achieved through event dispatch, so if the event -loop is not entered, e.g. by calling \fBTcl_DoOneEvent\fR or \fBvwait\fR or -using Tk, the thread performing the channel operation \fIblocks -indefinitely\fR, resulting in deadlock. -.PP -One side of a channel may be in one thread while the other side is in a -different thread, providing a stream-oriented bridge between the threads. This -provides a method for regular stream communication between threads as an -alternative to sending commands. -.PP -When the interpreter the handler is in is deleted each channel associated with -the handler is deleted as well, regardless of which interpreter or thread it -is currently in or shared with. -.PP -\fBchan create\fR is \fBsafe\fR and is accessible to safe interpreters. The -handler is always called in the safe interpreter it was created in. +The list must have at least one +element, as a channel you can neither write to nor read from makes no +sense. The handler command for the new channel must support the chosen +mode, or an error is thrown. +.PP +The command prefix is executed in the global namespace, at the top of +call stack, following the appending of arguments as described in the +\fBrefchan\fR manual page. Command resolution happens at the +time of the call. Renaming the command, or destroying it means that +the next call of a handler method may fail, causing the channel +command invoking the handler to fail as well. Depending on the +subcommand being invoked, the error message may not be able to explain +the reason for that failure. +.PP +Every channel created with this subcommand knows which interpreter it +was created in, and only ever executes its handler command in that +interpreter, even if the channel was shared with and/or was moved into +a different interpreter. Each reflected channel also knows the thread +it was created in, and executes its handler command only in that +thread, even if the channel was moved into a different thread. To this +end all invocations of the handler are forwarded to the original +thread by posting special events to it. This means that the original +thread (i.e. the thread that executed the \fBchan create\fR command) +must have an active event loop, i.e. it must be able to process such +events. Otherwise the thread sending them will \fIblock +indefinitely\fR. Deadlock may occur. +.PP +Note that this permits the creation of a channel whose two endpoints +live in two different threads, providing a stream-oriented bridge +between these threads. In other words, we can provide a way for +regular stream communication between threads instead of having to send +commands. +.PP +When a thread or interpreter is deleted, all channels created with +this subcommand and using this thread/interpreter as their computing +base are deleted as well, in all interpreters they have been shared +with or moved into, and in whatever thread they have been transferred +to. While this pulls the rug out under the other thread(s) and/or +interpreter(s), this cannot be avoided. Trying to use such a channel +will cause the generation of a regular error about unknown channel +handles. +.PP +This subcommand is \fBsafe\fR and made accessible to safe +interpreters. While it arranges for the execution of arbitrary Tcl +code the system also makes sure that the code is always executed +within the safe interpreter. .RE .\" METHOD: eof .TP -\fBchan eof \fIchannelName\fR +\fBchan eof \fIchannelId\fR . -Returns 1 if the last read on the channel failed because the end of the data -was already reached, and 0 otherwise. +Test whether the last input operation on the channel called +\fIchannelId\fR failed because the end of the data stream was reached, +returning 1 if end-of-file was reached, and 0 otherwise. .\" METHOD: event .TP -\fBchan event \fIchannelName event\fR ?\fIscript\fR? +\fBchan event \fIchannelId event\fR ?\fIscript\fR? . -Arranges for the given script, called a \fBchannel event handler\fR, to be -called whenever the given event, one of -.QW \fBreadable\fR -or -.QW \fBwritable\fR -occurs on the given channel, replacing any script that was previously set. If -\fIscript\fR is the empty string the current handler is deleted. It is also -deleted when the channel is closed. If \fIscript\fR is omitted, either the -existing script or the empty string is returned. The event loop must be -entered, e.g. via \fBvwait\fR or \fBupdate\fR, or by using Tk, for handlers to -be evaluated. +Arrange for the Tcl script \fIscript\fR to be installed as a \fIfile +event handler\fR to be called whenever the channel called +\fIchannelId\fR enters the state described by \fIevent\fR (which must +be either \fBreadable\fR or \fBwritable\fR); only one such handler may +be installed per event per channel at a time. If \fIscript\fR is the +empty string, the current handler is deleted (this also happens if the +channel is closed or the interpreter deleted). If \fIscript\fR is +omitted, the currently installed script is returned (or an empty +string if no such handler is installed). The callback is only +performed if the event loop is being serviced (e.g. via \fBvwait\fR or +\fBupdate\fR). .RS .PP -\fIscript\fR is evaluated at the global level in the interpreter it was -established in. Any resulting error is handled in the background, i.e. via -\fBinterp bgerror\fR. In order to prevent an endless loop due to a buggy -handler, the handler is deleted if \fIscript\fR returns an error so that it is -not evaluated again. -.PP -Without an event handler, \fBchan gets\fR or \fBchan read\fR on a channel in -blocking mode may block until data becomes available, during which the -thread is unable to perform other work or respond to events on other channels. -This could cause the application to appear to +A file event handler is a binding between a channel and a script, such +that the script is evaluated whenever the channel becomes readable or +writable. File event handlers are most commonly used to allow data to +be received from another process on an event-driven basis, so that the +receiver can continue to interact with the user or with other channels +while waiting for the data to arrive. If an application invokes +\fBchan gets\fR or \fBchan read\fR on a blocking channel when there is +no input data available, the process will block; until the input data +arrives, it will not be able to service other events, so it will +appear to the user to .QW "freeze up" \&. -Channel event handlers allow events on the channel to direct channel handling -so that the reader or writer can continue to perform other processing while -waiting for a channel to become available and then handle channel operations -when the channel is ready for the operation. +With \fBchan event\fR, the +process can tell when data is present and only invoke \fBchan gets\fR +or \fBchan read\fR when they will not block. .PP A channel is considered to be readable if there is unread data available on the underlying device. A channel is also considered to @@ -364,29 +443,47 @@ there is no special check for end of file, an infinite loop may occur where \fIscript\fR reads no data, returns, and is immediately invoked again. .PP -A channel is considered to be writable if at least one byte of data can be -written to the underlying file or device without blocking, or if an error -condition is present. Note that client sockets opened in asynchronous mode -become writable when they become connected or if the connection fails. -.PP -Event-driven channel handling works best for channels in non-blocking mode. A -channel in blocking mode blocks when \fBchan puts\fR writes more data than the -channel can accept at the moment, and when \fBchan gets\fR or \fBchan read\fR -requests more data than is currently available. When a channel blocks, the -thread can not do any other processing or service any other events. A channel -in non-blocking mode allows a thread to carry on with other work and get back -to the channel at the right time. +A channel is considered to be writable if at least one byte of data +can be written to the underlying file or device without blocking, or +if an error condition is present on the underlying file or device. +Note that client sockets opened in asynchronous mode become writable +when they become connected or if the connection fails. +.PP +Event-driven I/O works best for channels that have been placed into +non-blocking mode with the \fBchan configure\fR command. In blocking +mode, a \fBchan puts\fR command may block if you give it more data +than the underlying file or device can accept, and a \fBchan gets\fR +or \fBchan read\fR command will block if you attempt to read more data +than is ready; no events will be processed while the commands block. +In non-blocking mode \fBchan puts\fR, \fBchan read\fR, and \fBchan +gets\fR never block. +.PP +The script for a file event is executed at global level (outside the +context of any Tcl procedure) in the interpreter in which the \fBchan +event\fR command was invoked. If an error occurs while executing the +script then the command registered with \fBinterp bgerror\fR is used +to report the error. In addition, the file event handler is deleted +if it ever returns an error; this is done in order to prevent infinite +loops due to buggy handlers. .RE .\" METHOD: flush .TP -\fBchan flush \fIchannelName\fR +\fBchan flush \fIchannelId\fR . -For a channel in blocking mode, flushes all buffered output to the destination, -and then returns. For a channel in non-blocking mode, returns immediately -while all buffered output is flushed in the background as soon as possible. +Ensures that all pending output for the channel called \fIchannelId\fR +is written. +.RS +.PP +If the channel is in blocking mode the command does not return until +all the buffered output has been flushed to the channel. If the +channel is in non-blocking mode, the command may return before all +buffered output has been flushed; the remainder will be flushed in the +background as fast as the underlying file or device is able to absorb +it. +.RE .\" METHOD: gets .TP -\fBchan gets \fIchannelName\fR ?\fIvarName\fR? +\fBchan gets \fIchannelId\fR ?\fIvarName\fR? . Reads a line from the channel consisting of all characters up to the next end-of-line sequence or until end of file is seen. The line feed character @@ -434,126 +531,142 @@ changing the encoding in use. See \fBENCODING ERROR EXAMPLES\fR later. .TP \fBchan names\fR ?\fIpattern\fR? . -Returns a list of all channel names, or if \fIpattern\fR is given, only those -names that match according to the rules of \fBstring match\fR. +Produces a list of all channel names. If \fIpattern\fR is specified, +only those channel names that match it (according to the rules of +\fBstring match\fR) will be returned. .\" METHOD: pending .TP -\fBchan pending \fImode channelName\fR +\fBchan pending \fImode channelId\fR . -Returns the number of bytes of input -when \fImode\fR is -.QW\fBinput\fR -, or output when \fImode\fR is -.QW\fBoutput\fR -, that are currently internally buffered for the channel. Useful in a readable -event callback to impose limits on input line length to avoid a potential -denial-of-service attack where an extremely long line exceeds the available -memory to buffer it. Returns -1 if the channel was not opened for the mode in -question. +Depending on whether \fImode\fR is \fBinput\fR or \fBoutput\fR, +returns the number of +bytes of input or output (respectively) currently buffered +internally for \fIchannelId\fR (especially useful in a readable event +callback to impose application-specific limits on input line lengths to avoid +a potential denial-of-service attack where a hostile user crafts +an extremely long line that exceeds the available memory to buffer it). +Returns -1 if the channel was not opened for the mode in question. .\" METHOD: pipe .TP \fBchan pipe\fR . -Creates a pipe, i.e. a readable channel and a writable channel, and returns the -names of the readable channel and the writable channel. Data written to the -writable channel can be read from the readable channel. Because the pipe is a -real system-level pipe, it can be connected to other processes using -redirection. For example, to redirect \fBstderr\fR from a subprocess into one -channel, and \fBstdout\fR into another, \fBexec\fR with "2>@" and ">@", each -onto the writable side of a pipe, closing the writable side immediately -thereafter so that EOF is signaled on the read side once the subprocess has -closed its output, typically on exit. +Creates a standalone pipe whose read- and write-side channels are +returned as a 2-element list, the first element being the read side and +the second the write side. Can be useful e.g. to redirect +separately \fBstderr\fR and \fBstdout\fR from a subprocess. To do +this, spawn with "2>@" or +">@" redirection operators onto the write side of a pipe, and then +immediately close it in the parent. This is necessary to get an EOF on +the read side once the child has exited or otherwise closed its output. .RS .PP -Due to buffering, data written to one side of a pipe might not immediately -become available on the other side. Tcl's own buffers can be configured via -\fBchan configure -buffering\fR, but overall behaviour still depends on -operating system buffers outside of Tcl's control. Once the write side of the -channel is closed, any data remaining in the buffers is flushed through to the -read side. It may be useful to arrange for the connected process to flush at -some point after writing to the channel or to have it use some system-provided -mechanism to configure buffering. When two pipes are connected to the same -process, one to send data to the process, and one to read data from the -process, a deadlock may occur if the channels are in blocking mode: If -reading, the channel may block waiting for data that can never come because -buffers are only flushed on subsequent writes, and if writing, the channel may -block while waiting for the buffers to become free, which can never happen -because the reader can not read while the writer is blocking. To avoid this -issue, either put the channels into non-blocking mode and use event handlers, -or place the read channel and the write channel in separate interpreters in -separate threads. +Note that the pipe buffering semantics can vary at the operating system level +substantially; it is not safe to assume that a write performed on the output +side of the pipe will appear instantly to the input side. This is a +fundamental difference and Tcl cannot conceal it. The overall stream semantics +\fIare\fR compatible, so blocking reads and writes will not see most of the +differences, but the details of what exactly gets written when are not. This +is most likely to show up when using pipelines for testing; care should be +taken to ensure that deadlocks do not occur and that potential short reads are +allowed for. .RE .\" METHOD: pop .TP -\fBchan pop \fIchannelName\fR +\fBchan pop \fIchannelId\fR . -Removes the topmost transformation handler from the channel if there is one, -and closes the channel otherwise. The result is normally the empty string, but -may be an error in some situations, e.g. when closing the underlying resource -results in an error. +Removes the topmost transformation from the channel \fIchannelId\fR, if there +is any. If there are no transformations added to \fIchannelId\fR, this is +equivalent to \fBchan close\fR of that channel. The result is normally the +empty string, but can be an error in some situations (i.e. where the +underlying system stream is closed and that results in an error). .\" METHOD: postevent .TP -\fBchan postevent \fIchannelName eventSpec\fR +\fBchan postevent \fIchannelId eventSpec\fR . -For use by handlers established with \fBchan create\fR. Notifies Tcl that -that one or more event(s) listed in \fIeventSpec\fR, each of which is either -.QW\fBread\fR -or -.QW\fBwrite\fR. -, have occurred. +This subcommand is used by command handlers specified with \fBchan +create\fR. It notifies the channel represented by the handle +\fIchannelId\fR that the event(s) listed in the \fIeventSpec\fR have +occurred. The argument has to be a list containing any of the strings +\fBread\fR and \fBwrite\fR. The list must contain at least one +element as it does not make sense to invoke the command if there are +no events to post. .RS .PP -For use only by handlers for a channel created by \fBchan create\fR. It is an -error to post an event for any other channel. -.PP -Since only the handler for a reflected channel channel should post events it is -an error to post an event from any interpreter other than the interpreter that -created the channel. -.PP -It is an error to post an event that the channel has no interest in. See -\fBwatch\fR in the \fBrefchan\fR documentation for more information -.PP -\fBchan postevent\fR is available in safe interpreters, as any handler for a -reflected channel would have been created, and will be evaluated in that -interpreter as well. +Note that this subcommand can only be used with channel handles that +were created/opened by \fBchan create\fR. All other channels will +cause this subcommand to report an error. +.PP +As only the Tcl level of a channel, i.e. its command handler, should +post events to it we also restrict the usage of this command to the +interpreter that created the channel. In other words, posting events +to a reflected channel from an interpreter that does not contain it's +implementation is not allowed. Attempting to post an event from any +other interpreter will cause this subcommand to report an error. +.PP +Another restriction is that it is not possible to post events that the +I/O core has not registered an interest in. Trying to do so will cause +the method to throw an error. See the command handler method +\fBwatch\fR described in \fBrefchan\fR, the document specifying +the API of command handlers for reflected channels. +.PP +This command is \fBsafe\fR and made accessible to safe interpreters. +It can trigger the execution of \fBchan event\fR handlers, whether in the +current interpreter or in other interpreters or other threads, even +where the event is posted from a safe interpreter and listened for by +a trusted interpreter. \fBChan event\fR handlers are \fIalways\fR +executed in the interpreter that set them up. .RE .\" METHOD: push .TP -\fBchan push \fIchannelName cmdPrefix\fR +\fBchan push \fIchannelId cmdPrefix\fR . -Adds a new transformation handler on top of the channel and returns a handle -for the transformation. \fIcmdPrefix\fR is the first words of a command that -provides the interface documented for \fBtranschan\fR, and transforms data on -the channel, It is an error if handler does not support the mode(s) the channel -is in. +Adds a new transformation on top of the channel \fIchannelId\fR. The +\fIcmdPrefix\fR argument describes a list of one or more words which represent +a handler that will be used to implement the transformation. The command +prefix must provide the API described in the \fBtranschan\fR manual page. +The result of this subcommand is a handle to the transformation. Note that it +is important to make sure that the transformation is capable of supporting the +channel mode that it is used with or this can make the channel neither +readable nor writable. .\" METHOD: puts .TP -\fBchan puts\fR ?\fB\-nonewline\fR? ?\fIchannelName\fR? \fIstring\fR +\fBchan puts\fR ?\fB\-nonewline\fR? ?\fIchannelId\fR? \fIstring\fR . -Writes \fIstring\fR and a line feed to the channel. If \fB\-nonewline\fR is -given, the trailing line feed is not written. The default channel is +Writes \fIstring\fR to the channel named \fIchannelId\fR followed by a +newline character. A trailing newline character is written unless the +optional flag \fB\-nonewline\fR is given. If \fIchannelId\fR is +omitted, the string is written to the standard output channel, \fBstdout\fR. .RS .PP -Each line feed in the output is translated to the appropriate end of line -sequence as per the \fB\-translation\fR configuration setting of the channel. -.PP -Because Tcl internally buffers output, characters written to a channel may not -immediately be available at the destination. Tcl normally delays output until -the buffer is full or the channel is closed. \fBchan flush\fR forces output in -the direction of the destination. -.PP -When the output for a channel in blocking mode fills up, \fBchan puts\fR blocks -until space in the buffer is available again. On the other hand for a channel in -non-blocking mode, it returns immediately and the data is written in the -background as fast possible, constrained by the speed at which as the -destination accepts it. Output to a channel in non-blocking mode only works -properly when the application enters the event loop. When a channel is in -non-blocking mode, Tcl's internal buffers can hold an arbitrary amount of data, -possibly consuming a large amount of memory. To avoid wasting memory, channels -in non-blocking mode should normally be handled using \fBchan event\fR, where -the application only invokes \fBchan puts\fR after being notified through a file -event handler that the channel is ready for more output data. +Newline characters in the output are translated by \fBchan puts\fR to +platform-specific end-of-line sequences according to the currently +configured value of the \fB\-translation\fR option for the channel +(for example, on PCs newlines are normally replaced with +carriage-return-linefeed sequences; see \fBchan configure\fR above for +details). +.PP +Tcl buffers output internally, so characters written with \fBchan +puts\fR may not appear immediately on the output file or device; Tcl +will normally delay output until the buffer is full or the channel is +closed. You can force output to appear immediately with the \fBchan +flush\fR command. +.PP +When the output buffer fills up, the \fBchan puts\fR command will +normally block until all the buffered data has been accepted for +output by the operating system. If \fIchannelId\fR is in non-blocking +mode then the \fBchan puts\fR command will not block even if the +operating system cannot accept the data. Instead, Tcl continues to +buffer the data and writes it in the background as fast as the +underlying file or device can accept it. The application must use the +Tcl event loop for non-blocking output to work; otherwise Tcl never +finds out that the file or device is ready for more output data. It +is possible for an arbitrarily large amount of data to be buffered for +a channel in non-blocking mode, which could consume a large amount of +memory. To avoid wasting memory, non-blocking I/O should normally be +used in an event-driven fashion with the \fBchan event\fR command +(do not invoke \fBchan puts\fR unless you have recently been notified +via a file event that the channel is ready for more output data). .PP The command will raise an error exception with POSIX error code \fBEILSEQ\fR if the encoding profile \fBstrict\fR is in effect for the channel and the output @@ -562,34 +675,58 @@ may be partially written to the channel in this case. .RE .\" METHOD: read .TP -\fBchan read \fIchannelName\fR ?\fInumChars\fR? +\fBchan read \fIchannelId\fR ?\fInumChars\fR? .TP -\fBchan read \fR?\fB\-nonewline\fR? \fIchannelName\fR +\fBchan read \fR?\fB\-nonewline\fR? \fIchannelId\fR . -Reads and returns the next \fInumChars\fR characters from the channel. If -\fInumChars\fR is omitted, all available characters up to the end of the file -are read, or if the channel is in non-blocking mode, all currently-available -characters are read. If there is an error on the channel, reading ceases and -an error is returned. If \fInumChars\fR is not given, \fB\-nonewline\fR -may be given, causing any trailing line feed to be trimmed. +In the first form, the result will be the next \fInumChars\fR +characters read from the channel named \fIchannelId\fR; if +\fInumChars\fR is omitted, all characters up to the point when the +channel would signal a failure (whether an end-of-file, blocked or +other error condition) are read. In the second form (i.e. when +\fInumChars\fR has been omitted) the flag \fB\-nonewline\fR may be +given to indicate that any trailing newline in the string that has +been read should be trimmed. .RS .PP -If the channel is in non-blocking mode, fewer characters than requested may be -returned. If the channel is configured to use a multi-byte encoding, bytes -that do not form a complete character are retained in the buffers until enough -bytes to complete the character accumulate, or the end of the data is reached. -\fB\-nonewline\fR is ignored if characters are returned before reaching the end -of the file. +If \fIchannelId\fR is in non-blocking mode, \fBchan read\fR may not +read as many characters as requested: once all available input has +been read, the command will return the data that is available rather +than blocking for more input. If the channel is configured to use a +multi-byte encoding, then there may actually be some bytes remaining +in the internal buffers that do not form a complete character. These +bytes will not be returned until a complete character is available or +end-of-file is reached. The \fB\-nonewline\fR switch is ignored if +the command returns before reaching the end of the file. +.PP +\fBChan read\fR translates end-of-line sequences in the input into +newline characters according to the \fB\-translation\fR option for the +channel (see \fBchan configure\fR above for a discussion on the ways +in which \fBchan configure\fR will alter input). .PP -Each end-of-line sequence according to the value of \fB\-translation\fR is -translated into a line feed. +When reading from a serial port, most applications should configure +the serial port channel to be non-blocking, like this: .PP -When reading from a serial port, most applications should configure the serial -port channel to be in non-blocking mode, but not necessarily use an event -handler since most serial ports are comparatively slow. It is entirely -possible to get a \fBreadable\fR event for each individual character. In -blocking mode, \fBchan read\fR blocks forever when reading to the end of the -data if there is no \fBchan configure -eofchar\fR configured for the channel. +.CS +\fBchan configure \fIchannelId \fB\-blocking \fI0\fR. +.CE +.PP +Then \fBchan read\fR behaves much like described above. Note that +most serial ports are comparatively slow; it is entirely possible to +get a \fBreadable\fR event for each character read from them. Care +must be taken when using \fBchan read\fR on blocking serial ports: +.TP +\fBchan read \fIchannelId numChars\fR +. +In this form \fBchan read\fR blocks until \fInumChars\fR have been +received from the serial port. +.TP +\fBchan read \fIchannelId\fR +. +In this form \fBchan read\fR blocks until the reception of the +end-of-file character, see \fBchan configure -eofchar\fR. If there no +end-of-file character has been configured for the channel, then +\fBchan read\fR will block forever. .PP If the encoding profile \fBstrict\fR is in effect for the channel, the command will raise an exception with the POSIX error code \fBEILSEQ\fR if any encoding @@ -608,41 +745,56 @@ changing the encoding in use. See \fBENCODING ERROR EXAMPLES\fR later. .RE .\" METHOD: seek .TP -\fBchan seek \fIchannelName offset\fR ?\fIorigin\fR? +\fBchan seek \fIchannelId offset\fR ?\fIorigin\fR? . -Sets the current position for the data in the channel to integer \fIoffset\fR -bytes relative to \fIorigin\fR. A negative offset moves the current position -backwards from the origin. \fIorigin\fR is one of the -following: +Sets the current access position within the underlying data stream for +the channel named \fIchannelId\fR to be \fIoffset\fR bytes relative to +\fIorigin\fR. \fIOffset\fR must be an integer (which may be negative) +and \fIorigin\fR must be one of the following: .RS .IP \fBstart\fR -The origin is the start of the data. This is the default. +The new access position will be \fIoffset\fR bytes from the start +of the underlying file or device. .IP \fBcurrent\fR -The origin is the current position. +The new access position will be \fIoffset\fR bytes from the current +access position; a negative \fIoffset\fR moves the access position +backwards in the underlying file or device. .IP \fBend\fR -The origin is the end of the data. -.PP -\fBChan seek\fR flushes all buffered output even if the channel is in -non-blocking mode, discards any buffered and unread input, and returns the -empty string or an error if the channel does not support seeking. -.PP -\fIoffset\fR values are byte offsets, not character offsets. Unlike \fBchan -read\fR, both \fBchan seek\fR and \fBchan tell\fR operate in terms of bytes, -not characters, +The new access position will be \fIoffset\fR bytes from the end of the +file or device. A negative \fIoffset\fR places the access position +before the end of file, and a positive \fIoffset\fR places the access +position after the end of file. +.PP +The \fIorigin\fR argument defaults to \fBstart\fR. +.PP +\fBChan seek\fR flushes all buffered output for the channel before the +command returns, even if the channel is in non-blocking mode. It also +discards any buffered and unread input. This command returns an empty +string. An error occurs if this command is applied to channels whose +underlying file or device does not support seeking. +.PP +Note that \fIoffset\fR values are byte offsets, not character offsets. +Both \fBchan seek\fR and \fBchan tell\fR operate in terms of bytes, +not characters, unlike \fBchan read\fR. .RE .\" METHOD: tell .TP -\fBchan tell \fIchannelName\fR +\fBchan tell \fIchannelId\fR . -Returns the offset in bytes of the current position in the underlying data, or --1 if the channel does not support seeking. The value can be passed to \fBchan -seek\fR to set current position to that offset. +Returns a number giving the current access position within the +underlying data stream for the channel named \fIchannelId\fR. This +value returned is a byte offset that can be passed to \fBchan seek\fR +in order to set the channel to a particular position. Note that this +value is in terms of bytes, not characters like \fBchan read\fR. The +value returned is -1 for channels that do not support seeking. .\" METHOD: truncate .TP -\fBchan truncate \fIchannelName\fR ?\fIlength\fR? +\fBchan truncate \fIchannelId\fR ?\fIlength\fR? . -Flushes the channel and truncates the data in the channel to \fIlength\fR -bytes, or to the current position in bytes if \fIlength\fR is omitted. +Sets the byte length of the underlying data stream for the channel +named \fIchannelId\fR to be \fIlength\fR (or to the current byte +offset within the underlying data stream if \fIlength\fR is +omitted). The channel is flushed before truncation. . .SH EXAMPLES .SS "SIMPLE CHANNEL OPERATION EXAMPLES" @@ -753,7 +905,7 @@ preventing servicing of other connections at the same time: .PP .CS # This is a very simple logger... -proc log message { +proc log {message} { \fBchan puts\fR stdout $message } @@ -876,7 +1028,7 @@ full line. .CS % set f [open test_A_195_B.txt r] file384b6a8 -% chan configure $f -encoding utf-8 -profile strict +% chan configure $f -encoding utf-8 % catch {chan gets $f} e d 1 % set d @@ -886,7 +1038,7 @@ file384b6a8 -errorinfo {...} -errorline 1 % chan tell $f 0 -% chan configure $f -encoding binary -profile strict +% chan configure $f -encoding binary % chan gets $f AÃB .CE @@ -900,7 +1052,7 @@ position 1. The data at the error position is thus recovered by the next .CS % set f [open test_A_195_B.txt r] file35a65a0 -% chan configure $f -encoding utf-8 -profile strict -blocking 1 +% chan configure $f -encoding utf-8 -blocking 1 % catch {chan read $f} e d 1 % set d @@ -910,7 +1062,7 @@ file35a65a0 -errorinfo {...} -errorline 1 % chan tell $f 1 -% chan configure $f -encoding binary -profile strict +% chan configure $f -encoding binary % chan read $f ÃB % chan close $f @@ -921,7 +1073,7 @@ Finally the same example, but this time with a non-blocking channel. .CS % set f [open test_A_195_B.txt r] file35a65a0 -% chan configure $f -encoding utf-8 -profile strict -blocking 0 +% chan configure $f -encoding utf-8 -blocking 0 % chan read $f A % chan tell $f diff --git a/doc/configurable.n b/doc/configurable.n index 7ab5b92..d2e6b18 100644 --- a/doc/configurable.n +++ b/doc/configurable.n @@ -1,5 +1,5 @@ '\" -'\" Copyright © 2019 Donal K. Fellows +'\" Copyright (c) 2019 Donal K. Fellows '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. diff --git a/doc/encoding.n b/doc/encoding.n index d556839..c28406f 100644 --- a/doc/encoding.n +++ b/doc/encoding.n @@ -1,6 +1,5 @@ '\" '\" Copyright (c) 1998 Scriptics Corporation. -'\" Copyright (c) 2023 Nathan Coulter '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -9,86 +8,84 @@ .so man.macros .BS .SH NAME -encoding \- Work with encodings +encoding \- Manipulate encodings .SH SYNOPSIS -\fBencoding \fIoperation\fR ?\fIarg arg ...\fR? +\fBencoding \fIoption\fR ?\fIarg arg ...\fR? .BE .SH INTRODUCTION .PP -In Tcl every string is composed of Unicode values. Text may be encoded into an -encoding such as cp1252, iso8859-1, Shift\-JIS, utf-8, utf-16, etc. Not every -Unicode value is encodable in every encoding, and some encodings can encode -values that are not available in Unicode. -.PP -Even though Unicode is for encoding the written texts of human languages, any -sequence of bytes can be encoded as the first 255 Unicode values. In particular, -iso8859-1 is an encoding (a superset of classic ASCII) for a subset of Unicode -in which each byte is a Unicode value of 255 -or less; any sequence of bytes can be considered to be a Unicode string -encoded in iso8859-1. To work with binary data in Tcl, decode it from -iso8859-1 when reading it in, and encode it into iso8859-1 when writing it out, -ensuring that each character in the string has a value of 255 or less. -Decoding such a string does nothing, and encoding encoding such a string also -does nothing. -.PP -For example, the following is true: -.CS - -set text {In Tcl binary data is treated as Unicode text and it just works.} -set encoded [\fBencoding convertto\fR iso8859-1 $text] -expr {$text eq $encoded}; #-> 1 -.CE -The following is also true: -.CS -set decoded [\fBencoding convertfrom\fR iso8859-1 $text] -expr {$text eq $decoded}; #-> 1 -.CE +Strings in Tcl are logically a sequence of 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 4 +bytes per character), or a custom encoding start as 8 bit binary data. +.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 the following encoding \fIoperations\fR: +Performs one of several encoding related operations, depending on +\fIoption\fR. The legal \fIoption\fRs are: .\" METHOD: convertfrom .TP \fBencoding convertfrom\fR ?\fIencoding\fR? \fIdata\fR +.VS "TCL8.7 TIP607, TIP656" .TP -\fBencoding convertfrom\fR ?\fB\-profile \fIprofile\fR? ?\fB\-failindex var\fR? \fIencoding data\fR +\fBencoding convertfrom\fR ?\fB-profile \fIprofile\fR? ?\fB-failindex var\fR? \fIencoding data\fR +.VE "TCL8.7 TIP607, TIP656" . -Decodes \fIdata\fR encoded in \fIencoding\fR. If \fIencoding\fR is not -specified the current system encoding is used. +Converts \fIdata\fR, which should be in binary string encoded as per +\fIencoding\fR, to a Tcl string. If \fIencoding\fR is not specified, the current +system encoding is used. +.PP .VS "TCL8.7 TIP607, TIP656" -\fB\-profile\fR determines how invalid data for the encoding are handled. See -the \fBPROFILES\fR section below for details. Returns an error if decoding -fails. However, if \fB\-failindex\fR given, returns the result of the -conversion up to the point of termination, and stores in \fBvar\fR the index of -the character that could not be converted. If no errors are encountered the -entire result of the conversion is returned and the value \fB-1\fR is stored in -\fBvar\fR. +The \fB-profile\fR option determines the command behavior in the presence +of conversion errors. See the \fBPROFILES\fR section below for details. Any premature +termination of processing due to errors is reported through an exception if +the \fB-failindex\fR option is not specified. +.PP +If the \fB-failindex\fR is specified, instead of an exception being raised +on premature termination, the result of the conversion up to the point of the +error is returned as the result of the command. In addition, the index +of the source byte triggering the error is stored in \fBvar\fR. If no +errors are encountered, the entire result of the conversion is returned and +the value \fB-1\fR is stored in \fBvar\fR. .VE "TCL8.7 TIP607, TIP656" .\" METHOD: convertto .TP \fBencoding convertto\fR ?\fIencoding\fR? \fIdata\fR .TP -\fBencoding convertto\fR ?\fB\-profile \fIprofile\fR? ?\fB\-failindex var\fR? \fIencoding data\fR +\fBencoding convertto\fR ?\fB-profile \fIprofile\fR? ?\fB-failindex var\fR? \fIencoding data\fR . -Converts \fIstring\fR to \fIencoding\fR. If \fIencoding\fR is not given, the -current system encoding is used. +Convert \fIstring\fR to the specified \fIencoding\fR. The result is a Tcl binary +string that contains the sequence of bytes representing the converted string in +the specified encoding. If \fIencoding\fR is not specified, the current system +encoding is used. +.PP .VS "TCL8.7 TIP607, TIP656" -See \fBencoding convertfrom\fR for the meaning of \fB\-profile\fR and -\fB\-failindex\fR. +The \fB-profile\fR and \fB-failindex\fR options have the same effect as +described for the \fBencoding convertfrom\fR command. .VE "TCL8.7 TIP607, TIP656" .\" METHOD: dirs .TP \fBencoding dirs\fR ?\fIdirectoryList\fR? . -Sets the search path for \fB*.enc\fR encoding data files to the list of -directories given by \fIdirectoryList\fR. If \fIdirectoryList\fR is not given, -returns the current list of directories that make up the search path. It is -not an error for an item in \fIdirectoryList\fR to not refer to a readable, -searchable directory. +Tcl can load encoding data files from the file system that describe +additional encodings for it to work with. This command sets the search +path for \fB*.enc\fR encoding data files to the list of directories +\fIdirectoryList\fR. If \fIdirectoryList\fR is omitted then the +command returns the current list of directories that make up the +search path. It is an error for \fIdirectoryList\fR to not be a valid +list. If, when a search for an encoding data file is happening, an +element in \fIdirectoryList\fR does not refer to a readable, +searchable directory, that element is ignored. .\" METHOD: names .TP \fBencoding names\fR . -Returns a list of the names of available encodings. +Returns a list containing the names of all of the encodings that are +currently available. The encodings .QW utf-8 and @@ -98,66 +95,89 @@ are guaranteed to be present in the list. .TP \fBencoding profiles\fR .VS "TCL8.7 TIP656" -Returns a list of names of available encoding profiles. See \fBPROFILES\fR -below. +Returns a list of the names of encoding profiles. See \fBPROFILES\fR below. .VE "TCL8.7 TIP656" .\" METHOD: system .TP \fBencoding system\fR ?\fIencoding\fR? . -Sets the system encoding to \fIencoding\fR. If \fIencoding\fR is not given, -returns the current system encoding. The system encoding is used to pass -strings to system calls. +Set the system encoding to \fIencoding\fR. If \fIencoding\fR is +omitted then the command returns the current system encoding. The +system encoding is used whenever Tcl passes strings to system calls. .\" Do not put .VS on whole section as that messes up the bullet list alignment .SH PROFILES .PP .VS "TCL8.7 TIP656" -Each \fIprofile\fR is a distinct strategy for dealing with invalid data for an -encoding. -.PP -The following profiles are currently implemented. +Operations involving encoding transforms may encounter several types of +errors such as invalid sequences in the source data, characters that +cannot be encoded in the target encoding and so on. +A \fIprofile\fR prescribes the strategy for dealing with such errors +in one of two ways: .VE "TCL8.7 TIP656" -.TP -\fBstrict\fR +. +.IP \(bu .VS "TCL8.7 TIP656" -The default profile. The operation fails when invalid data for the encoding -are encountered. +Terminating further processing of the source data. The profile does not +determine how this premature termination is conveyed to the caller. By default, +this is signalled by raising an exception. If the \fB-failindex\fR option +is specified, errors are reported through that mechanism. .VE "TCL8.7 TIP656" -.TP -\fBtcl8\fR +.IP \(bu .VS "TCL8.7 TIP656" -Provides for behaviour identical to that of Tcl 8.6: When -decoding, for encodings \fBother than utf-8\fR, each invalid byte is interpreted -as the Unicode value given by that one byte. For example, the byte 0x80, which -is invalid in the ASCII encoding would be mapped to the Unicode value U+0080. -For \fButf-8\fR, each invalid byte that is a valid CP1252 character is -interpreted as the Unicode value for that character, while each byte that is -not is treated as the Unicode value given by that one byte. For example, byte -0x80 is defined by CP1252 and is therefore mapped to its Unicode equivalent -U+20AC while byte 0x81 which is not defined by CP1252 is mapped to U+0081. As -an additional special case, the sequence 0xC0 0x80 is mapped to U+0000. -.RS -.PP -When encoding, each character that cannot be represented in the encoding is -replaced by an encoding-dependent character, usually the question mark \fB?\fR. -.RE +Continue further processing of the source data using a fallback strategy such +as replacing or discarding the offending bytes in a profile-defined manner. .VE "TCL8.7 TIP656" +.PP +The following profiles are currently implemented with \fBstrict\fR being +the default if the \fB-profile\fR is not specified. +.VS "TCL8.7 TIP656" +.TP +\fBstrict\fR +. +The \fBstrict\fR profile always stops processing when an conversion error is +encountered. The error is signalled via an exception or the \fB-failindex\fR +option mechanism. The \fBstrict\fR profile implements a Unicode standard +conformant behavior. +.TP +\fBtcl8\fR +. +The \fBtcl8\fR profile always follows the first strategy above and corresponds +to the behavior of encoding transforms in Tcl 8.6. When converting from an +external encoding \fBother than utf-8\fR to Tcl strings with the \fBencoding +convertfrom\fR command, invalid bytes are mapped to their numerically equivalent +code points. For example, the byte 0x80 which is invalid in ASCII would be +mapped to code point U+0080. When converting from \fButf-8\fR, invalid bytes +that are defined in CP1252 are mapped to their Unicode equivalents while those +that are not fall back to the numerical equivalents. For example, byte 0x80 is +defined by CP1252 and is therefore mapped to its Unicode equivalent U+20AC while +byte 0x81 which is not defined by CP1252 is mapped to U+0081. As an additional +special case, the sequence 0xC0 0x80 is mapped to U+0000. + +When converting from Tcl strings to an external encoding format using +\fBencoding convertto\fR, characters that cannot be represented in the +target encoding are replaced by an encoding-dependent character, usually +the question mark \fB?\fR. .TP \fBreplace\fR -.VS "TCL8.7 TIP 656" -When decoding, invalid bytes are replaced by U+FFFD, the Unicode REPLACEMENT -CHARACTER. -.RS -.PP -When encoding, Unicode values that cannot be represented in the target encoding -are transformed to an encoding-specific fallback character, U+FFFD REPLACEMENT -CHARACTER for UTF targets, and generally `?` for other encodings. -.RE +. +Like the \fBtcl8\fR profile, the \fBreplace\fR profile always continues +processing on conversion errors but follows a Unicode standard conformant +method for substitution of invalid source data. + +When converting an encoded byte sequence to a Tcl string using +\fBencoding convertfrom\fR, invalid bytes +are replaced by the U+FFFD REPLACEMENT CHARACTER code point. + +When encoding a Tcl string with \fBencoding convertto\fR, +code points that cannot be represented in the +target encoding are transformed to an encoding-specific fallback character, +U+FFFD REPLACEMENT CHARACTER for UTF targets and generally `?` for other +encodings. .VE "TCL8.7 TIP656" .SH EXAMPLES .PP -These examples use the utility proc below that prints the Unicode value for -each character in a string. +These examples use the utility proc below that prints the Unicode code points +comprising a Tcl string. .PP .CS proc codepoints s {join [lmap c [split $s {}] { @@ -165,14 +185,14 @@ proc codepoints s {join [lmap c [split $s {}] { } .CE .PP -Example 1: Convert from euc-jp: +Example 1: convert a byte sequence in Japanese euc-jp encoding to a TCL string: .PP .CS -% codepoints [\fBencoding convertfrom\fR euc-jp \exA4\exCF] +% codepoints [\fBencoding convertfrom\fR euc-jp "\exA4\exCF"] U+00306F .CE .PP -The result is the Unicode value +The result is the unicode codepoint .QW "\eu306F" , which is the Hiragana letter HA. .VS "TCL8.7 TIP607, TIP656" @@ -194,7 +214,7 @@ unexpected byte sequence starting at index 1: '\ex80' Example 3: Get partial data and the error location: .PP .CS -% codepoints [\fBencoding convertfrom\fR -failindex idx ascii AB\ex80] +% codepoints [\fBencoding convertfrom\fR -profile strict -failindex idx ascii AB\ex80] U+000041 U+000042 % set idx 2 @@ -207,7 +227,7 @@ Example 4: Encode a character that is not representable in ISO8859-1: A? % \fBencoding convertto\fR -profile strict iso8859-1 A\eu0141 unexpected character at index 1: 'U+000141' -% \fBencoding convertto\fR -failindex idx iso8859-1 A\eu0141 +% \fBencoding convertto\fR -profile strict -failindex idx iso8859-1 A\eu0141 A % set idx 1 @@ -333,14 +333,6 @@ See the \fBmathfunc\fR(n) documentation for the math functions that are available by default. .SS "TYPES, OVERFLOW, AND PRECISION" .PP -When needed to guarantee exact performance, internal computations involving -integers use the LibTomMath multiple precision integer library. In Tcl releases -prior to 8.5, integer calculations were performed using one of the C types -\fIlong int\fR or \fITcl_WideInt\fR, causing implicit range truncation -in those calculations where values overflowed the range of those types. -Any code that relied on these implicit truncations should instead call -\fBwide()\fR, which does truncate. -.PP Internal floating-point computations are performed using the \fIdouble\fR C type. When converting a string to floating-point value, exponent overflow is @@ -259,7 +259,7 @@ The default is \fButf-8\fR, as specified by RFC 2718. The value of the User-Agent header in the HTTP request. In an unsafe interpreter, the default value depends upon the operating system, and the version numbers of \fBhttp\fR and \fBTcl\fR, and is (for example) -.QW "\fBMozilla/5.0 (Windows; U; Windows NT 10.0) http/2.9.0 Tcl/8.6.9\fR" . +.QW "\fBMozilla/5.0 (Windows; U; Windows NT 10.0) http/2.10.0 Tcl/9.0.0\fR" . A safe interpreter cannot determine its operating system, and so the default in a safe interpreter is to use a Windows 10 value with the current version numbers of \fBhttp\fR and \fBTcl\fR. @@ -511,32 +511,32 @@ own value is also specified: .PP .CS safe::interpCreate foo -accessPath { - /usr/local/TclHome/lib/tcl8.6 - /usr/local/TclHome/lib/tcl8.6/http1.0 - /usr/local/TclHome/lib/tcl8.6/opt0.4 - /usr/local/TclHome/lib/tcl8.6/msgs - /usr/local/TclHome/lib/tcl8.6/encoding + /usr/local/TclHome/lib/tcl9.0 + /usr/local/TclHome/lib/tcl9.0/http1.0 + /usr/local/TclHome/lib/tcl9.0/opt0.4 + /usr/local/TclHome/lib/tcl9.0/msgs + /usr/local/TclHome/lib/tcl9.0/encoding /usr/local/TclHome/lib } # The child's ::auto_path must be given a suitable value: safe::interpConfigure foo -autoPath { - /usr/local/TclHome/lib/tcl8.6 + /usr/local/TclHome/lib/tcl9.0 /usr/local/TclHome/lib } # The two commands can be combined: safe::interpCreate foo -accessPath { - /usr/local/TclHome/lib/tcl8.6 - /usr/local/TclHome/lib/tcl8.6/http1.0 - /usr/local/TclHome/lib/tcl8.6/opt0.4 - /usr/local/TclHome/lib/tcl8.6/msgs - /usr/local/TclHome/lib/tcl8.6/encoding + /usr/local/TclHome/lib/tcl9.0 + /usr/local/TclHome/lib/tcl9.0/http1.0 + /usr/local/TclHome/lib/tcl9.0/opt0.4 + /usr/local/TclHome/lib/tcl9.0/msgs + /usr/local/TclHome/lib/tcl9.0/encoding /usr/local/TclHome/lib } -autoPath { - /usr/local/TclHome/lib/tcl8.6 + /usr/local/TclHome/lib/tcl9.0 /usr/local/TclHome/lib } .CE @@ -73,17 +73,18 @@ The size modifier field is used only when scanning a substring into one of Tcl's integer values. The size modifier field dictates the integer range acceptable to be stored in a variable, or, for the inline case, in a position in the result list. -The syntactically valid values for the size modifier are \fBh\fR, \fBL\fR, -\fBl\fR, \fBz\fR, \fBt\fR, and \fBll\fR. The \fBh\fR size -modifier value is equivalent -to the absence of a size modifier in the the conversion specifier. -Either one indicates the integer range to be stored is limited to -the 32-bit range. -The \fBL\fR size modifier is equivalent to the \fBll\fR size -modifier. Either one indicates the integer range to be stored is unlimited. -The \fBl\fR (or \fBq\fR or \fBj\fR) size modifier indicates that the integer -range to be stored is limited to the same range produced by the -\fBwide()\fR function of the \fBexpr\fR command. +The syntactically valid values for the size modifier are \fBh\fR, +\fBl\fR, \fBz\fR, \fBt\fR, \fBq\fR, \fBj\fR, \fBll\fR, and \fBL\fR. +The \fBh\fR size modifier value is equivalent to the absence of a size +modifier in the the conversion specifier. Either one indicates the +integer range to be stored is limited to the 32-bit range. The \fBL\fR +size modifier is equivalent to the \fBll\fR size modifier. Either one +indicates the integer range to be stored is unlimited. The \fBl\fR (or +\fBq\fR or \fBj\fR) size modifier indicates that the integer range to be +stored is limited to the same range produced by the \fBwide()\fR function +of the \fBexpr\fR command. The \fBz\fR and \fBt\fR modifiers indicate the +integer range to be the same as for either \fBh\fR or \fBl\fR, depending +on the value of the \fBpointerSize\fR element of the \fBtcl_platform\fR array. .SS "MANDATORY CONVERSION CHARACTER" .PP The following conversion characters are supported: diff --git a/doc/socket.n b/doc/socket.n index 06d3b5b..623fac6 100644 --- a/doc/socket.n +++ b/doc/socket.n @@ -261,8 +261,6 @@ close $sockChan puts "The time on $server is $line1" puts "That is [lindex $line2 0]s since the server started" .CE -.SH "HISTORY" -Support for IPv6 was added in Tcl 8.6. .SH "SEE ALSO" chan(n), flush(n), open(n), read(n) .SH KEYWORDS diff --git a/doc/transchan.n b/doc/transchan.n index a511c75..abae7b9 100644 --- a/doc/transchan.n +++ b/doc/transchan.n @@ -12,7 +12,7 @@ transchan \- command handler API of channel transforms .SH SYNOPSIS .nf -\fBchan push \fIchannelName cmdPrefix\fR +\fBchan push \fIchannelId cmdPrefix\fR \fIcmdPrefix \fBclear \fIhandle\fR \fIcmdPrefix \fBdrain \fIhandle\fR diff --git a/generic/regc_color.c b/generic/regc_color.c index f1e25d2..ccb1826 100644 --- a/generic/regc_color.c +++ b/generic/regc_color.c @@ -430,7 +430,7 @@ newsub( /* - subrange - allocate new subcolors to this range of chrs, fill in arcs ^ static void subrange(struct vars *, pchr, pchr, struct state *, - ^ struct state *); + ^ struct state *); */ static void subrange( @@ -689,7 +689,7 @@ uncolorchain( /* - rainbow - add arcs of all full colors (but one) between specified states ^ static void rainbow(struct nfa *, struct colormap *, int, pcolor, - ^ struct state *, struct state *); + ^ struct state *, struct state *); */ static void rainbow( @@ -716,7 +716,7 @@ rainbow( - colorcomplement - add arcs of complementary colors * The calling sequence ought to be reconciled with cloneouts(). ^ static void colorcomplement(struct nfa *, struct colormap *, int, - ^ struct state *, struct state *, struct state *); + ^ struct state *, struct state *, struct state *); */ static void colorcomplement( diff --git a/generic/regc_locale.c b/generic/regc_locale.c index b6687f3..6613e69 100644 --- a/generic/regc_locale.c +++ b/generic/regc_locale.c @@ -1187,24 +1187,24 @@ cclass( } break; case CC_PRINT: - cv = getcvec(v, NUM_SPACE_CHAR + NUM_GRAPH_CHAR, NUM_SPACE_RANGE + NUM_GRAPH_RANGE - 1); - if (cv) { - for (i=1 ; i<NUM_SPACE_RANGE ; i++) { - addrange(cv, spaceRangeTable[i].start, - spaceRangeTable[i].end); - } - for (i=0 ; i<NUM_SPACE_CHAR ; i++) { - addchr(cv, spaceCharTable[i]); - } - for (i=0 ; i<NUM_GRAPH_RANGE ; i++) { - addrange(cv, graphRangeTable[i].start, - graphRangeTable[i].end); - } - for (i=0 ; i<NUM_GRAPH_CHAR ; i++) { - addchr(cv, graphCharTable[i]); - } - } - break; + cv = getcvec(v, NUM_SPACE_CHAR + NUM_GRAPH_CHAR, NUM_SPACE_RANGE + NUM_GRAPH_RANGE - 1); + if (cv) { + for (i=1 ; i<NUM_SPACE_RANGE ; i++) { + addrange(cv, spaceRangeTable[i].start, + spaceRangeTable[i].end); + } + for (i=0 ; i<NUM_SPACE_CHAR ; i++) { + addchr(cv, spaceCharTable[i]); + } + for (i=0 ; i<NUM_GRAPH_RANGE ; i++) { + addrange(cv, graphRangeTable[i].start, + graphRangeTable[i].end); + } + for (i=0 ; i<NUM_GRAPH_CHAR ; i++) { + addchr(cv, graphCharTable[i]); + } + } + break; case CC_GRAPH: cv = getcvec(v, NUM_GRAPH_CHAR, NUM_GRAPH_RANGE); if (cv) { diff --git a/generic/regc_nfa.c b/generic/regc_nfa.c index 5357571..abeb359 100644 --- a/generic/regc_nfa.c +++ b/generic/regc_nfa.c @@ -570,7 +570,7 @@ findarc( /* - cparc - allocate a new arc within an NFA, copying details from old one ^ static void cparc(struct nfa *, struct arc *, struct state *, - ^ struct state *); + ^ struct state *); */ static void cparc( @@ -641,19 +641,19 @@ sortins_cmp( return -1; } if (aa->from->no > bb->from->no) { - return 1; + return 1; } if (aa->co < bb->co) { - return -1; + return -1; } if (aa->co > bb->co) { - return 1; + return 1; } if (aa->type < bb->type) { - return -1; + return -1; } if (aa->type > bb->type) { - return 1; + return 1; } return 0; } @@ -1118,7 +1118,7 @@ copyouts( cparc(nfa, a, newState, a->to); } } else { - /* + /* * With many arcs, use a sort-merge approach. Note that createarc() * will put new arcs onto the front of newState's chain, so it does * not break our walk through the sorted part of the chain. @@ -1177,7 +1177,7 @@ copyouts( /* - cloneouts - copy out arcs of a state to another state pair, modifying type ^ static void cloneouts(struct nfa *, struct state *, struct state *, - ^ struct state *, int); + ^ struct state *, int); */ static void cloneouts( @@ -1267,7 +1267,7 @@ deltraverse( * well as mark already-seen states. (You knew there was a reason why it's a * state pointer, didn't you? :-)) ^ static void dupnfa(struct nfa *, struct state *, struct state *, - ^ struct state *, struct state *); + ^ struct state *, struct state *); */ static void dupnfa( @@ -1599,10 +1599,10 @@ pull( s->tmp = *intermediates; *intermediates = s; } - cparc(nfa, con, a->from, s); + cparc(nfa, con, a->from, s); cparc(nfa, a, s, to); - freearc(nfa, a); - break; + freearc(nfa, a); + break; default: assert(NOTREACHED); break; @@ -1779,9 +1779,9 @@ push( *intermediates = s; } cparc(nfa, con, s, a->to); - cparc(nfa, a, from, s); - freearc(nfa, a); - break; + cparc(nfa, a, from, s); + freearc(nfa, a); + break; default: assert(NOTREACHED); break; @@ -2021,11 +2021,11 @@ fixempties( } } - /* Reset the tmp fields as we walk back */ - nexts = s2->tmp; - s2->tmp = NULL; - } - s->tmp = NULL; + /* Reset the tmp fields as we walk back */ + nexts = s2->tmp; + s2->tmp = NULL; + } + s->tmp = NULL; assert(arccount <= totalinarcs); /* Remember how many original inarcs this state has */ @@ -2185,12 +2185,12 @@ fixconstraintloops( freearc(nfa, a); } else { hasconstraints = 1; - } + } } } - /* If we removed all the outarcs, the state is useless. */ - if (s->nouts == 0 && !s->flag) { - dropstate(nfa, s); + /* If we removed all the outarcs, the state is useless. */ + if (s->nouts == 0 && !s->flag) { + dropstate(nfa, s); } } @@ -2235,7 +2235,7 @@ fixconstraintloops( } if (f != NULL) { - dumpnfa(nfa, f); + dumpnfa(nfa, f); } } @@ -2725,7 +2725,7 @@ cleanup( /* - markreachable - recursive marking of reachable states ^ static void markreachable(struct nfa *, struct state *, struct state *, - ^ struct state *); + ^ struct state *); */ static void markreachable( @@ -2749,7 +2749,7 @@ markreachable( /* - markcanreach - recursive marking of states which can reach here ^ static void markcanreach(struct nfa *, struct state *, struct state *, - ^ struct state *); + ^ struct state *); */ static void markcanreach( diff --git a/generic/regcomp.c b/generic/regcomp.c index 012e37c..949f397 100644 --- a/generic/regcomp.c +++ b/generic/regcomp.c @@ -644,7 +644,7 @@ makesearch( * together with '|'. They appear in the tree as the left children of a chain * of '|' subres. ^ static struct subre *parse(struct vars *, int, int, struct state *, - ^ struct state *); + ^ struct state *); */ static struct subre * parse( @@ -726,7 +726,7 @@ parse( * Concatenated things are bundled up as much as possible, with separate * ',' nodes introduced only when necessary due to substructure. ^ static struct subre *parsebranch(struct vars *, int, int, struct state *, - ^ struct state *, int); + ^ struct state *, int); */ static struct subre * parsebranch( @@ -775,7 +775,7 @@ parsebranch( * particular, it contains a recursion that can involve parsing the rest of * the branch, making this function's name somewhat inaccurate. ^ static void parseqatom(struct vars *, int, int, struct state *, - ^ struct state *, struct subre *); + ^ struct state *, struct subre *); */ static void parseqatom( @@ -1649,7 +1649,7 @@ onechr( /* - dovec - fill in arcs for each element of a cvec ^ static void dovec(struct vars *, struct cvec *, struct state *, - ^ struct state *); + ^ struct state *); */ static void dovec( diff --git a/generic/rege_dfa.c b/generic/rege_dfa.c index 5d49aa5..c8c74f0 100644 --- a/generic/rege_dfa.c +++ b/generic/rege_dfa.c @@ -159,7 +159,7 @@ longest( /* - shortest - shortest-preferred matching engine ^ static chr *shortest(struct vars *, struct dfa *, chr *, chr *, chr *, - ^ chr **, int *); + ^ chr **, int *); */ static chr * /* endpoint, or NULL */ shortest( @@ -308,7 +308,7 @@ lastCold( /* - newDFA - set up a fresh DFA ^ static struct dfa *newDFA(struct vars *, struct cnfa *, - ^ struct colormap *, struct smalldfa *); + ^ struct colormap *, struct smalldfa *); */ static struct dfa * newDFA( @@ -477,7 +477,7 @@ initialize( /* - miss - handle a cache miss ^ static struct sset *miss(struct vars *, struct dfa *, struct sset *, - ^ pcolor, chr *, chr *); + ^ pcolor, chr *, chr *); */ static struct sset * /* NULL if goes to empty set */ miss( diff --git a/generic/tcl.h b/generic/tcl.h index 41e68a8..b5630cc 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -1105,7 +1105,7 @@ struct Tcl_HashEntry { * allocated for the hash table that is not for an * entry will use the system heap. * TCL_HASH_KEY_DIRECT_COMPARE - - * Allows fast comparison for hash keys directly + * Allows fast comparison for hash keys directly * by compare of their key.oneWordValue values, * before call of compareKeysProc (much slower * than a direct compare, so it is speed-up only @@ -1250,7 +1250,7 @@ typedef struct Tcl_HashSearch { typedef struct { void *next; /* Search position for underlying hash * table. */ - TCL_HASH_TYPE epoch; /* Epoch marker for dictionary being searched, + TCL_HASH_TYPE epoch; /* Epoch marker for dictionary being searched, * or 0 if search has terminated. */ Tcl_Dict dictionaryPtr; /* Reference to dictionary being searched. */ } Tcl_DictSearch; @@ -1998,7 +1998,7 @@ typedef struct Tcl_EncodingType { * buffer contains the entire input stream to be * converted, this flag should be set. * TCL_ENCODING_STOPONERROR - Not used any more. - * TCL_ENCODING_NO_TERMINATE - If set, Tcl_ExternalToUtf does not append a + * TCL_ENCODING_NO_TERMINATE - If set, Tcl_ExternalToUtf does not append a * terminating NUL byte. Since it does not need * an extra byte for a terminating NUL, it fills * all dstLen bytes with encoded UTF-8 content if diff --git a/generic/tclArithSeries.c b/generic/tclArithSeries.c index fd1014c..7618415 100755 --- a/generic/tclArithSeries.c +++ b/generic/tclArithSeries.c @@ -231,21 +231,19 @@ maxPrecision( * * ArithSeriesLen -- * - * Compute the length of the equivalent list where - * every element is generated starting from *start*, - * and adding *step* to generate every successive element - * that's < *end* for positive steps, or > *end* for negative - * steps. + * Compute the length of the equivalent list where + * every element is generated starting from *start*, + * and adding *step* to generate every successive element + * that's < *end* for positive steps, or > *end* for negative + * steps. * * Results: - * - * The length of the list generated by the given range, - * that may be zero. - * The function returns -1 if the list is of length infinite. + * The length of the list generated by the given range, + * that may be zero. + * The function returns -1 if the list is of length infinite. * * Side effects: - * - * None. + * None. * *---------------------------------------------------------------------- */ @@ -383,12 +381,11 @@ FreeArithSeriesInternalRep( * refcount = 0. * * Results: - * - * A Tcl_Obj pointer to the created ArithSeries object. - * A NULL pointer of the range is invalid. + * A Tcl_Obj pointer to the created ArithSeries object. + * A NULL pointer of the range is invalid. * * Side Effects: - * None. + * None. * *---------------------------------------------------------------------- */ @@ -425,7 +422,7 @@ NewArithSeriesInt( arithSeriesObj->internalRep.twoPtrValue.ptr2 = NULL; arithSeriesObj->typePtr = &arithSeriesType; if (length > 0) { - Tcl_InvalidateStringRep(arithSeriesObj); + Tcl_InvalidateStringRep(arithSeriesObj); } return arithSeriesObj; @@ -440,16 +437,13 @@ NewArithSeriesInt( * refcount = 0. * * Results: - * - * A Tcl_Obj pointer to the created ArithSeries object. - * A NULL pointer of the range is invalid. + * A Tcl_Obj pointer to the created ArithSeries object. + * A NULL pointer of the range is invalid. * * Side Effects: - * - * None. + * None. *---------------------------------------------------------------------- */ - static Tcl_Obj * NewArithSeriesDbl( double start, @@ -485,7 +479,7 @@ NewArithSeriesDbl( arithSeriesObj->typePtr = &arithSeriesType; if (length > 0) { - Tcl_InvalidateStringRep(arithSeriesObj); + Tcl_InvalidateStringRep(arithSeriesObj); } return arithSeriesObj; @@ -501,17 +495,15 @@ NewArithSeriesDbl( * refcount = 0. * * Results: - * - * A Tcl_Obj pointer. - * No assignment on error. + * A Tcl_Obj pointer. No assignment on error. * * Side Effects: - * - * None. + * None. *---------------------------------------------------------------------- */ -static void +static int assignNumber( + Tcl_Interp *interp, int useDoubles, Tcl_WideInt *intNumberPtr, double *dblNumberPtr, @@ -520,9 +512,15 @@ assignNumber( void *clientData; int tcl_number_type; - if (Tcl_GetNumberFromObj(NULL, numberObj, &clientData, &tcl_number_type) != TCL_OK - || tcl_number_type == TCL_NUMBER_BIG) { - return; + if (Tcl_GetNumberFromObj(interp, numberObj, &clientData, + &tcl_number_type) != TCL_OK) { + return TCL_ERROR; + } + if (tcl_number_type == TCL_NUMBER_BIG) { + /* bignum is not supported yet. */ + Tcl_WideInt w; + (void)Tcl_GetWideIntFromObj(interp, numberObj, &w); + return TCL_ERROR; } if (useDoubles) { if (tcl_number_type != TCL_NUMBER_INT) { @@ -537,6 +535,7 @@ assignNumber( *intNumberPtr = (Tcl_WideInt)*(double *)clientData; } } + return TCL_OK; } /* @@ -549,20 +548,16 @@ assignNumber( * refcount = 0. * * Results: - * - * A Tcl_Obj pointer to the created ArithSeries object. - * An empty Tcl_Obj if the range is invalid. + * A Tcl_Obj pointer to the created ArithSeries object. + * NULL if the range is invalid. * * Side Effects: - * - * None. + * None. *---------------------------------------------------------------------- */ - -int +Tcl_Obj * TclNewArithSeriesObj( Tcl_Interp *interp, /* For error reporting */ - Tcl_Obj **arithSeriesObj, /* return value */ int useDoubles, /* Flag indicates values start, ** end, step, are treated as doubles */ Tcl_Obj *startObj, /* Starting value */ @@ -573,31 +568,38 @@ TclNewArithSeriesObj( double dstart, dend, dstep; Tcl_WideInt start, end, step; Tcl_WideInt len = -1; + Tcl_Obj *objPtr; if (startObj) { - assignNumber(useDoubles, &start, &dstart, startObj); + if (assignNumber(interp, useDoubles, &start, &dstart, startObj) != TCL_OK) { + return NULL; + } } else { start = 0; dstart = start; } if (stepObj) { - assignNumber(useDoubles, &step, &dstep, stepObj); + if (assignNumber(interp, useDoubles, &step, &dstep, stepObj) != TCL_OK) { + return NULL; + } if (useDoubles) { step = dstep; } else { dstep = step; } if (dstep == 0) { - TclNewObj(*arithSeriesObj); - return TCL_OK; + TclNewObj(objPtr); + return objPtr; } } if (endObj) { - assignNumber(useDoubles, &end, &dend, endObj); + if (assignNumber(interp, useDoubles, &end, &dend, endObj) != TCL_OK) { + return NULL; + } } if (lenObj) { if (TCL_OK != Tcl_GetWideIntFromObj(interp, lenObj, &len)) { - return TCL_ERROR; + return NULL; } } @@ -641,15 +643,13 @@ TclNewArithSeriesObj( Tcl_SetObjResult(interp, Tcl_NewStringObj( "max length of a Tcl list exceeded", TCL_AUTO_LENGTH)); Tcl_SetErrorCode(interp, "TCL", "MEMORY", (void *)NULL); - return TCL_ERROR; + return NULL; } - if (arithSeriesObj) { - *arithSeriesObj = (useDoubles) + objPtr = (useDoubles) ? NewArithSeriesDbl(dstart, dend, dstep, len) : NewArithSeriesInt(start, end, step, len); - } - return TCL_OK; + return objPtr; } /* @@ -664,13 +664,11 @@ TclNewArithSeriesObj( * element is stored in *element. * * Results: - * - * TCL_OK on success. + * TCL_OK on success. * * Side Effects: - * - * On success, the integer pointed by *element is modified. - * An empty string ("") is assigned if index is out-of-bounds. + * On success, the integer pointed by *element is modified. + * An empty string ("") is assigned if index is out-of-bounds. * *---------------------------------------------------------------------- */ @@ -705,12 +703,10 @@ TclArithSeriesObjIndex( * Returns the length of the arithmetic series. * * Results: - * - * The length of the series as Tcl_WideInt. + * The length of the series as Tcl_WideInt. * * Side Effects: - * - * None. + * None. * *---------------------------------------------------------------------- */ @@ -732,13 +728,11 @@ ArithSeriesObjLength( * refcount = 0. * * Results: - * - * A Tcl_Obj pointer to the created ArithSeries object. - * A NULL pointer of the range is invalid. + * A Tcl_Obj pointer to the created ArithSeries object. + * A NULL pointer of the range is invalid. * * Side Effects: - * - * None. + * None. *---------------------------------------------------------------------- */ @@ -762,19 +756,17 @@ TclArithSeriesObjStep( * * SetArithSeriesFromAny -- * - * The Arithmetic Series object is just an way to optimize - * Lists space complexity, so no one should try to convert - * a string to an Arithmetic Series object. + * The Arithmetic Series object is just an way to optimize + * Lists space complexity, so no one should try to convert + * a string to an Arithmetic Series object. * - * This function is here just to populate the Type structure. + * This function is here just to populate the Type structure. * * Results: - * - * The result is always TCL_ERROR. But see Side Effects. + * The result is always TCL_ERROR. But see Side Effects. * * Side effects: - * - * Tcl Panic if called. + * Tcl Panic if called. * *---------------------------------------------------------------------- */ @@ -852,14 +844,14 @@ TclArithSeriesObjRange( TclArithSeriesObjStep(arithSeriesObj, &stepObj); Tcl_IncrRefCount(stepObj); - if (Tcl_IsShared(arithSeriesObj) || (arithSeriesObj->refCount > 1)) { - int status = TclNewArithSeriesObj(NULL, newObjPtr, - arithSeriesRepPtr->isDouble, startObj, endObj, stepObj, NULL); - + if (Tcl_IsShared(arithSeriesObj) || ((arithSeriesObj->refCount > 1))) { + Tcl_Obj *newSlicePtr = TclNewArithSeriesObj(interp, + arithSeriesRepPtr->isDouble, startObj, endObj, stepObj, NULL); + *newObjPtr = newSlicePtr; Tcl_DecrRefCount(startObj); Tcl_DecrRefCount(endObj); Tcl_DecrRefCount(stepObj); - return status; + return newSlicePtr ? TCL_OK : TCL_ERROR; } /* @@ -1063,10 +1055,8 @@ TclArithSeriesObjReverse( Tcl_Obj *lenObj; TclNewIntObj(lenObj, len); - if (TclNewArithSeriesObj(NULL, &resultObj, isDouble, - startObj, endObj, stepObj, lenObj) != TCL_OK) { - resultObj = NULL; - } + resultObj = TclNewArithSeriesObj(interp, isDouble, + startObj, endObj, stepObj, lenObj); Tcl_DecrRefCount(lenObj); } else { /* @@ -1097,7 +1087,7 @@ TclArithSeriesObjReverse( *newObjPtr = resultObj; - return TCL_OK; + return resultObj ? TCL_OK : TCL_ERROR; } /* @@ -1119,11 +1109,11 @@ TclArithSeriesObjReverse( * should not be NULL and we assume it is not NULL. * * Notes: - * At the cost of overallocation it's possible to estimate - * the length of the string representation and make this procedure - * much faster. Because the programmer shouldn't expect the - * string conversion of a big arithmetic sequence to be fast - * this version takes more care of space than time. + * At the cost of overallocation it's possible to estimate + * the length of the string representation and make this procedure + * much faster. Because the programmer shouldn't expect the + * string conversion of a big arithmetic sequence to be fast + * this version takes more care of space than time. * *---------------------------------------------------------------------- */ diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index 1d09317..7283b0a 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -51,7 +51,7 @@ typedef enum BasicBlockCatchState { BBCS_UNKNOWN = 0, /* Catch context has not yet been identified */ BBCS_NONE, /* Block is outside of any catch */ BBCS_INCATCH, /* Block is within a catch context */ - BBCS_CAUGHT /* Block is within a catch context and + BBCS_CAUGHT /* Block is within a catch context and * may be executed after an exception fires */ } BasicBlockCatchState; @@ -1930,7 +1930,7 @@ MoveExceptionRangesToBasicBlock( curr_bb->foreignExceptionBase = savedExceptArrayNext; curr_bb->foreignExceptionCount = exceptionCount; curr_bb->foreignExceptions = - (ExceptionRange*)Tcl_Alloc(exceptionCount * sizeof(ExceptionRange)); + (ExceptionRange*)Tcl_Alloc(exceptionCount * sizeof(ExceptionRange)); memcpy(curr_bb->foreignExceptions, envPtr->exceptArrayPtr + savedExceptArrayNext, exceptionCount * sizeof(ExceptionRange)); diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 16721b1..dfed030 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -319,7 +319,7 @@ static const CmdInfo builtInCmds[] = { {"break", Tcl_BreakObjCmd, TclCompileBreakCmd, NULL, CMD_IS_SAFE}, {"catch", Tcl_CatchObjCmd, TclCompileCatchCmd, TclNRCatchObjCmd, CMD_IS_SAFE}, {"concat", Tcl_ConcatObjCmd, TclCompileConcatCmd, NULL, CMD_IS_SAFE}, - {"const", Tcl_ConstObjCmd, TclCompileConstCmd, NULL, CMD_IS_SAFE}, + {"const", Tcl_ConstObjCmd, TclCompileConstCmd, NULL, CMD_IS_SAFE}, {"continue", Tcl_ContinueObjCmd, TclCompileContinueCmd, NULL, CMD_IS_SAFE}, {"coroinject", NULL, NULL, TclNRCoroInjectObjCmd, CMD_IS_SAFE}, {"coroprobe", NULL, NULL, TclNRCoroProbeObjCmd, CMD_IS_SAFE}, @@ -345,7 +345,7 @@ static const CmdInfo builtInCmds[] = { {"lmap", Tcl_LmapObjCmd, TclCompileLmapCmd, TclNRLmapCmd, CMD_IS_SAFE}, {"lpop", Tcl_LpopObjCmd, NULL, NULL, CMD_IS_SAFE}, {"lrange", Tcl_LrangeObjCmd, TclCompileLrangeCmd, NULL, CMD_IS_SAFE}, - {"lremove", Tcl_LremoveObjCmd, NULL, NULL, CMD_IS_SAFE}, + {"lremove", Tcl_LremoveObjCmd, NULL, NULL, CMD_IS_SAFE}, {"lrepeat", Tcl_LrepeatObjCmd, NULL, NULL, CMD_IS_SAFE}, {"lreplace", Tcl_LreplaceObjCmd, TclCompileLreplaceCmd, NULL, CMD_IS_SAFE}, {"lreverse", Tcl_LreverseObjCmd, NULL, NULL, CMD_IS_SAFE}, @@ -433,6 +433,7 @@ static const UnsafeEnsembleInfo unsafeEnsembleCommands[] = { {"file", "executable"}, {"file", "exists"}, {"file", "extension"}, + {"file", "home"}, {"file", "isdirectory"}, {"file", "isfile"}, {"file", "link"}, @@ -451,6 +452,7 @@ static const UnsafeEnsembleInfo unsafeEnsembleCommands[] = { {"file", "tail"}, {"file", "tempdir"}, {"file", "tempfile"}, + {"file", "tildeexpand"}, {"file", "type"}, {"file", "volumes"}, {"file", "writable"}, @@ -749,7 +751,7 @@ buildInfoObjCmd2( p += len; q = strchr(++p, '.'); if (!q) { - q = p + strlen(p); + q = p + strlen(p); } memcpy(buf, p, q - p); buf[q - p] = '\0'; @@ -8868,7 +8870,7 @@ TclNRTailcallObjCmd( nsObjPtr = Tcl_NewStringObj(nsPtr->fullName, TCL_INDEX_NONE); listPtr = Tcl_NewListObj(objc, objv); - TclListObjSetElement(interp, listPtr, 0, nsObjPtr); + TclListObjSetElement(interp, listPtr, 0, nsObjPtr); iPtr->varFramePtr->tailcallPtr = listPtr; } diff --git a/generic/tclClock.c b/generic/tclClock.c index 3b07b51..2496243 100644 --- a/generic/tclClock.c +++ b/generic/tclClock.c @@ -128,7 +128,7 @@ struct ClockCommand { * to it, but may well ignore this data. */ CompileProc *compileProc; /* The compiler for the command. */ void *clientData; /* Any clientData to give the command (if NULL - * a reference to ClockClientData will be sent) */ + * a reference to ClockClientData will be sent) */ }; static const struct ClockCommand clockCommands[] = { @@ -257,7 +257,7 @@ TclClockInit( #define TCL_CLOCK_PREFIX_LEN 14 /* == strlen("::tcl::clock::") */ memcpy(cmdName, "::tcl::clock::", TCL_CLOCK_PREFIX_LEN); for (clockCmdPtr=clockCommands ; clockCmdPtr->name!=NULL ; clockCmdPtr++) { - void *clientData; + void *clientData; strcpy(cmdName + TCL_CLOCK_PREFIX_LEN, clockCmdPtr->name); if (!(clientData = clockCmdPtr->clientData)) { @@ -438,7 +438,7 @@ NormTimezoneObj( } if (timezoneObj == dataPtr->prevSetupTimeZoneUnnorm && dataPtr->prevSetupTimeZone != NULL) { - return dataPtr->prevSetupTimeZone; + return dataPtr->prevSetupTimeZone; } if (timezoneObj == dataPtr->gmtSetupTimeZoneUnnorm && dataPtr->gmtSetupTimeZone != NULL) { @@ -648,7 +648,7 @@ NormLocaleObj( if ((localeObj->length == 1 /* C */ && strcasecmp(loc, Literals[LIT_C]) == 0) || (dataPtr->defaultLocale && (loc2 = TclGetString(dataPtr->defaultLocale)) - && localeObj->length == dataPtr->defaultLocale->length + && localeObj->length == dataPtr->defaultLocale->length && strcasecmp(loc, loc2) == 0)) { *mcDictObj = dataPtr->defaultLocaleDict; return dataPtr->defaultLocale ? @@ -1323,8 +1323,8 @@ ClockSetupTimeZone( /* before setup just take a look in TZData variable */ if (Tcl_ObjGetVar2(interp, dataPtr->literals[LIT_TZDATA], timezoneObj, 0)) { - /* put it to last slot and return normalized */ - TimezoneLoaded(dataPtr, callargs[1], timezoneObj); + /* put it to last slot and return normalized */ + TimezoneLoaded(dataPtr, callargs[1], timezoneObj); return callargs[1]; } /* setup now */ @@ -3305,10 +3305,10 @@ ClockParseFmtScnArgs( Tcl_WideInt baseVal; /* Base time, expressed in seconds from the Epoch */ if (operation == CLC_OP_SCN) { - /* default flags (from configure) */ - opts->flags |= dataPtr->defFlags & CLF_VALIDATE; + /* default flags (from configure) */ + opts->flags |= dataPtr->defFlags & CLF_VALIDATE; } else { - /* clock value (as current base) */ + /* clock value (as current base) */ opts->baseObj = objv[(baseIdx = 1)]; saw |= 1 << CLC_ARGS_BASE; } diff --git a/generic/tclClockFmt.c b/generic/tclClockFmt.c index b3401a0..0dfc9bb 100644 --- a/generic/tclClockFmt.c +++ b/generic/tclClockFmt.c @@ -22,20 +22,28 @@ static void ClockFmtObj_DupInternalRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr); static void ClockFmtObj_FreeInternalRep(Tcl_Obj *objPtr); static int ClockFmtObj_SetFromAny(Tcl_Interp *, Tcl_Obj *objPtr); static void ClockFmtObj_UpdateString(Tcl_Obj *objPtr); +static Tcl_HashEntry * ClockFmtScnStorageAllocProc(Tcl_HashTable *, void *keyPtr); +static void ClockFmtScnStorageFreeProc(Tcl_HashEntry *hPtr); +static void ClockFmtScnStorageDelete(ClockFmtScnStorage *fss); TCL_DECLARE_MUTEX(ClockFmtMutex); /* Serializes access to common format list. */ -static void ClockFmtScnStorageDelete(ClockFmtScnStorage *fss); - #ifndef TCL_CLOCK_FULL_COMPAT #define TCL_CLOCK_FULL_COMPAT 1 #endif /* - * Derivation of tclStringHashKeyType with another allocEntryProc + * Derivation of tclStringHashKeyType with extra memory management trickery. */ -static Tcl_HashKeyType ClockFmtScnStorageHashKeyType; +static const Tcl_HashKeyType ClockFmtScnStorageHashKeyType = { + TCL_HASH_KEY_TYPE_VERSION, /* version */ + 0, /* flags */ + TclHashStringKey, /* hashKeyProc */ + TclCompareStringKeys, /* compareKeysProc */ + ClockFmtScnStorageAllocProc, /* allocEntryProc */ + ClockFmtScnStorageFreeProc /* freeEntryProc */ +}; #define IntFieldAt(info, offset) \ ((int *) (((char *) (info)) + (offset))) @@ -543,7 +551,7 @@ FmtScn4HashEntry( static Tcl_HashEntry * ClockFmtScnStorageAllocProc( - TCL_UNUSED(Tcl_HashTable *), /* Hash table. */ + TCL_UNUSED(Tcl_HashTable *),/* Hash table. */ void *keyPtr) /* Key to store in the hash table entry. */ { ClockFmtScnStorage *fss; @@ -758,7 +766,7 @@ ClockFmtObj_UpdateString( * Returns tcl object with key or format object if not localizable. * * Side effects: - * Converts given format object to ClockFmtObjType on demand for caching + * Converts given format object to ClockFmtObjType on demand for caching * the key inside its internal representation. * *---------------------------------------------------------------------- @@ -804,7 +812,7 @@ ClockFrmObjGetLocFmtKey( * Returns scan/format storage pointer to ClockFmtScnStorage. * * Side effects: - * Converts given format object to ClockFmtObjType on demand for caching + * Converts given format object to ClockFmtObjType on demand for caching * the format storage reference inside its internal representation. * Increments objRefCount of the ClockFmtScnStorage reference. * @@ -825,11 +833,6 @@ FindOrCreateFmtScnStorage( /* if not yet initialized */ if (!initialized) { - /* initialize type */ - memcpy(&ClockFmtScnStorageHashKeyType, &tclStringHashKeyType, sizeof(tclStringHashKeyType)); - ClockFmtScnStorageHashKeyType.allocEntryProc = ClockFmtScnStorageAllocProc; - ClockFmtScnStorageHashKeyType.freeEntryProc = ClockFmtScnStorageFreeProc; - /* initialize hash table */ Tcl_InitCustomHashTable(&FmtScnHashTable, TCL_CUSTOM_TYPE_KEYS, &ClockFmtScnStorageHashKeyType); @@ -1241,9 +1244,13 @@ ObjListSearch( /* currently unused */ static int -LocaleListSearch(ClockFmtScnCmdArgs *opts, - DateInfo *info, int mcKey, int *val, - int minLen, int maxLen) +LocaleListSearch( + ClockFmtScnCmdArgs *opts, + DateInfo *info, + int mcKey, + int *val, + int minLen, + int maxLen) { Tcl_Obj **lstv; Tcl_Size lstc; @@ -1416,7 +1423,7 @@ ClockMCGetMultiListIdxTree( * Results: * TCL_OK - match found and the index stored in *val, * TCL_RETURN - not matched or ambigous, - * TCL_ERROR - in error case. + * TCL_ERROR - in error case. * * Side effects: * Input points to end of the found token in string. @@ -1770,7 +1777,7 @@ ClockScnToken_JDN_Proc( } s = p; while (p < end && isdigit(UCHAR(*p))) { - fractJDDiv *= 10; + fractJDDiv *= 10; p++; } if (Clock_str2int(&fractJD, s, p, 1) != TCL_OK) { @@ -2649,7 +2656,7 @@ ClockScan( } if (flags & (CLF_ISO8601WEEK | CLF_ISO8601YEAR)) { if ((flags & (CLF_ISO8601YEAR | CLF_YEAR)) == CLF_YEAR) { - /* for calculations expected iso year */ + /* for calculations expected iso year */ info->date.iso8601Year = yyYear; } else if (info->date.iso8601Year < 100) { if (!(flags & CLF_ISO8601CENTURY)) { @@ -2662,7 +2669,7 @@ ClockScan( } } if ((flags & (CLF_ISO8601YEAR | CLF_YEAR)) == CLF_ISO8601YEAR) { - /* for calculations expected year (e. g. CLF_ISO8601WEEK not set) */ + /* for calculations expected year (e. g. CLF_ISO8601WEEK not set) */ yyYear = info->date.iso8601Year; } } @@ -2862,7 +2869,7 @@ ClockFmtToken_JDN_Proc( fractJD = dateFmt->date.secondOfDay - (int)tok->map->offs; /* 0 for calendar or 43200 for astro JD */ if (fractJD < 0) { - intJD--; + intJD--; fractJD += SECONDS_PER_DAY; } if (fractJD && intJD < 0) { /* avoid jump over 0, by negative JD's */ diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index d2f30dd..cab20b8 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -30,7 +30,7 @@ struct ForeachState { Tcl_Size j, maxj; /* Number of loop iterations. */ Tcl_Size numLists; /* Count of value lists. */ Tcl_Size *index; /* Array of value list indices. */ - Tcl_Size *varcList; /* # loop variables per list. */ + Tcl_Size *varcList; /* # loop variables per list. */ Tcl_Obj ***varvList; /* Array of var name lists. */ Tcl_Obj **vCopyList; /* Copies of var name list arguments. */ Tcl_Size *argcList; /* Array of value list sizes. */ diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index 83320cd..e2ea401 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -102,15 +102,11 @@ typedef struct { static const char *const seq_operations[] = { "..", "to", "count", "by", NULL }; -typedef enum Sequence_Operators { +typedef enum { LSEQ_DOTS, LSEQ_TO, LSEQ_COUNT, LSEQ_BY } SequenceOperators; -static const char *const seq_step_keywords[] = {"by", NULL}; -typedef enum Step_Operators { - STEP_BY = 4 -} SequenceByMode; -typedef enum Sequence_Decoded { - NoneArg, NumericArg, RangeKeywordArg, ByKeywordArg +typedef enum { + NoneArg, NumericArg, RangeKeywordArg, ErrArg, LastArg = 8 } SequenceDecoded; /* @@ -4027,81 +4023,67 @@ Tcl_LsearchObjCmd( * 3 - value is a by keyword * * The decoded value will be assigned to the appropriate - * pointer, if supplied. + * pointer, numValuePtr reference count is incremented. */ static SequenceDecoded SequenceIdentifyArgument( Tcl_Interp *interp, /* for error reporting */ Tcl_Obj *argPtr, /* Argument to decode */ + int allowedArgs, /* Flags if keyword or numeric allowed. */ Tcl_Obj **numValuePtr, /* Return numeric value */ int *keywordIndexPtr) /* Return keyword enum */ { - int status; + int result = TCL_ERROR; SequenceOperators opmode; - SequenceByMode bymode; - void *clientData; + void *internalPtr; - status = Tcl_GetNumberFromObj(NULL, argPtr, &clientData, keywordIndexPtr); - if (status == TCL_OK) { - if (numValuePtr) { - *numValuePtr = argPtr; + if (allowedArgs & NumericArg) { + /* speed-up a bit (and avoid shimmer for compiled expressions) */ + if (TclHasInternalRep(argPtr, &tclExprCodeType)) { + goto doExpr; } - return NumericArg; - } else { - /* Check for an index expression */ - long value; - double dvalue; - Tcl_Obj *exprValueObj; - int keyword; - Tcl_InterpState savedstate; - savedstate = Tcl_SaveInterpState(interp, status); - if (Tcl_ExprLongObj(interp, argPtr, &value) != TCL_OK) { - status = Tcl_RestoreInterpState(interp, savedstate); - exprValueObj = argPtr; - } else { - // Determine if expression is double or int - if (Tcl_ExprDoubleObj(interp, argPtr, &dvalue) != TCL_OK) { - keyword = TCL_NUMBER_INT; - exprValueObj = argPtr; - } else { - if (floor(dvalue) == dvalue) { - TclNewIntObj(exprValueObj, value); - keyword = TCL_NUMBER_INT; - } else { - TclNewDoubleObj(exprValueObj, dvalue); - keyword = TCL_NUMBER_DOUBLE; - } - } - status = Tcl_RestoreInterpState(interp, savedstate); - if (numValuePtr) { - *numValuePtr = exprValueObj; - } - if (keywordIndexPtr) { - *keywordIndexPtr = keyword ;// type of expression result - } + result = Tcl_GetNumberFromObj(NULL, argPtr, &internalPtr, keywordIndexPtr); + if (result == TCL_OK) { + *numValuePtr = argPtr; + Tcl_IncrRefCount(argPtr); return NumericArg; } } - - status = Tcl_GetIndexFromObj(NULL, argPtr, seq_operations, - "range operation", 0, &opmode); - if (status == TCL_OK) { - if (keywordIndexPtr) { - *keywordIndexPtr = opmode; + if (allowedArgs & RangeKeywordArg) { + result = Tcl_GetIndexFromObj(NULL, argPtr, seq_operations, + "range operation", 0, &opmode); + } + if (result == TCL_OK) { + if (allowedArgs & LastArg) { + /* keyword found, but no followed number */ + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "missing \"%s\" value.", TclGetString(argPtr))); + return ErrArg; } + *keywordIndexPtr = opmode; return RangeKeywordArg; - } - - status = Tcl_GetIndexFromObj(NULL, argPtr, seq_step_keywords, - "step keyword", 0, &bymode); - if (status == TCL_OK) { - if (keywordIndexPtr) { - *keywordIndexPtr = bymode; + } else { + Tcl_Obj *exprValueObj; + if (!(allowedArgs & NumericArg)) { + return NoneArg; + } + doExpr: + /* Check for an index expression */ + if (Tcl_ExprObj(interp, argPtr, &exprValueObj) != TCL_OK) { + return ErrArg; } - return ByKeywordArg; + int keyword; + /* Determine if result of expression is double or int */ + if (Tcl_GetNumberFromObj(interp, exprValueObj, &internalPtr, + &keyword) != TCL_OK + ) { + return ErrArg; + } + *numValuePtr = exprValueObj; /* incremented in Tcl_ExprObj */ + *keywordIndexPtr = keyword; /* type of expression result */ + return NumericArg; } - return NoneArg; } /* @@ -4152,14 +4134,15 @@ Tcl_LseqObjCmd( Tcl_WideInt values[5]; Tcl_Obj *numValues[5]; Tcl_Obj *numberObj; - int status = TCL_ERROR, keyword, useDoubles = 0; + int status = TCL_ERROR, keyword, useDoubles = 0, allowedArgs = NumericArg; + int remNums = 3; Tcl_Obj *arithSeriesPtr; SequenceOperators opmode; SequenceDecoded decoded; int i, arg_key = 0, value_i = 0; - // Default constants - Tcl_Obj *zero = Tcl_NewIntObj(0); - Tcl_Obj *one = Tcl_NewIntObj(1); + /* Default constants */ + #define zero ((Interp *)interp)->execEnvPtr->constants[0]; + #define one ((Interp *)interp)->execEnvPtr->constants[1]; /* * Create a decoding key by looping through the arguments and identify @@ -4167,49 +4150,50 @@ Tcl_LseqObjCmd( * digit. */ if (objc > 6) { - /* Too many arguments */ - arg_key=0; - } else for (i=1; i<objc; i++) { - arg_key = (arg_key * 10); - numValues[value_i] = NULL; - decoded = SequenceIdentifyArgument(interp, objv[i], &numberObj, &keyword); - switch (decoded) { - - case NoneArg: - /* - * Unrecognizable argument - * Reproduce operation error message - */ - status = Tcl_GetIndexFromObj(interp, objv[i], seq_operations, - "operation", 0, &opmode); - goto done; - - case NumericArg: - arg_key += NumericArg; - numValues[value_i] = numberObj; - Tcl_IncrRefCount(numValues[value_i]); - values[value_i] = keyword; // This is the TCL_NUMBER_* value - useDoubles = useDoubles ? useDoubles : keyword == TCL_NUMBER_DOUBLE; - value_i++; - break; - - case RangeKeywordArg: - arg_key += RangeKeywordArg; - values[value_i] = keyword; - value_i++; - break; - - case ByKeywordArg: - arg_key += ByKeywordArg; - values[value_i] = keyword; - value_i++; - break; - - default: - arg_key += 9; // Error state - value_i++; - break; - } + /* Too many arguments */ + goto syntax; + } + for (i = 1; i < objc; i++) { + arg_key = (arg_key * 10); + numValues[value_i] = NULL; + decoded = SequenceIdentifyArgument(interp, objv[i], + allowedArgs | (i == objc-1 ? LastArg : 0), + &numberObj, &keyword); + switch (decoded) { + case NoneArg: + /* + * Unrecognizable argument + * Reproduce operation error message + */ + status = Tcl_GetIndexFromObj(interp, objv[i], seq_operations, + "operation", 0, &opmode); + goto done; + + case NumericArg: + remNums--; + arg_key += NumericArg; + allowedArgs = RangeKeywordArg; + /* if last number but 2 arguments remain, next is not numeric */ + if ((remNums != 1) || ((objc-1-i) != 2)) { + allowedArgs |= NumericArg; + } + numValues[value_i] = numberObj; + values[value_i] = keyword; /* TCL_NUMBER_* */ + useDoubles |= (keyword == TCL_NUMBER_DOUBLE) ? 1 : 0; + value_i++; + break; + + case RangeKeywordArg: + arg_key += RangeKeywordArg; + allowedArgs = NumericArg; /* after keyword always numeric only */ + values[value_i] = keyword; /* SequenceOperators */ + value_i++; + break; + + default: /* Error state */ + status = TCL_ERROR; + goto done; + } } /* @@ -4218,13 +4202,6 @@ Tcl_LseqObjCmd( */ switch (arg_key) { -/* No argument */ - case 0: - Tcl_WrongNumArgs(interp, 1, objv, - "n ??op? n ??by? n??"); - goto done; - break; - /* lseq n */ case 1: start = zero; @@ -4346,46 +4323,44 @@ Tcl_LseqObjCmd( } break; -/* Error cases: incomplete arguments */ - case 12: - opmode = (SequenceOperators)values[1]; goto KeywordError; break; - case 112: - opmode = (SequenceOperators)values[2]; goto KeywordError; break; - case 1212: - opmode = (SequenceOperators)values[3]; goto KeywordError; break; - KeywordError: - switch (opmode) { - case LSEQ_DOTS: - case LSEQ_TO: - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "missing \"to\" value.")); - break; - case LSEQ_COUNT: - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "missing \"count\" value.")); - break; - case LSEQ_BY: - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "missing \"by\" value.")); - break; - } - goto done; - break; - /* All other argument errors */ default: + syntax: Tcl_WrongNumArgs(interp, 1, objv, "n ??op? n ??by? n??"); goto done; break; } + /* Count needs to be integer, so try to convert if possible */ + if (elementCount && TclHasInternalRep(elementCount, &tclDoubleType)) { + double d; + (void)Tcl_GetDoubleFromObj(NULL, elementCount, &d); + if (floor(d) == d) { + if ((d >= (double)WIDE_MAX) || (d <= (double)WIDE_MIN)) { + mp_int big; + + if (Tcl_InitBignumFromDouble(NULL, d, &big) == TCL_OK) { + elementCount = Tcl_NewBignumObj(&big); + keyword = TCL_NUMBER_INT; + } + /* Infinity, don't convert, let fail later */ + } else { + elementCount = Tcl_NewWideIntObj((Tcl_WideInt)d); + keyword = TCL_NUMBER_INT; + } + } + } + + /* * Success! Now lets create the series object. */ - status = TclNewArithSeriesObj(interp, &arithSeriesPtr, + arithSeriesPtr = TclNewArithSeriesObj(interp, useDoubles, start, end, step, elementCount); - if (status == TCL_OK) { + status = TCL_ERROR; + if (arithSeriesPtr) { + status = TCL_OK; Tcl_SetObjResult(interp, arithSeriesPtr); } @@ -4393,13 +4368,19 @@ Tcl_LseqObjCmd( // Free number arguments. while (--value_i>=0) { if (numValues[value_i]) { + if (elementCount == numValues[value_i]) { + elementCount = NULL; + } Tcl_DecrRefCount(numValues[value_i]); } } + if (elementCount) { + Tcl_DecrRefCount(elementCount); + } - // Free constants - Tcl_DecrRefCount(zero); - Tcl_DecrRefCount(one); + /* Undef constants */ + #undef zero + #undef one return status; } diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 2a9d316..a36e349 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -2765,9 +2765,9 @@ StringCmpOpts( return TCL_ERROR; } if ((Tcl_WideUInt)wreqlength > TCL_SIZE_MAX) { - *reqlength = -1; + *reqlength = -1; } else { - *reqlength = wreqlength; + *reqlength = wreqlength; } } else { Tcl_SetObjResult(interp, Tcl_ObjPrintf( diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 6d3eabd..001310b 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -379,9 +379,9 @@ TclCompileArraySetCmd( localIndex = TclFindCompiledLocal(varTokenPtr->start, varTokenPtr->size, 1, envPtr); PushStringLiteral(envPtr, "0"); - TclEmitInstInt4(INST_REVERSE, 2, envPtr); - TclEmitInstInt4(INST_UPVAR, localIndex, envPtr); - TclEmitOpcode(INST_POP, envPtr); + TclEmitInstInt4(INST_REVERSE, 2, envPtr); + TclEmitInstInt4(INST_UPVAR, localIndex, envPtr); + TclEmitOpcode(INST_POP, envPtr); } /* @@ -3415,10 +3415,10 @@ TclCompileFormatCmd( * to a local scalar variable name. * * Results: - * Returns the non-negative integer index value into the table of - * compiled locals corresponding to a local scalar variable name. - * If the arguments passed in do not identify a local scalar variable - * then return TCL_INDEX_NONE. + * Returns the non-negative integer index value into the table of + * compiled locals corresponding to a local scalar variable name. + * If the arguments passed in do not identify a local scalar variable + * then return TCL_INDEX_NONE. * * Side effects: * May add an entry into the table of compiled locals. diff --git a/generic/tclCompile.h b/generic/tclCompile.h index a20f81e..0a9f2a3 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -34,7 +34,7 @@ struct ByteCode; /* Forward declaration. */ * This variable is linked to the Tcl variable "tcl_traceCompile". */ -MODULE_SCOPE int tclTraceCompile; +MODULE_SCOPE int tclTraceCompile; /* * Variable that controls whether execution tracing is enabled and, if so, @@ -46,7 +46,7 @@ MODULE_SCOPE int tclTraceCompile; * This variable is linked to the Tcl variable "tcl_traceExec". */ -MODULE_SCOPE int tclTraceExec; +MODULE_SCOPE int tclTraceExec; #endif /* @@ -325,13 +325,13 @@ typedef struct CompileEnv { * exceptArrayPtr points in heap, else 0. */ #endif LiteralEntry *literalArrayPtr; - /* Points to start of LiteralEntry array. */ + /* Points to start of LiteralEntry array. */ Tcl_Size literalArrayNext; /* Index of next free object array entry. */ Tcl_Size literalArrayEnd; /* Index just after last obj array entry. */ int mallocedLiteralArray; /* 1 if object array was expanded and objArray * points into the heap, else 0. */ ExceptionRange *exceptArrayPtr; - /* Points to start of the ExceptionRange + /* Points to start of the ExceptionRange * array. */ Tcl_Size exceptArrayNext; /* Next free ExceptionRange array index. * exceptArrayNext is the number of ranges and @@ -482,7 +482,7 @@ typedef struct ByteCode { * array. This is just after the last code * byte. */ ExceptionRange *exceptArrayPtr; - /* Points to the start of the ExceptionRange + /* Points to the start of the ExceptionRange * array. This is just after the last object * in the object array. */ AuxData *auxDataArrayPtr; /* Points to the start of the auxiliary data diff --git a/generic/tclDate.c b/generic/tclDate.c index a22168f..312a000 100644 --- a/generic/tclDate.c +++ b/generic/tclDate.c @@ -2649,7 +2649,7 @@ TclClockFreeScan( /* parse */ status = yyparse(info); if (status == 1) { - const char *msg = NULL; + const char *msg = NULL; if (info->errFlags & CLF_HAVEDATE) { msg = "more than one date in string"; } else if (info->errFlags & CLF_TIME) { diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index a0016df..ea989be 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -80,7 +80,7 @@ static const EnsembleImplMap implementationMap[] = { {"info", DictInfoCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0 }, {"keys", DictKeysCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0 }, {"lappend", DictLappendCmd, TclCompileDictLappendCmd, NULL, NULL, 0 }, - {"map", NULL, TclCompileDictMapCmd, DictMapNRCmd, NULL, 0 }, + {"map", NULL, TclCompileDictMapCmd, DictMapNRCmd, NULL, 0 }, {"merge", DictMergeCmd, TclCompileDictMergeCmd, NULL, NULL, 0 }, {"remove", DictRemoveCmd, TclCompileBasicMin1ArgCmd, NULL, NULL, 0 }, {"replace", DictReplaceCmd, NULL, NULL, NULL, 0 }, @@ -129,7 +129,7 @@ typedef struct Dict { * the dictionary. Used for doing traversal of * the entries in the order that they are * created. */ - size_t epoch; /* Epoch counter */ + size_t epoch; /* Epoch counter */ size_t refCount; /* Reference counter (see above) */ Tcl_Obj *chain; /* Linked list used for invalidating the * string representations of updated nested @@ -1058,7 +1058,8 @@ Tcl_DictObjRemove( */ Tcl_Size -TclDictGetSize(Tcl_Obj *dictPtr) +TclDictGetSize( + Tcl_Obj *dictPtr) { Dict *dict; DictGetInternalRep(dictPtr, dict); diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index 176838d..624705d 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -34,9 +34,9 @@ typedef struct { Tcl_EncodingFreeProc *freeProc; /* If non-NULL, function to call when this * encoding is deleted. */ - void *clientData; /* Arbitrary value associated with encoding + void *clientData; /* Arbitrary value associated with encoding * type. Passed to conversion functions. */ - Tcl_Size nullSize; /* Number of 0x00 bytes that signify + Tcl_Size nullSize; /* Number of 0x00 bytes that signify * end-of-string in this encoding. This number * is used to determine the source string * length when the srcLen argument is @@ -119,7 +119,8 @@ typedef struct { * entry in this array is 1, otherwise it is * 0. */ int numSubTables; /* Length of following array. */ - EscapeSubTable subTables[TCLFLEXARRAY];/* Information about each EscapeSubTable used + EscapeSubTable subTables[TCLFLEXARRAY]; + /* Information about each EscapeSubTable used * by this encoding type. The actual size is * as large as necessary to hold all * EscapeSubTables. */ @@ -201,19 +202,19 @@ static const struct TclEncodingProfiles { {"tcl8", TCL_ENCODING_PROFILE_TCL8}, }; -#define PROFILE_TCL8(flags_) \ +#define PROFILE_TCL8(flags_) \ (ENCODING_PROFILE_GET(flags_) == TCL_ENCODING_PROFILE_TCL8) -#define PROFILE_REPLACE(flags_) \ +#define PROFILE_REPLACE(flags_) \ (ENCODING_PROFILE_GET(flags_) == TCL_ENCODING_PROFILE_REPLACE) -#define PROFILE_STRICT(flags_) \ +#define PROFILE_STRICT(flags_) \ (!PROFILE_TCL8(flags_) && !PROFILE_REPLACE(flags_)) #define UNICODE_REPLACE_CHAR 0xFFFD -#define SURROGATE(c_) (((c_) & ~0x7FF) == 0xD800) -#define HIGH_SURROGATE(c_) (((c_) & ~0x3FF) == 0xD800) -#define LOW_SURROGATE(c_) (((c_) & ~0x3FF) == 0xDC00) +#define SURROGATE(c_) (((c_) & ~0x7FF) == 0xD800) +#define HIGH_SURROGATE(c_) (((c_) & ~0x3FF) == 0xD800) +#define LOW_SURROGATE(c_) (((c_) & ~0x3FF) == 0xDC00) /* * The following variable is used in the sparse matrix code for a @@ -259,9 +260,9 @@ static Tcl_EncodingConvertProc Iso88591FromUtfProc; static Tcl_EncodingConvertProc Iso88591ToUtfProc; /* - * A Tcl_ObjType for holding a cached Tcl_Encoding in the twoPtrValue.ptr1 field - * of the internalrep. This should help the lifetime of encodings be more useful. - * See concerns raised in [Bug 1077262]. + * A Tcl_ObjType for holding a cached Tcl_Encoding in the twoPtrValue.ptr1 + * field of the internalrep. This should help the lifetime of encodings be more + * useful. See concerns raised in [Bug 1077262]. */ static const Tcl_ObjType encodingType = { @@ -510,9 +511,13 @@ FillEncodingFileMap(void) * * To prevent conflicting bits, only define bits within 0xff00 mask here. */ -#define TCL_ENCODING_LE 0x100 /* Used to distinguish LE/BE variants */ -#define ENCODING_UTF 0x200 /* For UTF-8 encoding, allow 4-byte output sequences */ -#define ENCODING_INPUT 0x400 /* For UTF-8/CESU-8 encoding, means external -> internal */ +enum InternalEncodingFlags { + TCL_ENCODING_LE = 0x100, /* Used to distinguish LE/BE variants */ + ENCODING_UTF = 0x200, /* For UTF-8 encoding, allow 4-byte output + * sequences */ + ENCODING_INPUT = 0x400 /* For UTF-8/CESU-8 encoding, means + * external -> internal */ +}; void TclInitEncodingSubsystem(void) @@ -565,30 +570,30 @@ TclInitEncodingSubsystem(void) Tcl_CreateEncoding(&type); type.toUtfProc = Utf16ToUtfProc; - type.fromUtfProc = UtfToUcs2Proc; + type.fromUtfProc = UtfToUcs2Proc; type.freeProc = NULL; type.nullSize = 2; - type.encodingName = "ucs-2le"; + type.encodingName = "ucs-2le"; type.clientData = INT2PTR(TCL_ENCODING_LE); Tcl_CreateEncoding(&type); - type.encodingName = "ucs-2be"; + type.encodingName = "ucs-2be"; type.clientData = NULL; Tcl_CreateEncoding(&type); - type.encodingName = "ucs-2"; + type.encodingName = "ucs-2"; type.clientData = INT2PTR(leFlags); Tcl_CreateEncoding(&type); type.toUtfProc = Utf32ToUtfProc; - type.fromUtfProc = UtfToUtf32Proc; + type.fromUtfProc = UtfToUtf32Proc; type.freeProc = NULL; type.nullSize = 4; - type.encodingName = "utf-32le"; + type.encodingName = "utf-32le"; type.clientData = INT2PTR(TCL_ENCODING_LE); Tcl_CreateEncoding(&type); - type.encodingName = "utf-32be"; + type.encodingName = "utf-32be"; type.clientData = NULL; Tcl_CreateEncoding(&type); - type.encodingName = "utf-32"; + type.encodingName = "utf-32"; type.clientData = INT2PTR(leFlags); Tcl_CreateEncoding(&type); @@ -596,18 +601,18 @@ TclInitEncodingSubsystem(void) type.fromUtfProc = UtfToUtf16Proc; type.freeProc = NULL; type.nullSize = 2; - type.encodingName = "utf-16le"; + type.encodingName = "utf-16le"; type.clientData = INT2PTR(TCL_ENCODING_LE); Tcl_CreateEncoding(&type); - type.encodingName = "utf-16be"; + type.encodingName = "utf-16be"; type.clientData = NULL; Tcl_CreateEncoding(&type); - type.encodingName = "utf-16"; + type.encodingName = "utf-16"; type.clientData = INT2PTR(leFlags); Tcl_CreateEncoding(&type); #ifndef TCL_NO_DEPRECATED - type.encodingName = "unicode"; + type.encodingName = "unicode"; Tcl_CreateEncoding(&type); #endif @@ -924,7 +929,7 @@ Tcl_GetEncodingNames( * Tcl_GetEncodingNulLength -- * * Given an encoding, return the number of nul bytes used for the - * string termination. + * string termination. * * Results: * The number of nul bytes used for the string termination. @@ -1124,34 +1129,33 @@ Tcl_ExternalToUtfDString( * - *At most one* of TCL_ENCODING_PROFILE{DEFAULT,TCL8,STRICT} * * Results: - * The return value is one of - * TCL_OK: success. Converted string in *dstPtr - * TCL_ERROR: error in passed parameters. Error message in interp - * TCL_CONVERT_MULTIBYTE: source ends in truncated multibyte sequence - * TCL_CONVERT_SYNTAX: source is not conformant to encoding definition - * TCL_CONVERT_UNKNOWN: source contained a character that could not - * be represented in target encoding. + * The return value is one of + * TCL_OK: success. Converted string in *dstPtr + * TCL_ERROR: error in passed parameters. Error message in interp + * TCL_CONVERT_MULTIBYTE: source ends in truncated multibyte sequence + * TCL_CONVERT_SYNTAX: source is not conformant to encoding definition + * TCL_CONVERT_UNKNOWN: source contained a character that could not + * be represented in target encoding. * * Side effects: - * - * TCL_OK: The converted bytes are stored in the DString and NUL - * terminated in an encoding-specific manner. - * TCL_ERROR: an error, message is stored in the interp if not NULL. - * TCL_CONVERT_*: if errorLocPtr is NULL, an error message is stored - * in the interpreter (if not NULL). If errorLocPtr is not NULL, - * no error message is stored as it is expected the caller is - * interested in whatever is decoded so far and not treating this - * as an error condition. - * - * In addition, *dstPtr is always initialized and must be cleared - * by the caller irrespective of the return code. + * TCL_OK: The converted bytes are stored in the DString and NUL + * terminated in an encoding-specific manner. + * TCL_ERROR: an error, message is stored in the interp if not NULL. + * TCL_CONVERT_*: if errorLocPtr is NULL, an error message is stored + * in the interpreter (if not NULL). If errorLocPtr is not NULL, + * no error message is stored as it is expected the caller is + * interested in whatever is decoded so far and not treating this + * as an error condition. + * + * In addition, *dstPtr is always initialized and must be cleared + * by the caller irrespective of the return code. * *------------------------------------------------------------------------- */ int Tcl_ExternalToUtfDStringEx( - Tcl_Interp *interp, /* For error messages. May be NULL. */ + Tcl_Interp *interp, /* For error messages. May be NULL. */ Tcl_Encoding encoding, /* The encoding for the source string, or NULL * for the default system encoding. */ const char *src, /* Source string in specified encoding. */ @@ -1160,8 +1164,8 @@ Tcl_ExternalToUtfDStringEx( int flags, /* Conversion control flags. */ Tcl_DString *dstPtr, /* Uninitialized or free DString in which the * converted string is stored. */ - Tcl_Size *errorLocPtr) /* Where to store the error location - * (or TCL_INDEX_NONE if no error). May + Tcl_Size *errorLocPtr) /* Where to store the error location + * (or TCL_INDEX_NONE if no error). May * be NULL. */ { char *dst; @@ -1231,18 +1235,21 @@ Tcl_ExternalToUtfDStringEx( * Do not write error message into interpreter if caller * wants to know error location. */ - *errorLocPtr = result == TCL_OK ? TCL_INDEX_NONE : nBytesProcessed; + *errorLocPtr = result == TCL_OK + ? TCL_INDEX_NONE : nBytesProcessed; } else { /* Caller wants error message on failure */ if (result != TCL_OK && interp != NULL) { char buf[TCL_INTEGER_SPACE]; - snprintf(buf, sizeof(buf), "%" TCL_SIZE_MODIFIER "d", nBytesProcessed); + snprintf(buf, sizeof(buf), "%" TCL_SIZE_MODIFIER "d", + nBytesProcessed); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "unexpected byte sequence starting at index %" TCL_SIZE_MODIFIER "d: '\\x%02X'", nBytesProcessed, UCHAR(srcStart[nBytesProcessed]))); Tcl_SetErrorCode( - interp, "TCL", "ENCODING", "ILLEGALSEQUENCE", buf, (void *)NULL); + interp, "TCL", "ENCODING", "ILLEGALSEQUENCE", buf, + (void *)NULL); } } if (result != TCL_OK) { @@ -1287,8 +1294,9 @@ Tcl_ExternalToUtf( Tcl_Encoding encoding, /* The encoding for the source string, or NULL * for the default system encoding. */ const char *src, /* Source string in specified encoding. */ - Tcl_Size srcLen, /* Source string length in bytes, or TCL_INDEX_NONE for - * encoding-specific string length. */ + Tcl_Size srcLen, /* Source string length in bytes, or + * TCL_INDEX_NONE for encoding-specific string + * length. */ int flags, /* Conversion control flags. */ Tcl_EncodingState *statePtr,/* Place for conversion routine to store state * information used during a piecewise @@ -1440,34 +1448,33 @@ Tcl_UtfToExternalDString( * - *At most one* of TCL_ENCODING_PROFILE_* * * Results: - * The return value is one of - * TCL_OK: success. Converted string in *dstPtr - * TCL_ERROR: error in passed parameters. Error message in interp - * TCL_CONVERT_MULTIBYTE: source ends in truncated multibyte sequence - * TCL_CONVERT_SYNTAX: source is not conformant to encoding definition - * TCL_CONVERT_UNKNOWN: source contained a character that could not - * be represented in target encoding. + * The return value is one of + * TCL_OK: success. Converted string in *dstPtr + * TCL_ERROR: error in passed parameters. Error message in interp + * TCL_CONVERT_MULTIBYTE: source ends in truncated multibyte sequence + * TCL_CONVERT_SYNTAX: source is not conformant to encoding definition + * TCL_CONVERT_UNKNOWN: source contained a character that could not + * be represented in target encoding. * * Side effects: - * - * TCL_OK: The converted bytes are stored in the DString and NUL - * terminated in an encoding-specific manner - * TCL_ERROR: an error, message is stored in the interp if not NULL. - * TCL_CONVERT_*: if errorLocPtr is NULL, an error message is stored - * in the interpreter (if not NULL). If errorLocPtr is not NULL, - * no error message is stored as it is expected the caller is - * interested in whatever is decoded so far and not treating this - * as an error condition. - * - * In addition, *dstPtr is always initialized and must be cleared - * by the caller irrespective of the return code. + * TCL_OK: The converted bytes are stored in the DString and NUL + * terminated in an encoding-specific manner + * TCL_ERROR: an error, message is stored in the interp if not NULL. + * TCL_CONVERT_*: if errorLocPtr is NULL, an error message is stored + * in the interpreter (if not NULL). If errorLocPtr is not NULL, + * no error message is stored as it is expected the caller is + * interested in whatever is decoded so far and not treating this + * as an error condition. + * + * In addition, *dstPtr is always initialized and must be cleared + * by the caller irrespective of the return code. * *------------------------------------------------------------------------- */ int Tcl_UtfToExternalDStringEx( - Tcl_Interp *interp, /* For error messages. May be NULL. */ + Tcl_Interp *interp, /* For error messages. May be NULL. */ Tcl_Encoding encoding, /* The encoding for the converted string, or * NULL for the default system encoding. */ const char *src, /* Source string in UTF-8. */ @@ -1476,8 +1483,8 @@ Tcl_UtfToExternalDStringEx( int flags, /* Conversion control flags. */ Tcl_DString *dstPtr, /* Uninitialized or free DString in which the * converted string is stored. */ - Tcl_Size *errorLocPtr) /* Where to store the error location - * (or TCL_INDEX_NONE if no error). May + Tcl_Size *errorLocPtr) /* Where to store the error location + * (or TCL_INDEX_NONE if no error). May * be NULL. */ { char *dst; @@ -1547,7 +1554,8 @@ Tcl_UtfToExternalDStringEx( * Do not write error message into interpreter if caller * wants to know error location. */ - *errorLocPtr = result == TCL_OK ? TCL_INDEX_NONE : nBytesProcessed; + *errorLocPtr = result == TCL_OK + ? TCL_INDEX_NONE : nBytesProcessed; } else { /* Caller wants error message on failure */ if (result != TCL_OK && interp != NULL) { @@ -1556,7 +1564,8 @@ Tcl_UtfToExternalDStringEx( char buf[TCL_INTEGER_SPACE]; TclUtfToUniChar(&srcStart[nBytesProcessed], &ucs4); - snprintf(buf, sizeof(buf), "%" TCL_SIZE_MODIFIER "d", nBytesProcessed); + snprintf(buf, sizeof(buf), "%" TCL_SIZE_MODIFIER "d", + nBytesProcessed); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "unexpected character at index %" TCL_SIZE_MODIFIER "u: 'U+%06X'", @@ -1607,8 +1616,8 @@ Tcl_UtfToExternal( Tcl_Encoding encoding, /* The encoding for the converted string, or * NULL for the default system encoding. */ const char *src, /* Source string in UTF-8. */ - Tcl_Size srcLen, /* Source string length in bytes, or TCL_INDEX_NONE for - * strlen(). */ + Tcl_Size srcLen, /* Source string length in bytes, or + * TCL_INDEX_NONE for strlen(). */ int flags, /* Conversion control flags. */ Tcl_EncodingState *statePtr,/* Place for conversion routine to store state * information used during a piecewise @@ -1816,7 +1825,8 @@ OpenEncodingFileChannel( if ((NULL == chan) && (interp != NULL)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "unknown encoding \"%s\"", name)); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ENCODING", name, (void *)NULL); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ENCODING", name, + (void *)NULL); } Tcl_DecrRefCount(fileNameObj); Tcl_DecrRefCount(searchPath); @@ -1890,7 +1900,8 @@ LoadEncodingFile( if ((encoding == NULL) && (interp != NULL)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "invalid encoding file \"%s\"", name)); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ENCODING", name, (void *)NULL); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ENCODING", name, + (void *)NULL); } Tcl_CloseEx(NULL, chan, 0); @@ -2280,8 +2291,8 @@ LoadEscapeEncoding( e = (Encoding *) Tcl_GetEncoding(NULL, est.name); if ((e != NULL) && (e->toUtfProc != TableToUtfProc) && (e->toUtfProc != Iso88591ToUtfProc)) { - Tcl_FreeEncoding((Tcl_Encoding) e); - e = NULL; + Tcl_FreeEncoding((Tcl_Encoding) e); + e = NULL; } est.encodingPtr = e; Tcl_DStringAppend(&escapeData, (char *) &est, sizeof(est)); @@ -2468,7 +2479,8 @@ UtfToUtfProc( result = TCL_CONVERT_NOSPACE; break; } - if (UCHAR(*src) < 0x80 && !((UCHAR(*src) == 0) && (flags & ENCODING_INPUT))) { + if (UCHAR(*src) < 0x80 + && !((UCHAR(*src) == 0) && (flags & ENCODING_INPUT))) { /* * Copy 7bit characters, but skip null-bytes when we are in input * mode, so that they get converted to \xC0\x80. @@ -2480,12 +2492,12 @@ UtfToUtfProc( /* Special sequence \xC0\x80 */ if (!PROFILE_TCL8(profile) && (flags & ENCODING_INPUT)) { if (PROFILE_REPLACE(profile)) { - dst += Tcl_UniCharToUtf(UNICODE_REPLACE_CHAR, dst); - src += 2; + dst += Tcl_UniCharToUtf(UNICODE_REPLACE_CHAR, dst); + src += 2; } else { - /* PROFILE_STRICT */ - result = TCL_CONVERT_SYNTAX; - break; + /* PROFILE_STRICT */ + result = TCL_CONVERT_SYNTAX; + break; } } else { /* @@ -2509,8 +2521,8 @@ UtfToUtfProc( /* Incomplete bytes for modified UTF-8 target */ if (PROFILE_STRICT(profile)) { result = (flags & TCL_ENCODING_CHAR_LIMIT) - ? TCL_CONVERT_MULTIBYTE - : TCL_CONVERT_SYNTAX; + ? TCL_CONVERT_MULTIBYTE + : TCL_CONVERT_SYNTAX; break; } } @@ -2527,7 +2539,8 @@ UtfToUtfProc( } else { size_t len = TclUtfToUniChar(src, &ch); if (flags & ENCODING_INPUT) { - if (((len < 2) && (ch != 0)) || ((ch > 0xFFFF) && !(flags & ENCODING_UTF))) { + if (((len < 2) && (ch != 0)) + || ((ch > 0xFFFF) && !(flags & ENCODING_UTF))) { if (PROFILE_STRICT(profile)) { result = TCL_CONVERT_SYNTAX; break; @@ -2539,7 +2552,8 @@ UtfToUtfProc( const char *saveSrc = src; src += len; - if (!(flags & ENCODING_UTF) && !(flags & ENCODING_INPUT) && (ch > 0x3FF)) { + if (!(flags & ENCODING_UTF) && !(flags & ENCODING_INPUT) + && (ch > 0x3FF)) { if (ch > 0xFFFF) { /* CESU-8 6-byte sequence for chars > U+FFFF */ ch -= 0x10000; @@ -2554,7 +2568,8 @@ UtfToUtfProc( continue; } else if (SURROGATE(ch)) { if (PROFILE_STRICT(profile)) { - result = (flags & ENCODING_INPUT) ? TCL_CONVERT_SYNTAX : TCL_CONVERT_UNKNOWN; + result = (flags & ENCODING_INPUT) + ? TCL_CONVERT_SYNTAX : TCL_CONVERT_UNKNOWN; src = saveSrc; break; } else if (PROFILE_REPLACE(profile)) { @@ -2589,7 +2604,7 @@ UtfToUtfProc( static int Utf32ToUtfProc( - void *clientData, /* additional flags, e.g. TCL_ENCODING_LE */ + void *clientData, /* additional flags, e.g. TCL_ENCODING_LE */ const char *src, /* Source string in Unicode. */ int srcLen, /* Source string length in bytes. */ int flags, /* Conversion control flags. */ @@ -2643,9 +2658,11 @@ Utf32ToUtfProc( } if (flags & TCL_ENCODING_LE) { - ch = (unsigned int)(src[3] & 0xFF) << 24 | (src[2] & 0xFF) << 16 | (src[1] & 0xFF) << 8 | (src[0] & 0xFF); + ch = (unsigned int)(src[3] & 0xFF) << 24 | (src[2] & 0xFF) << 16 + | (src[1] & 0xFF) << 8 | (src[0] & 0xFF); } else { - ch = (unsigned int)(src[0] & 0xFF) << 24 | (src[1] & 0xFF) << 16 | (src[2] & 0xFF) << 8 | (src[3] & 0xFF); + ch = (unsigned int)(src[0] & 0xFF) << 24 | (src[1] & 0xFF) << 16 + | (src[2] & 0xFF) << 8 | (src[3] & 0xFF); } if ((unsigned)ch > 0x10FFFF) { if (PROFILE_STRICT(flags)) { @@ -2718,7 +2735,7 @@ Utf32ToUtfProc( static int UtfToUtf32Proc( - void *clientData, /* additional flags, e.g. TCL_ENCODING_LE */ + void *clientData, /* additional flags, e.g. TCL_ENCODING_LE */ const char *src, /* Source string in UTF-8. */ int srcLen, /* Source string length in bytes. */ int flags, /* Conversion control flags. */ @@ -2817,7 +2834,7 @@ UtfToUtf32Proc( static int Utf16ToUtfProc( - void *clientData, /* additional flags, e.g. TCL_ENCODING_LE */ + void *clientData, /* additional flags, e.g. TCL_ENCODING_LE */ const char *src, /* Source string in Unicode. */ int srcLen, /* Source string length in bytes. */ int flags, /* Conversion control flags. */ @@ -2875,7 +2892,8 @@ Utf16ToUtfProc( dstStart = dst; dstEnd = dst + dstLen - TCL_UTF_MAX; - for (numChars = 0; src < srcEnd && numChars <= charLimit; src += 2, numChars++) { + for (numChars = 0; src < srcEnd && numChars <= charLimit; + src += 2, numChars++) { if (dst > dstEnd) { result = TCL_CONVERT_NOSPACE; break; @@ -2890,16 +2908,16 @@ Utf16ToUtfProc( if (HIGH_SURROGATE(prev) && !LOW_SURROGATE(ch)) { if (PROFILE_STRICT(flags)) { result = TCL_CONVERT_SYNTAX; - src -= 2; /* Go back to beginning of high surrogate */ - dst--; /* Also undo writing a single byte too much */ + src -= 2; /* Go back to beginning of high surrogate */ + dst--; /* Also undo writing a single byte too much */ numChars--; break; } else if (PROFILE_REPLACE(flags)) { /* * Previous loop wrote a single byte to mark the high surrogate. * Replace it with the replacement character. Further, restart - * current loop iteration since need to recheck destination space - * and reset processing of current character. + * current loop iteration since need to recheck destination + * space and reset processing of current character. */ ch = UNICODE_REPLACE_CHAR; dst--; @@ -2908,7 +2926,10 @@ Utf16ToUtfProc( numChars--; continue; } else { - /* Bug [10c2c17c32]. If Hi surrogate not followed by Lo surrogate, finish 3-byte UTF-8 */ + /* + * Bug [10c2c17c32]. If Hi surrogate not followed by Lo + * surrogate, finish 3-byte UTF-8 + */ dst += Tcl_UniCharToUtf(-1, dst); } } @@ -2995,7 +3016,7 @@ Utf16ToUtfProc( static int UtfToUtf16Proc( - void *clientData, /* additional flags, e.g. TCL_ENCODING_LE */ + void *clientData, /* additional flags, e.g. TCL_ENCODING_LE */ const char *src, /* Source string in UTF-8. */ int srcLen, /* Source string length in bytes. */ int flags, /* Conversion control flags. */ @@ -3103,7 +3124,7 @@ UtfToUtf16Proc( static int UtfToUcs2Proc( - void *clientData, /* additional flags, e.g. TCL_ENCODING_LE */ + void *clientData, /* additional flags, e.g. TCL_ENCODING_LE */ const char *src, /* Source string in UTF-8. */ int srcLen, /* Source string length in bytes. */ int flags, /* Conversion control flags. */ @@ -3207,7 +3228,7 @@ UtfToUcs2Proc( static int TableToUtfProc( - void *clientData, /* TableEncodingData that specifies + void *clientData, /* TableEncodingData that specifies * encoding. */ const char *src, /* Source string in specified encoding. */ int srcLen, /* Source string length in bytes. */ @@ -3270,7 +3291,8 @@ TableToUtfProc( } else if (PROFILE_REPLACE(flags)) { ch = UNICODE_REPLACE_CHAR; } else { - /* For prefix bytes, we don't fallback to cp1252, see [1355b9a874] */ + /* For prefix bytes, we don't fallback to cp1252, see + * [1355b9a874] */ ch = byte; } } else { @@ -3335,7 +3357,7 @@ TableToUtfProc( static int TableFromUtfProc( - void *clientData, /* TableEncodingData that specifies + void *clientData, /* TableEncodingData that specifies * encoding. */ const char *src, /* Source string in UTF-8. */ int srcLen, /* Source string length in bytes. */ @@ -3627,7 +3649,7 @@ Iso88591FromUtfProc( static void TableFreeProc( - void *clientData) /* TableEncodingData that specifies + void *clientData) /* TableEncodingData that specifies * encoding. */ { TableEncodingData *dataPtr = (TableEncodingData *)clientData; @@ -3662,7 +3684,7 @@ TableFreeProc( static int EscapeToUtfProc( - void *clientData, /* EscapeEncodingData that specifies + void *clientData, /* EscapeEncodingData that specifies * encoding. */ const char *src, /* Source string in specified encoding. */ int srcLen, /* Source string length in bytes. */ @@ -3875,7 +3897,7 @@ EscapeToUtfProc( static int EscapeFromUtfProc( - void *clientData, /* EscapeEncodingData that specifies + void *clientData, /* EscapeEncodingData that specifies * encoding. */ const char *src, /* Source string in UTF-8. */ int srcLen, /* Source string length in bytes. */ @@ -3942,7 +3964,7 @@ EscapeFromUtfProc( } encodingPtr = GetTableEncoding(dataPtr, state); - tableDataPtr = (const TableEncodingData *)encodingPtr->clientData; + tableDataPtr = (TableEncodingData *) encodingPtr->clientData; tablePrefixBytes = tableDataPtr->prefixBytes; tableFromUnicode = (const unsigned short *const *) tableDataPtr->fromUnicode; @@ -3970,7 +3992,7 @@ EscapeFromUtfProc( oldState = state; for (state = 0; state < dataPtr->numSubTables; state++) { encodingPtr = GetTableEncoding(dataPtr, state); - tableDataPtr = (const TableEncodingData *)encodingPtr->clientData; + tableDataPtr = (TableEncodingData *) encodingPtr->clientData; word = tableDataPtr->fromUnicode[(ch >> 8)][ch & 0xFF]; if (word != 0) { break; @@ -3984,7 +4006,7 @@ EscapeFromUtfProc( break; } encodingPtr = GetTableEncoding(dataPtr, state); - tableDataPtr = (const TableEncodingData *)encodingPtr->clientData; + tableDataPtr = (TableEncodingData *) encodingPtr->clientData; word = tableDataPtr->fallback; } @@ -4086,7 +4108,7 @@ EscapeFromUtfProc( static void EscapeFreeProc( - void *clientData) /* EscapeEncodingData that specifies + void *clientData) /* EscapeEncodingData that specifies * encoding. */ { EscapeEncodingData *dataPtr = (EscapeEncodingData *)clientData; @@ -4291,7 +4313,7 @@ int TclEncodingProfileNameToId( Tcl_Interp *interp, /* For error messages. May be NULL */ const char *profileName, /* Name of profile */ - int *profilePtr) /* Output */ + int *profilePtr) /* Output */ { size_t i; size_t numProfiles = sizeof(encodingProfiles) / sizeof(encodingProfiles[0]); @@ -4308,14 +4330,17 @@ TclEncodingProfileNameToId( profileName); for (i = 0; i < (numProfiles - 1); ++i) { Tcl_AppendStringsToObj( - errorObj, " ", encodingProfiles[i].name, ",", (void *)NULL); + errorObj, " ", encodingProfiles[i].name, ",", + (void *)NULL); } Tcl_AppendStringsToObj( - errorObj, " or ", encodingProfiles[numProfiles-1].name, (void *)NULL); + errorObj, " or ", encodingProfiles[numProfiles-1].name, + (void *)NULL); Tcl_SetObjResult(interp, errorObj); Tcl_SetErrorCode( - interp, "TCL", "ENCODING", "PROFILE", profileName, (void *)NULL); + interp, "TCL", "ENCODING", "PROFILE", profileName, + (void *)NULL); } return TCL_ERROR; } @@ -4342,7 +4367,8 @@ TclEncodingProfileIdToName( { size_t i; - for (i = 0; i < sizeof(encodingProfiles) / sizeof(encodingProfiles[0]); ++i) { + for (i = 0; i < sizeof(encodingProfiles) / sizeof(encodingProfiles[0]); + ++i) { if (profileValue == encodingProfiles[i].value) { return encodingProfiles[i].name; } @@ -4352,7 +4378,7 @@ TclEncodingProfileIdToName( "Internal error. Bad profile id \"%d\".", profileValue)); Tcl_SetErrorCode( - interp, "TCL", "ENCODING", "PROFILEID", (void *)NULL); + interp, "TCL", "ENCODING", "PROFILEID", (void *)NULL); } return NULL; } @@ -4373,19 +4399,20 @@ TclEncodingProfileIdToName( *------------------------------------------------------------------------ */ void -TclGetEncodingProfiles(Tcl_Interp *interp) +TclGetEncodingProfiles( + Tcl_Interp *interp) { size_t i, n; Tcl_Obj *objPtr; n = sizeof(encodingProfiles) / sizeof(encodingProfiles[0]); objPtr = Tcl_NewListObj(n, NULL); for (i = 0; i < n; ++i) { - Tcl_ListObjAppendElement( - interp, objPtr, Tcl_NewStringObj(encodingProfiles[i].name, TCL_INDEX_NONE)); + Tcl_ListObjAppendElement(interp, objPtr, + Tcl_NewStringObj(encodingProfiles[i].name, TCL_INDEX_NONE)); } Tcl_SetObjResult(interp, objPtr); } - + /* * Local Variables: * mode: c diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index 3b7230a..a9bcf0c 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -18,6 +18,15 @@ */ static inline Tcl_Obj * NewNsObj(Tcl_Namespace *namespacePtr); +static Tcl_Command InitEnsembleFromOptions(Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); +static int ReadOneEnsembleOption(Tcl_Interp *interp, + Tcl_Command token, Tcl_Obj *optionObj); +static int ReadAllEnsembleOptions(Tcl_Interp *interp, + Tcl_Command token); +static int SetEnsembleConfigOptions(Tcl_Interp *interp, + Tcl_Command token, int objc, + Tcl_Obj *const objv[]); static inline int EnsembleUnknownCallback(Tcl_Interp *interp, EnsembleConfig *ensemblePtr, int objc, Tcl_Obj *const objv[], Tcl_Obj **prefixObjPtr); @@ -85,7 +94,7 @@ static const Tcl_ObjType ensembleCmdType = { TCL_OBJTYPE_V0 }; -#define ECRSetInternalRep(objPtr, ecRepPtr) \ +#define ECRSetInternalRep(objPtr, ecRepPtr) \ do { \ Tcl_ObjInternalRep ir; \ ir.twoPtrValue.ptr1 = (ecRepPtr); \ @@ -93,11 +102,12 @@ static const Tcl_ObjType ensembleCmdType = { Tcl_StoreInternalRep((objPtr), &ensembleCmdType, &ir); \ } while (0) -#define ECRGetInternalRep(objPtr, ecRepPtr) \ +#define ECRGetInternalRep(objPtr, ecRepPtr) \ do { \ - const Tcl_ObjInternalRep *irPtr; \ - irPtr = TclFetchInternalRep((objPtr), &ensembleCmdType); \ - (ecRepPtr) = irPtr ? (EnsembleCmdRep *)irPtr->twoPtrValue.ptr1 : NULL; \ + const Tcl_ObjInternalRep *irPtr; \ + irPtr = TclFetchInternalRep((objPtr), &ensembleCmdType); \ + (ecRepPtr) = irPtr ? (EnsembleCmdRep *) \ + irPtr->twoPtrValue.ptr1 : NULL; \ } while (0) /* @@ -106,16 +116,28 @@ static const Tcl_ObjType ensembleCmdType = { */ typedef struct { - Tcl_Size epoch; /* Used to confirm when the data in this - * really structure matches up with the - * ensemble. */ - Command *token; /* Reference to the command for which this - * structure is a cache of the resolution. */ - Tcl_Obj *fix; /* Corrected spelling, if needed. */ - Tcl_HashEntry *hPtr; /* Direct link to entry in the subcommand hash - * table. */ + Tcl_Size epoch; /* Used to confirm when the data in this + * really structure matches up with the + * ensemble. */ + Command *token; /* Reference to the command for which this + * structure is a cache of the resolution. */ + Tcl_Obj *fix; /* Corrected spelling, if needed. */ + Tcl_HashEntry *hPtr; /* Direct link to entry in the subcommand hash + * table. */ } EnsembleCmdRep; +/* + *---------------------------------------------------------------------- + * + * NewNsObj -- + * + * Make an object that contains a namespace's name. + * + * TODO: + * This is a candidate for doing something better! + * + *---------------------------------------------------------------------- + */ static inline Tcl_Obj * NewNsObj( Tcl_Namespace *namespacePtr) @@ -125,7 +147,7 @@ NewNsObj( if (namespacePtr == TclGetGlobalNamespace(nsPtr->interp)) { return Tcl_NewStringObj("::", 2); } - return Tcl_NewStringObj(nsPtr->fullName, -1); + return Tcl_NewStringObj(nsPtr->fullName, TCL_AUTO_LENGTH); } /* @@ -157,21 +179,15 @@ TclNamespaceEnsembleCmd( int objc, Tcl_Obj *const objv[]) { - Tcl_Namespace *namespacePtr; - Namespace *nsPtr = (Namespace *) TclGetCurrentNamespace(interp), *cxtPtr, - *foundNsPtr, *altFoundNsPtr, *actualCxtPtr; - Tcl_Command token; - Tcl_DictSearch search; - Tcl_Obj *listObj; - const char *simpleName; + Namespace *nsPtr = (Namespace *) TclGetCurrentNamespace(interp); + Tcl_Command token; /* The ensemble command. */ enum EnsSubcmds index; - int done; if (nsPtr == NULL || nsPtr->flags & NS_DEAD) { if (!Tcl_InterpDeleted(interp)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "tried to manipulate ensemble of deleted namespace", - -1)); + TCL_AUTO_LENGTH)); Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "DEAD", (char *)NULL); } return TCL_ERROR; @@ -180,26 +196,13 @@ TclNamespaceEnsembleCmd( if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?arg ...?"); return TCL_ERROR; - } - if (Tcl_GetIndexFromObj(interp, objv[1], ensembleSubcommands, + } else if (Tcl_GetIndexFromObj(interp, objv[1], ensembleSubcommands, "subcommand", 0, &index) != TCL_OK) { return TCL_ERROR; } switch (index) { - case ENS_CREATE: { - const char *name; - Tcl_Size len; - int allocatedMapFlag = 0; - /* - * Defaults - */ - Tcl_Obj *subcmdObj = NULL; - Tcl_Obj *mapObj = NULL; - int permitPrefix = 1; - Tcl_Obj *unknownObj = NULL; - Tcl_Obj *paramObj = NULL; - + case ENS_CREATE: /* * Check that we've got option-value pairs... [Bug 1558654] */ @@ -208,169 +211,11 @@ TclNamespaceEnsembleCmd( Tcl_WrongNumArgs(interp, 2, objv, "?option value ...?"); return TCL_ERROR; } - objv += 2; - objc -= 2; - - name = nsPtr->name; - cxtPtr = (Namespace *) nsPtr->parentPtr; - - /* - * Parse the option list, applying type checks as we go. Note that we - * are not incrementing any reference counts in the objects at this - * stage, so the presence of an option multiple times won't cause any - * memory leaks. - */ - - for (; objc>1 ; objc-=2,objv+=2) { - enum EnsCreateOpts idx; - if (Tcl_GetIndexFromObj(interp, objv[0], ensembleCreateOptions, - "option", 0, &idx) != TCL_OK) { - if (allocatedMapFlag) { - Tcl_DecrRefCount(mapObj); - } - return TCL_ERROR; - } - switch (idx) { - case CRT_CMD: - name = TclGetString(objv[1]); - cxtPtr = nsPtr; - continue; - case CRT_SUBCMDS: - if (TclListObjLength(interp, objv[1], &len) != TCL_OK) { - if (allocatedMapFlag) { - Tcl_DecrRefCount(mapObj); - } - return TCL_ERROR; - } - subcmdObj = (len > 0 ? objv[1] : NULL); - continue; - case CRT_PARAM: - if (TclListObjLength(interp, objv[1], &len) != TCL_OK) { - if (allocatedMapFlag) { - Tcl_DecrRefCount(mapObj); - } - return TCL_ERROR; - } - paramObj = (len > 0 ? objv[1] : NULL); - continue; - case CRT_MAP: { - Tcl_Obj *patchedDict = NULL, *subcmdWordsObj; - - /* - * Verify that the map is sensible. - */ - - if (Tcl_DictObjFirst(interp, objv[1], &search, - &subcmdWordsObj, &listObj, &done) != TCL_OK) { - if (allocatedMapFlag) { - Tcl_DecrRefCount(mapObj); - } - return TCL_ERROR; - } - if (done) { - mapObj = NULL; - continue; - } - do { - Tcl_Obj **listv; - const char *cmd; - - if (TclListObjGetElements(interp, listObj, &len, - &listv) != TCL_OK) { - Tcl_DictObjDone(&search); - if (patchedDict) { - Tcl_DecrRefCount(patchedDict); - } - if (allocatedMapFlag) { - Tcl_DecrRefCount(mapObj); - } - return TCL_ERROR; - } - if (len < 1) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "ensemble subcommand implementations " - "must be non-empty lists", -1)); - Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", - "EMPTY_TARGET", (char *)NULL); - Tcl_DictObjDone(&search); - if (patchedDict) { - Tcl_DecrRefCount(patchedDict); - } - if (allocatedMapFlag) { - Tcl_DecrRefCount(mapObj); - } - return TCL_ERROR; - } - cmd = TclGetString(listv[0]); - if (!(cmd[0] == ':' && cmd[1] == ':')) { - Tcl_Obj *newList = Tcl_NewListObj(len, listv); - Tcl_Obj *newCmd = NewNsObj((Tcl_Namespace *) nsPtr); - - if (nsPtr->parentPtr) { - Tcl_AppendStringsToObj(newCmd, "::", (char *)NULL); - } - Tcl_AppendObjToObj(newCmd, listv[0]); - Tcl_ListObjReplace(NULL, newList, 0, 1, 1, &newCmd); - if (patchedDict == NULL) { - patchedDict = Tcl_DuplicateObj(objv[1]); - } - Tcl_DictObjPut(NULL, patchedDict, subcmdWordsObj, - newList); - } - Tcl_DictObjNext(&search, &subcmdWordsObj, &listObj, - &done); - } while (!done); - - if (allocatedMapFlag) { - Tcl_DecrRefCount(mapObj); - } - mapObj = (patchedDict ? patchedDict : objv[1]); - if (patchedDict) { - allocatedMapFlag = 1; - } - continue; - } - case CRT_PREFIX: { - if (Tcl_GetBooleanFromObj(interp, objv[1], - &permitPrefix) != TCL_OK) { - if (allocatedMapFlag) { - Tcl_DecrRefCount(mapObj); - } - return TCL_ERROR; - } - continue; - } - case CRT_UNKNOWN: - if (TclListObjLength(interp, objv[1], &len) != TCL_OK) { - if (allocatedMapFlag) { - Tcl_DecrRefCount(mapObj); - } - return TCL_ERROR; - } - unknownObj = (len > 0 ? objv[1] : NULL); - continue; - } + token = InitEnsembleFromOptions(interp, objc - 2, objv + 2); + if (token == NULL) { + return TCL_ERROR; } - TclGetNamespaceForQualName(interp, name, cxtPtr, - TCL_CREATE_NS_IF_UNKNOWN, &foundNsPtr, &altFoundNsPtr, - &actualCxtPtr, &simpleName); - - /* - * Create the ensemble. Note that this might delete another ensemble - * linked to the same namespace, so we must be careful. However, we - * should be OK because we only link the namespace into the list once - * we've created it (and after any deletions have occurred.) - */ - - token = TclCreateEnsembleInNs(interp, simpleName, - (Tcl_Namespace *) foundNsPtr, (Tcl_Namespace *) nsPtr, - (permitPrefix ? TCL_ENSEMBLE_PREFIX : 0)); - Tcl_SetEnsembleSubcommandList(interp, token, subcmdObj); - Tcl_SetEnsembleMappingDict(interp, token, mapObj); - Tcl_SetEnsembleUnknownHandler(interp, token, unknownObj); - Tcl_SetEnsembleParameterList(interp, token, paramObj); - /* * Tricky! Must ensure that the result is not shared (command delete * traces could have corrupted the pristine object that we started @@ -380,7 +225,6 @@ TclNamespaceEnsembleCmd( Tcl_ResetResult(interp); Tcl_GetCommandFullName(interp, token, Tcl_GetObjResult(interp)); return TCL_OK; - } case ENS_EXISTS: if (objc != 3) { @@ -403,265 +247,518 @@ TclNamespaceEnsembleCmd( } if (objc == 4) { - enum EnsConfigOpts idx; - Tcl_Obj *resultObj = NULL; /* silence gcc 4 warning */ + return ReadOneEnsembleOption(interp, token, objv[3]); + } else if (objc == 3) { + return ReadAllEnsembleOptions(interp, token); + } else { + return SetEnsembleConfigOptions(interp, token, objc - 3, objv + 3); + } - if (Tcl_GetIndexFromObj(interp, objv[3], ensembleConfigOptions, - "option", 0, &idx) != TCL_OK) { - return TCL_ERROR; + default: + Tcl_Panic("unexpected ensemble command"); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * InitEnsembleFromOptions -- + * + * Core of implementation of "namespace ensemble create". + * + * Results: + * Returns created ensemble's command token if successful, and NULL if + * anything goes wrong. + * + * Side effects: + * Creates the ensemble for the namespace if one did not previously + * exist. + * + * Note: + * Can't use SetEnsembleConfigOptions() here. Different (but overlapping) + * options are supported. + * + *---------------------------------------------------------------------- + */ +static Tcl_Command +InitEnsembleFromOptions( + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Namespace *nsPtr = (Namespace *) TclGetCurrentNamespace(interp); + Namespace *cxtPtr = nsPtr->parentPtr; + Namespace *altFoundNsPtr, *actualCxtPtr; + const char *name = nsPtr->name; + Tcl_Size len; + int allocatedMapFlag = 0; + enum EnsCreateOpts index; + Tcl_Command token; /* The created ensemble command. */ + Namespace *foundNsPtr; + const char *simpleName; + /* + * Defaults + */ + Tcl_Obj *subcmdObj = NULL; + Tcl_Obj *mapObj = NULL; + int permitPrefix = 1; + Tcl_Obj *unknownObj = NULL; + Tcl_Obj *paramObj = NULL; + + /* + * Parse the option list, applying type checks as we go. Note that we are + * not incrementing any reference counts in the objects at this stage, so + * the presence of an option multiple times won't cause any memory leaks. + */ + + for (; objc>1 ; objc-=2,objv+=2) { + if (Tcl_GetIndexFromObj(interp, objv[0], ensembleCreateOptions, + "option", 0, &index) != TCL_OK) { + goto error; + } + switch (index) { + case CRT_CMD: + name = TclGetString(objv[1]); + cxtPtr = nsPtr; + continue; + case CRT_SUBCMDS: + if (TclListObjLength(interp, objv[1], &len) != TCL_OK) { + goto error; + } + subcmdObj = (len > 0 ? objv[1] : NULL); + continue; + case CRT_PARAM: + if (TclListObjLength(interp, objv[1], &len) != TCL_OK) { + goto error; + } + paramObj = (len > 0 ? objv[1] : NULL); + continue; + case CRT_MAP: { + Tcl_Obj *patchedDict = NULL, *subcmdWordsObj, *listObj; + Tcl_DictSearch search; + int done; + + /* + * Verify that the map is sensible. + */ + + if (Tcl_DictObjFirst(interp, objv[1], &search, + &subcmdWordsObj, &listObj, &done) != TCL_OK) { + goto error; + } else if (done) { + mapObj = NULL; + continue; } - switch (idx) { - case CONF_SUBCMDS: - Tcl_GetEnsembleSubcommandList(NULL, token, &resultObj); - if (resultObj != NULL) { - Tcl_SetObjResult(interp, resultObj); + do { + Tcl_Obj **listv; + const char *cmd; + + if (TclListObjGetElements(interp, listObj, &len, + &listv) != TCL_OK) { + goto mapError; } - break; - case CONF_PARAM: - Tcl_GetEnsembleParameterList(NULL, token, &resultObj); - if (resultObj != NULL) { - Tcl_SetObjResult(interp, resultObj); + if (len < 1) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "ensemble subcommand implementations " + "must be non-empty lists", TCL_AUTO_LENGTH)); + Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", + "EMPTY_TARGET", (char *)NULL); + goto mapError; } - break; - case CONF_MAP: - Tcl_GetEnsembleMappingDict(NULL, token, &resultObj); - if (resultObj != NULL) { - Tcl_SetObjResult(interp, resultObj); + cmd = TclGetString(listv[0]); + if (!(cmd[0] == ':' && cmd[1] == ':')) { + Tcl_Obj *newList = Tcl_NewListObj(len, listv); + Tcl_Obj *newCmd = NewNsObj((Tcl_Namespace *) nsPtr); + + if (nsPtr->parentPtr) { + Tcl_AppendStringsToObj(newCmd, "::", (char *)NULL); + } + Tcl_AppendObjToObj(newCmd, listv[0]); + Tcl_ListObjReplace(NULL, newList, 0, 1, 1, &newCmd); + if (patchedDict == NULL) { + patchedDict = Tcl_DuplicateObj(objv[1]); + } + Tcl_DictObjPut(NULL, patchedDict, subcmdWordsObj, newList); } - break; - case CONF_NAMESPACE: - namespacePtr = NULL; /* silence gcc 4 warning */ - Tcl_GetEnsembleNamespace(NULL, token, &namespacePtr); - Tcl_SetObjResult(interp, NewNsObj(namespacePtr)); - break; - case CONF_PREFIX: { - int flags = 0; /* silence gcc 4 warning */ + Tcl_DictObjNext(&search, &subcmdWordsObj, &listObj, &done); + } while (!done); - Tcl_GetEnsembleFlags(NULL, token, &flags); - Tcl_SetObjResult(interp, - Tcl_NewBooleanObj(flags & TCL_ENSEMBLE_PREFIX)); - break; + if (allocatedMapFlag) { + Tcl_DecrRefCount(mapObj); } - case CONF_UNKNOWN: - Tcl_GetEnsembleUnknownHandler(NULL, token, &resultObj); - if (resultObj != NULL) { - Tcl_SetObjResult(interp, resultObj); - } - break; + mapObj = (patchedDict ? patchedDict : objv[1]); + if (patchedDict) { + allocatedMapFlag = 1; } - } else if (objc == 3) { - /* - * Produce list of all information. - */ + continue; + mapError: + Tcl_DictObjDone(&search); + if (patchedDict) { + Tcl_DecrRefCount(patchedDict); + } + goto error; + } + case CRT_PREFIX: + if (Tcl_GetBooleanFromObj(interp, objv[1], + &permitPrefix) != TCL_OK) { + goto error; + } + continue; + case CRT_UNKNOWN: + if (TclListObjLength(interp, objv[1], &len) != TCL_OK) { + goto error; + } + unknownObj = (len > 0 ? objv[1] : NULL); + continue; + } + } + + TclGetNamespaceForQualName(interp, name, cxtPtr, + TCL_CREATE_NS_IF_UNKNOWN, &foundNsPtr, &altFoundNsPtr, + &actualCxtPtr, &simpleName); + + /* + * Create the ensemble. Note that this might delete another ensemble + * linked to the same namespace, so we must be careful. However, we + * should be OK because we only link the namespace into the list once + * we've created it (and after any deletions have occurred.) + */ - Tcl_Obj *resultObj, *tmpObj = NULL; /* silence gcc 4 warning */ - int flags = 0; /* silence gcc 4 warning */ - - TclNewObj(resultObj); - - /* -map option */ - Tcl_ListObjAppendElement(NULL, resultObj, - Tcl_NewStringObj(ensembleConfigOptions[CONF_MAP], -1)); - Tcl_GetEnsembleMappingDict(NULL, token, &tmpObj); - Tcl_ListObjAppendElement(NULL, resultObj, - (tmpObj != NULL) ? tmpObj : Tcl_NewObj()); - - /* -namespace option */ - Tcl_ListObjAppendElement(NULL, resultObj, - Tcl_NewStringObj(ensembleConfigOptions[CONF_NAMESPACE], - -1)); - namespacePtr = NULL; /* silence gcc 4 warning */ - Tcl_GetEnsembleNamespace(NULL, token, &namespacePtr); - Tcl_ListObjAppendElement(NULL, resultObj, NewNsObj(namespacePtr)); - - /* -parameters option */ - Tcl_ListObjAppendElement(NULL, resultObj, - Tcl_NewStringObj(ensembleConfigOptions[CONF_PARAM], -1)); - Tcl_GetEnsembleParameterList(NULL, token, &tmpObj); - Tcl_ListObjAppendElement(NULL, resultObj, - (tmpObj != NULL) ? tmpObj : Tcl_NewObj()); - - /* -prefix option */ - Tcl_ListObjAppendElement(NULL, resultObj, - Tcl_NewStringObj(ensembleConfigOptions[CONF_PREFIX], -1)); - Tcl_GetEnsembleFlags(NULL, token, &flags); - Tcl_ListObjAppendElement(NULL, resultObj, - Tcl_NewBooleanObj(flags & TCL_ENSEMBLE_PREFIX)); - - /* -subcommands option */ - Tcl_ListObjAppendElement(NULL, resultObj, - Tcl_NewStringObj(ensembleConfigOptions[CONF_SUBCMDS],-1)); - Tcl_GetEnsembleSubcommandList(NULL, token, &tmpObj); - Tcl_ListObjAppendElement(NULL, resultObj, - (tmpObj != NULL) ? tmpObj : Tcl_NewObj()); - - /* -unknown option */ - Tcl_ListObjAppendElement(NULL, resultObj, - Tcl_NewStringObj(ensembleConfigOptions[CONF_UNKNOWN],-1)); - Tcl_GetEnsembleUnknownHandler(NULL, token, &tmpObj); - Tcl_ListObjAppendElement(NULL, resultObj, - (tmpObj != NULL) ? tmpObj : Tcl_NewObj()); + token = TclCreateEnsembleInNs(interp, simpleName, + (Tcl_Namespace *) foundNsPtr, (Tcl_Namespace *) nsPtr, + (permitPrefix ? TCL_ENSEMBLE_PREFIX : 0)); + Tcl_SetEnsembleSubcommandList(interp, token, subcmdObj); + Tcl_SetEnsembleMappingDict(interp, token, mapObj); + Tcl_SetEnsembleUnknownHandler(interp, token, unknownObj); + Tcl_SetEnsembleParameterList(interp, token, paramObj); + return token; + error: + if (allocatedMapFlag) { + Tcl_DecrRefCount(mapObj); + } + return NULL; +} + +/* + *---------------------------------------------------------------------- + * + * ReadOneEnsembleOption -- + * + * Core of implementation of "namespace ensemble configure" with just a + * single option name. + * + * Results: + * Tcl result code. Modifies the interpreter result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ +static int +ReadOneEnsembleOption( + Tcl_Interp *interp, + Tcl_Command token, /* The ensemble to read from. */ + Tcl_Obj *optionObj) /* The name of the option to read. */ +{ + Tcl_Obj *resultObj = NULL; /* silence gcc 4 warning */ + enum EnsConfigOpts index; + + if (Tcl_GetIndexFromObj(interp, optionObj, ensembleConfigOptions, + "option", 0, &index) != TCL_OK) { + return TCL_ERROR; + } + switch (index) { + case CONF_SUBCMDS: + Tcl_GetEnsembleSubcommandList(NULL, token, &resultObj); + if (resultObj != NULL) { Tcl_SetObjResult(interp, resultObj); - } else { - Tcl_Size len; - int allocatedMapFlag = 0; - Tcl_Obj *subcmdObj = NULL, *mapObj = NULL, *paramObj = NULL, - *unknownObj = NULL; /* Defaults, silence gcc 4 warnings */ - int permitPrefix, flags = 0; /* silence gcc 4 warning */ - - Tcl_GetEnsembleSubcommandList(NULL, token, &subcmdObj); - Tcl_GetEnsembleMappingDict(NULL, token, &mapObj); - Tcl_GetEnsembleParameterList(NULL, token, ¶mObj); - Tcl_GetEnsembleUnknownHandler(NULL, token, &unknownObj); - Tcl_GetEnsembleFlags(NULL, token, &flags); - permitPrefix = (flags & TCL_ENSEMBLE_PREFIX) != 0; - - objv += 3; - objc -= 3; + } + break; + case CONF_PARAM: + Tcl_GetEnsembleParameterList(NULL, token, &resultObj); + if (resultObj != NULL) { + Tcl_SetObjResult(interp, resultObj); + } + break; + case CONF_MAP: + Tcl_GetEnsembleMappingDict(NULL, token, &resultObj); + if (resultObj != NULL) { + Tcl_SetObjResult(interp, resultObj); + } + break; + case CONF_NAMESPACE: { + Tcl_Namespace *namespacePtr = NULL; /* silence gcc 4 warning */ + Tcl_GetEnsembleNamespace(NULL, token, &namespacePtr); + Tcl_SetObjResult(interp, NewNsObj(namespacePtr)); + break; + } + case CONF_PREFIX: { + int flags = 0; /* silence gcc 4 warning */ + + Tcl_GetEnsembleFlags(NULL, token, &flags); + Tcl_SetObjResult(interp, + Tcl_NewBooleanObj(flags & TCL_ENSEMBLE_PREFIX)); + break; + } + case CONF_UNKNOWN: + Tcl_GetEnsembleUnknownHandler(NULL, token, &resultObj); + if (resultObj != NULL) { + Tcl_SetObjResult(interp, resultObj); + } + break; + } + return TCL_OK; +} +/* + *---------------------------------------------------------------------- + * + * ReadAllEnsembleOptions -- + * + * Core of implementation of "namespace ensemble configure" without + * option names. + * + * Results: + * Tcl result code. Modifies the interpreter result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ +static int +ReadAllEnsembleOptions( + Tcl_Interp *interp, + Tcl_Command token) /* The ensemble to read from. */ +{ + Tcl_Obj *resultObj, *tmpObj = NULL; /* silence gcc 4 warning */ + int flags = 0; /* silence gcc 4 warning */ + Tcl_Namespace *namespacePtr = NULL; /* silence gcc 4 warning */ + + TclNewObj(resultObj); + + /* -map option */ + Tcl_ListObjAppendElement(NULL, resultObj, + Tcl_NewStringObj(ensembleConfigOptions[CONF_MAP], + TCL_AUTO_LENGTH)); + Tcl_GetEnsembleMappingDict(NULL, token, &tmpObj); + Tcl_ListObjAppendElement(NULL, resultObj, + (tmpObj != NULL) ? tmpObj : Tcl_NewObj()); + + /* -namespace option */ + Tcl_ListObjAppendElement(NULL, resultObj, + Tcl_NewStringObj(ensembleConfigOptions[CONF_NAMESPACE], + TCL_AUTO_LENGTH)); + Tcl_GetEnsembleNamespace(NULL, token, &namespacePtr); + Tcl_ListObjAppendElement(NULL, resultObj, NewNsObj(namespacePtr)); + + /* -parameters option */ + Tcl_ListObjAppendElement(NULL, resultObj, + Tcl_NewStringObj(ensembleConfigOptions[CONF_PARAM], + TCL_AUTO_LENGTH)); + Tcl_GetEnsembleParameterList(NULL, token, &tmpObj); + Tcl_ListObjAppendElement(NULL, resultObj, + (tmpObj != NULL) ? tmpObj : Tcl_NewObj()); + + /* -prefix option */ + Tcl_ListObjAppendElement(NULL, resultObj, + Tcl_NewStringObj(ensembleConfigOptions[CONF_PREFIX], + TCL_AUTO_LENGTH)); + Tcl_GetEnsembleFlags(NULL, token, &flags); + Tcl_ListObjAppendElement(NULL, resultObj, + Tcl_NewBooleanObj(flags & TCL_ENSEMBLE_PREFIX)); + + /* -subcommands option */ + Tcl_ListObjAppendElement(NULL, resultObj, + Tcl_NewStringObj(ensembleConfigOptions[CONF_SUBCMDS], + TCL_AUTO_LENGTH)); + Tcl_GetEnsembleSubcommandList(NULL, token, &tmpObj); + Tcl_ListObjAppendElement(NULL, resultObj, + (tmpObj != NULL) ? tmpObj : Tcl_NewObj()); + + /* -unknown option */ + Tcl_ListObjAppendElement(NULL, resultObj, + Tcl_NewStringObj(ensembleConfigOptions[CONF_UNKNOWN], + TCL_AUTO_LENGTH)); + Tcl_GetEnsembleUnknownHandler(NULL, token, &tmpObj); + Tcl_ListObjAppendElement(NULL, resultObj, + (tmpObj != NULL) ? tmpObj : Tcl_NewObj()); + + Tcl_SetObjResult(interp, resultObj); + return TCL_OK; +} +/* + *---------------------------------------------------------------------- + * + * SetEnsembleConfigOptions -- + * + * Core of implementation of "namespace ensemble configure" with even + * number of arguments (where there is at least one pair). + * + * Results: + * Tcl result code. Modifies the interpreter result. + * + * Side effects: + * Modifies the ensemble's configuration. + * + *---------------------------------------------------------------------- + */ +static int +SetEnsembleConfigOptions( + Tcl_Interp *interp, + Tcl_Command token, /* The ensemble to configure. */ + int objc, /* The count of option-related arguments. */ + Tcl_Obj *const objv[]) /* Option-related arguments. */ +{ + Tcl_Size len; + int allocatedMapFlag = 0; + Tcl_Obj *subcmdObj = NULL, *mapObj = NULL, *paramObj = NULL, + *unknownObj = NULL; /* Defaults, silence gcc 4 warnings */ + Tcl_Obj *listObj; + Tcl_DictSearch search; + int permitPrefix, flags = 0; /* silence gcc 4 warning */ + enum EnsConfigOpts index; + int done; + + Tcl_GetEnsembleSubcommandList(NULL, token, &subcmdObj); + Tcl_GetEnsembleMappingDict(NULL, token, &mapObj); + Tcl_GetEnsembleParameterList(NULL, token, ¶mObj); + Tcl_GetEnsembleUnknownHandler(NULL, token, &unknownObj); + Tcl_GetEnsembleFlags(NULL, token, &flags); + permitPrefix = (flags & TCL_ENSEMBLE_PREFIX) != 0; + + /* + * Parse the option list, applying type checks as we go. Note that + * we are not incrementing any reference counts in the objects at + * this stage, so the presence of an option multiple times won't + * cause any memory leaks. + */ + + for (; objc>0 ; objc-=2,objv+=2) { + if (Tcl_GetIndexFromObj(interp, objv[0], ensembleConfigOptions, + "option", 0, &index) != TCL_OK) { + goto freeMapAndError; + } + switch (index) { + case CONF_SUBCMDS: + if (TclListObjLength(interp, objv[1], &len) != TCL_OK) { + goto freeMapAndError; + } + subcmdObj = (len > 0 ? objv[1] : NULL); + continue; + case CONF_PARAM: + if (TclListObjLength(interp, objv[1], &len) != TCL_OK) { + goto freeMapAndError; + } + paramObj = (len > 0 ? objv[1] : NULL); + continue; + case CONF_MAP: { + Tcl_Obj *patchedDict = NULL, *subcmdWordsObj, **listv; + Namespace *nsPtr = (Namespace *) TclGetCurrentNamespace(interp); + const char *cmd; /* - * Parse the option list, applying type checks as we go. Note that - * we are not incrementing any reference counts in the objects at - * this stage, so the presence of an option multiple times won't - * cause any memory leaks. + * Verify that the map is sensible. */ - for (; objc>0 ; objc-=2,objv+=2) { - enum EnsConfigOpts idx; - if (Tcl_GetIndexFromObj(interp, objv[0],ensembleConfigOptions, - "option", 0, &idx) != TCL_OK) { - freeMapAndError: - if (allocatedMapFlag) { - Tcl_DecrRefCount(mapObj); - } - return TCL_ERROR; - } - switch (idx) { - case CONF_SUBCMDS: - if (TclListObjLength(interp, objv[1], &len) != TCL_OK) { - goto freeMapAndError; - } - subcmdObj = (len > 0 ? objv[1] : NULL); - continue; - case CONF_PARAM: - if (TclListObjLength(interp, objv[1], &len) != TCL_OK) { - goto freeMapAndError; - } - paramObj = (len > 0 ? objv[1] : NULL); - continue; - case CONF_MAP: { - Tcl_Obj *patchedDict = NULL, *subcmdWordsObj, **listv; - const char *cmd; - - /* - * Verify that the map is sensible. - */ + if (Tcl_DictObjFirst(interp, objv[1], &search, + &subcmdWordsObj, &listObj, &done) != TCL_OK) { + goto freeMapAndError; + } else if (done) { + mapObj = NULL; + continue; + } - if (Tcl_DictObjFirst(interp, objv[1], &search, - &subcmdWordsObj, &listObj, &done) != TCL_OK) { - goto freeMapAndError; - } - if (done) { - mapObj = NULL; - continue; - } - do { - if (TclListObjLength(interp, listObj, &len) != TCL_OK) { - Tcl_DictObjDone(&search); - if (patchedDict) { - Tcl_DecrRefCount(patchedDict); - } - goto freeMapAndError; - } - if (len < 1) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "ensemble subcommand implementations " - "must be non-empty lists", -1)); - Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", - "EMPTY_TARGET", (char *)NULL); - Tcl_DictObjDone(&search); - if (patchedDict) { - Tcl_DecrRefCount(patchedDict); - } - goto freeMapAndError; - } - if (TclListObjGetElements(interp, listObj, &len, - &listv) != TCL_OK) { - Tcl_DictObjDone(&search); - if (patchedDict) { - Tcl_DecrRefCount(patchedDict); - } - goto freeMapAndError; - } - cmd = TclGetString(listv[0]); - if (!(cmd[0] == ':' && cmd[1] == ':')) { - Tcl_Obj *newList = Tcl_DuplicateObj(listObj); - Tcl_Obj *newCmd = NewNsObj((Tcl_Namespace*)nsPtr); - - if (nsPtr->parentPtr) { - Tcl_AppendStringsToObj(newCmd, "::", (char *)NULL); - } - Tcl_AppendObjToObj(newCmd, listv[0]); - Tcl_ListObjReplace(NULL, newList, 0, 1, 1, - &newCmd); - if (patchedDict == NULL) { - patchedDict = Tcl_DuplicateObj(objv[1]); - } - Tcl_DictObjPut(NULL, patchedDict, subcmdWordsObj, - newList); - } - Tcl_DictObjNext(&search, &subcmdWordsObj, &listObj, - &done); - } while (!done); - if (allocatedMapFlag) { - Tcl_DecrRefCount(mapObj); - } - mapObj = (patchedDict ? patchedDict : objv[1]); - if (patchedDict) { - allocatedMapFlag = 1; - } - continue; + do { + if (TclListObjLength(interp, listObj, &len) != TCL_OK) { + goto finishSearchAndError; } - case CONF_NAMESPACE: + if (len < 1) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "option -namespace is read-only", -1)); - Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "READ_ONLY", - (char *)NULL); - goto freeMapAndError; - case CONF_PREFIX: - if (Tcl_GetBooleanFromObj(interp, objv[1], - &permitPrefix) != TCL_OK) { - goto freeMapAndError; + "ensemble subcommand implementations " + "must be non-empty lists", TCL_AUTO_LENGTH)); + Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", + "EMPTY_TARGET", (char *)NULL); + goto finishSearchAndError; + } + if (TclListObjGetElements(interp, listObj, &len, + &listv) != TCL_OK) { + goto finishSearchAndError; + } + cmd = TclGetString(listv[0]); + if (!(cmd[0] == ':' && cmd[1] == ':')) { + Tcl_Obj *newList = Tcl_DuplicateObj(listObj); + Tcl_Obj *newCmd = NewNsObj((Tcl_Namespace*) nsPtr); + + if (nsPtr->parentPtr) { + Tcl_AppendStringsToObj(newCmd, "::", (char *)NULL); } - continue; - case CONF_UNKNOWN: - if (TclListObjLength(interp, objv[1], &len) != TCL_OK) { - goto freeMapAndError; + Tcl_AppendObjToObj(newCmd, listv[0]); + Tcl_ListObjReplace(NULL, newList, 0, 1, 1, &newCmd); + if (patchedDict == NULL) { + patchedDict = Tcl_DuplicateObj(objv[1]); } - unknownObj = (len > 0 ? objv[1] : NULL); - continue; + Tcl_DictObjPut(NULL, patchedDict, subcmdWordsObj, newList); } + Tcl_DictObjNext(&search, &subcmdWordsObj, &listObj, &done); + } while (!done); + if (allocatedMapFlag) { + Tcl_DecrRefCount(mapObj); } + mapObj = (patchedDict ? patchedDict : objv[1]); + if (patchedDict) { + allocatedMapFlag = 1; + } + continue; - /* - * Update the namespace now that we've finished the parsing stage. - */ - - flags = (permitPrefix ? flags|TCL_ENSEMBLE_PREFIX - : flags&~TCL_ENSEMBLE_PREFIX); - Tcl_SetEnsembleSubcommandList(interp, token, subcmdObj); - Tcl_SetEnsembleMappingDict(interp, token, mapObj); - Tcl_SetEnsembleParameterList(interp, token, paramObj); - Tcl_SetEnsembleUnknownHandler(interp, token, unknownObj); - Tcl_SetEnsembleFlags(interp, token, flags); + finishSearchAndError: + Tcl_DictObjDone(&search); + if (patchedDict) { + Tcl_DecrRefCount(patchedDict); + } + goto freeMapAndError; + } + case CONF_NAMESPACE: + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "option -namespace is read-only", TCL_AUTO_LENGTH)); + Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "READ_ONLY", + (char *)NULL); + goto freeMapAndError; + case CONF_PREFIX: + if (Tcl_GetBooleanFromObj(interp, objv[1], + &permitPrefix) != TCL_OK) { + goto freeMapAndError; + } + continue; + case CONF_UNKNOWN: + if (TclListObjLength(interp, objv[1], &len) != TCL_OK) { + goto freeMapAndError; + } + unknownObj = (len > 0 ? objv[1] : NULL); + continue; } - return TCL_OK; - - default: - Tcl_Panic("unexpected ensemble command"); } + + /* + * Update the namespace now that we've finished the parsing stage. + */ + + flags = (permitPrefix ? flags | TCL_ENSEMBLE_PREFIX + : flags & ~TCL_ENSEMBLE_PREFIX); + Tcl_SetEnsembleSubcommandList(interp, token, subcmdObj); + Tcl_SetEnsembleMappingDict(interp, token, mapObj); + Tcl_SetEnsembleParameterList(interp, token, paramObj); + Tcl_SetEnsembleUnknownHandler(interp, token, unknownObj); + Tcl_SetEnsembleFlags(interp, token, flags); return TCL_OK; + + freeMapAndError: + if (allocatedMapFlag) { + Tcl_DecrRefCount(mapObj); + } + return TCL_ERROR; } /* @@ -684,13 +781,14 @@ TclCreateEnsembleInNs( * in. */ Tcl_Namespace *ensembleNsPtr, /* Name of the namespace for the ensemble. */ - int flags) + int flags) /* Whether we need exact matching and whether + * we bytecode-compile the ensemble's uses. */ { Namespace *nsPtr = (Namespace *) ensembleNsPtr; EnsembleConfig *ensemblePtr; Tcl_Command token; - ensemblePtr = (EnsembleConfig *)Tcl_Alloc(sizeof(EnsembleConfig)); + ensemblePtr = (EnsembleConfig *) Tcl_Alloc(sizeof(EnsembleConfig)); token = TclNRCreateCommandInNs(interp, name, (Tcl_Namespace *) nameNsPtr, TclEnsembleImplementationCmd, NsEnsembleImplementationCmdNR, ensemblePtr, DeleteEnsembleConfig); @@ -744,16 +842,16 @@ TclCreateEnsembleInNs( * Effect * The ensemble is created and marked for compilation. * - * *---------------------------------------------------------------------- */ Tcl_Command Tcl_CreateEnsemble( Tcl_Interp *interp, - const char *name, - Tcl_Namespace *namespacePtr, - int flags) + const char *name, /* The ensemble name. */ + Tcl_Namespace *namespacePtr,/* Context namespace. */ + int flags) /* Whether we need exact matching and whether + * we bytecode-compile the ensemble's uses. */ { Namespace *nsPtr = (Namespace *) namespacePtr, *foundNsPtr, *altNsPtr, *actualNsPtr; @@ -772,6 +870,73 @@ Tcl_CreateEnsemble( /* *---------------------------------------------------------------------- * + * GetEnsembleFromCommand -- + * + * Standard check to see if a command is an ensemble. + * + * Results: + * The ensemble implementation if the command is an ensemble. NULL if it + * isn't. + * + * Side effects: + * Reports an error in the interpreter (if non-NULL) if the command is + * not an ensemble. + * + *---------------------------------------------------------------------- + */ +static inline EnsembleConfig * +GetEnsembleFromCommand( + Tcl_Interp *interp, /* Where to report an error. May be NULL. */ + Tcl_Command token) /* What to check for ensemble-ness. */ +{ + Command *cmdPtr = (Command *) token; + + if (cmdPtr->objProc != TclEnsembleImplementationCmd) { + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "command is not an ensemble", TCL_AUTO_LENGTH)); + Tcl_SetErrorCode(interp, + "TCL", "ENSEMBLE", "NOT_ENSEMBLE", (char *)NULL); + } + return NULL; + } + return (EnsembleConfig *) cmdPtr->objClientData; +} + +/* + *---------------------------------------------------------------------- + * + * BumpEpochIfNecessary -- + * + * Increments the compilation epoch if the (ensemble) command is one where + * changes would be seen by the compiler in some cases. + * + * Results: + * None. + * + * Side effects: + * May trigger later bytecode recompilations. + * + *---------------------------------------------------------------------- + */ +static inline void +BumpEpochIfNecessary( + Tcl_Interp *interp, + Tcl_Command token) /* The ensemble command to check. */ +{ + /* + * Special hack to make compiling of [info exists] work when the + * dictionary is modified. + */ + + if (((Command *) token)->compileProc != NULL) { + ((Interp *) interp)->compileEpoch++; + } +} + +/* + *---------------------------------------------------------------------- + * * Tcl_SetEnsembleSubcommandList -- * * Set the subcommand list for a particular ensemble. @@ -789,17 +954,13 @@ Tcl_CreateEnsemble( int Tcl_SetEnsembleSubcommandList( Tcl_Interp *interp, - Tcl_Command token, + Tcl_Command token, /* The ensemble command to write to. */ Tcl_Obj *subcmdList) { - Command *cmdPtr = (Command *) token; - EnsembleConfig *ensemblePtr; + EnsembleConfig *ensemblePtr = GetEnsembleFromCommand(interp, token); Tcl_Obj *oldList; - if (cmdPtr->objProc != TclEnsembleImplementationCmd) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "command is not an ensemble", -1)); - Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", (char *)NULL); + if (ensemblePtr == NULL) { return TCL_ERROR; } if (subcmdList != NULL) { @@ -813,7 +974,6 @@ Tcl_SetEnsembleSubcommandList( } } - ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData; oldList = ensemblePtr->subcmdList; ensemblePtr->subcmdList = subcmdList; if (subcmdList != NULL) { @@ -831,16 +991,7 @@ Tcl_SetEnsembleSubcommandList( */ ensemblePtr->nsPtr->exportLookupEpoch++; - - /* - * Special hack to make compiling of [info exists] work when the - * dictionary is modified. - */ - - if (cmdPtr->compileProc != NULL) { - ((Interp *) interp)->compileEpoch++; - } - + BumpEpochIfNecessary(interp, token); return TCL_OK; } @@ -864,18 +1015,14 @@ Tcl_SetEnsembleSubcommandList( int Tcl_SetEnsembleParameterList( Tcl_Interp *interp, - Tcl_Command token, + Tcl_Command token, /* The ensemble command to write to. */ Tcl_Obj *paramList) { - Command *cmdPtr = (Command *) token; - EnsembleConfig *ensemblePtr; + EnsembleConfig *ensemblePtr = GetEnsembleFromCommand(interp, token); Tcl_Obj *oldList; Tcl_Size length; - if (cmdPtr->objProc != TclEnsembleImplementationCmd) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "command is not an ensemble", -1)); - Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", (char *)NULL); + if (ensemblePtr == NULL) { return TCL_ERROR; } if (paramList == NULL) { @@ -889,7 +1036,6 @@ Tcl_SetEnsembleParameterList( } } - ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData; oldList = ensemblePtr->parameterList; ensemblePtr->parameterList = paramList; if (paramList != NULL) { @@ -908,16 +1054,7 @@ Tcl_SetEnsembleParameterList( */ ensemblePtr->nsPtr->exportLookupEpoch++; - - /* - * Special hack to make compiling of [info exists] work when the - * dictionary is modified. - */ - - if (cmdPtr->compileProc != NULL) { - ((Interp *) interp)->compileEpoch++; - } - + BumpEpochIfNecessary(interp, token); return TCL_OK; } @@ -941,17 +1078,13 @@ Tcl_SetEnsembleParameterList( int Tcl_SetEnsembleMappingDict( Tcl_Interp *interp, - Tcl_Command token, + Tcl_Command token, /* The ensemble command to write to. */ Tcl_Obj *mapDict) { - Command *cmdPtr = (Command *) token; - EnsembleConfig *ensemblePtr; + EnsembleConfig *ensemblePtr = GetEnsembleFromCommand(interp, token); Tcl_Obj *oldDict; - if (cmdPtr->objProc != TclEnsembleImplementationCmd) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "command is not an ensemble", -1)); - Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", (char *)NULL); + if (ensemblePtr == NULL) { return TCL_ERROR; } if (mapDict != NULL) { @@ -977,7 +1110,7 @@ Tcl_SetEnsembleMappingDict( if (bytes[0] != ':' || bytes[1] != ':') { Tcl_SetObjResult(interp, Tcl_NewStringObj( "ensemble target is not a fully-qualified command", - -1)); + TCL_AUTO_LENGTH)); Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "UNQUALIFIED_TARGET", (char *)NULL); Tcl_DictObjDone(&search); @@ -990,7 +1123,6 @@ Tcl_SetEnsembleMappingDict( } } - ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData; oldDict = ensemblePtr->subcommandDict; ensemblePtr->subcommandDict = mapDict; if (mapDict != NULL) { @@ -1008,16 +1140,7 @@ Tcl_SetEnsembleMappingDict( */ ensemblePtr->nsPtr->exportLookupEpoch++; - - /* - * Special hack to make compiling of [info exists] work when the - * dictionary is modified. - */ - - if (cmdPtr->compileProc != NULL) { - ((Interp *) interp)->compileEpoch++; - } - + BumpEpochIfNecessary(interp, token); return TCL_OK; } @@ -1041,17 +1164,13 @@ Tcl_SetEnsembleMappingDict( int Tcl_SetEnsembleUnknownHandler( Tcl_Interp *interp, - Tcl_Command token, + Tcl_Command token, /* The ensemble command to write to. */ Tcl_Obj *unknownList) { - Command *cmdPtr = (Command *) token; - EnsembleConfig *ensemblePtr; + EnsembleConfig *ensemblePtr = GetEnsembleFromCommand(interp, token); Tcl_Obj *oldList; - if (cmdPtr->objProc != TclEnsembleImplementationCmd) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "command is not an ensemble", -1)); - Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", (char *)NULL); + if (ensemblePtr == NULL) { return TCL_ERROR; } if (unknownList != NULL) { @@ -1065,7 +1184,6 @@ Tcl_SetEnsembleUnknownHandler( } } - ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData; oldList = ensemblePtr->unknownHandler; ensemblePtr->unknownHandler = unknownList; if (unknownList != NULL) { @@ -1107,23 +1225,16 @@ Tcl_SetEnsembleUnknownHandler( int Tcl_SetEnsembleFlags( Tcl_Interp *interp, - Tcl_Command token, + Tcl_Command token, /* The ensemble command to write to. */ int flags) { - Command *cmdPtr = (Command *) token; - EnsembleConfig *ensemblePtr; - int wasCompiled; + EnsembleConfig *ensemblePtr = GetEnsembleFromCommand(interp, token); + int changedFlags = flags ^ ensemblePtr->flags; - if (cmdPtr->objProc != TclEnsembleImplementationCmd) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "command is not an ensemble", -1)); - Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", (char *)NULL); + if (ensemblePtr == NULL) { return TCL_ERROR; } - ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData; - wasCompiled = ensemblePtr->flags & ENSEMBLE_COMPILE; - /* * This API refuses to set the ENSEMBLE_DEAD flag... */ @@ -1146,16 +1257,10 @@ Tcl_SetEnsembleFlags( * bytecode gets regenerated. */ - if (flags & ENSEMBLE_COMPILE) { - if (!wasCompiled) { - ((Command*) ensemblePtr->token)->compileProc = TclCompileEnsemble; - ((Interp *) interp)->compileEpoch++; - } - } else { - if (wasCompiled) { - ((Command *) ensemblePtr->token)->compileProc = NULL; - ((Interp *) interp)->compileEpoch++; - } + if (changedFlags & ENSEMBLE_COMPILE) { + ((Command*) ensemblePtr->token)->compileProc = + ((flags & ENSEMBLE_COMPILE) ? TclCompileEnsemble : NULL); + ((Interp *) interp)->compileEpoch++; } return TCL_OK; @@ -1184,22 +1289,14 @@ Tcl_SetEnsembleFlags( int Tcl_GetEnsembleSubcommandList( Tcl_Interp *interp, - Tcl_Command token, + Tcl_Command token, /* The ensemble command to read from. */ Tcl_Obj **subcmdListPtr) { - Command *cmdPtr = (Command *) token; - EnsembleConfig *ensemblePtr; + EnsembleConfig *ensemblePtr = GetEnsembleFromCommand(interp, token); - if (cmdPtr->objProc != TclEnsembleImplementationCmd) { - if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "command is not an ensemble", -1)); - Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", (char *)NULL); - } + if (ensemblePtr == NULL) { return TCL_ERROR; } - - ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData; *subcmdListPtr = ensemblePtr->subcmdList; return TCL_OK; } @@ -1226,22 +1323,14 @@ Tcl_GetEnsembleSubcommandList( int Tcl_GetEnsembleParameterList( Tcl_Interp *interp, - Tcl_Command token, + Tcl_Command token, /* The ensemble command to read from. */ Tcl_Obj **paramListPtr) { - Command *cmdPtr = (Command *) token; - EnsembleConfig *ensemblePtr; + EnsembleConfig *ensemblePtr = GetEnsembleFromCommand(interp, token); - if (cmdPtr->objProc != TclEnsembleImplementationCmd) { - if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "command is not an ensemble", -1)); - Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", (char *)NULL); - } + if (ensemblePtr == NULL) { return TCL_ERROR; } - - ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData; *paramListPtr = ensemblePtr->parameterList; return TCL_OK; } @@ -1268,22 +1357,14 @@ Tcl_GetEnsembleParameterList( int Tcl_GetEnsembleMappingDict( Tcl_Interp *interp, - Tcl_Command token, + Tcl_Command token, /* The ensemble command to read from. */ Tcl_Obj **mapDictPtr) { - Command *cmdPtr = (Command *) token; - EnsembleConfig *ensemblePtr; + EnsembleConfig *ensemblePtr = GetEnsembleFromCommand(interp, token); - if (cmdPtr->objProc != TclEnsembleImplementationCmd) { - if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "command is not an ensemble", -1)); - Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", (char *)NULL); - } + if (ensemblePtr == NULL) { return TCL_ERROR; } - - ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData; *mapDictPtr = ensemblePtr->subcommandDict; return TCL_OK; } @@ -1309,22 +1390,14 @@ Tcl_GetEnsembleMappingDict( int Tcl_GetEnsembleUnknownHandler( Tcl_Interp *interp, - Tcl_Command token, + Tcl_Command token, /* The ensemble command to read from. */ Tcl_Obj **unknownListPtr) { - Command *cmdPtr = (Command *) token; - EnsembleConfig *ensemblePtr; + EnsembleConfig *ensemblePtr = GetEnsembleFromCommand(interp, token); - if (cmdPtr->objProc != TclEnsembleImplementationCmd) { - if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "command is not an ensemble", -1)); - Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", (char *)NULL); - } + if (ensemblePtr == NULL) { return TCL_ERROR; } - - ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData; *unknownListPtr = ensemblePtr->unknownHandler; return TCL_OK; } @@ -1350,22 +1423,14 @@ Tcl_GetEnsembleUnknownHandler( int Tcl_GetEnsembleFlags( Tcl_Interp *interp, - Tcl_Command token, + Tcl_Command token, /* The ensemble command to read from. */ int *flagsPtr) { - Command *cmdPtr = (Command *) token; - EnsembleConfig *ensemblePtr; + EnsembleConfig *ensemblePtr = GetEnsembleFromCommand(interp, token); - if (cmdPtr->objProc != TclEnsembleImplementationCmd) { - if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "command is not an ensemble", -1)); - Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", (char *)NULL); - } + if (ensemblePtr == NULL) { return TCL_ERROR; } - - ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData; *flagsPtr = ensemblePtr->flags; return TCL_OK; } @@ -1391,22 +1456,14 @@ Tcl_GetEnsembleFlags( int Tcl_GetEnsembleNamespace( Tcl_Interp *interp, - Tcl_Command token, + Tcl_Command token, /* The ensemble command to read from. */ Tcl_Namespace **namespacePtrPtr) { - Command *cmdPtr = (Command *) token; - EnsembleConfig *ensemblePtr; + EnsembleConfig *ensemblePtr = GetEnsembleFromCommand(interp, token); - if (cmdPtr->objProc != TclEnsembleImplementationCmd) { - if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "command is not an ensemble", -1)); - Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", (char *)NULL); - } + if (ensemblePtr == NULL) { return TCL_ERROR; } - - ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData; *namespacePtrPtr = (Tcl_Namespace *) ensemblePtr->nsPtr; return TCL_OK; } @@ -1439,24 +1496,23 @@ Tcl_FindEnsemble( int flags) /* Either 0 or TCL_LEAVE_ERR_MSG; other flags * are probably not useful. */ { - Command *cmdPtr; + Tcl_Command token; - cmdPtr = (Command *) - Tcl_FindCommand(interp, TclGetString(cmdNameObj), NULL, flags); - if (cmdPtr == NULL) { + token = Tcl_FindCommand(interp, TclGetString(cmdNameObj), NULL, flags); + if (token == NULL) { return NULL; } - if (cmdPtr->objProc != TclEnsembleImplementationCmd) { + if (((Command *) token)->objProc != TclEnsembleImplementationCmd) { /* * Reuse existing infrastructure for following import link chains * rather than duplicating it. */ - cmdPtr = (Command *) TclGetOriginalCommand((Tcl_Command) cmdPtr); + token = TclGetOriginalCommand(token); - if (cmdPtr == NULL - || cmdPtr->objProc != TclEnsembleImplementationCmd) { + if (token == NULL || + ((Command *) token)->objProc != TclEnsembleImplementationCmd) { if (flags & TCL_LEAVE_ERR_MSG) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "\"%s\" is not an ensemble command", @@ -1468,7 +1524,7 @@ Tcl_FindEnsemble( } } - return (Tcl_Command) cmdPtr; + return token; } /* @@ -1490,7 +1546,7 @@ Tcl_FindEnsemble( int Tcl_IsEnsemble( - Tcl_Command token) + Tcl_Command token) /* The command to check. */ { Command *cmdPtr = (Command *) token; @@ -1519,6 +1575,11 @@ Tcl_IsEnsemble( * Currently, the TCL_ENSEMBLE_PREFIX ensemble flag is only used on * top-level ensemble commands. * + * This code is not safe to run in Safe interpreter after user code has + * executed. That's OK right now because it's just used to set up Tcl, + * but it means we mustn't expose it at all, not even to Tk (until we can + * hide commands in namespaces directly). + * * Results: * Handle for the new ensemble, or NULL on failure. * @@ -1531,8 +1592,8 @@ Tcl_IsEnsemble( Tcl_Command TclMakeEnsemble( Tcl_Interp *interp, - const char *name, /* The ensemble name (as explained above) */ - const EnsembleImplMap map[]) /* The subcommands to create */ + const char *name, /* The ensemble name (as explained above) */ + const EnsembleImplMap map[])/* The subcommands to create */ { Tcl_Command ensemble; Tcl_Namespace *ns; @@ -1549,7 +1610,7 @@ TclMakeEnsemble( Tcl_DStringInit(&buf); Tcl_DStringInit(&hiddenBuf); TclDStringAppendLiteral(&hiddenBuf, "tcl:"); - Tcl_DStringAppend(&hiddenBuf, name, -1); + Tcl_DStringAppend(&hiddenBuf, name, TCL_AUTO_LENGTH); TclDStringAppendLiteral(&hiddenBuf, ":"); hiddenLen = Tcl_DStringLength(&hiddenBuf); if (name[0] == ':' && name[1] == ':') { @@ -1558,7 +1619,7 @@ TclMakeEnsemble( */ cmdName = name; - Tcl_DStringAppend(&buf, name, -1); + Tcl_DStringAppend(&buf, name, TCL_AUTO_LENGTH); ensembleFlags = TCL_ENSEMBLE_PREFIX; } else { /* @@ -1574,7 +1635,7 @@ TclMakeEnsemble( for (i = 0; i < nameCount; ++i) { TclDStringAppendLiteral(&buf, "::"); - Tcl_DStringAppend(&buf, nameParts[i], -1); + Tcl_DStringAppend(&buf, nameParts[i], TCL_AUTO_LENGTH); } } @@ -1621,7 +1682,7 @@ TclMakeEnsemble( for (i=0 ; map[i].name != NULL ; i++) { TclNewStringObj(toObj, Tcl_DStringValue(&buf), Tcl_DStringLength(&buf)); - Tcl_AppendToObj(toObj, map[i].name, -1); + Tcl_AppendToObj(toObj, map[i].name, TCL_AUTO_LENGTH); TclDictPut(NULL, mapDict, map[i].name, toObj); if (map[i].proc || map[i].nreProc) { @@ -1639,7 +1700,8 @@ TclMakeEnsemble( map[i].nreProc, map[i].clientData, NULL); Tcl_DStringSetLength(&hiddenBuf, hiddenLen); if (Tcl_HideCommand(interp, "___tmp", - Tcl_DStringAppend(&hiddenBuf, map[i].name, -1))) { + Tcl_DStringAppend(&hiddenBuf, map[i].name, + TCL_AUTO_LENGTH))) { Tcl_Panic("%s", Tcl_GetStringResult(interp)); } } else { @@ -1701,12 +1763,12 @@ TclEnsembleImplementationCmd( static int NsEnsembleImplementationCmdNR( - void *clientData, + void *clientData, /* The ensemble this is the impl. of. */ Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { - EnsembleConfig *ensemblePtr = (EnsembleConfig *)clientData; + EnsembleConfig *ensemblePtr = (EnsembleConfig *) clientData; /* The ensemble itself. */ Tcl_Obj *prefixObj; /* An object containing the prefix words of * the command that implements the @@ -1735,8 +1797,7 @@ NsEnsembleImplementationCmdNR( Tcl_DStringInit(&buf); if (ensemblePtr->parameterList) { - Tcl_DStringAppend(&buf, - TclGetString(ensemblePtr->parameterList), -1); + TclDStringAppendObj(&buf, ensemblePtr->parameterList); TclDStringAppendLiteral(&buf, " "); } TclDStringAppendLiteral(&buf, "subcommand ?arg ...?"); @@ -1753,7 +1814,8 @@ NsEnsembleImplementationCmdNR( if (!Tcl_InterpDeleted(interp)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "ensemble activated for deleted namespace", -1)); + "ensemble activated for deleted namespace", + TCL_AUTO_LENGTH)); Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "DEAD", (char *)NULL); } return TCL_ERROR; @@ -1776,8 +1838,8 @@ NsEnsembleImplementationCmdNR( ECRGetInternalRep(subObj, ensembleCmd); if (ensembleCmd) { if (ensembleCmd->epoch == ensemblePtr->epoch && - ensembleCmd->token == (Command *)ensemblePtr->token) { - prefixObj = (Tcl_Obj *)Tcl_GetHashValue(ensembleCmd->hPtr); + ensembleCmd->token == (Command *) ensemblePtr->token) { + prefixObj = (Tcl_Obj *) Tcl_GetHashValue(ensembleCmd->hPtr); Tcl_IncrRefCount(prefixObj); if (ensembleCmd->fix) { TclSpellFix(interp, objv, objc, subIdx, subObj, ensembleCmd->fix); @@ -1798,7 +1860,6 @@ NsEnsembleImplementationCmdNR( hPtr = Tcl_FindHashEntry(&ensemblePtr->subcommandTable, TclGetString(subObj)); if (hPtr != NULL) { - /* * Cache ensemble in the subcommand object for later. */ @@ -1867,7 +1928,7 @@ NsEnsembleImplementationCmdNR( * Record the spelling correction for usage message. */ - fix = Tcl_NewStringObj(fullName, -1); + fix = Tcl_NewStringObj(fullName, TCL_AUTO_LENGTH); /* * Cache for later in the subcommand object. @@ -1877,7 +1938,7 @@ NsEnsembleImplementationCmdNR( TclSpellFix(interp, objv, objc, subIdx, subObj, fix); } - prefixObj = (Tcl_Obj *)Tcl_GetHashValue(hPtr); + prefixObj = (Tcl_Obj *) Tcl_GetHashValue(hPtr); Tcl_IncrRefCount(prefixObj); runResultingSubcommand: @@ -1934,7 +1995,7 @@ NsEnsembleImplementationCmdNR( TclSkipTailcall(interp); TclListObjGetElements(NULL, copyPtr, ©Objc, ©Objv); - ((Interp *)interp)->lookupNsPtr = ensemblePtr->nsPtr; + ((Interp *) interp)->lookupNsPtr = ensemblePtr->nsPtr; return TclNREvalObjv(interp, copyObjc, copyObjv, TCL_EVAL_INVOKE, NULL); } @@ -1978,12 +2039,14 @@ NsEnsembleImplementationCmdNR( (ensemblePtr->flags & TCL_ENSEMBLE_PREFIX ? " or ambiguous" : ""), TclGetString(subObj)); if (ensemblePtr->subcommandTable.numEntries == 1) { - Tcl_AppendToObj(errorObj, ensemblePtr->subcommandArrayPtr[0], -1); + Tcl_AppendToObj(errorObj, ensemblePtr->subcommandArrayPtr[0], + TCL_AUTO_LENGTH); } else { Tcl_Size i; for (i=0 ; i<ensemblePtr->subcommandTable.numEntries-1 ; i++) { - Tcl_AppendToObj(errorObj, ensemblePtr->subcommandArrayPtr[i], -1); + Tcl_AppendToObj(errorObj, ensemblePtr->subcommandArrayPtr[i], + TCL_AUTO_LENGTH); Tcl_AppendToObj(errorObj, ", ", 2); } Tcl_AppendPrintfToObj(errorObj, "or %s", @@ -2184,9 +2247,9 @@ TclSpellFix( if (search[0] == NULL) { store = (Tcl_Obj **) search[2]; } else { - Tcl_Obj **tmp = (Tcl_Obj **)Tcl_Alloc(3 * sizeof(Tcl_Obj *)); + Tcl_Obj **tmp = (Tcl_Obj **) Tcl_Alloc(3 * sizeof(Tcl_Obj *)); - store = (Tcl_Obj **)Tcl_Alloc(size * sizeof(Tcl_Obj *)); + store = (Tcl_Obj **) Tcl_Alloc(size * sizeof(Tcl_Obj *)); memcpy(store, iPtr->ensembleRewrite.sourceObjs, size * sizeof(Tcl_Obj *)); @@ -2209,14 +2272,25 @@ TclSpellFix( TclNRAddCallback(interp, TclNRReleaseValues, fix, NULL, NULL, NULL); } +/* + *---------------------------------------------------------------------- + * + * TclEnsembleGetRewriteValues -- + * + * Get the original arguments to the current command before any rewrite + * rules (from aliases, ensembles, and method forwards) were applied. + * + *---------------------------------------------------------------------- + */ Tcl_Obj *const * TclEnsembleGetRewriteValues( Tcl_Interp *interp) /* Current interpreter. */ { Interp *iPtr = (Interp *) interp; Tcl_Obj *const *origObjv = iPtr->ensembleRewrite.sourceObjs; + if (origObjv[0] == NULL) { - origObjv = (Tcl_Obj *const *)origObjv[2]; + origObjv = (Tcl_Obj *const *) origObjv[2]; } return origObjv; } @@ -2237,7 +2311,6 @@ TclEnsembleGetRewriteValues( * *---------------------------------------------------------------------- */ - Tcl_Obj *const * TclFetchEnsembleRoot( Tcl_Interp *interp, @@ -2252,7 +2325,7 @@ TclFetchEnsembleRoot( *objcPtr = objc + iPtr->ensembleRewrite.numRemovedObjs - iPtr->ensembleRewrite.numInsertedObjs; if (iPtr->ensembleRewrite.sourceObjs[0] == NULL) { - sourceObjs = (Tcl_Obj *const *)iPtr->ensembleRewrite.sourceObjs[1]; + sourceObjs = (Tcl_Obj *const *) iPtr->ensembleRewrite.sourceObjs[1]; } else { sourceObjs = iPtr->ensembleRewrite.sourceObjs; } @@ -2288,10 +2361,12 @@ TclFetchEnsembleRoot( static inline int EnsembleUnknownCallback( Tcl_Interp *interp, - EnsembleConfig *ensemblePtr, - int objc, - Tcl_Obj *const objv[], - Tcl_Obj **prefixObjPtr) + EnsembleConfig *ensemblePtr,/* The ensemble structure. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[], /* Actual arguments. */ + Tcl_Obj **prefixObjPtr) /* Where to write the prefix suggested by the + * unknown callback. Must not be NULL. Only has + * a meaningful value on TCL_OK. */ { Tcl_Size paramc; int result; @@ -2324,7 +2399,8 @@ EnsembleUnknownCallback( if ((result == TCL_OK) && (ensemblePtr->flags & ENSEMBLE_DEAD)) { if (!Tcl_InterpDeleted(interp)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "unknown subcommand handler deleted its ensemble", -1)); + "unknown subcommand handler deleted its ensemble", + TCL_AUTO_LENGTH)); Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "UNKNOWN_DELETED", (char *)NULL); } @@ -2372,16 +2448,20 @@ EnsembleUnknownCallback( if (result != TCL_ERROR) { Tcl_ResetResult(interp); Tcl_SetObjResult(interp, Tcl_NewStringObj( - "unknown subcommand handler returned bad code: ", -1)); + "unknown subcommand handler returned bad code: ", + TCL_AUTO_LENGTH)); switch (result) { case TCL_RETURN: - Tcl_AppendToObj(Tcl_GetObjResult(interp), "return", -1); + Tcl_AppendToObj(Tcl_GetObjResult(interp), "return", + TCL_AUTO_LENGTH); break; case TCL_BREAK: - Tcl_AppendToObj(Tcl_GetObjResult(interp), "break", -1); + Tcl_AppendToObj(Tcl_GetObjResult(interp), "break", + TCL_AUTO_LENGTH); break; case TCL_CONTINUE: - Tcl_AppendToObj(Tcl_GetObjResult(interp), "continue", -1); + Tcl_AppendToObj(Tcl_GetObjResult(interp), "continue", + TCL_AUTO_LENGTH); break; default: Tcl_AppendPrintfToObj(Tcl_GetObjResult(interp), "%d", result); @@ -2421,10 +2501,11 @@ EnsembleUnknownCallback( static void MakeCachedEnsembleCommand( - Tcl_Obj *objPtr, - EnsembleConfig *ensemblePtr, - Tcl_HashEntry *hPtr, - Tcl_Obj *fix) + Tcl_Obj *objPtr, /* Object to cache in. */ + EnsembleConfig *ensemblePtr,/* Ensemble implementation. */ + Tcl_HashEntry *hPtr, /* What to cache; what the object maps to. */ + Tcl_Obj *fix) /* Spelling correction for later error, or NULL + * if no correction. */ { EnsembleCmdRep *ensembleCmd; @@ -2439,7 +2520,7 @@ MakeCachedEnsembleCommand( * Replace any old internal representation with a new one. */ - ensembleCmd = (EnsembleCmdRep *)Tcl_Alloc(sizeof(EnsembleCmdRep)); + ensembleCmd = (EnsembleCmdRep *) Tcl_Alloc(sizeof(EnsembleCmdRep)); ECRSetInternalRep(objPtr, ensembleCmd); } @@ -2478,29 +2559,29 @@ MakeCachedEnsembleCommand( static void ClearTable( - EnsembleConfig *ensemblePtr) + EnsembleConfig *ensemblePtr)/* Ensemble to clear table of. */ { Tcl_HashTable *hash = &ensemblePtr->subcommandTable; if (hash->numEntries != 0) { - Tcl_HashSearch search; - Tcl_HashEntry *hPtr = Tcl_FirstHashEntry(hash, &search); + Tcl_HashSearch search; + Tcl_HashEntry *hPtr = Tcl_FirstHashEntry(hash, &search); - while (hPtr != NULL) { - Tcl_Obj *prefixObj = (Tcl_Obj *)Tcl_GetHashValue(hPtr); - Tcl_DecrRefCount(prefixObj); - hPtr = Tcl_NextHashEntry(&search); - } - Tcl_Free(ensemblePtr->subcommandArrayPtr); + while (hPtr != NULL) { + Tcl_Obj *prefixObj = (Tcl_Obj *) Tcl_GetHashValue(hPtr); + Tcl_DecrRefCount(prefixObj); + hPtr = Tcl_NextHashEntry(&search); + } + Tcl_Free(ensemblePtr->subcommandArrayPtr); } Tcl_DeleteHashTable(hash); } static void DeleteEnsembleConfig( - void *clientData) + void *clientData) /* Ensemble to delete. */ { - EnsembleConfig *ensemblePtr = (EnsembleConfig *)clientData; + EnsembleConfig *ensemblePtr = (EnsembleConfig *) clientData; Namespace *nsPtr = ensemblePtr->nsPtr; /* Unlink from the ensemble chain if it not already marked as unlinked. */ @@ -2579,7 +2660,7 @@ DeleteEnsembleConfig( static void BuildEnsembleConfig( - EnsembleConfig *ensemblePtr) + EnsembleConfig *ensemblePtr)/* Ensemble to set up. */ { Tcl_HashSearch search; /* Used for scanning the commands in * the namespace for this ensemble. */ @@ -2594,100 +2675,100 @@ BuildEnsembleConfig( Tcl_InitHashTable(hash, TCL_STRING_KEYS); if (subList) { - Tcl_Size subc; - Tcl_Obj **subv, *target, *cmdObj, *cmdPrefixObj; - const char *name; - - /* - * There is a list of exactly what subcommands go in the table. - * Determine the target for each. - */ - - TclListObjGetElements(NULL, subList, &subc, &subv); - if (subList == mapDict) { - /* - * Unusual case where explicit list of subcommands is same value - * as the dict mapping to targets. - */ - - for (i = 0; i < subc; i += 2) { - name = TclGetString(subv[i]); - hPtr = Tcl_CreateHashEntry(hash, name, &isNew); - if (!isNew) { - cmdObj = (Tcl_Obj *)Tcl_GetHashValue(hPtr); - Tcl_DecrRefCount(cmdObj); - } - Tcl_SetHashValue(hPtr, subv[i+1]); - Tcl_IncrRefCount(subv[i+1]); - - name = TclGetString(subv[i+1]); - hPtr = Tcl_CreateHashEntry(hash, name, &isNew); - if (isNew) { - cmdObj = Tcl_NewStringObj(name, -1); - cmdPrefixObj = Tcl_NewListObj(1, &cmdObj); - Tcl_SetHashValue(hPtr, cmdPrefixObj); - Tcl_IncrRefCount(cmdPrefixObj); - } - } - } else { - /* + Tcl_Size subc; + Tcl_Obj **subv, *target, *cmdObj, *cmdPrefixObj; + const char *name; + + /* + * There is a list of exactly what subcommands go in the table. + * Determine the target for each. + */ + + TclListObjGetElements(NULL, subList, &subc, &subv); + if (subList == mapDict) { + /* + * Unusual case where explicit list of subcommands is same value + * as the dict mapping to targets. + */ + + for (i = 0; i < subc; i += 2) { + name = TclGetString(subv[i]); + hPtr = Tcl_CreateHashEntry(hash, name, &isNew); + if (!isNew) { + cmdObj = (Tcl_Obj *) Tcl_GetHashValue(hPtr); + Tcl_DecrRefCount(cmdObj); + } + Tcl_SetHashValue(hPtr, subv[i + 1]); + Tcl_IncrRefCount(subv[i + 1]); + + name = TclGetString(subv[i + 1]); + hPtr = Tcl_CreateHashEntry(hash, name, &isNew); + if (isNew) { + cmdObj = Tcl_NewStringObj(name, TCL_AUTO_LENGTH); + cmdPrefixObj = Tcl_NewListObj(1, &cmdObj); + Tcl_SetHashValue(hPtr, cmdPrefixObj); + Tcl_IncrRefCount(cmdPrefixObj); + } + } + } else { + /* * Usual case where we can freely act on the list and dict. */ - for (i = 0; i < subc; i++) { - name = TclGetString(subv[i]); - hPtr = Tcl_CreateHashEntry(hash, name, &isNew); - if (!isNew) { - continue; - } + for (i = 0; i < subc; i++) { + name = TclGetString(subv[i]); + hPtr = Tcl_CreateHashEntry(hash, name, &isNew); + if (!isNew) { + continue; + } - /* + /* * Lookup target in the dictionary. */ - if (mapDict) { - Tcl_DictObjGet(NULL, mapDict, subv[i], &target); - if (target) { - Tcl_SetHashValue(hPtr, target); - Tcl_IncrRefCount(target); - continue; - } - } - - /* - * Target was not in the dictionary. Map onto the namespace. - * In this case there is no guarantee that the command - * is actually there. It is the responsibility of the - * programmer (or [::unknown] of course) to provide the procedure. - */ - - cmdObj = Tcl_NewStringObj(name, -1); - cmdPrefixObj = Tcl_NewListObj(1, &cmdObj); - Tcl_SetHashValue(hPtr, cmdPrefixObj); - Tcl_IncrRefCount(cmdPrefixObj); - } - } + if (mapDict) { + Tcl_DictObjGet(NULL, mapDict, subv[i], &target); + if (target) { + Tcl_SetHashValue(hPtr, target); + Tcl_IncrRefCount(target); + continue; + } + } + + /* + * Target was not in the dictionary. Map onto the namespace. + * In this case there is no guarantee that the command is + * actually there. It is the responsibility of the programmer + * (or [::unknown] of course) to provide the procedure. + */ + + cmdObj = Tcl_NewStringObj(name, TCL_AUTO_LENGTH); + cmdPrefixObj = Tcl_NewListObj(1, &cmdObj); + Tcl_SetHashValue(hPtr, cmdPrefixObj); + Tcl_IncrRefCount(cmdPrefixObj); + } + } } else if (mapDict) { - /* - * No subcmd list, but there is a mapping dictionary, so - * use the keys of that. Convert the contents of the dictionary into the - * form required for the internal hashtable of the ensemble. - */ - - Tcl_DictSearch dictSearch; - Tcl_Obj *keyObj, *valueObj; - int done; - - Tcl_DictObjFirst(NULL, ensemblePtr->subcommandDict, &dictSearch, - &keyObj, &valueObj, &done); - while (!done) { - const char *name = TclGetString(keyObj); - - hPtr = Tcl_CreateHashEntry(hash, name, &isNew); - Tcl_SetHashValue(hPtr, valueObj); - Tcl_IncrRefCount(valueObj); - Tcl_DictObjNext(&dictSearch, &keyObj, &valueObj, &done); - } + /* + * No subcmd list, but there is a mapping dictionary, so use + * the keys of that. Convert the contents of the dictionary into the + * form required for the internal hashtable of the ensemble. + */ + + Tcl_DictSearch dictSearch; + Tcl_Obj *keyObj, *valueObj; + int done; + + Tcl_DictObjFirst(NULL, ensemblePtr->subcommandDict, &dictSearch, + &keyObj, &valueObj, &done); + while (!done) { + const char *name = TclGetString(keyObj); + + hPtr = Tcl_CreateHashEntry(hash, name, &isNew); + Tcl_SetHashValue(hPtr, valueObj); + Tcl_IncrRefCount(valueObj); + Tcl_DictObjNext(&dictSearch, &keyObj, &valueObj, &done); + } } else { /* * Use the array of patterns and the hash table whose keys are the @@ -2703,8 +2784,8 @@ BuildEnsembleConfig( hPtr = Tcl_FirstHashEntry(&ensemblePtr->nsPtr->cmdTable, &search); for (; hPtr!= NULL ; hPtr=Tcl_NextHashEntry(&search)) { - char *nsCmdName = /* Name of command in namespace. */ - (char *)Tcl_GetHashKey(&ensemblePtr->nsPtr->cmdTable, hPtr); + char *nsCmdName = (char *) /* Name of command in namespace. */ + Tcl_GetHashKey(&ensemblePtr->nsPtr->cmdTable, hPtr); for (i=0 ; i<ensemblePtr->nsPtr->numExportPatterns ; i++) { if (Tcl_StringMatch(nsCmdName, @@ -2752,8 +2833,8 @@ BuildEnsembleConfig( * the hash too, and vice versa, and run quicksort over the array. */ - ensemblePtr->subcommandArrayPtr = - (char **)Tcl_Alloc(sizeof(char *) * hash->numEntries); + ensemblePtr->subcommandArrayPtr = (char **) + Tcl_Alloc(sizeof(char *) * hash->numEntries); /* * Fill the array from both ends as this reduces the likelihood of @@ -2777,12 +2858,14 @@ BuildEnsembleConfig( j = hash->numEntries; hPtr = Tcl_FirstHashEntry(hash, &search); while (hPtr != NULL) { - ensemblePtr->subcommandArrayPtr[i++] = (char *)Tcl_GetHashKey(hash, hPtr); + ensemblePtr->subcommandArrayPtr[i++] = (char *) + Tcl_GetHashKey(hash, hPtr); hPtr = Tcl_NextHashEntry(&search); if (hPtr == NULL) { break; } - ensemblePtr->subcommandArrayPtr[--j] = (char *)Tcl_GetHashKey(hash, hPtr); + ensemblePtr->subcommandArrayPtr[--j] = (char *) + Tcl_GetHashKey(hash, hPtr); hPtr = Tcl_NextHashEntry(&search); } if (hash->numEntries > 1) { @@ -2796,7 +2879,8 @@ BuildEnsembleConfig( * * NsEnsembleStringOrder -- * - * Helper to for uset with sort() that compares two string pointers. + * Helper to for use with qsort() that compares two array entries that + * contain string pointers. * * Results: * -1 if the first string is smaller, 1 if the second string is smaller, @@ -2810,8 +2894,8 @@ BuildEnsembleConfig( static int NsEnsembleStringOrder( - const void *strPtr1, - const void *strPtr2) + const void *strPtr1, /* Points to first array entry */ + const void *strPtr2) /* Points to second array entry */ { return strcmp(*(const char **)strPtr1, *(const char **)strPtr2); } @@ -2873,7 +2957,8 @@ DupEnsembleCmdRep( Tcl_Obj *copyPtr) { EnsembleCmdRep *ensembleCmd; - EnsembleCmdRep *ensembleCopy = (EnsembleCmdRep *)Tcl_Alloc(sizeof(EnsembleCmdRep)); + EnsembleCmdRep *ensembleCopy = (EnsembleCmdRep *) + Tcl_Alloc(sizeof(EnsembleCmdRep)); ECRGetInternalRep(objPtr, ensembleCmd); ECRSetInternalRep(copyPtr, ensembleCopy); @@ -3140,7 +3225,7 @@ TclCompileEnsemble( if (newCmdPtr == NULL || Tcl_IsSafe(interp) || newCmdPtr->nsPtr->flags & NS_SUPPRESS_COMPILATION || newCmdPtr->flags & CMD_HAS_EXEC_TRACES - || ((Interp *)interp)->flags & DONT_COMPILE_CMDS_INLINE) { + || ((Interp *) interp)->flags & DONT_COMPILE_CMDS_INLINE) { /* * Maps to an undefined command or a command without a compiler. * Cannot compile. @@ -3192,9 +3277,9 @@ TclCompileEnsemble( */ while (mapPtr->nuloc > eclIndex + 1) { - mapPtr->nuloc--; - Tcl_Free(mapPtr->loc[mapPtr->nuloc].line); - mapPtr->loc[mapPtr->nuloc].line = NULL; + mapPtr->nuloc--; + Tcl_Free(mapPtr->loc[mapPtr->nuloc].line); + mapPtr->loc[mapPtr->nuloc].line = NULL; } /* @@ -3408,7 +3493,7 @@ CompileToInvokedCommand( for (i = 0, tokPtr = parsePtr->tokenPtr; i < parsePtr->numWords; i++, tokPtr = TokenAfter(tokPtr)) { if (i > 0 && i <= numWords) { - bytes = TclGetStringFromObj(words[i-1], &length); + bytes = TclGetStringFromObj(words[i - 1], &length); PushLiteral(envPtr, bytes, length); continue; } @@ -3450,7 +3535,8 @@ CompileToInvokedCommand( * Do the replacing dispatch. */ - TclEmitInvoke(envPtr, INST_INVOKE_REPLACE, parsePtr->numWords,numWords+1); + TclEmitInvoke(envPtr, INST_INVOKE_REPLACE, parsePtr->numWords, + numWords + 1); } /* diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 4b0284f..fab8590 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -659,7 +659,7 @@ static Tcl_NRPostProc TEBCresume; * compiled bytecode for Tcl expressions. */ -static const Tcl_ObjType exprCodeType = { +const Tcl_ObjType tclExprCodeType = { "exprcode", FreeExprCodeInternalRep, /* freeIntRepProc */ DupExprCodeInternalRep, /* dupIntRepProc */ @@ -1417,7 +1417,7 @@ CompileExprObj( * is valid in the current context. */ - ByteCodeGetInternalRep(objPtr, &exprCodeType, codePtr); + ByteCodeGetInternalRep(objPtr, &tclExprCodeType, codePtr); if (codePtr != NULL) { Namespace *namespacePtr = iPtr->varFramePtr->nsPtr; @@ -1427,7 +1427,7 @@ CompileExprObj( || (codePtr->nsPtr != namespacePtr) || (codePtr->nsEpoch != namespacePtr->resolverEpoch) || (codePtr->localCachePtr != iPtr->varFramePtr->localCachePtr)) { - Tcl_StoreInternalRep(objPtr, &exprCodeType, NULL); + Tcl_StoreInternalRep(objPtr, &tclExprCodeType, NULL); codePtr = NULL; } } @@ -1460,7 +1460,7 @@ CompileExprObj( */ TclEmitOpcode(INST_DONE, &compEnv); - codePtr = TclInitByteCodeObj(objPtr, &exprCodeType, &compEnv); + codePtr = TclInitByteCodeObj(objPtr, &tclExprCodeType, &compEnv); TclFreeCompileEnv(&compEnv); if (iPtr->varFramePtr->localCachePtr) { codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr; @@ -1529,7 +1529,7 @@ FreeExprCodeInternalRep( Tcl_Obj *objPtr) { ByteCode *codePtr; - ByteCodeGetInternalRep(objPtr, &exprCodeType, codePtr); + ByteCodeGetInternalRep(objPtr, &tclExprCodeType, codePtr); assert(codePtr != NULL); TclReleaseByteCode(codePtr); @@ -3951,7 +3951,7 @@ TEBCresume( varPtr = TclObjLookupVarEx(interp, part1Ptr, NULL, 0, NULL, /*createPart1*/1, /*createPart2*/0, &arrayPtr); doConst: - if (TclIsVarConstant(varPtr)) { + if (TclIsVarConstant(varPtr)) { TRACE_APPEND(("\n")); NEXT_INST_V(pcAdjustment, cleanup, 0); } @@ -7865,8 +7865,10 @@ FinalizeOONextFilter( * Helper to calculate small powers of integers whose result is wide. */ static inline Tcl_WideInt -WidePwrSmallExpon(Tcl_WideInt w1, long exponent) { - +WidePwrSmallExpon( + Tcl_WideInt w1, + long exponent) +{ Tcl_WideInt wResult; wResult = w1 * w1; /* b**2 */ diff --git a/generic/tclGetDate.y b/generic/tclGetDate.y index 3b04de4..301bf9d 100644 --- a/generic/tclGetDate.y +++ b/generic/tclGetDate.y @@ -1025,7 +1025,7 @@ TclClockFreeScan( /* parse */ status = yyparse(info); if (status == 1) { - const char *msg = NULL; + const char *msg = NULL; if (info->errFlags & CLF_HAVEDATE) { msg = "more than one date in string"; } else if (info->errFlags & CLF_TIME) { diff --git a/generic/tclHash.c b/generic/tclHash.c index 89807e2..9bdb079 100644 --- a/generic/tclHash.c +++ b/generic/tclHash.c @@ -44,8 +44,6 @@ static size_t HashArrayKey(Tcl_HashTable *tablePtr, void *keyPtr); static Tcl_HashEntry * AllocStringEntry(Tcl_HashTable *tablePtr, void *keyPtr); -static int CompareStringKeys(void *keyPtr, Tcl_HashEntry *hPtr); -static size_t HashStringKey(Tcl_HashTable *tablePtr, void *keyPtr); /* * Function prototypes for static functions in this file: @@ -80,8 +78,8 @@ const Tcl_HashKeyType tclOneWordHashKeyType = { const Tcl_HashKeyType tclStringHashKeyType = { TCL_HASH_KEY_TYPE_VERSION, /* version */ 0, /* flags */ - HashStringKey, /* hashKeyProc */ - CompareStringKeys, /* compareKeysProc */ + TclHashStringKey, /* hashKeyProc */ + TclCompareStringKeys, /* compareKeysProc */ AllocStringEntry, /* allocEntryProc */ NULL /* freeEntryProc */ }; @@ -556,8 +554,7 @@ Tcl_FirstHashEntry( Tcl_HashEntry * Tcl_NextHashEntry( - Tcl_HashSearch *searchPtr) - /* Place to store information about progress + Tcl_HashSearch *searchPtr) /* Place to store information about progress * through the table. Must have been * initialized by calling * Tcl_FirstHashEntry. */ @@ -671,7 +668,7 @@ Tcl_HashStats( static Tcl_HashEntry * AllocArrayEntry( Tcl_HashTable *tablePtr, /* Hash table. */ - void *keyPtr) /* Key to store in the hash table entry. */ + void *keyPtr) /* Key to store in the hash table entry. */ { Tcl_HashEntry *hPtr; size_t count = tablePtr->keyType * sizeof(int); @@ -707,7 +704,7 @@ AllocArrayEntry( static int CompareArrayKeys( - void *keyPtr, /* New key to compare. */ + void *keyPtr, /* New key to compare. */ Tcl_HashEntry *hPtr) /* Existing key to compare. */ { size_t count = hPtr->tablePtr->keyType * sizeof(int); @@ -736,7 +733,7 @@ CompareArrayKeys( static size_t HashArrayKey( Tcl_HashTable *tablePtr, /* Hash table. */ - void *keyPtr) /* Key from which to compute hash value. */ + void *keyPtr) /* Key from which to compute hash value. */ { const int *array = (const int *) keyPtr; size_t result; @@ -768,7 +765,7 @@ HashArrayKey( static Tcl_HashEntry * AllocStringEntry( TCL_UNUSED(Tcl_HashTable *), - void *keyPtr) /* Key to store in the hash table entry. */ + void *keyPtr) /* Key to store in the hash table entry. */ { const char *string = (const char *) keyPtr; Tcl_HashEntry *hPtr; @@ -788,7 +785,7 @@ AllocStringEntry( /* *---------------------------------------------------------------------- * - * CompareStringKeys -- + * TclCompareStringKeys -- * * Compares two string keys. * @@ -802,9 +799,9 @@ AllocStringEntry( *---------------------------------------------------------------------- */ -static int -CompareStringKeys( - void *keyPtr, /* New key to compare. */ +int +TclCompareStringKeys( + void *keyPtr, /* New key to compare. */ Tcl_HashEntry *hPtr) /* Existing key to compare. */ { return !strcmp((char *)keyPtr, hPtr->key.string); @@ -813,7 +810,7 @@ CompareStringKeys( /* *---------------------------------------------------------------------- * - * HashStringKey -- + * TclHashStringKey -- * * Compute a one-word summary of a text string, which can be used to * generate a hash index. @@ -827,10 +824,10 @@ CompareStringKeys( *---------------------------------------------------------------------- */ -static size_t -HashStringKey( +size_t +TclHashStringKey( TCL_UNUSED(Tcl_HashTable *), - void *keyPtr) /* Key from which to compute hash value. */ + void *keyPtr) /* Key from which to compute hash value. */ { const char *string = (const char *)keyPtr; size_t result; diff --git a/generic/tclIO.c b/generic/tclIO.c index 96a6d33..4859bc1 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -1530,8 +1530,8 @@ TclGetChannelFromObj( ChanGetInternalRep(objPtr, resPtr); if (resPtr) { /* - * Confirm validity of saved lookup results. - */ + * Confirm validity of saved lookup results. + */ statePtr = resPtr->statePtr; if ((resPtr->interp == interp) /* Same interp context */ @@ -1599,7 +1599,7 @@ Tcl_Channel Tcl_CreateChannel( const Tcl_ChannelType *typePtr, /* The channel type record. */ const char *chanName, /* Name of channel to record. */ - void *instanceData, /* Instance specific data. */ + void *instanceData, /* Instance specific data. */ int mask) /* TCL_READABLE & TCL_WRITABLE to indicate if * the channel is readable, writable. */ { @@ -1809,7 +1809,7 @@ Tcl_StackChannel( const Tcl_ChannelType *typePtr, /* The channel type record for the new * channel. */ - void *instanceData, /* Instance specific data for the new + void *instanceData, /* Instance specific data for the new * channel. */ int mask, /* TCL_READABLE & TCL_WRITABLE to indicate if * the channel is readable, writable. */ @@ -4514,15 +4514,15 @@ Write( flushed += statePtr->bufSize; /* - * We just flushed. So if we have needNlFlush set to record that - * we need to flush because there is a (translated) newline in the - * buffer, that's likely not true any more. But there is a tricky - * exception. If we have saved bytes that did not really get - * flushed and those bytes came from a translation of a newline as - * the last thing taken from the src array, then needNlFlush needs - * to remain set to flag that the next buffer still needs a - * newline flush. - */ + * We just flushed. So if we have needNlFlush set to record that + * we need to flush because there is a (translated) newline in the + * buffer, that's likely not true any more. But there is a tricky + * exception. If we have saved bytes that did not really get + * flushed and those bytes came from a translation of a newline as + * the last thing taken from the src array, then needNlFlush needs + * to remain set to flag that the next buffer still needs a + * newline flush. + */ if (needNlFlush && (saved == 0 || src[-1] != '\n')) { needNlFlush = 0; @@ -10006,12 +10006,12 @@ CopyData( * * Results: * The number of bytes actually stored (<= bytesToRead), - * or TCL_INDEX_NONE if there is an error in reading the channel. Use - * Tcl_GetErrno() to retrieve the error code for the error + * or TCL_INDEX_NONE 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 + * requested when * - EOF is reached on the channel; or * - the channel is non-blocking, and we've read all we can * without blocking. @@ -10090,7 +10090,7 @@ DoRead( */ while (!bufPtr || /* We got no buffer! OR */ - (!IsBufferFull(bufPtr) && /* Our buffer has room AND */ + (!IsBufferFull(bufPtr) && /* Our buffer has room AND */ ((Tcl_Size) BytesLeft(bufPtr) < bytesToRead))) { /* Not enough bytes in it yet * to fill the dst */ @@ -10762,7 +10762,8 @@ Tcl_IsChannelExisting( const char * Tcl_ChannelName( - const Tcl_ChannelType *chanTypePtr) /* Pointer to channel type. */ + const Tcl_ChannelType *chanTypePtr) + /* Pointer to channel type. */ { return chanTypePtr->typeName; } diff --git a/generic/tclIO.h b/generic/tclIO.h index 8823e06..711863b 100644 --- a/generic/tclIO.h +++ b/generic/tclIO.h @@ -39,12 +39,12 @@ typedef struct ChannelBuffer { Tcl_Size refCount; /* Current uses count */ Tcl_Size nextAdded; /* The next position into which a character * will be put in the buffer. */ - Tcl_Size nextRemoved; /* Position of next byte to be removed from + Tcl_Size nextRemoved; /* Position of next byte to be removed from * the buffer. */ Tcl_Size bufLength; /* How big is the buffer? */ struct ChannelBuffer *nextPtr; - /* Next buffer in chain. */ - char buf[TCLFLEXARRAY]; /* Placeholder for real buffer. The real + /* Next buffer in chain. */ + char buf[TCLFLEXARRAY]; /* Placeholder for real buffer. The real * buffer occupies this space + bufSize-1 * bytes. This must be the last field in the * structure. */ @@ -96,7 +96,7 @@ typedef struct EventScriptRecord { typedef struct Channel { struct ChannelState *state; /* Split out state information */ - void *instanceData; /* Instance-specific data provided by creator + void *instanceData; /* Instance-specific data provided by creator * of channel. */ const Tcl_ChannelType *typePtr; /* Pointer to channel type structure. */ struct Channel *downChanPtr;/* Refers to channel this one was stacked @@ -160,7 +160,8 @@ typedef struct ChannelState { * input. */ #if TCL_MAJOR_VERSION < 9 int outEofChar; /* If nonzero, append this to the channel when - * it is closed if it is open for writing. For Tcl 8.x only */ + * it is closed if it is open for writing. + * For Tcl 8.x only */ #endif int unreportedError; /* Non-zero if an error report was deferred * because it happened in the background. The @@ -214,8 +215,8 @@ typedef struct ChannelState { * precedence over a Posix error code returned by a channel operation. */ - Tcl_Obj* chanMsg; - Tcl_Obj* unreportedMsg; /* Non-NULL if an error report was deferred + Tcl_Obj *chanMsg; + Tcl_Obj *unreportedMsg; /* Non-NULL if an error report was deferred * because it happened in the background. The * value is the chanMg, if any. #219's * companion to 'unreportedError'. */ diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c index 2f3f48e..c7ecb76 100644 --- a/generic/tclIOCmd.c +++ b/generic/tclIOCmd.c @@ -39,7 +39,7 @@ static Tcl_ThreadDataKey dataKey; */ static Tcl_ExitProc FinalizeIOCmdTSD; -static Tcl_TcpAcceptProc AcceptCallbackProc; +static Tcl_TcpAcceptProc AcceptCallbackProc; static Tcl_ObjCmdProc ChanPendingObjCmd; static Tcl_ObjCmdProc ChanTruncateObjCmd; static void RegisterTcpServerInterpCleanup( diff --git a/generic/tclIOGT.c b/generic/tclIOGT.c index aa63cd0..a1ba9f9 100644 --- a/generic/tclIOGT.c +++ b/generic/tclIOGT.c @@ -115,23 +115,23 @@ static inline void ResultAdd(ResultBuffer *r, unsigned char *buf, */ static const Tcl_ChannelType transformChannelType = { - "transform", /* Type name. */ - TCL_CHANNEL_VERSION_5, /* v5 channel */ - NULL, /* Close proc. */ - TransformInputProc, /* Input proc. */ - TransformOutputProc, /* Output proc. */ - NULL, /* Seek proc. */ - TransformSetOptionProc, /* Set option proc. */ - TransformGetOptionProc, /* Get option proc. */ - TransformWatchProc, /* Initialize notifier. */ - TransformGetFileHandleProc, /* Get OS handles out of channel. */ - TransformCloseProc, /* close2proc */ - TransformBlockModeProc, /* Set blocking/nonblocking mode.*/ + "transform", + TCL_CHANNEL_VERSION_5, + NULL, /* Deprecated. */ + TransformInputProc, + TransformOutputProc, + NULL, /* Deprecated. */ + TransformSetOptionProc, + TransformGetOptionProc, + TransformWatchProc, + TransformGetFileHandleProc, + TransformCloseProc, + TransformBlockModeProc, NULL, /* Flush proc. */ - TransformNotifyProc, /* Handling of events bubbling up. */ - TransformWideSeekProc, /* Wide seek proc. */ - NULL, /* Thread action. */ - NULL /* Truncate. */ + TransformNotifyProc, + TransformWideSeekProc, + NULL, /* Thread action proc. */ + NULL /* Truncate proc. */ }; /* @@ -850,14 +850,14 @@ TransformOutputProc( static long long TransformWideSeekProc( - void *instanceData, /* The channel to manipulate. */ + void *instanceData, /* The channel to manipulate. */ long long offset, /* Size of movement. */ int mode, /* How to move. */ int *errorCodePtr) /* Location of error flag. */ { TransformChannelData *dataPtr = (TransformChannelData *)instanceData; Tcl_Channel parent = Tcl_GetStackedChannel(dataPtr->self); - const Tcl_ChannelType *parentType = Tcl_GetChannelType(parent); + const Tcl_ChannelType *parentType = Tcl_GetChannelType(parent); Tcl_DriverWideSeekProc *parentWideSeekProc = Tcl_ChannelWideSeekProc(parentType); void *parentData = Tcl_GetChannelInstanceData(parent); @@ -905,7 +905,7 @@ TransformWideSeekProc( *errorCodePtr = EINVAL; return -1; } - return parentWideSeekProc(parentData, offset, mode, errorCodePtr); + return parentWideSeekProc(parentData, offset, mode, errorCodePtr); } /* diff --git a/generic/tclIORChan.c b/generic/tclIORChan.c index e8a243b..c8449aa 100644 --- a/generic/tclIORChan.c +++ b/generic/tclIORChan.c @@ -59,28 +59,28 @@ static int ReflectTruncate(void *clientData, * The C layer channel type/driver definition used by the reflection. */ -static const Tcl_ChannelType tclRChannelType = { - "tclrchannel", /* Type name. */ - TCL_CHANNEL_VERSION_5, /* v5 channel */ - NULL, /* Old close API */ - ReflectInput, /* Handle read request */ - ReflectOutput, /* Handle write request */ - NULL, - ReflectSetOption, /* Set options. */ - ReflectGetOption, /* Get options. */ - ReflectWatch, /* Initialize notifier */ - NULL, /* Get OS handle from the channel. */ - ReflectClose, /* Close channel. Clean instance data */ - ReflectBlock, /* Set blocking/nonblocking. */ - NULL, /* Flush channel. */ - NULL, /* Handle events. */ - ReflectSeekWide, /* Move access point (64 bit). */ +static const Tcl_ChannelType reflectedChannelType = { + "tclrchannel", + TCL_CHANNEL_VERSION_5, + NULL, /* Deprecated */ + ReflectInput, + ReflectOutput, + NULL, /* Deprecated */ + ReflectSetOption, + ReflectGetOption, + ReflectWatch, + NULL, /* Get OS handle from the channel. */ + ReflectClose, + ReflectBlock, + NULL, /* Flush channel. */ + NULL, /* Handle bubbled events. */ + ReflectSeekWide, #if TCL_THREADS - ReflectThread, /* thread action, tracking owner */ + ReflectThread, #else - NULL, /* thread action */ + NULL, /* Thread action proc */ #endif - ReflectTruncate /* Truncate. */ + ReflectTruncate /* Truncate proc. */ }; /* @@ -667,7 +667,7 @@ TclChanCreateObjCmd( * Everything is fine now. */ - chan = Tcl_CreateChannel(&tclRChannelType, TclGetString(rcId), rcPtr, + chan = Tcl_CreateChannel(&reflectedChannelType, TclGetString(rcId), rcPtr, mode); rcPtr->chan = chan; TclChannelPreserve(chan); @@ -682,7 +682,7 @@ TclChanCreateObjCmd( Tcl_ChannelType *clonePtr = (Tcl_ChannelType *)Tcl_Alloc(sizeof(Tcl_ChannelType)); - memcpy(clonePtr, &tclRChannelType, sizeof(Tcl_ChannelType)); + memcpy(clonePtr, &reflectedChannelType, sizeof(Tcl_ChannelType)); if (!(methods & FLAG(METH_CONFIGURE))) { clonePtr->setOptionProc = NULL; @@ -1179,7 +1179,7 @@ ReflectClose( #endif tctPtr = ((Channel *)rcPtr->chan)->typePtr; - if (tctPtr && tctPtr != &tclRChannelType) { + if (tctPtr && tctPtr != &reflectedChannelType) { Tcl_Free((void *)tctPtr); ((Channel *)rcPtr->chan)->typePtr = NULL; } @@ -1248,7 +1248,7 @@ ReflectClose( } #endif tctPtr = ((Channel *)rcPtr->chan)->typePtr; - if (tctPtr && tctPtr != &tclRChannelType) { + if (tctPtr && tctPtr != &reflectedChannelType) { Tcl_Free((void *)tctPtr); ((Channel *)rcPtr->chan)->typePtr = NULL; } diff --git a/generic/tclIORTrans.c b/generic/tclIORTrans.c index 2ad6ecf0..c151448 100644 --- a/generic/tclIORTrans.c +++ b/generic/tclIORTrans.c @@ -55,24 +55,24 @@ static int ReflectNotify(void *clientData, int mask); * The C layer channel type/driver definition used by the reflection. */ -static const Tcl_ChannelType tclRTransformType = { - "tclrtransform", /* Type name. */ - TCL_CHANNEL_VERSION_5, /* v5 channel. */ - NULL, - ReflectInput, /* Handle read request. */ - ReflectOutput, /* Handle write request. */ - NULL, /* Move location of access point. */ - ReflectSetOption, /* Set options. */ - ReflectGetOption, /* Get options. */ - ReflectWatch, /* Initialize notifier. */ - ReflectHandle, /* Get OS handle from the channel. */ - ReflectClose, /* Close channel, clean instance data. */ - ReflectBlock, /* Set blocking/nonblocking. */ +static const Tcl_ChannelType reflectedTransformType = { + "tclrtransform", + TCL_CHANNEL_VERSION_5, + NULL, /* Deprecated. */ + ReflectInput, + ReflectOutput, + NULL, /* Deprecated. */ + ReflectSetOption, + ReflectGetOption, + ReflectWatch, + ReflectHandle, + ReflectClose, + ReflectBlock, NULL, /* Flush channel. Not used by core. */ - ReflectNotify, /* Handle events. */ - ReflectSeekWide, /* Move access point (64 bit). */ - NULL, /* thread action */ - NULL /* truncate */ + ReflectNotify, + ReflectSeekWide, + NULL, /* Thread action proc. */ + NULL /* Truncate proc. */ }; /* @@ -678,7 +678,7 @@ TclChanPushObjCmd( rtPtr->methods = methods; rtPtr->mode = mode; - rtPtr->chan = Tcl_StackChannel(interp, &tclRTransformType, rtPtr, mode, + rtPtr->chan = Tcl_StackChannel(interp, &reflectedTransformType, rtPtr, mode, rtPtr->parent); /* @@ -1374,8 +1374,8 @@ ReflectSeekWide( *errorCodePtr = EINVAL; curPos = -1; } else { - curPos = Tcl_ChannelWideSeekProc(parent->typePtr)(parent->instanceData, offset, - seekMode, errorCodePtr); + curPos = Tcl_ChannelWideSeekProc(parent->typePtr)(parent->instanceData, offset, + seekMode, errorCodePtr); } if (curPos == -1) { Tcl_SetErrno(*errorCodePtr); diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c index c3131cd..3ead628 100644 --- a/generic/tclIOUtil.c +++ b/generic/tclIOUtil.c @@ -3464,7 +3464,7 @@ Tcl_LoadFile( static void * DivertFindSymbol( - Tcl_Interp *interp, /* The relevant interpreter. */ + Tcl_Interp *interp, /* The relevant interpreter. */ Tcl_LoadHandle loadHandle, /* A handle to the diverted module. */ const char *symbol) /* The name of symbol to resolve. */ { diff --git a/generic/tclInt.h b/generic/tclInt.h index bb6c4d0..7f0e842 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -1091,10 +1091,10 @@ typedef struct ActiveInterpTrace { * related flag values. * * TCL_TRACE_ENTER_EXEC - triggers enter/enterstep traces. - * - passed to Tcl_CreateObjTrace to set up + * - passed to Tcl_CreateObjTrace to set up * "enterstep" traces. * TCL_TRACE_LEAVE_EXEC - triggers leave/leavestep traces. - * - passed to Tcl_CreateObjTrace to set up + * - passed to Tcl_CreateObjTrace to set up * "leavestep" traces. */ @@ -1546,15 +1546,15 @@ struct CompileEnv; * be one of the following: * * TCL_OK Compilation completed normally. - * TCL_ERROR Compilation could not be completed. This can be just a - * judgment by the CompileProc that the command is too - * complex to compile effectively, or it can indicate - * that in the current state of the interp, the command - * would raise an error. The bytecode compiler will not - * do any error reporting at compiler time. Error - * reporting is deferred until the actual runtime, - * because by then changes in the interp state may allow - * the command to be successfully evaluated. + * TCL_ERROR Compilation could not be completed. This can be just a + * judgment by the CompileProc that the command is too + * complex to compile effectively, or it can indicate + * that in the current state of the interp, the command + * would raise an error. The bytecode compiler will not + * do any error reporting at compiler time. Error + * reporting is deferred until the actual runtime, + * because by then changes in the interp state may allow + * the command to be successfully evaluated. */ typedef int (CompileProc)(Tcl_Interp *interp, Tcl_Parse *parsePtr, @@ -2166,7 +2166,8 @@ typedef struct Interp { * processing an ensemble. */ Tcl_Size numRemovedObjs;/* How many arguments have been stripped off * because of ensemble processing. */ - Tcl_Size numInsertedObjs;/* How many of the current arguments were + Tcl_Size numInsertedObjs; + /* How many of the current arguments were * inserted by an ensemble. */ } ensembleRewrite; @@ -2924,7 +2925,7 @@ typedef struct ProcessGlobalValue { Tcl_Encoding encoding; /* system encoding when global string was * initialized. */ TclInitProcessGlobalValueProc *proc; - /* A procedure to initialize the global string + /* A procedure to initialize the global string * copy when a "get" request comes in before * any "set" request has been received. */ Tcl_Mutex mutex; /* Enforce orderly access from multiple @@ -3109,6 +3110,7 @@ MODULE_SCOPE const Tcl_ObjType tclBignumType; MODULE_SCOPE const Tcl_ObjType tclBooleanType; MODULE_SCOPE const Tcl_ObjType tclByteCodeType; MODULE_SCOPE const Tcl_ObjType tclDoubleType; +MODULE_SCOPE const Tcl_ObjType tclExprCodeType; MODULE_SCOPE const Tcl_ObjType tclIntType; MODULE_SCOPE const Tcl_ObjType tclIndexType; MODULE_SCOPE const Tcl_ObjType tclListType; @@ -3405,6 +3407,8 @@ MODULE_SCOPE int TclGetLoadedLibraries(Tcl_Interp *interp, const char *packageName); MODULE_SCOPE int TclGetWideBitsFromObj(Tcl_Interp *, Tcl_Obj *, Tcl_WideInt *); +MODULE_SCOPE int TclCompareStringKeys(void *keyPtr, Tcl_HashEntry *hPtr); +MODULE_SCOPE size_t TclHashStringKey(Tcl_HashTable *tablePtr, void *keyPtr); MODULE_SCOPE int TclIncrObj(Tcl_Interp *interp, Tcl_Obj *valuePtr, Tcl_Obj *incrPtr); MODULE_SCOPE Tcl_Obj * TclIncrObjVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr, @@ -3486,13 +3490,12 @@ MODULE_SCOPE void TclParseInit(Tcl_Interp *interp, const char *string, MODULE_SCOPE Tcl_Size TclParseAllWhiteSpace(const char *src, Tcl_Size numBytes); MODULE_SCOPE int TclProcessReturn(Tcl_Interp *interp, int code, int level, Tcl_Obj *returnOpts); -MODULE_SCOPE void TclUndoRefCount(Tcl_Obj *objPtr); +MODULE_SCOPE void TclUndoRefCount(Tcl_Obj *objPtr); MODULE_SCOPE int TclpObjLstat(Tcl_Obj *pathPtr, Tcl_StatBuf *buf); MODULE_SCOPE Tcl_Obj * TclpTempFileName(void); MODULE_SCOPE Tcl_Obj * TclpTempFileNameForLibrary(Tcl_Interp *interp, Tcl_Obj* pathPtr); -MODULE_SCOPE int TclNewArithSeriesObj(Tcl_Interp *interp, - Tcl_Obj **arithSeriesPtr, +MODULE_SCOPE Tcl_Obj * TclNewArithSeriesObj(Tcl_Interp *interp, int useDoubles, Tcl_Obj *startObj, Tcl_Obj *endObj, Tcl_Obj *stepObj, Tcl_Obj *lenObj); MODULE_SCOPE Tcl_Obj * TclNewFSPathObj(Tcl_Obj *dirPtr, const char *addStrRep, diff --git a/generic/tclLink.c b/generic/tclLink.c index 3bd855b..2e7d3b0 100644 --- a/generic/tclLink.c +++ b/generic/tclLink.c @@ -109,7 +109,7 @@ static int SetInvalidRealFromAny(Tcl_Interp *interp, * A marker type used to flag weirdnesses so we can pass them around right. */ -static Tcl_ObjType invalidRealType = { +static const Tcl_ObjType invalidRealType = { "invalidReal", /* name */ NULL, /* freeIntRepProc */ NULL, /* dupIntRepProc */ diff --git a/generic/tclListObj.c b/generic/tclListObj.c index 20e85dd..726a9db 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -266,7 +266,8 @@ ListSpanNew( *------------------------------------------------------------------------ */ static inline void -ListSpanDecrRefs(ListSpan *spanPtr) +ListSpanDecrRefs( + ListSpan *spanPtr) { if (spanPtr->refCount <= 1) { Tcl_Free(spanPtr); @@ -343,7 +344,8 @@ ListSpanMerited( *------------------------------------------------------------------------ */ static inline void -ListRepFreeUnreferenced(const ListRep *repPtr) +ListRepFreeUnreferenced( + const ListRep *repPtr) { if (! ListRepIsShared(repPtr) && repPtr->spanPtr) { /* T:listrep-1.5.1 */ @@ -492,12 +494,12 @@ MemoryAllocationError( *------------------------------------------------------------------------ */ static int -ListLimitExceededError(Tcl_Interp *interp) +ListLimitExceededError( + Tcl_Interp *interp) { if (interp != NULL) { - Tcl_SetObjResult( - interp, - Tcl_NewStringObj("max length of a Tcl list exceeded", -1)); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "max length of a Tcl list exceeded", -1)); Tcl_SetErrorCode(interp, "TCL", "MEMORY", (char *)NULL); } return TCL_ERROR; @@ -523,7 +525,9 @@ ListLimitExceededError(Tcl_Interp *interp) *------------------------------------------------------------------------ */ static inline void -ListRepUnsharedShiftDown(ListRep *repPtr, Tcl_Size shiftCount) +ListRepUnsharedShiftDown( + ListRep *repPtr, + Tcl_Size shiftCount) { ListStore *storePtr; @@ -578,7 +582,9 @@ ListRepUnsharedShiftDown(ListRep *repPtr, Tcl_Size shiftCount) */ #if 0 static inline void -ListRepUnsharedShiftUp(ListRep *repPtr, Tcl_Size shiftCount) +ListRepUnsharedShiftUp( + ListRep *repPtr, + Tcl_Size shiftCount) { ListStore *storePtr; @@ -624,7 +630,10 @@ ListRepUnsharedShiftUp(ListRep *repPtr, Tcl_Size shiftCount) *------------------------------------------------------------------------ */ static void -ListRepValidate(const ListRep *repPtr, const char *file, int lineNum) +ListRepValidate( + const ListRep *repPtr, + const char *file, + int lineNum) { ListStore *storePtr = repPtr->storePtr; const char *condition; @@ -689,7 +698,9 @@ failure: *------------------------------------------------------------------------ */ void -TclListObjValidate(Tcl_Interp *interp, Tcl_Obj *listObj) +TclListObjValidate( + Tcl_Interp *interp, + Tcl_Obj *listObj) { ListRep listRep; if (TclListObjGetRep(interp, listObj, &listRep) != TCL_OK) { @@ -1668,7 +1679,7 @@ Tcl_ListObjGetElements( return TclObjTypeGetElements(interp, objPtr, objcPtr, objvPtr); } if (TclListObjGetRep(interp, objPtr, &listRep) != TCL_OK) { - return TCL_ERROR; + return TCL_ERROR; } ListRepElements(&listRep, *objcPtr, *objvPtr); return TCL_OK; @@ -1730,8 +1741,8 @@ Tcl_ListObjAppendList( * the passed Tcl_Obj is not a list object, it will be converted to one * and an error raised if the conversion fails. * - * The Tcl_Obj must not be shared though the internal representation - * may be. + * The Tcl_Obj must not be shared though the internal representation + * may be. * * Results: * On success, TCL_OK is returned with the specified elements appended. @@ -1918,27 +1929,23 @@ Tcl_ListObjAppendElement( * * Tcl_ListObjIndex -- * - * Retrieve a pointer to the element of 'listPtr' at 'index'. The index - * of the first element is 0. - * - * Value - * - * TCL_OK + * Retrieve a pointer to the element of 'listPtr' at 'index'. The index + * of the first element is 0. * + * Returns: + * TCL_OK * A pointer to the element at 'index' is stored in 'objPtrPtr'. If * 'index' is out of range, NULL is stored in 'objPtrPtr'. This * object should be treated as readonly and its 'refCount' is _not_ * incremented. The caller must do that if it holds on to the * reference. * - * TCL_ERROR - * - * 'listPtr' is not a valid list. An error message is left in the - * interpreter's result if 'interp' is not NULL. - * - * Effect + * TCL_ERROR + * 'listPtr' is not a valid list. An error message is left in the + * interpreter's result if 'interp' is not NULL. * - * If 'listPtr' is not already of type 'tclListType', it is converted. + * Effect: + * If 'listPtr' is not already of type 'tclListType', it is converted. * *---------------------------------------------------------------------- */ @@ -2917,7 +2924,7 @@ TclLsetFlat( result = TCL_OK; /* Allocate if static array for pending invalidations is too small */ - if (indexCount > (int) (sizeof(pendingInvalidates) / + if (indexCount > (Tcl_Size) (sizeof(pendingInvalidates) / sizeof(pendingInvalidates[0]))) { pendingInvalidatesPtr = (Tcl_Obj **) Tcl_Alloc(indexCount * sizeof(*pendingInvalidatesPtr)); @@ -3024,9 +3031,8 @@ TclLsetFlat( * value of the lset variable. Later on, when we set valueObj * in its proper place, then all containing lists will have * their values changed, and will need their string reps - * spoiled. We maintain a list of all those Tcl_Obj's (via a - * little internalrep surgery) so we can spoil them at that - * time. + * spoiled. We maintain a list of all those Tcl_Obj's + * pendingInvalidatesPtr[] so we can spoil them at that time. */ pendingInvalidatesPtr[numPendingInvalidates] = parentList; diff --git a/generic/tclParse.c b/generic/tclParse.c index e88de0b..dca351c 100644 --- a/generic/tclParse.c +++ b/generic/tclParse.c @@ -1039,7 +1039,7 @@ ParseComment( static int ParseTokens( - const char *src, /* First character to parse. */ + const char *src, /* First character to parse. */ Tcl_Size numBytes, /* Max number of bytes to scan. */ int mask, /* Specifies when to stop parsing. The parse * stops at the first unquoted character whose @@ -1531,7 +1531,7 @@ Tcl_ParseVarName( const char * Tcl_ParseVar( Tcl_Interp *interp, /* Context for looking up variable. */ - const char *start, /* Start of variable substitution. First + const char *start, /* Start of variable substitution. First * character must be "$". */ const char **termPtr) /* If non-NULL, points to word to fill in with * character just after last one in the diff --git a/generic/tclParse.h b/generic/tclParse.h index b28ac8c..1381b30 100644 --- a/generic/tclParse.h +++ b/generic/tclParse.h @@ -1,18 +1,21 @@ /* - * Minimal set of shared macro definitions and declarations so that multiple + * Minimal set of shared flag definitions and declarations so that multiple * source files can make use of the parsing table in tclParse.c */ -#define TYPE_NORMAL 0 -#define TYPE_SPACE 0x1 -#define TYPE_COMMAND_END 0x2 -#define TYPE_SUBS 0x4 -#define TYPE_QUOTE 0x8 -#define TYPE_CLOSE_PAREN 0x10 -#define TYPE_CLOSE_BRACK 0x20 -#define TYPE_BRACE 0x40 -#define TYPE_OPEN_PAREN 0x80 -#define TYPE_BAD_ARRAY_INDEX (TYPE_OPEN_PAREN|TYPE_CLOSE_PAREN|TYPE_QUOTE|TYPE_BRACE) +enum ParseTypeFlags { + TYPE_NORMAL = 0, + TYPE_SPACE = 0x1, + TYPE_COMMAND_END = 0x2, + TYPE_SUBS = 0x4, + TYPE_QUOTE = 0x8, + TYPE_CLOSE_PAREN = 0x10, + TYPE_CLOSE_BRACK = 0x20, + TYPE_BRACE = 0x40, + TYPE_OPEN_PAREN = 0x80, + TYPE_BAD_ARRAY_INDEX = ( + TYPE_OPEN_PAREN | TYPE_CLOSE_PAREN | TYPE_QUOTE | TYPE_BRACE) +}; #define CHAR_TYPE(c) tclCharTypeTable[(unsigned char)(c)] diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c index 9a44863..7664827 100644 --- a/generic/tclPathObj.c +++ b/generic/tclPathObj.c @@ -40,11 +40,11 @@ static int MakeTildeRelativePath(Tcl_Interp *interp, */ static const Tcl_ObjType fsPathType = { - "path", /* name */ - FreeFsPathInternalRep, /* freeIntRepProc */ - DupFsPathInternalRep, /* dupIntRepProc */ - UpdateStringOfFsPath, /* updateStringProc */ - SetFsPathFromAny, /* setFromAnyProc */ + "path", /* name */ + FreeFsPathInternalRep, /* freeIntRepProc */ + DupFsPathInternalRep, /* dupIntRepProc */ + UpdateStringOfFsPath, /* updateStringProc */ + SetFsPathFromAny, /* setFromAnyProc */ TCL_OBJTYPE_V0 }; @@ -2347,7 +2347,7 @@ DupFsPathInternalRep( static void UpdateStringOfFsPath( - Tcl_Obj *pathPtr) /* path obj with string rep to update. */ + Tcl_Obj *pathPtr) /* path obj with string rep to update. */ { FsPath *fsPathPtr = PATHOBJ(pathPtr); Tcl_Size cwdLen; @@ -2469,11 +2469,11 @@ TclNativePathInFilesystem( */ int MakeTildeRelativePath( - Tcl_Interp *interp, /* May be NULL. Only used for error messages */ - const char *user, /* User name. NULL -> current user */ - const char *subPath, /* Rest of path. May be NULL */ - Tcl_DString *dsPtr) /* Output. Is initialized by the function. Must be - * freed on success */ + Tcl_Interp *interp, /* May be NULL. Only used for error messages */ + const char *user, /* User name. NULL -> current user */ + const char *subPath, /* Rest of path. May be NULL */ + Tcl_DString *dsPtr) /* Output. Is initialized by the function. Must + * be freed on success */ { const char *dir; Tcl_DString dirString; @@ -2537,8 +2537,8 @@ MakeTildeRelativePath( */ Tcl_Obj * TclGetHomeDirObj( - Tcl_Interp *interp, /* May be NULL. Only used for error messages */ - const char *user) /* User name. NULL -> current user */ + Tcl_Interp *interp, /* May be NULL. Only used for error messages */ + const char *user) /* User name. NULL -> current user */ { Tcl_DString dirString; @@ -2569,7 +2569,7 @@ TclGetHomeDirObj( */ Tcl_Obj * TclResolveTildePath( - Tcl_Interp *interp, /* May be NULL. Only used for error messages */ + Tcl_Interp *interp, /* May be NULL. Only used for error messages */ Tcl_Obj *pathObj) { const char *path; diff --git a/generic/tclPipe.c b/generic/tclPipe.c index 73f291a..1efe1ba 100644 --- a/generic/tclPipe.c +++ b/generic/tclPipe.c @@ -1021,7 +1021,7 @@ Tcl_Channel Tcl_OpenCommandChannel( Tcl_Interp *interp, /* Interpreter for error reporting. Can NOT be * NULL. */ - Tcl_Size argc, /* How many arguments. */ + Tcl_Size argc, /* How many arguments. */ const char **argv, /* Array of arguments for command pipe. */ int flags) /* Or'ed combination of TCL_STDIN, TCL_STDOUT, * TCL_STDERR, and TCL_ENFORCE_MODE. */ diff --git a/generic/tclPkgConfig.c b/generic/tclPkgConfig.c index d84472c..40ec9d0 100644 --- a/generic/tclPkgConfig.c +++ b/generic/tclPkgConfig.c @@ -22,7 +22,7 @@ * - TCL_COMPILE_STATS OSCMa bytecode compiler statistics. * * - TCL_CFG_DO64BIT NSCMdt tcl is compiled for a 64bit system. - * - NDEBUG NSCMdt tcl is compiled with symbol info off. + * - NDEBUG NSCMdt tcl is compiled with symbol info off. * - TCL_CFG_OPTIMIZED NSCMdt tcl is compiled with cc optimizations on * - TCL_CFG_PROFILED NSCMdt tcl is compiled with profiling info. * diff --git a/generic/tclPreserve.c b/generic/tclPreserve.c index 36a9537..58bc82d 100644 --- a/generic/tclPreserve.c +++ b/generic/tclPreserve.c @@ -21,7 +21,7 @@ */ typedef struct { - void *clientData; /* Address of preserved block. */ + void *clientData; /* Address of preserved block. */ size_t refCount; /* Number of Tcl_Preserve calls in effect for * block. */ int mustFree; /* Non-zero means Tcl_EventuallyFree was @@ -36,10 +36,11 @@ typedef struct { * These variables are protected by "preserveMutex". */ -static Reference *refArray = NULL; /* First in array of references. */ +static Reference *refArray = NULL; + /* First in array of references. */ static size_t spaceAvl = 0; /* Total number of structures available at * *firstRefPtr. */ -static size_t inUse = 0; /* Count of structures currently in use in +static size_t inUse = 0; /* Count of structures currently in use in * refArray. */ TCL_DECLARE_MUTEX(preserveMutex)/* To protect the above statics */ @@ -117,7 +118,7 @@ TclFinalizePreserve(void) void Tcl_Preserve( - void *clientData) /* Pointer to malloc'ed block of memory. */ + void *clientData) /* Pointer to malloc'ed block of memory. */ { Reference *refPtr; size_t i; @@ -180,7 +181,7 @@ Tcl_Preserve( void Tcl_Release( - void *clientData) /* Pointer to malloc'ed block of memory. */ + void *clientData) /* Pointer to malloc'ed block of memory. */ { Reference *refPtr; size_t i; @@ -259,7 +260,7 @@ Tcl_Release( void Tcl_EventuallyFree( - void *clientData, /* Pointer to malloc'ed block of memory. */ + void *clientData, /* Pointer to malloc'ed block of memory. */ Tcl_FreeProc *freeProc) /* Function to actually do free. */ { Reference *refPtr; diff --git a/generic/tclProc.c b/generic/tclProc.c index 2f87048..17f3c06 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -1635,7 +1635,7 @@ static int NRInterpProc( void *clientData, /* Record describing procedure to be * interpreted. */ - Tcl_Interp *interp, /* Interpreter in which procedure was + Tcl_Interp *interp, /* Interpreter in which procedure was * invoked. */ int objc, /* Count of number of arguments to this * procedure. */ @@ -2108,7 +2108,7 @@ MakeProcError( void TclProcDeleteProc( - void *clientData) /* Procedure to be deleted. */ + void *clientData) /* Procedure to be deleted. */ { Proc *procPtr = (Proc *)clientData; diff --git a/generic/tclRegexp.c b/generic/tclRegexp.c index 04f060b..caf6461 100644 --- a/generic/tclRegexp.c +++ b/generic/tclRegexp.c @@ -103,11 +103,11 @@ static int SetRegexpFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); */ const Tcl_ObjType tclRegexpType = { - "regexp", /* name */ - FreeRegexpInternalRep, /* freeIntRepProc */ - DupRegexpInternalRep, /* dupIntRepProc */ - NULL, /* updateStringProc */ - SetRegexpFromAny, /* setFromAnyProc */ + "regexp", /* name */ + FreeRegexpInternalRep, /* freeIntRepProc */ + DupRegexpInternalRep, /* dupIntRepProc */ + NULL, /* updateStringProc */ + SetRegexpFromAny, /* setFromAnyProc */ TCL_OBJTYPE_V0 }; diff --git a/generic/tclResult.c b/generic/tclResult.c index 7151fc4..2baa32c 100644 --- a/generic/tclResult.c +++ b/generic/tclResult.c @@ -388,7 +388,7 @@ Tcl_AppendElement( void Tcl_ResetResult( - Tcl_Interp *interp)/* Interpreter for which to clear result. */ + Tcl_Interp *interp) /* Interpreter for which to clear result. */ { Interp *iPtr = (Interp *) interp; @@ -441,7 +441,7 @@ Tcl_ResetResult( static void ResetObjResult( - Interp *iPtr) /* Points to the interpreter whose result + Interp *iPtr) /* Points to the interpreter whose result * object should be reset. */ { Tcl_Obj *objResultPtr = iPtr->objResultPtr; @@ -760,7 +760,7 @@ TclProcessReturn( Tcl_ListObjReplace(interp, iPtr->errorStack, 0, len, valueObjc, valueObjv); - } + } Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORCODE], &valuePtr); if (valuePtr != NULL) { diff --git a/generic/tclScan.c b/generic/tclScan.c index e4511bf..48d2bcc 100644 --- a/generic/tclScan.c +++ b/generic/tclScan.c @@ -16,14 +16,15 @@ /* * Flag values used by Tcl_ScanObjCmd. */ +enum ScanFlags { + SCAN_NOSKIP = 0x1, /* Don't skip blanks. */ + SCAN_SUPPRESS = 0x2, /* Suppress assignment. */ + SCAN_UNSIGNED = 0x4, /* Read an unsigned value. */ + SCAN_WIDTH = 0x8, /* A width value was supplied. */ -#define SCAN_NOSKIP 0x1 /* Don't skip blanks. */ -#define SCAN_SUPPRESS 0x2 /* Suppress assignment. */ -#define SCAN_UNSIGNED 0x4 /* Read an unsigned value. */ -#define SCAN_WIDTH 0x8 /* A width value was supplied. */ - -#define SCAN_LONGER 0x400 /* Asked for a wide value. */ -#define SCAN_BIG 0x800 /* Asked for a bignum value. */ + SCAN_LONGER = 0x400, /* Asked for a wide value. */ + SCAN_BIG = 0x800 /* Asked for a bignum value. */ +}; /* * The following structure contains the information associated with a @@ -357,17 +358,15 @@ ValidateFormat( /* Note ull >= 0 because of isdigit check above */ unsigned long long ull; ull = strtoull( - format - 1, (char **)&format, 10); /* INTL: "C" locale. */ + format - 1, (char **)&format, 10); /* INTL: "C" locale. */ /* Note >=, not >, to leave room for a nul */ if (ull >= TCL_SIZE_MAX) { - Tcl_SetObjResult( - interp, - Tcl_ObjPrintf("specified field width %" TCL_LL_MODIFIER - "u exceeds limit %" TCL_SIZE_MODIFIER "d.", - ull, - (Tcl_Size)TCL_SIZE_MAX-1)); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "specified field width %" TCL_LL_MODIFIER + "u exceeds limit %" TCL_SIZE_MODIFIER "d.", + ull, (Tcl_Size)TCL_SIZE_MAX-1)); Tcl_SetErrorCode( - interp, "TCL", "FORMAT", "WIDTHLIMIT", (void *)NULL); + interp, "TCL", "FORMAT", "WIDTHLIMIT", (char *)NULL); goto error; } flags |= SCAN_WIDTH; @@ -1006,7 +1005,19 @@ Tcl_ScanObjCmd( } } if ((flags & SCAN_UNSIGNED) && (value < 0)) { - Tcl_SetWideIntObj(objPtr, (unsigned int)value); +#ifdef TCL_WIDE_INT_IS_LONG + mp_int big; + if (mp_init_u64(&big, (unsigned long)value) != MP_OKAY) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "insufficient memory to create bignum", -1)); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", (char *)NULL); + return TCL_ERROR; + } else { + Tcl_SetBignumObj(objPtr, &big); + } +#else + Tcl_SetWideIntObj(objPtr, (unsigned long)value); +#endif } else { TclSetIntObj(objPtr, value); } @@ -1096,9 +1107,7 @@ Tcl_ScanObjCmd( * We create an empty Tcl_Obj to fill missing values rather than * allocating a new Tcl_Obj every time. See test scan-bigdata-XX. */ - Tcl_Obj *emptyObj; - TclNewObj(emptyObj); - Tcl_IncrRefCount(emptyObj); + Tcl_Obj *emptyObj = NULL; TclNewObj(objPtr); for (i = 0; code == TCL_OK && i < totalVars; i++) { if (objs[i] != NULL) { @@ -1109,11 +1118,12 @@ Tcl_ScanObjCmd( * More %-specifiers than matching chars, so we just spit out * empty strings for these. */ - + if (!emptyObj) { + TclNewObj(emptyObj); + } code = Tcl_ListObjAppendElement(interp, objPtr, emptyObj); } } - Tcl_DecrRefCount(emptyObj); if (code != TCL_OK) { /* If error'ed out, free up remaining. i contains last index freed */ while (++i < totalVars) { diff --git a/generic/tclStrToD.c b/generic/tclStrToD.c index ee21cf8..f6e0e3c 100644 --- a/generic/tclStrToD.c +++ b/generic/tclStrToD.c @@ -124,7 +124,7 @@ typedef unsigned int fpu_control_t __attribute__ ((__mode__ (__HI__))); * Definitions of the parts of an IEEE754-format floating point number. */ -#define SIGN_BIT 0x80000000 +#define SIGN_BIT 0x80000000 /* Mask for the sign bit in the first word of * a double. */ #define EXP_MASK 0x7FF00000 @@ -308,7 +308,7 @@ static double MakeNaN(int signum, Tcl_WideUInt tag); static double RefineApproximation(double approx, mp_int *exactSignificand, int exponent); static mp_err MulPow5(mp_int *, unsigned, mp_int *) MP_WUR; -static int NormalizeRightward(Tcl_WideUInt *); +static int NormalizeRightward(Tcl_WideUInt *); static int RequiredPrecision(Tcl_WideUInt); static void DoubleToExpAndSig(double, Tcl_WideUInt *, int *, int *); @@ -1696,7 +1696,7 @@ MakeLowPrecisionDouble( * ulp, so we need to change rounding mode to 53-bits. We also make * 'retval' volatile, so that it doesn't get promoted to a register. */ - volatile double retval; /* Value of the number. */ + volatile double retval; /* Value of the number. */ /* * Test for zero significand, which requires explicit construction @@ -2209,7 +2209,7 @@ RefineApproximation( static inline mp_err MulPow5( - mp_int *base, /* Number to multiply. */ + mp_int *base, /* Number to multiply. */ unsigned n, /* Power of 5 to multiply by. */ mp_int *result) /* Place to store the result. */ { @@ -2652,7 +2652,7 @@ ComputeScale( static inline void SetPrecisionLimits( - int flags, /* Type of conversion: TCL_DD_SHORTEST, + int flags, /* Type of conversion: TCL_DD_SHORTEST, * TCL_DD_E_FMT, TCL_DD_F_FMT. */ int k, /* Floor(log10(number to convert)) */ int *ndigitsPtr, /* IN/OUT: Number of digits requested (will be @@ -2706,7 +2706,7 @@ SetPrecisionLimits( static inline char * BumpUp( - char *s, /* Cursor pointing one past the end of the + char *s, /* Cursor pointing one past the end of the * string. */ char *retval, /* Start of the string of digits. */ int *kPtr) /* Position of the decimal point. */ @@ -3433,7 +3433,8 @@ ShouldBankerRoundUpToNextPowD( * 2**(MP_DIGIT_BIT*sd) */ - if ((mp_add(b, m, temp) != MP_OKAY) || (temp->used <= sd)) { /* Too few digits to be > s */ + if ((mp_add(b, m, temp) != MP_OKAY) || (temp->used <= sd)) { + /* Too few digits to be > s */ return 0; } if (temp->used > sd+1 || temp->dp[sd] > 1) { @@ -4153,7 +4154,7 @@ StrictBignumConversion( } err = mp_mul_2d(&b, b2, &b); if (err == MP_OKAY) { - err = mp_init_set(&S, 1); + err = mp_init_set(&S, 1); } if (err == MP_OKAY) { err = MulPow5(&S, s5, &S); @@ -4808,7 +4809,7 @@ Tcl_InitBignumFromDouble( err = mp_init_i64(b, w); if (err != MP_OKAY) { - /* just skip */ + /* just skip */ } else if (shift < 0) { err = mp_div_2d(b, -shift, b, NULL); } else if (shift > 0) { @@ -4838,7 +4839,7 @@ Tcl_InitBignumFromDouble( double TclBignumToDouble( - const void *big) /* Integer to convert. */ + const void *big) /* Integer to convert. */ { mp_int b; int bits, shift, i, lsb; @@ -4959,7 +4960,7 @@ TclBignumToDouble( double TclCeil( - const void *big) /* Integer to convert. */ + const void *big) /* Integer to convert. */ { double r = 0.0; mp_int b; @@ -5025,7 +5026,7 @@ TclCeil( double TclFloor( - const void *big) /* Integer to convert. */ + const void *big) /* Integer to convert. */ { double r = 0.0; mp_int b; diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index c29d964..75b4fdd 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -1,24 +1,24 @@ /* * tclStringObj.c -- * - * This file contains functions that implement string operations on Tcl - * objects. Some string operations work with UTF-8 encoding forms. - * Functions that require knowledge of the width of each character, - * such as indexing, operate on fixed width encoding forms such as UTF-32. + * This file contains functions that implement string operations on Tcl + * objects. Some string operations work with UTF-8 encoding forms. + * Functions that require knowledge of the width of each character, + * such as indexing, operate on fixed width encoding forms such as UTF-32. * - * Conceptually, a string is a sequence of Unicode code points. Internally - * it may be stored in an encoding form such as a modified version of - * UTF-8 or UTF-32. + * Conceptually, a string is a sequence of Unicode code points. Internally + * it may be stored in an encoding form such as a modified version of + * UTF-8 or UTF-32. * * The String object is optimized for the case where each UTF char * in a string is only one byte. In this case, we store the value of * numChars, but we don't store the fixed form encoding (unless - * Tcl_GetUnicode is explicitly called). + * Tcl_GetUnicode is explicitly called). * - * The String object type stores one or both formats. The default - * behavior is to store UTF-8. Once UTF-16/UTF32 is calculated, it is - * stored in the internal rep for future access (without an additional - * O(n) cost). + * The String object type stores one or both formats. The default + * behavior is to store UTF-8. Once UTF-16/UTF32 is calculated, it is + * stored in the internal rep for future access (without an additional + * O(n) cost). * * To allow many appends to be done to an object without constantly * reallocating space, we allocate double the space and use the @@ -124,8 +124,8 @@ const Tcl_ObjType tclStringType = { static void GrowStringBuffer( Tcl_Obj *objPtr, - Tcl_Size needed, /* Not including terminating nul */ - int flag) /* If 0, try to overallocate */ + Tcl_Size needed, /* Not including terminating nul */ + int flag) /* If 0, try to overallocate */ { /* * Preconditions: @@ -718,8 +718,8 @@ Tcl_GetUnicodeFromObj( Tcl_Obj * Tcl_GetRange( Tcl_Obj *objPtr, /* The Tcl object to find the range of. */ - Tcl_Size first, /* First index of the range. */ - Tcl_Size last) /* Last index of the range. */ + Tcl_Size first, /* First index of the range. */ + Tcl_Size last) /* Last index of the range. */ { Tcl_Obj *newObjPtr; /* The Tcl object to find the range of. */ String *stringPtr; @@ -1322,7 +1322,7 @@ Tcl_AppendUnicodeToObj( const Tcl_UniChar *unicode, /* The Unicode string to append to the * object. */ Tcl_Size length) /* Number of chars in Unicode. Negative - * lengths means nul terminated */ + * lengths means nul terminated */ { String *stringPtr; @@ -2151,7 +2151,7 @@ Tcl_AppendFormatToObj( goto error; } if ((unsigned)code > 0x10FFFF) { - code = 0xFFFD; + code = 0xFFFD; } length = Tcl_UniCharToUtf(code, buf); segment = Tcl_NewStringObj(buf, length); @@ -2971,11 +2971,11 @@ TclGetStringStorage( * Performs the [string repeat] function. * * Results: - * A (Tcl_Obj *) pointing to the result value, or NULL in case of an - * error. + * A (Tcl_Obj *) pointing to the result value, or NULL in case of an + * error. * * Side effects: - * On error, when interp is not NULL, error information is left in it. + * On error, when interp is not NULL, error information is left in it. * *--------------------------------------------------------------------------- */ @@ -2998,8 +2998,8 @@ TclStringRepeat( /* * Analyze to determine what representation result should be. * GOALS: Avoid shimmering & string rep generation. - * Produce pure bytearray when possible. - * Error on overflow. + * Produce pure bytearray when possible. + * Error on overflow. */ if (!binary) { @@ -3033,11 +3033,9 @@ TclStringRepeat( /* maxCount includes space for null */ if (count > (maxCount-1)) { if (interp) { - Tcl_SetObjResult( - interp, - Tcl_ObjPrintf("max size for a Tcl value (%" TCL_SIZE_MODIFIER - "d bytes) exceeded", - TCL_SIZE_MAX)); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "max size for a Tcl value (%" TCL_SIZE_MODIFIER + "d bytes) exceeded", TCL_SIZE_MAX)); Tcl_SetErrorCode(interp, "TCL", "MEMORY", (char *)NULL); } return NULL; @@ -3128,11 +3126,11 @@ TclStringRepeat( * Performs the [string cat] function. * * Results: - * A (Tcl_Obj *) pointing to the result value, or NULL in case of an - * error. + * A (Tcl_Obj *) pointing to the result value, or NULL in case of an + * error. * * Side effects: - * On error, when interp is not NULL, error information is left in it. + * On error, when interp is not NULL, error information is left in it. * *--------------------------------------------------------------------------- */ @@ -3166,8 +3164,8 @@ TclStringCat( /* * Analyze to determine what representation result should be. * GOALS: Avoid shimmering & string rep generation. - * Produce pure bytearray when possible. - * Error on overflow. + * Produce pure bytearray when possible. + * Error on overflow. */ ov = objv, oc = objc; @@ -3184,10 +3182,10 @@ TclStringCat( * create a pure bytearray. */ - binary = 0; - if (ov > objv+1 && ISCONTINUATION(TclGetString(objPtr))) { - forceUniChar = 1; - } else if ((objPtr->typePtr) && TclHasInternalRep(objPtr, &tclStringType)) { + binary = 0; + if (ov > objv+1 && ISCONTINUATION(TclGetString(objPtr))) { + forceUniChar = 1; + } else if ((objPtr->typePtr) && TclHasInternalRep(objPtr, &tclStringType)) { /* Prevent shimmer of non-string types. */ allowUniChar = 0; } @@ -3286,11 +3284,11 @@ TclStringCat( } while (--oc && (length == 0) && (pendingPtr == NULL)); /* - * Either we found a possibly non-empty value, and we remember - * this index as the first and last such value so far seen, + * Either we found a possibly non-empty value, and we remember + * this index as the first and last such value so far seen, * or (oc == 0) and all values are known empty, - * so first = last = objc - 1 signals the right quick return. - */ + * so first = last = objc - 1 signals the right quick return. + */ first = last = objc - oc - 1; @@ -3401,7 +3399,7 @@ TclStringCat( if (0 == Tcl_AttemptSetObjLength(objResultPtr, length)) { if (interp) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "concatenation failed: unable to alloc %" + "concatenation failed: unable to alloc %" TCL_Z_MODIFIER "u bytes", STRING_SIZE(length))); Tcl_SetErrorCode(interp, "TCL", "MEMORY", (char *)NULL); @@ -3418,7 +3416,7 @@ TclStringCat( Tcl_DecrRefCount(objResultPtr); if (interp) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "concatenation failed: unable to alloc %" + "concatenation failed: unable to alloc %" TCL_Z_MODIFIER "u bytes", STRING_SIZE(length))); Tcl_SetErrorCode(interp, "TCL", "MEMORY", (char *)NULL); @@ -3450,7 +3448,7 @@ TclStringCat( if (0 == Tcl_AttemptSetObjLength(objResultPtr, length)) { if (interp) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "concatenation failed: unable to alloc %" TCL_SIZE_MODIFIER "d bytes", + "concatenation failed: unable to alloc %" TCL_SIZE_MODIFIER "d bytes", length)); Tcl_SetErrorCode(interp, "TCL", "MEMORY", (char *)NULL); } @@ -3465,7 +3463,7 @@ TclStringCat( Tcl_DecrRefCount(objResultPtr); if (interp) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "concatenation failed: unable to alloc %" TCL_SIZE_MODIFIER "d bytes", + "concatenation failed: unable to alloc %" TCL_SIZE_MODIFIER "d bytes", length)); Tcl_SetErrorCode(interp, "TCL", "MEMORY", (char *)NULL); } @@ -3492,7 +3490,8 @@ TclStringCat( overflow: if (interp) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "max size for a Tcl value (%" TCL_SIZE_MODIFIER "d bytes) exceeded", TCL_SIZE_MAX)); + "max size for a Tcl value (%" TCL_SIZE_MODIFIER + "d bytes) exceeded", TCL_SIZE_MAX)); Tcl_SetErrorCode(interp, "TCL", "MEMORY", (char *)NULL); } return NULL; @@ -3516,9 +3515,9 @@ TclStringCat( static int UniCharNcasememcmp( - const void *ucsPtr, /* Unicode string to compare to uct. */ - const void *uctPtr, /* Unicode string ucs is compared to. */ - size_t numChars) /* Number of Unichars to compare. */ + const void *ucsPtr, /* Unicode string to compare to uct. */ + const void *uctPtr, /* Unicode string ucs is compared to. */ + size_t numChars) /* Number of Unichars to compare. */ { const Tcl_UniChar *ucs = (const Tcl_UniChar *)ucsPtr; const Tcl_UniChar *uct = (const Tcl_UniChar *)uctPtr; @@ -3539,7 +3538,7 @@ static int UtfNmemcmp( const void *csPtr, /* UTF string to compare to ct. */ const void *ctPtr, /* UTF string cs is compared to. */ - size_t numChars) /* Number of UTF chars to compare. */ + size_t numChars) /* Number of UTF chars to compare. */ { Tcl_UniChar ch1 = 0, ch2 = 0; const char *cs = (const char *)csPtr; @@ -3571,7 +3570,7 @@ static int UtfNcasememcmp( const void *csPtr, /* UTF string to compare to ct. */ const void *ctPtr, /* UTF string cs is compared to. */ - size_t numChars) /* Number of UTF chars to compare. */ + size_t numChars) /* Number of UTF chars to compare. */ { Tcl_UniChar ch1 = 0, ch2 = 0; const char *cs = (const char *)csPtr; @@ -3598,9 +3597,9 @@ UtfNcasememcmp( static int UniCharNmemcmp( - const void *ucsPtr, /* Unicode string to compare to uct. */ - const void *uctPtr, /* Unicode string ucs is compared to. */ - size_t numChars) /* Number of unichars to compare. */ + const void *ucsPtr, /* Unicode string to compare to uct. */ + const void *uctPtr, /* Unicode string ucs is compared to. */ + size_t numChars) /* Number of unichars to compare. */ { const Tcl_UniChar *ucs = (const Tcl_UniChar *)ucsPtr; const Tcl_UniChar *uct = (const Tcl_UniChar *)uctPtr; @@ -3632,7 +3631,7 @@ TclStringCmp( int checkEq, /* comparison is only for equality */ int nocase, /* comparison is not case sensitive */ Tcl_Size reqlength) /* requested length in characters; - * TCL_INDEX_NONE to compare whole strings */ + * TCL_INDEX_NONE to compare whole strings */ { const char *s1, *s2; int empty, match; @@ -3678,9 +3677,8 @@ TclStringCmp( && (value1Ptr->bytes != NULL) && (s2len == value2Ptr->length) && (value2Ptr->bytes != NULL)) { - /* each byte represents one character so s1l3n, s2l3n, and - * reqlength are in both bytes and characters - */ + /* each byte represents one character so s1l3n, s2l3n, + * and reqlength are in both bytes and characters */ s1 = value1Ptr->bytes; s2 = value2Ptr->bytes; memCmpFn = memcmp; @@ -3941,10 +3939,10 @@ TclStringLast( if (ln == 0) { /* - * We don't find empty substrings. Bizarre! + * We don't find empty substrings. Bizarre! * - * TODO: When we one day make this a true substring - * finder, change this to "return last", after limitation. + * TODO: When we one day make this a true substring + * finder, change this to "return last", after limitation. */ goto lastEnd; } diff --git a/generic/tclTest.c b/generic/tclTest.c index 795310d..0bb09f6 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -2070,7 +2070,7 @@ static void SpecialFree( * these functions (i/o command cannot test all combinations) * The arguments at the script level are roughly those of the above * functions: - * encodingname srcbytes flags state dstlen ?srcreadvar? ?dstwrotevar? ?dstcharsvar? + * encodingname srcbytes flags state dstlen ?srcreadvar? ?dstwrotevar? ?dstcharsvar? * * Results: * TCL_OK or TCL_ERROR. This any errors running the test, NOT the @@ -3754,7 +3754,7 @@ TestlinkarrayCmd( i++; } if (Tcl_GetIndexFromObj(interp, objv[i++], LinkType, "type", 0, - &typeIndex) != TCL_OK) { + &typeIndex) != TCL_OK) { return TCL_ERROR; } if (Tcl_GetIntFromObj(interp, objv[i++], &size) == TCL_ERROR) { @@ -3769,7 +3769,7 @@ TestlinkarrayCmd( if (i < objc) { if (Tcl_GetWideIntFromObj(interp, objv[i], &addr) == TCL_ERROR) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( + Tcl_SetObjResult(interp, Tcl_NewStringObj( "wrong address value", -1)); return TCL_ERROR; } @@ -8531,15 +8531,15 @@ InterpCompiledVarResolver( Tcl_ResolvedVarInfo **rPtr) { if (*name == 'T') { - MyResolvedVarInfo *resVarInfo = (MyResolvedVarInfo *)Tcl_Alloc(sizeof(MyResolvedVarInfo)); - - resVarInfo->vInfo.fetchProc = MyCompiledVarFetch; - resVarInfo->vInfo.deleteProc = MyCompiledVarFree; - resVarInfo->var = NULL; - resVarInfo->nameObj = Tcl_NewStringObj(name, -1); - Tcl_IncrRefCount(resVarInfo->nameObj); - *rPtr = &resVarInfo->vInfo; - return TCL_OK; + MyResolvedVarInfo *resVarInfo = (MyResolvedVarInfo *)Tcl_Alloc(sizeof(MyResolvedVarInfo)); + + resVarInfo->vInfo.fetchProc = MyCompiledVarFetch; + resVarInfo->vInfo.deleteProc = MyCompiledVarFree; + resVarInfo->var = NULL; + resVarInfo->nameObj = Tcl_NewStringObj(name, -1); + Tcl_IncrRefCount(resVarInfo->nameObj); + *rPtr = &resVarInfo->vInfo; + return TCL_OK; } return TCL_CONTINUE; } @@ -8656,8 +8656,7 @@ int TestApplyLambdaObjCmd ( * - The body of the lambda (lambdaObjs[1]) ALREADY has internal * representation of ByteCode and thus will not be compiled again */ - evalObjs[1] = lambdaObj; /* lambdaObj already has a ref count so - no need for IncrRef */ + evalObjs[1] = lambdaObj; /* lambdaObj already has a ref count so no need for IncrRef */ result = Tcl_EvalObjv(interp, 2, evalObjs, TCL_EVAL_GLOBAL); Tcl_DecrRefCount(evalObjs[0]); Tcl_DecrRefCount(lambdaObj); diff --git a/generic/tclThreadTest.c b/generic/tclThreadTest.c index e4a9312..49d9cf2 100644 --- a/generic/tclThreadTest.c +++ b/generic/tclThreadTest.c @@ -985,7 +985,7 @@ ThreadCancel( Tcl_MutexUnlock(&threadMutex); Tcl_ResetResult(interp); return Tcl_CancelEval(tsdPtr->interp, - (result != NULL) ? Tcl_NewStringObj(result, -1) : NULL, 0, flags); + (result != NULL) ? Tcl_NewStringObj(result, -1) : NULL, 0, flags); } /* diff --git a/generic/tclUtf.c b/generic/tclUtf.c index 03ea8b6..a0cb936 100644 --- a/generic/tclUtf.c +++ b/generic/tclUtf.c @@ -206,13 +206,11 @@ Invalid( Tcl_Size Tcl_UniCharToUtf( - int ch, /* The Tcl_UniChar to be stored in the - * buffer. Can be or'ed with flag TCL_COMBINE. - */ - char *buf) /* Buffer in which the UTF-8 representation of - * ch is stored. Must be large enough to hold the UTF-8 - * character (at most 4 bytes). - */ + int ch, /* The Tcl_UniChar to be stored in the buffer. + * Can be or'ed with flag TCL_COMBINE. */ + char *buf) /* Buffer in which the UTF-8 representation of + * ch is stored. Must be large enough to hold + * the UTF-8 character (at most 4 bytes). */ { int flags = ch; @@ -309,9 +307,9 @@ three: char * Tcl_UniCharToUtfDString( - const int *uniStr, /* Unicode string to convert to UTF-8. */ + const int *uniStr, /* Unicode string to convert to UTF-8. */ Tcl_Size uniLength, /* Length of Unicode string. Negative for nul - * terminated string */ + * terminated string */ Tcl_DString *dsPtr) /* UTF-8 representation of string is appended * to this previously initialized DString. */ { @@ -440,9 +438,9 @@ static const unsigned short cp1252[32] = { Tcl_Size Tcl_UtfToUniChar( - const char *src, /* The UTF-8 string. */ - int *chPtr)/* Filled with the Unicode character represented by - * the UTF-8 string. */ + const char *src, /* The UTF-8 string. */ + int *chPtr) /* Filled with the Unicode character + * represented by the UTF-8 string. */ { int byte; diff --git a/generic/tclUtil.c b/generic/tclUtil.c index c2fa64f..a3bfc09 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -158,7 +158,7 @@ TclLengthOne( * \u000A \n NEWLINE * \u000B \v VERTICAL TAB * \u000C \f FORM FEED - * \u000D \r CARRIAGE RETURN + * \u000D \r CARRIAGE RETURN * \u0020 SPACE * * NOTE: differences between this and other places where Tcl defines a role @@ -276,7 +276,7 @@ TclLengthOne( * * The command terminating character, * \u003b ; SEMICOLON * must be BRACEd, QUOTEd, or escaped so that it does not terminate the - * command prematurely. + * command prematurely. * * Any of the characters that begin substitutions in scripts, * \u0024 $ DOLLAR * \u005b [ OPEN BRACKET @@ -1672,7 +1672,7 @@ TclTrimRight( pp = Tcl_UtfPrev(p, bytes); do { pp += pInc; - pInc = TclUtfToUniChar(pp, &ch1); + pInc = TclUtfToUniChar(pp, &ch1); } while (pp + pInc < p); /* @@ -1881,7 +1881,7 @@ Tcl_Concat( for (i = 0; i < argc; i++) { bytesNeeded += strlen(argv[i]); - if (bytesNeeded < 0) { + if (bytesNeeded < 0) { Tcl_Panic("Tcl_Concat: max size of Tcl value exceeded"); } } @@ -3413,19 +3413,19 @@ GetWideForIndex( * list. * * Results: - * TCL_OK + * TCL_OK * - * The index is stored at the address given by by 'indexPtr'. + * The index is stored at the address given by by 'indexPtr'. * - * TCL_ERROR + * TCL_ERROR * - * The value of 'objPtr' does not have one of the expected formats. If - * 'interp' is non-NULL, an error message is left in the interpreter's - * result object. + * The value of 'objPtr' does not have one of the expected formats. If + * 'interp' is non-NULL, an error message is left in the interpreter's + * result object. * * Side effects: * - * The internal representation contained within objPtr may shimmer. + * The internal representation contained within objPtr may shimmer. * *---------------------------------------------------------------------- */ @@ -3707,17 +3707,13 @@ GetEndOffsetFromObj( */ *widePtr = (endValue == -1) ? WIDE_MAX : endValue + 1; } else if (offset == WIDE_MIN) { - /* -1 - position before first */ - *widePtr = -1; + *widePtr = (endValue == -1) ? WIDE_MIN : -1; } else if (offset < 0) { /* end-(n-1) - Different signs, sum cannot overflow */ *widePtr = endValue + offset + 1; - } else if (offset < WIDE_MAX) { - /* 0:WIDE_MAX-1 - plain old index. */ - *widePtr = offset; } else { - /* Huh, what case remains here? */ - *widePtr = WIDE_MAX; + /* 0:WIDE_MAX - plain old index. */ + *widePtr = offset; } return TCL_OK; diff --git a/generic/tclVar.c b/generic/tclVar.c index 41bfa39..68d467a 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -6572,7 +6572,7 @@ AppendLocals( && (includeLinks || !TclIsVarLink(varPtr))) { varName = TclGetString(*varNamePtr); if ((pattern == NULL) || Tcl_StringMatch(varName, pattern)) { - if (!justConstants || TclIsVarConstant(varPtr)) { + if (!justConstants || TclIsVarConstant(varPtr)) { Tcl_ListObjAppendElement(interp, listPtr, *varNamePtr); } if (includeLinks) { @@ -6626,7 +6626,7 @@ AppendLocals( objNamePtr = VarHashGetKey(varPtr); varName = TclGetString(objNamePtr); if ((pattern == NULL) || Tcl_StringMatch(varName, pattern)) { - if (!justConstants || TclIsVarConstant(varPtr)) { + if (!justConstants || TclIsVarConstant(varPtr)) { Tcl_ListObjAppendElement(interp, listPtr, objNamePtr); } if (includeLinks) { diff --git a/generic/tclZipfs.c b/generic/tclZipfs.c index f09030a..683e4ff 100644 --- a/generic/tclZipfs.c +++ b/generic/tclZipfs.c @@ -217,9 +217,9 @@ typedef struct ZipEntry { ZipFile *zipFilePtr; /* The ZIP file holding this virtual file */ size_t offset; /* Data offset into memory mapped ZIP file */ int numBytes; /* Uncompressed size of the virtual file. - * -1 for zip64 */ + * -1 for zip64 */ int numCompressedBytes; /* Compressed size of the virtual file. - * -1 for zip64 */ + * -1 for zip64 */ int compressMethod; /* Compress method */ int isDirectory; /* 0 if file, 1 if directory, -1 if root */ int depth; /* Number of slashes in path. */ @@ -258,7 +258,7 @@ typedef struct ZipChannel { Tcl_Size cursor; /* Seek position for next read or write*/ unsigned char *ubuf; /* Pointer to the uncompressed data */ unsigned char *ubufToFree; /* NULL if ubuf points to memory that does not - need freeing. Else memory to free (ubuf + need freeing. Else memory to free (ubuf may point *inside* the block) */ Tcl_Size ubufSize; /* Size of allocated ubufToFree */ int iscompr; /* True if data is compressed */ @@ -433,28 +433,26 @@ static const Tcl_Filesystem zipfsFilesystem = { /* * The channel type/driver definition used for ZIP archive members. */ - -static Tcl_ChannelType ZipChannelType = { - "zip", /* Type name. */ +static const Tcl_ChannelType zipChannelType = { + "zip", TCL_CHANNEL_VERSION_5, - NULL, /* Close channel, clean instance data */ - ZipChannelRead, /* Handle read request */ - ZipChannelWrite, /* Handle write request */ - NULL, /* Move location of access point, NULL'able */ - NULL, /* Set options, NULL'able */ - NULL, /* Get options, NULL'able */ - ZipChannelWatchChannel, /* Initialize notifier */ - ZipChannelGetFile, /* Get OS handle from the channel */ - ZipChannelClose, /* 2nd version of close channel, NULL'able */ - NULL, /* Set blocking mode for raw channel, - * NULL'able */ - NULL, /* Function to flush channel, NULL'able */ - NULL, /* Function to handle event, NULL'able */ - ZipChannelWideSeek, /* Wide seek function, NULL'able */ - NULL, /* Thread action function, NULL'able */ - NULL, /* Truncate function, NULL'able */ + NULL, /* Deprecated. */ + ZipChannelRead, + ZipChannelWrite, + NULL, /* Deprecated. */ + NULL, /* Set options proc. */ + NULL, /* Get options proc. */ + ZipChannelWatchChannel, + ZipChannelGetFile, + ZipChannelClose, + NULL, /* Set blocking mode for raw channel. */ + NULL, /* Function to flush channel. */ + NULL, /* Function to handle bubbled events. */ + ZipChannelWideSeek, + NULL, /* Thread action function. */ + NULL, /* Truncate function. */ }; - + /* *------------------------------------------------------------------------ * @@ -875,7 +873,7 @@ static char * DecodeZipEntryText( const unsigned char *inputBytes, unsigned int inputLength, - Tcl_DString *dstPtr) /* Must have been initialized by caller! */ + Tcl_DString *dstPtr) /* Must have been initialized by caller! */ { Tcl_Encoding encoding; const char *src; @@ -980,9 +978,10 @@ DecodeZipEntryText( *------------------------------------------------------------------------ */ static int -NormalizeMountPoint(Tcl_Interp *interp, - const char *mountPath, - Tcl_DString *dsPtr) /* Must be initialized by caller! */ +NormalizeMountPoint( + Tcl_Interp *interp, + const char *mountPath, + Tcl_DString *dsPtr) /* Must be initialized by caller! */ { const char *joiner[2]; char *joinedPath; @@ -2230,7 +2229,8 @@ ListMountPoints( *------------------------------------------------------------------------ */ static void -CleanupMount(ZipFile *zf) /* Mount point */ +CleanupMount( + ZipFile *zf) /* Mount point */ { ZipEntry *z, *znext; Tcl_HashEntry *hPtr; @@ -4901,7 +4901,7 @@ ZipChannelOpen( ZipFS.idCount++); z->zipFilePtr->numOpen++; Unlock(); - return Tcl_CreateChannel(&ZipChannelType, cname, info, flags); + return Tcl_CreateChannel(&zipChannelType, cname, info, flags); error: Unlock(); diff --git a/generic/tclZlib.c b/generic/tclZlib.c index 0c11bb4..a1f4f12 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -208,21 +208,21 @@ static void ZlibTransformTimerRun(void *clientData); static const Tcl_ChannelType zlibChannelType = { "zlib", TCL_CHANNEL_VERSION_5, - NULL, + NULL, /* Deprecated. */ ZlibTransformInput, ZlibTransformOutput, - NULL, /* seekProc */ + NULL, /* Deprecated. */ ZlibTransformSetOption, ZlibTransformGetOption, ZlibTransformWatch, ZlibTransformGetHandle, - ZlibTransformClose, /* close2Proc */ + ZlibTransformClose, ZlibTransformBlockMode, - NULL, /* flushProc */ + NULL, /* Flush proc. */ ZlibTransformEventHandler, - NULL, /* wideSeekProc */ - NULL, - NULL + NULL, /* Seek proc. */ + NULL, /* Thread action proc. */ + NULL /* Truncate proc. */ }; /* @@ -3111,7 +3111,7 @@ ZlibTransformInput( gotBytes = 0; readBytes = chanDataPtr->inStream.avail_in; /* how many bytes in buffer now */ while (!HaveFlag(chanDataPtr, STREAM_DONE) && toRead > 0) { - unsigned int n; + unsigned int n; int decBytes; /* if starting from scratch or continuation after full decompression */ diff --git a/library/auto.tcl b/library/auto.tcl index 824cdac..cc779cf 100644 --- a/library/auto.tcl +++ b/library/auto.tcl @@ -45,7 +45,7 @@ proc auto_reset {} { # initialization script and set a global library variable. # # Arguments: -# basename Prefix of the directory name, (e.g., "tk") +# basename Prefix of the directory name, (e.g., "tk") # version Version number of the package, (e.g., "8.0") # patch Patchlevel of the package, (e.g., "8.0.3") # initScript Initialization script to source (e.g., tk.tcl) @@ -130,7 +130,7 @@ proc tcl_findLibrary {basename version patch initScript enVarName varName} { } else { catch {zipfs unmount $mountpoint} } - } + } } } } @@ -480,9 +480,9 @@ proc auto_mkindex_parser::childhook {cmd} { # "tclIndex" file for auto-loading. # # Arguments: -# name Name of command recognized in Tcl files. +# name Name of command recognized in Tcl files. # arglist Argument list for command. -# body Implementation of command to handle indexing. +# body Implementation of command to handle indexing. proc auto_mkindex_parser::command {name arglist body} { hook [list auto_mkindex_parser::commandInit $name $arglist $body] @@ -494,9 +494,9 @@ proc auto_mkindex_parser::command {name arglist body} { # called when the interpreter used by the parser is created. # # Arguments: -# name Name of command recognized in Tcl files. +# name Name of command recognized in Tcl files. # arglist Argument list for command. -# body Implementation of command to handle indexing. +# body Implementation of command to handle indexing. proc auto_mkindex_parser::commandInit {name arglist body} { variable parser diff --git a/library/clock.tcl b/library/clock.tcl index ef82372..83c6e61 100644 --- a/library/clock.tcl +++ b/library/clock.tcl @@ -140,9 +140,9 @@ proc ::tcl::clock::Initialize {} { Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec } MONTHS_FULL { - January February March - April May June - July August September + January February March + April May June + July August September October November December } PM {pm} @@ -292,7 +292,7 @@ proc ::tcl::clock::Initialize {} { # The keys are long lists of values obtained from the time zone # information in the Registry. In order, the list elements are: - # Bias StandardBias DaylightBias + # Bias StandardBias DaylightBias # StandardDate.wYear StandardDate.wMonth StandardDate.wDayOfWeek # StandardDate.wDay StandardDate.wHour StandardDate.wMinute # StandardDate.wSecond StandardDate.wMilliseconds @@ -339,7 +339,7 @@ proc ::tcl::clock::Initialize {} { {3600 0 3600 0 10 0 5 3 0 0 0 0 3 0 5 2 0 0 0} :CET {7200 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Africa/Harare {7200 0 3600 0 9 4 5 23 59 59 0 0 4 4 5 23 59 59 0} - :Africa/Cairo + :Africa/Cairo {7200 0 3600 0 10 0 5 4 0 0 0 0 3 0 5 3 0 0 0} :Europe/Helsinki {7200 0 3600 0 9 0 3 2 0 0 0 0 3 5 5 2 0 0 0} :Asia/Jerusalem {7200 0 3600 0 9 0 5 1 0 0 0 0 3 0 5 0 0 0 0} :Europe/Bucharest @@ -480,9 +480,9 @@ proc ::tcl::clock::Initialize {} { variable LocFmtMap [dict create]; # Dictionary with localized format maps variable TimeZoneBad [dict create]; # Dictionary whose keys are time zone - # names and whose values are 1 if + # names and whose values are 1 if # the time zone is unknown and 0 - # if it is known. + # if it is known. variable TZData; # Array whose keys are time zone names # and whose values are lists of quads # comprising start time, UTC offset, @@ -518,7 +518,7 @@ proc ::tcl::clock::mcget {loc} { set loc [mclocale] } if {$loc ne {}} { - set loc [string tolower $loc] + set loc [string tolower $loc] } # try to retrieve now if already available: @@ -651,7 +651,7 @@ proc ::tcl::clock::GetSystemLocale {} { proc ::tcl::clock::EnterLocale { locale } { switch -- $locale system { - set locale [GetSystemLocale] + set locale [GetSystemLocale] } current { set locale [mclocale] } @@ -1001,7 +1001,7 @@ proc ::tcl::clock::SetupTimeZone { timezone {alias {}} } { LoadZoneinfoFile [string range $timezone 1 end] }] } then { - dict set TimeZoneBad $timezone 1 + dict set TimeZoneBad $timezone 1 return -code error \ -errorcode [list CLOCK badTimeZone $timezone] \ "time zone \"$timezone\" not found" diff --git a/library/history.tcl b/library/history.tcl index e3d3fe4..4c36bf0 100644 --- a/library/history.tcl +++ b/library/history.tcl @@ -89,7 +89,7 @@ trace add command ::history delete [list apply {{oldName newName op} { # exec (optional) a substring of "exec" causes the command to # be evaled. # Results: -# If executing, then the results of the command are returned +# If executing, then the results of the command are returned # # Side Effects: # Adds to the history list @@ -197,7 +197,7 @@ proc ::tcl::HistInfo {{count {}}} { if {![info exists history($i)]} { continue } - set cmd [string map [list \n \n\t] [string trimright $history($i) \ \n]] + set cmd [string map [list \n \n\t] [string trimright $history($i) \ \n]] append result $newline[format "%6d %s" $i $cmd] set newline \n } diff --git a/library/http/http.tcl b/library/http/http.tcl index d53ecef..54af38f 100644 --- a/library/http/http.tcl +++ b/library/http/http.tcl @@ -157,69 +157,69 @@ namespace eval http { variable ThreadCounter 0 variable reasonDict [dict create {*}{ - 100 Continue - 101 {Switching Protocols} - 102 Processing - 103 {Early Hints} - 200 OK - 201 Created - 202 Accepted - 203 {Non-Authoritative Information} - 204 {No Content} - 205 {Reset Content} - 206 {Partial Content} - 207 Multi-Status - 208 {Already Reported} - 226 {IM Used} - 300 {Multiple Choices} - 301 {Moved Permanently} - 302 Found - 303 {See Other} - 304 {Not Modified} - 305 {Use Proxy} - 306 (Unused) - 307 {Temporary Redirect} - 308 {Permanent Redirect} - 400 {Bad Request} - 401 Unauthorized - 402 {Payment Required} - 403 Forbidden - 404 {Not Found} - 405 {Method Not Allowed} - 406 {Not Acceptable} - 407 {Proxy Authentication Required} - 408 {Request Timeout} - 409 Conflict - 410 Gone - 411 {Length Required} - 412 {Precondition Failed} - 413 {Content Too Large} - 414 {URI Too Long} - 415 {Unsupported Media Type} - 416 {Range Not Satisfiable} - 417 {Expectation Failed} - 418 (Unused) - 421 {Misdirected Request} - 422 {Unprocessable Content} - 423 Locked - 424 {Failed Dependency} - 425 {Too Early} - 426 {Upgrade Required} - 428 {Precondition Required} - 429 {Too Many Requests} - 431 {Request Header Fields Too Large} - 451 {Unavailable For Legal Reasons} - 500 {Internal Server Error} - 501 {Not Implemented} - 502 {Bad Gateway} - 503 {Service Unavailable} - 504 {Gateway Timeout} - 505 {HTTP Version Not Supported} - 506 {Variant Also Negotiates} - 507 {Insufficient Storage} - 508 {Loop Detected} - 510 {Not Extended (OBSOLETED)} - 511 {Network Authentication Required} + 100 Continue + 101 {Switching Protocols} + 102 Processing + 103 {Early Hints} + 200 OK + 201 Created + 202 Accepted + 203 {Non-Authoritative Information} + 204 {No Content} + 205 {Reset Content} + 206 {Partial Content} + 207 Multi-Status + 208 {Already Reported} + 226 {IM Used} + 300 {Multiple Choices} + 301 {Moved Permanently} + 302 Found + 303 {See Other} + 304 {Not Modified} + 305 {Use Proxy} + 306 (Unused) + 307 {Temporary Redirect} + 308 {Permanent Redirect} + 400 {Bad Request} + 401 Unauthorized + 402 {Payment Required} + 403 Forbidden + 404 {Not Found} + 405 {Method Not Allowed} + 406 {Not Acceptable} + 407 {Proxy Authentication Required} + 408 {Request Timeout} + 409 Conflict + 410 Gone + 411 {Length Required} + 412 {Precondition Failed} + 413 {Content Too Large} + 414 {URI Too Long} + 415 {Unsupported Media Type} + 416 {Range Not Satisfiable} + 417 {Expectation Failed} + 418 (Unused) + 421 {Misdirected Request} + 422 {Unprocessable Content} + 423 Locked + 424 {Failed Dependency} + 425 {Too Early} + 426 {Upgrade Required} + 428 {Precondition Required} + 429 {Too Many Requests} + 431 {Request Header Fields Too Large} + 451 {Unavailable For Legal Reasons} + 500 {Internal Server Error} + 501 {Not Implemented} + 502 {Bad Gateway} + 503 {Service Unavailable} + 504 {Gateway Timeout} + 505 {HTTP Version Not Supported} + 506 {Variant Also Negotiates} + 507 {Insufficient Storage} + 508 {Loop Detected} + 510 {Not Extended (OBSOLETED)} + 511 {Network Authentication Required} }] variable failedProxyValues { @@ -299,7 +299,7 @@ proc http::register {proto port command {socketCmdVarName {}} {useSockThread 0} variable urlTypes set lower [string tolower $proto] if {[info exists urlTypes($lower)]} { - unregister $lower + unregister $lower } set urlTypes($lower) [list $port $command $socketCmdVarName $useSockThread $endToEndProxy] @@ -347,7 +347,7 @@ proc http::unregister {proto} { # Arguments: # args Options parsed by the procedure. # Results: -# TODO +# TODO proc http::config {args} { variable http @@ -401,13 +401,13 @@ proc http::config {args} { proc http::reasonPhrase {code} { variable reasonDict if {![regexp -- {^[1-5][0-9][0-9]$} $code]} { - set msg {argument must be a three-digit integer from 100 to 599} - return -code error $msg + set msg {argument must be a three-digit integer from 100 to 599} + return -code error $msg } if {[dict exists $reasonDict $code]} { - set reason [dict get $reasonDict $code] + set reason [dict get $reasonDict $code] } else { - set reason Unassigned + set reason Unassigned } return $reason } @@ -425,7 +425,7 @@ proc http::reasonPhrase {code} { # reported to two places. # # Side Effects: -# May close the socket. +# May close the socket. proc http::Finish {token {errormsg ""} {skipCB 0}} { variable socketMapping @@ -454,9 +454,9 @@ proc http::Finish {token {errormsg ""} {skipCB 0}} { rename ${token}--SocketCoroutine {} } if {[info exists state(socketcoro)]} { - Log $token Cancel socket after-idle event (Finish) - after cancel $state(socketcoro) - unset state(socketcoro) + Log $token Cancel socket after-idle event (Finish) + after cancel $state(socketcoro) + unset state(socketcoro) } # Is this an upgrade request/response? @@ -481,14 +481,14 @@ proc http::Finish {token {errormsg ""} {skipCB 0}} { set sock $state(sock) CloseSocket $state(sock) $token } else { - # When opening the socket and calling http::reset - # immediately, the socket may not yet exist. - # Test http-4.11 may come here. + # When opening the socket and calling http::reset + # immediately, the socket may not yet exist. + # Test http-4.11 may come here. } if {$state(tid) ne {}} { - # When opening the socket in a thread, and calling http::reset - # immediately, the thread may still exist. - # Test http-4.11 may come here. + # When opening the socket in a thread, and calling http::reset + # immediately, the thread may still exist. + # Test http-4.11 may come here. thread::release $state(tid) set state(tid) {} } else { @@ -503,9 +503,8 @@ proc http::Finish {token {errormsg ""} {skipCB 0}} { # PASSED TO http::geturl AS -command callback. catch {fileevent $state(sock) readable {}} catch {fileevent $state(sock) writable {}} - } elseif { - ([info exists state(-keepalive)] && !$state(-keepalive)) - || ([info exists state(connection)] && ("close" in $state(connection))) + } elseif {([info exists state(-keepalive)] && !$state(-keepalive)) + || ([info exists state(connection)] && ("close" in $state(connection))) } { set closeQueue 1 set connId $state(socketinfo) @@ -513,9 +512,9 @@ proc http::Finish {token {errormsg ""} {skipCB 0}} { set sock $state(sock) CloseSocket $state(sock) $token } else { - # When opening the socket and calling http::reset - # immediately, the socket may not yet exist. - # Test http-4.11 may come here. + # When opening the socket and calling http::reset + # immediately, the socket may not yet exist. + # Test http-4.11 may come here. } } elseif { ([info exists state(-keepalive)] && $state(-keepalive)) @@ -921,7 +920,7 @@ proc http::Unset {connId} { # why Status info. # # Side Effects: -# See Finish +# See Finish proc http::reset {token {why reset}} { variable $token @@ -1120,7 +1119,7 @@ proc http::CreateToken {url args} { if {[regexp -- $pat $flag]} { # Validate numbers if { [info exists type($flag)] - && (![string is $type($flag) -strict $value]) + && (![string is $type($flag) -strict $value]) } { unset $token return -code error \ @@ -1404,9 +1403,9 @@ proc http::CreateToken {url args} { } if {$useSockThread} { - set targs [list -type $token] + set targs [list -type $token] } else { - set targs {} + set targs {} } set state(connArgs) [list $proto $phost $srvurl] set state(openCmd) [list {*}$defcmd {*}$sockopts {*}$targs {*}$targetAddr] @@ -1507,8 +1506,8 @@ proc http::CreateToken {url args} { unset reusing if {![info exists sock]} { - # N.B. At this point ([info exists sock] == $state(reusing)). - # This will no longer be true after we set a value of sock here. + # N.B. At this point ([info exists sock] == $state(reusing)). + # This will no longer be true after we set a value of sock here. # Give the socket a placeholder name. set sock HTTP_PLACEHOLDER_[incr TmpSockCounter] } @@ -1605,34 +1604,34 @@ proc http::AsyncTransaction {token} { # This code is executed only for the first -keepalive request on a # socket. It makes the socket persistent. ##Log " PreparePersistentConnection" $token -- $sock -- DO - set DoLater [PreparePersistentConnection $token] + set DoLater [PreparePersistentConnection $token] } else { - ##Log " PreparePersistentConnection" $token -- $sock -- SKIP - set DoLater {-traceread 0 -tracewrite 0} + ##Log " PreparePersistentConnection" $token -- $sock -- SKIP + set DoLater {-traceread 0 -tracewrite 0} } if {$state(ReusingPlaceholder)} { - # - This request was added to the socketPhQueue of a persistent - # connection. - # - But the connection has not yet been created and is a placeholder; - # - And the placeholder was created by an earlier request. - # - When that earlier request calls OpenSocket, its placeholder is - # replaced with a true socket, and it then executes the equivalent of - # OpenSocket for any subsequent requests that have - # $state(ReusingPlaceholder). - Log >J$tk after idle coro NO - ReusingPlaceholder + # - This request was added to the socketPhQueue of a persistent + # connection. + # - But the connection has not yet been created and is a placeholder; + # - And the placeholder was created by an earlier request. + # - When that earlier request calls OpenSocket, its placeholder is + # replaced with a true socket, and it then executes the equivalent of + # OpenSocket for any subsequent requests that have + # $state(ReusingPlaceholder). + Log >J$tk after idle coro NO - ReusingPlaceholder } elseif {$state(alreadyQueued)} { - # - This request was added to the socketWrQueue and socketPlayCmd - # of a persistent connection that will close at the end of its current - # read operation. - Log >J$tk after idle coro NO - alreadyQueued + # - This request was added to the socketWrQueue and socketPlayCmd + # of a persistent connection that will close at the end of its current + # read operation. + Log >J$tk after idle coro NO - alreadyQueued } else { - Log >J$tk after idle coro YES - set CoroName ${token}--SocketCoroutine - set cancel [after idle [list coroutine $CoroName ::http::OpenSocket \ - $token $DoLater]] - dict set socketCoEvent($state(socketinfo)) $token $cancel - set state(socketcoro) $cancel + Log >J$tk after idle coro YES + set CoroName ${token}--SocketCoroutine + set cancel [after idle [list coroutine $CoroName ::http::OpenSocket \ + $token $DoLater]] + dict set socketCoEvent($state(socketinfo)) $token $cancel + set state(socketcoro) $cancel } return @@ -1677,36 +1676,36 @@ proc http::PreparePersistentConnection {token} { # no other tokens whose (proxyUsed) must be modified. if {![info exists socketRdState($state(socketinfo))]} { - set socketRdState($state(socketinfo)) {} - # set varName ::http::socketRdState($state(socketinfo)) - # trace add variable $varName unset ::http::CancelReadPipeline - dict set DoLater -traceread 1 + set socketRdState($state(socketinfo)) {} + # set varName ::http::socketRdState($state(socketinfo)) + # trace add variable $varName unset ::http::CancelReadPipeline + dict set DoLater -traceread 1 } if {![info exists socketWrState($state(socketinfo))]} { - set socketWrState($state(socketinfo)) {} - # set varName ::http::socketWrState($state(socketinfo)) - # trace add variable $varName unset ::http::CancelWritePipeline - dict set DoLater -tracewrite 1 + set socketWrState($state(socketinfo)) {} + # set varName ::http::socketWrState($state(socketinfo)) + # trace add variable $varName unset ::http::CancelWritePipeline + dict set DoLater -tracewrite 1 } if {$state(-pipeline)} { - #Log new, init for pipelined, GRANT write access to $token in geturl - # Also grant premature read access to the socket. This is OK. - set socketRdState($state(socketinfo)) $token - set socketWrState($state(socketinfo)) $token + #Log new, init for pipelined, GRANT write access to $token in geturl + # Also grant premature read access to the socket. This is OK. + set socketRdState($state(socketinfo)) $token + set socketWrState($state(socketinfo)) $token } else { - # socketWrState is not used by this non-pipelined transaction. - # We cannot leave it as "Wready" because the next call to - # http::geturl with a pipelined transaction would conclude that the - # socket is available for writing. - #Log new, init for nonpipeline, GRANT r/w access to $token in geturl - set socketRdState($state(socketinfo)) $token - set socketWrState($state(socketinfo)) $token + # socketWrState is not used by this non-pipelined transaction. + # We cannot leave it as "Wready" because the next call to + # http::geturl with a pipelined transaction would conclude that the + # socket is available for writing. + #Log new, init for nonpipeline, GRANT r/w access to $token in geturl + set socketRdState($state(socketinfo)) $token + set socketWrState($state(socketinfo)) $token } # Value of socketPhQueue() may have already been set by ReplayCore. if {![info exists socketPhQueue($state(sock))]} { - set socketPhQueue($state(sock)) {} + set socketPhQueue($state(sock)) {} } set socketRdQueue($state(socketinfo)) {} set socketWrQueue($state(socketinfo)) {} @@ -1751,8 +1750,8 @@ proc http::OpenSocket {token DoLater} { Log >K$tk Start OpenSocket coroutine if {![info exists state(-keepalive)]} { - # The request has already been cancelled by the calling script. - return + # The request has already been cancelled by the calling script. + return } set sockOld $state(sock) @@ -1761,11 +1760,11 @@ proc http::OpenSocket {token DoLater} { unset -nocomplain state(socketcoro) if {[catch { - if {$state(reusing)} { + if {$state(reusing)} { # If ($state(reusing)) is true, then we do not need to create a new # socket, even if $sockOld is only a placeholder for a socket. - set sock $sockOld - } else { + set sock $sockOld + } else { # set sock in the [catch] below. set pre [clock milliseconds] ##Log pre socket opened, - token $token @@ -1789,14 +1788,14 @@ proc http::OpenSocket {token DoLater} { fconfigure $sock -profile replace } ##Log socket opened, DONE fconfigure - token $token - } + } - Log "Using $sock for $state(socketinfo) - token $token" \ + Log "Using $sock for $state(socketinfo) - token $token" \ [expr {$state(-keepalive)?"keepalive":""}] - # Code above has set state(sock) $sock - ConfigureNewSocket $token $sockOld $DoLater - ##Log OpenSocket success $sock - token $token + # Code above has set state(sock) $sock + ConfigureNewSocket $token $sockOld $DoLater + ##Log OpenSocket success $sock - token $token } result errdict]} { ##Log OpenSocket failed $result - token $token # There may be other requests in the socketPhQueue. @@ -1812,7 +1811,7 @@ proc http::OpenSocket {token DoLater} { set socketPlayCmd($state(socketinfo)) [list ReplayIfClose Wready {} $socketPhQueue($sockOld)] set socketPhQueue($sockOld) {} } - if {[string range $result 0 20] eq {proxy connect failed:}} { + if {[string range $result 0 20] eq {proxy connect failed:}} { # - The HTTPS proxy did not create a socket. The pre-existing value # (a "placeholder socket") is unchanged. # - The proxy returned a valid HTTP response to the failed CONNECT @@ -1887,38 +1886,38 @@ proc http::ConfigureNewSocket {token sockOld DoLater} { ##Log " ConfigureNewSocket" $token $sockOld ... -- $reusing $sock $proxyUsed if {(!$reusing) && ($sock ne $sockOld)} { - # Replace the placeholder value sockOld with sock. - - if { [info exists socketMapping($state(socketinfo))] - && ($socketMapping($state(socketinfo)) eq $sockOld) - } { - set socketMapping($state(socketinfo)) $sock - set socketProxyId($state(socketinfo)) $proxyUsed - # tokens that use the placeholder $sockOld are updated below. - ##Log set socketMapping($state(socketinfo)) $sock - } - - # Now finish any tasks left over from PreparePersistentConnection on - # the connection. - # - # The "unset" traces are fired by init (clears entire arrays), and - # by http::Unset. - # Unset is called by CloseQueuedQueries and (possibly never) by geturl. - # - # CancelReadPipeline, CancelWritePipeline call http::Finish for each - # token. - # - # FIXME If Finish is placeholder-aware, these traces can be set earlier, - # in PreparePersistentConnection. - - if {[dict get $DoLater -traceread]} { + # Replace the placeholder value sockOld with sock. + + if { [info exists socketMapping($state(socketinfo))] + && ($socketMapping($state(socketinfo)) eq $sockOld) + } { + set socketMapping($state(socketinfo)) $sock + set socketProxyId($state(socketinfo)) $proxyUsed + # tokens that use the placeholder $sockOld are updated below. + ##Log set socketMapping($state(socketinfo)) $sock + } + + # Now finish any tasks left over from PreparePersistentConnection on + # the connection. + # + # The "unset" traces are fired by init (clears entire arrays), and + # by http::Unset. + # Unset is called by CloseQueuedQueries and (possibly never) by geturl. + # + # CancelReadPipeline, CancelWritePipeline call http::Finish for each + # token. + # + # FIXME If Finish is placeholder-aware, these traces can be set earlier, + # in PreparePersistentConnection. + + if {[dict get $DoLater -traceread]} { set varName ::http::socketRdState($state(socketinfo)) trace add variable $varName unset ::http::CancelReadPipeline - } - if {[dict get $DoLater -tracewrite]} { + } + if {[dict get $DoLater -tracewrite]} { set varName ::http::socketWrState($state(socketinfo)) trace add variable $varName unset ::http::CancelWritePipeline - } + } } # Do this in all cases. @@ -1926,11 +1925,11 @@ proc http::ConfigureNewSocket {token sockOld DoLater} { # Now look at all other tokens that use the placeholder $sockOld. if { (!$reusing) - && ($sock ne $sockOld) - && [info exists socketPhQueue($sockOld)] + && ($sock ne $sockOld) + && [info exists socketPhQueue($sockOld)] } { - ##Log " ConfigureNewSocket" $token scheduled, now do $socketPhQueue($sockOld) - foreach tok $socketPhQueue($sockOld) { + ##Log " ConfigureNewSocket" $token scheduled, now do $socketPhQueue($sockOld) + foreach tok $socketPhQueue($sockOld) { # 1. Amend the token's (sock). ##Log set ${tok}(sock) $sock set ${tok}(sock) $sock @@ -2085,21 +2084,21 @@ proc http::ScheduleRequest {token} { lappend socketWrQueue($state(socketinfo)) $token } else { - if {$reusing && $state(-pipeline)} { + if {$reusing && $state(-pipeline)} { #Log new, init for pipelined, GRANT write access to $token in geturl # DO NOT grant premature read access to the socket. - # set socketRdState($state(socketinfo)) $token - set socketWrState($state(socketinfo)) $token - } elseif {$reusing} { + # set socketRdState($state(socketinfo)) $token + set socketWrState($state(socketinfo)) $token + } elseif {$reusing} { # socketWrState is not used by this non-pipelined transaction. # We cannot leave it as "Wready" because the next call to # http::geturl with a pipelined transaction would conclude that the # socket is available for writing. #Log new, init for nonpipeline, GRANT r/w access to $token in geturl - set socketRdState($state(socketinfo)) $token - set socketWrState($state(socketinfo)) $token - } else { - } + set socketRdState($state(socketinfo)) $token + set socketWrState($state(socketinfo)) $token + } else { + } # Process the request now. # - Command is not called unless $state(sock) is a real socket handle @@ -2115,7 +2114,7 @@ proc http::ScheduleRequest {token} { ##Log " ScheduleRequest" $token -- fileevent $state(sock) writable for $token # Connect does its own fconfigure. - lassign $state(connArgs) proto phost srvurl + lassign $state(connArgs) proto phost srvurl if {[catch { fileevent $state(sock) writable \ @@ -2284,11 +2283,11 @@ proc http::Connected {token proto phost srvurl} { # and "state(-keepalive) 0". set ConnVal close } - # Proxy authorisation (cf. mod by Anders Ramdahl to autoproxy by - # Pat Thoyts). - if {($http(-proxyauth) ne {}) && ($state(proxyUsed) eq {HttpProxy})} { + # Proxy authorisation (cf. mod by Anders Ramdahl to autoproxy by + # Pat Thoyts). + if {($http(-proxyauth) ne {}) && ($state(proxyUsed) eq {HttpProxy})} { SendHeader $token Proxy-Authorization $http(-proxyauth) - } + } # RFC7230 A.1 - "clients are encouraged not to send the # Proxy-Connection header field in any requests" set accept_encoding_seen 0 @@ -2314,7 +2313,7 @@ proc http::Connected {token proto phost srvurl} { set state(querylength) $value } if { [string equal -nocase $key "connection"] - && [info exists state(bypass)] + && [info exists state(bypass)] } { # Value supplied in -headers overrides $ConnVal. set connection_seen 1 @@ -2449,7 +2448,7 @@ proc http::Connected {token proto phost srvurl} { if {[info exists state(reusing)] && $state(reusing)} { # The socket was closed at the server end, and closed at # this end by http::CheckEof. - if {[TestForReplay $token write $err a]} { + if {[TestForReplay $token write $err a]} { return } else { Finish $token {failed to re-use socket} @@ -2606,9 +2605,9 @@ proc http::ReceiveResponse {token} { coroutine ${token}--EventCoroutine http::Event $sock $token if {[info exists state(-handler)] || [info exists state(-progress)]} { - fileevent $sock readable [list http::EventGateway $sock $token] + fileevent $sock readable [list http::EventGateway $sock $token] } else { - fileevent $sock readable ${token}--EventCoroutine + fileevent $sock readable ${token}--EventCoroutine } return } @@ -2634,15 +2633,15 @@ proc http::EventGateway {sock token} { fileevent $sock readable {} catch {${token}--EventCoroutine} res opts if {[info commands ${token}--EventCoroutine] ne {}} { - # The coroutine can be deleted by completion (a non-yield return), by - # http::Finish (when there is a premature end to the transaction), by - # http::reset or http::cleanup, or if the caller set option -channel - # but not option -handler: in the last case reading from the socket is - # now managed by commands ::http::Copy*, http::ReceiveChunked, and - # http::MakeTransformationChunked. - # - # Catch in case the coroutine has closed the socket. - catch {fileevent $sock readable [list http::EventGateway $sock $token]} + # The coroutine can be deleted by completion (a non-yield return), by + # http::Finish (when there is a premature end to the transaction), by + # http::reset or http::cleanup, or if the caller set option -channel + # but not option -handler: in the last case reading from the socket is + # now managed by commands ::http::Copy*, http::ReceiveChunked, and + # http::MakeTransformationChunked. + # + # Catch in case the coroutine has closed the socket. + catch {fileevent $sock readable [list http::EventGateway $sock $token]} } # If there was an error, re-throw it. @@ -3048,9 +3047,9 @@ proc http::ReInit {token} { unset state(after) } if {[info exists state(socketcoro)]} { - Log $token Cancel socket after-idle event (ReInit) - after cancel $state(socketcoro) - unset state(socketcoro) + Log $token Cancel socket after-idle event (ReInit) + after cancel $state(socketcoro) + unset state(socketcoro) } # Don't alter state(status) - this would trigger http::wait if it is in use. @@ -3210,17 +3209,17 @@ proc http::size {token} { proc http::requestHeaders {token args} { set lenny [llength $args] if {$lenny > 1} { - return -code error {usage: ::http::requestHeaders token ?headerName?} + return -code error {usage: ::http::requestHeaders token ?headerName?} } else { - return [Meta $token request {*}$args] + return [Meta $token request {*}$args] } } proc http::responseHeaders {token args} { set lenny [llength $args] if {$lenny > 1} { - return -code error {usage: ::http::responseHeaders token ?headerName?} + return -code error {usage: ::http::responseHeaders token ?headerName?} } else { - return [Meta $token response {*}$args] + return [Meta $token response {*}$args] } } proc http::requestHeaderValue {token header} { @@ -3234,34 +3233,34 @@ proc http::Meta {token who args} { upvar 0 $token state if {$who eq {request}} { - set whom requestHeaders + set whom requestHeaders } elseif {$who eq {response}} { - set whom meta + set whom meta } else { - return -code error {usage: ::http::Meta token request|response ?headerName ?VALUE??} + return -code error {usage: ::http::Meta token request|response ?headerName ?VALUE??} } set header [string tolower [lindex $args 0]] set how [string tolower [lindex $args 1]] set lenny [llength $args] if {$lenny == 0} { - return $state($whom) + return $state($whom) } elseif {($lenny > 2) || (($lenny == 2) && ($how ne {value}))} { - return -code error {usage: ::http::Meta token request|response ?headerName ?VALUE??} + return -code error {usage: ::http::Meta token request|response ?headerName ?VALUE??} } else { - set result {} - set combined {} - foreach {key value} $state($whom) { - if {$key eq $header} { - lappend result $key $value - append combined $value {, } - } - } - if {$lenny == 1} { - return $result - } else { - return [string range $combined 0 end-2] - } + set result {} + set combined {} + foreach {key value} $state($whom) { + if {$key eq $header} { + lappend result $key $value + append combined $value {, } + } + } + if {$lenny == 1} { + return $result + } else { + return [string range $combined 0 end-2] + } } } @@ -3283,56 +3282,56 @@ proc http::responseInfo {token} { upvar 0 $token state set result {} foreach {key origin name} { - stage STATE state - status STATE status - responseCode STATE responseCode - reasonPhrase STATE reasonPhrase - contentType STATE type - binary STATE binary - redirection RESP location - upgrade STATE upgrade - error ERROR - - postError STATE posterror - method STATE method - charset STATE charset - compression STATE coding - httpRequest STATE -protocol - httpResponse STATE httpResponse - url STATE url - connectionRequest REQ connection - connectionResponse RESP connection - connectionActual STATE connection - transferEncoding STATE transfer - totalPost STATE querylength - currentPost STATE queryoffset - totalSize STATE totalsize - currentSize STATE currentsize - proxyUsed STATE proxyUsed + stage STATE state + status STATE status + responseCode STATE responseCode + reasonPhrase STATE reasonPhrase + contentType STATE type + binary STATE binary + redirection RESP location + upgrade STATE upgrade + error ERROR - + postError STATE posterror + method STATE method + charset STATE charset + compression STATE coding + httpRequest STATE -protocol + httpResponse STATE httpResponse + url STATE url + connectionRequest REQ connection + connectionResponse RESP connection + connectionActual STATE connection + transferEncoding STATE transfer + totalPost STATE querylength + currentPost STATE queryoffset + totalSize STATE totalsize + currentSize STATE currentsize + proxyUsed STATE proxyUsed } { - if {$origin eq {STATE}} { - if {[info exists state($name)]} { - dict set result $key $state($name) - } else { - # Should never come here - dict set result $key {} - } - } elseif {$origin eq {REQ}} { - dict set result $key [requestHeaderValue $token $name] - } elseif {$origin eq {RESP}} { - dict set result $key [responseHeaderValue $token $name] - } elseif {$origin eq {ERROR}} { - # Don't flood the dict with data. The command ::http::error is - # available. - if {[info exists state(error)]} { - set msg [lindex $state(error) 0] - } else { - set msg {} - } - dict set result $key $msg - } else { - # Should never come here - dict set result $key {} - } + if {$origin eq {STATE}} { + if {[info exists state($name)]} { + dict set result $key $state($name) + } else { + # Should never come here + dict set result $key {} + } + } elseif {$origin eq {REQ}} { + dict set result $key [requestHeaderValue $token $name] + } elseif {$origin eq {RESP}} { + dict set result $key [responseHeaderValue $token $name] + } elseif {$origin eq {ERROR}} { + # Don't flood the dict with data. The command ::http::error is + # available. + if {[info exists state(error)]} { + set msg [lindex $state(error) 0] + } else { + set msg {} + } + dict set result $key $msg + } else { + # Should never come here + dict set result $key {} + } } return $result } @@ -3377,9 +3376,9 @@ proc http::cleanup {token} { unset state(after) } if {[info exists state(socketcoro)]} { - Log $token Cancel socket after-idle event (cleanup) - after cancel $state(socketcoro) - unset state(socketcoro) + Log $token Cancel socket after-idle event (cleanup) + after cancel $state(socketcoro) + unset state(socketcoro) } if {[info exists state]} { unset state @@ -3396,7 +3395,7 @@ proc http::cleanup {token} { # # Side Effects # Sets the status of the connection, which unblocks -# the waiting geturl call +# the waiting geturl call proc http::Connect {token proto phost srvurl} { variable $token @@ -3404,11 +3403,11 @@ proc http::Connect {token proto phost srvurl} { set tk [namespace tail $token] if {[catch {eof $state(sock)} tmp] || $tmp} { - set err "due to unexpected EOF" + set err "due to unexpected EOF" } elseif {[set err [fconfigure $state(sock) -error]] ne ""} { - # set err is done in test + # set err is done in test } else { - # All OK + # All OK set state(state) connecting fileevent $state(sock) writable {} ::http::Connected $token $proto $phost $srvurl @@ -3821,9 +3820,9 @@ proc http::Event {sock token} { rename ${token}--SocketCoroutine {} } if {[info exists state(socketcoro)]} { - Log $token Cancel socket after-idle event (Finish) - after cancel $state(socketcoro) - unset state(socketcoro) + Log $token Cancel socket after-idle event (Finish) + after cancel $state(socketcoro) + unset state(socketcoro) } if {[info exists state(after)]} { after cancel $state(after) @@ -4647,14 +4646,14 @@ proc http::GuessType {token} { upvar 0 $token state if {$state(type) ne {application/octet-stream}} { - return 0 + return 0 } set body $state(body) # e.g. {<?xml version="1.0" encoding="utf-8"?> ...} if {![regexp -nocase -- {^<[?]xml[[:space:]][^>?]*[?]>} $body match]} { - return 0 + return 0 } # e.g. {<?xml version="1.0" encoding="utf-8"?>} @@ -4664,21 +4663,21 @@ proc http::GuessType {token} { # without excess whitespace or upper-case letters if {![regexp -- {^([^=" ]+="[^"]+" )+$} "$contents "]} { - return 0 + return 0 } # The application/xml default encoding: set res utf-8 set tagList [regexp -all -inline -- {[^=" ]+="[^"]+"} $contents] foreach tag $tagList { - regexp -- {([^=" ]+)="([^"]+)"} $tag -> name value - if {$name eq {encoding}} { - set res $value - } + regexp -- {([^=" ]+)="([^"]+)"} $tag -> name value + if {$name eq {encoding}} { + set res $value + } } set enc [CharsetToEncoding $res] if {$enc eq "binary"} { - return 0 + return 0 } if {[package vsatisfies [package provide Tcl] 9.0-]} { set state(body) [encoding convertfrom -profile replace $enc $state(body)] @@ -4729,10 +4728,10 @@ proc http::wait {token} { proc http::formatQuery {args} { if {[llength $args] % 2} { - return \ - -code error \ - -errorcode [list HTTP BADARGCNT $args] \ - {Incorrect number of arguments, must be an even number.} + return \ + -code error \ + -errorcode [list HTTP BADARGCNT $args] \ + {Incorrect number of arguments, must be an even number.} } set result "" set sep "" @@ -4785,7 +4784,7 @@ proc http::quoteString {string} { proc http::ProxyRequired {host} { variable http if {(![info exists http(-proxyhost)]) || ($http(-proxyhost) eq {})} { - return + return } if {![info exists http(-proxyport)] || ($http(-proxyport) eq {})} { set port 8080 @@ -4796,9 +4795,9 @@ proc http::ProxyRequired {host} { # Simple test (cf. autoproxy) for hosts that must be accessed directly, # not through the proxy server. foreach domain $http(-proxynot) { - if {[string match -nocase $domain $host]} { - return {} - } + if {[string match -nocase $domain $host]} { + return {} + } } return [list $http(-proxyhost) $port] } @@ -4925,7 +4924,7 @@ proc http::ReceiveChunked {chan command} { } # http::SplitCommaSeparatedFieldValue -- -# Return the individual values of a comma-separated field value. +# Return the individual values of a comma-separated field value. # # Arguments: # fieldValue Comma-separated header field value. @@ -4942,7 +4941,7 @@ proc http::SplitCommaSeparatedFieldValue {fieldValue} { # http::GetFieldValue -- -# Return the value of a header field. +# Return the value of a header field. # # Arguments: # headers Headers key-value list @@ -5011,29 +5010,29 @@ proc http::socketAsCallback {args} { set targ [lsearch -exact $args -type] if {$targ != -1} { - set token [lindex $args $targ+1] - upvar 0 ${token} state - set protoProxyConn $state(protoProxyConn) + set token [lindex $args $targ+1] + upvar 0 ${token} state + set protoProxyConn $state(protoProxyConn) } else { - set protoProxyConn 0 + set protoProxyConn 0 } set host [lindex $args end-1] set port [lindex $args end] if { ($http(-proxyfilter) ne {}) - && (![catch {$http(-proxyfilter) $host} proxy]) - && $protoProxyConn + && (![catch {$http(-proxyfilter) $host} proxy]) + && $protoProxyConn } { - set phost [lindex $proxy 0] - set pport [lindex $proxy 1] + set phost [lindex $proxy 0] + set pport [lindex $proxy 1] } else { - set phost {} - set pport {} + set phost {} + set pport {} } if {$phost eq ""} { - set sock [::http::AltSocket {*}$args] + set sock [::http::AltSocket {*}$args] } else { - set sock [::http::SecureProxyConnect {*}$args $phost $pport] + set sock [::http::SecureProxyConnect {*}$args $phost $pport] } return $sock } @@ -5079,8 +5078,8 @@ proc http::SecureProxyConnect {args} { set phost [lindex $args end-1] set pport [lindex $args end] if {[string first : $phost] != -1} { - # IPv6 address, wrap it in [] so we can append :pport - set phost "\[${phost}\]" + # IPv6 address, wrap it in [] so we can append :pport + set phost "\[${phost}\]" } set url http://${phost}:${pport} # Elements of args other than host and port are not used when @@ -5091,21 +5090,21 @@ proc http::SecureProxyConnect {args} { set targ [lsearch -exact $args -type] if {$targ != -1} { - # Record in the token that this is a proxy call. - set token [lindex $args $targ+1] - upvar 0 ${token} state - set tim $state(-timeout) - set state(proxyUsed) SecureProxyFailed - # This value is overwritten with "SecureProxy" below if the CONNECT is - # successful. If it is unsuccessful, the socket will be closed - # below, and so in this unsuccessful case there are no other transactions - # whose (proxyUsed) must be updated. + # Record in the token that this is a proxy call. + set token [lindex $args $targ+1] + upvar 0 ${token} state + set tim $state(-timeout) + set state(proxyUsed) SecureProxyFailed + # This value is overwritten with "SecureProxy" below if the CONNECT is + # successful. If it is unsuccessful, the socket will be closed + # below, and so in this unsuccessful case there are no other transactions + # whose (proxyUsed) must be updated. } else { - set tim 0 + set tim 0 } if {$tim == 0} { - # Do not use infinite timeout for the proxy. - set tim 30000 + # Do not use infinite timeout for the proxy. + set tim 30000 } # Prepare and send a CONNECT request to the proxy, using @@ -5113,11 +5112,11 @@ proc http::SecureProxyConnect {args} { set requestHeaders [list Host $host] lappend requestHeaders Connection keep-alive if {$http(-proxyauth) != {}} { - lappend requestHeaders Proxy-Authorization $http(-proxyauth) + lappend requestHeaders Proxy-Authorization $http(-proxyauth) } set token2 [CreateToken $url -keepalive 0 -timeout $tim \ - -headers $requestHeaders -command [list http::AllDone $varName]] + -headers $requestHeaders -command [list http::AllDone $varName]] variable $token2 upvar 0 $token2 state2 @@ -5131,61 +5130,61 @@ proc http::SecureProxyConnect {args} { AsyncTransaction $token2 if {[info coroutine] ne {}} { - # All callers in the http package are coroutines launched by - # the event loop. - # The cwait command requires a coroutine because it yields - # to the caller; $varName is traced and the coroutine resumes - # when the variable is written. - cwait $varName + # All callers in the http package are coroutines launched by + # the event loop. + # The cwait command requires a coroutine because it yields + # to the caller; $varName is traced and the coroutine resumes + # when the variable is written. + cwait $varName } else { - return -code error {code must run in a coroutine} - # For testing with a non-coroutine caller outside the http package. - # vwait $varName + return -code error {code must run in a coroutine} + # For testing with a non-coroutine caller outside the http package. + # vwait $varName } unset $varName if { ($state2(state) ne "complete") - || ($state2(status) ne "ok") - || (![string is integer -strict $state2(responseCode)]) + || ($state2(status) ne "ok") + || (![string is integer -strict $state2(responseCode)]) } { - set msg {the HTTP request to the proxy server did not return a valid\ - and complete response} - if {[info exists state2(error)]} { - append msg ": " [lindex $state2(error) 0] - } - cleanup $token2 - return -code error $msg + set msg {the HTTP request to the proxy server did not return a valid\ + and complete response} + if {[info exists state2(error)]} { + append msg ": " [lindex $state2(error) 0] + } + cleanup $token2 + return -code error $msg } set code $state2(responseCode) if {($code >= 200) && ($code < 300)} { - # All OK. The caller in package tls will now call "tls::import $sock". - # The cleanup command does not close $sock. - # Other tidying was done in http::Event. + # All OK. The caller in package tls will now call "tls::import $sock". + # The cleanup command does not close $sock. + # Other tidying was done in http::Event. - # If this is a persistent socket, any other transactions that are - # already marked to use the socket will have their (proxyUsed) updated - # when http::OpenSocket calls http::ConfigureNewSocket. - set state(proxyUsed) SecureProxy - set sock $state2(sock) - cleanup $token2 - return $sock + # If this is a persistent socket, any other transactions that are + # already marked to use the socket will have their (proxyUsed) updated + # when http::OpenSocket calls http::ConfigureNewSocket. + set state(proxyUsed) SecureProxy + set sock $state2(sock) + cleanup $token2 + return $sock } if {$targ != -1} { - # Non-OK HTTP status code; token is known because option -type - # (cf. targ) was passed through tcltls, and so the useful - # parts of the proxy's response can be copied to state(*). - # Do not copy state2(sock). - # Return the proxy response to the caller of geturl. - foreach name $failedProxyValues { - if {[info exists state2($name)]} { - set state($name) $state2($name) - } - } - set state(connection) close - set msg "proxy connect failed: $code" + # Non-OK HTTP status code; token is known because option -type + # (cf. targ) was passed through tcltls, and so the useful + # parts of the proxy's response can be copied to state(*). + # Do not copy state2(sock). + # Return the proxy response to the caller of geturl. + foreach name $failedProxyValues { + if {[info exists state2($name)]} { + set state($name) $state2($name) + } + } + set state(connection) close + set msg "proxy connect failed: $code" # - This error message will be detected by http::OpenSocket and will # cause it to present the proxy's HTTP response as that of the # original $token transaction, identified only by state(proxyUsed) @@ -5272,25 +5271,25 @@ proc http::AltSocket {args} { set targ [lsearch -exact $args -type] if {$targ != -1} { - set token [lindex $args $targ+1] - set args [lreplace $args $targ $targ+1] - upvar 0 $token state + set token [lindex $args $targ+1] + set args [lreplace $args $targ $targ+1] + upvar 0 $token state } if {$http(usingThread) && [info exists state] && $state(protoSockThread)} { } else { - # Use plain "::socket". This is the default. - return [eval ::socket $args] + # Use plain "::socket". This is the default. + return [eval ::socket $args] } set defcmd ::socket set sockargs $args set script " - set code \[catch { - [list proc ::SockInThread {caller defcmd sockargs} [info body ::http::SockInThread]] - [list ::SockInThread [thread::id] $defcmd $sockargs] - } result opts\] - list \$code \$opts \$result + set code \[catch { + [list proc ::SockInThread {caller defcmd sockargs} [info body ::http::SockInThread]] + [list ::SockInThread [thread::id] $defcmd $sockargs] + } result opts\] + list \$code \$opts \$result " set state(tid) [thread::create] @@ -5298,16 +5297,16 @@ proc http::AltSocket {args} { thread::send -async $state(tid) $script $varName Log >T Thread Start Wait $args -- coro [info coroutine] $varName if {[info coroutine] ne {}} { - # All callers in the http package are coroutines launched by - # the event loop. - # The cwait command requires a coroutine because it yields - # to the caller; $varName is traced and the coroutine resumes - # when the variable is written. - cwait $varName + # All callers in the http package are coroutines launched by + # the event loop. + # The cwait command requires a coroutine because it yields + # to the caller; $varName is traced and the coroutine resumes + # when the variable is written. + cwait $varName } else { - return -code error {code must run in a coroutine} - # For testing with a non-coroutine caller outside the http package. - # vwait $varName + return -code error {code must run in a coroutine} + # For testing with a non-coroutine caller outside the http package. + # vwait $varName } Log >U Thread End Wait $args -- coro [info coroutine] $varName [set $varName] thread::release $state(tid) @@ -5315,20 +5314,20 @@ proc http::AltSocket {args} { set result [set $varName] unset $varName if {(![string is list $result]) || ([llength $result] != 3)} { - return -code error "result from peer thread is not a list of\ - length 3: it is \n$result" + return -code error "result from peer thread is not a list of\ + length 3: it is \n$result" } lassign $result threadCode threadDict threadResult if {($threadCode != 0)} { - # This is an error in thread::send. Return the lot. - return -options $threadDict -code error $threadResult + # This is an error in thread::send. Return the lot. + return -options $threadDict -code error $threadResult } # Now the results of the catch in the peer thread. lassign $threadResult catchCode errdict sock if {($catchCode == 0) && ($sock ni [chan names])} { - return -code error {Transfer of socket from peer thread failed.\ + return -code error {Transfer of socket from peer thread failed.\ Check that this script is not running in a child interpreter.} } return -options $errdict -code $catchCode $sock @@ -5356,17 +5355,17 @@ proc http::AltSocket {args} { proc http::LoadThreadIfNeeded {} { variable http if {$http(-threadlevel) == 0} { - set http(usingThread) 0 - return + set http(usingThread) 0 + return } if {[catch {package require Thread}]} { - if {$http(-threadlevel) == 2} { - set msg {[http::config -threadlevel] has value 2,\ - but the Thread package is not available} - return -code error $msg - } - set http(usingThread) 0 - return + if {$http(-threadlevel) == 2} { + set msg {[http::config -threadlevel] has value 2,\ + but the Thread package is not available} + return -code error $msg + } + set http(usingThread) 0 + return } set http(usingThread) 1 return @@ -5393,7 +5392,7 @@ proc http::SockInThread {caller defcmd sockargs} { set catchCode [catch {eval $defcmd $sockargs} sock errdict] if {$catchCode == 0} { - set catchCode [catch {thread::transfer $caller $sock; set sock} sock errdict] + set catchCode [catch {thread::transfer $caller $sock; set sock} sock errdict] } return [list $catchCode $errdict $sock] } @@ -5430,20 +5429,20 @@ proc http::cwaiter::cwait { } { set thisCoro [info coroutine] if {$thisCoro eq {}} { - return -code error {cwait cannot be called outside a coroutine} + return -code error {cwait cannot be called outside a coroutine} } if {$coroName eq {}} { - set coroName $thisCoro + set coroName $thisCoro } if {[string range $varName 0 1] ne {::}} { - return -code error {argument varName must be fully qualified} + return -code error {argument varName must be fully qualified} } if {$timeout eq {}} { - set toe {} + set toe {} } elseif {[string is integer -strict $timeout] && ($timeout > 0)} { - set toe [after $timeout [list set $varName $timeoutValue]] + set toe [after $timeout [list set $varName $timeoutValue]] } else { - return -code error {if timeout is supplied it must be a positive integer} + return -code error {if timeout is supplied it must be a positive integer} } set cmd [list ::http::cwaiter::CwaitHelper $varName $coroName $toe] @@ -5501,7 +5500,7 @@ proc http::cwaiter::CoLog {msg} { variable log variable logOn if {$logOn} { - append log $msg \n + append log $msg \n } return } diff --git a/library/init.tcl b/library/init.tcl index 72d0e75..9658991 100644 --- a/library/init.tcl +++ b/library/init.tcl @@ -554,12 +554,12 @@ proc auto_import {pattern} { auto_load_index foreach pattern $patternList { - foreach name [array names auto_index $pattern] { - if {([namespace which -command $name] eq "") + foreach name [array names auto_index $pattern] { + if {([namespace which -command $name] eq "") && ([namespace qualifiers $pattern] eq [namespace qualifiers $name])} { - namespace inscope :: $auto_index($name) - } - } + namespace inscope :: $auto_index($name) + } + } } } diff --git a/library/msgcat/msgcat.tcl b/library/msgcat/msgcat.tcl index f6e5224..eaaafa8 100644 --- a/library/msgcat/msgcat.tcl +++ b/library/msgcat/msgcat.tcl @@ -20,7 +20,7 @@ package provide msgcat 1.7.1 namespace eval msgcat { namespace export mc mcn mcexists mcload mclocale mcmax\ mcmset mcpreferences mcset\ - mcunknown mcflset mcflmset mcloadedlocales mcforgetpackage\ + mcunknown mcflset mcflmset mcloadedlocales mcforgetpackage\ mcpackagenamespaceget mcpackageconfig mcpackagelocale mcutil # Records the list of locales to search @@ -738,7 +738,7 @@ proc msgcat::mcpackageconfig {subcommand option {value ""}} { \"[lrange [info level 0] 0 2] value\"" } } elseif {$subcommand eq "set"} { - return -code error\ + return -code error\ "wrong # args: should be \"[lrange [info level 0] 0 2]\"" } diff --git a/library/opt/optparse.tcl b/library/opt/optparse.tcl index 0a6cdfa..7225edd 100644 --- a/library/opt/optparse.tcl +++ b/library/opt/optparse.tcl @@ -17,10 +17,10 @@ namespace eval ::tcl { # Exported APIs namespace export OptKeyRegister OptKeyDelete OptKeyError OptKeyParse \ - OptProc OptProcArgGiven OptParse \ - Lempty Lget \ - Lassign Lvarpop Lvarpop1 Lvarset Lvarincr \ - SetMax SetMin + OptProc OptProcArgGiven OptParse \ + Lempty Lget \ + Lassign Lvarpop Lvarpop1 Lvarset Lvarincr \ + SetMax SetMin ################# Example of use / 'user documentation' ################### @@ -38,28 +38,28 @@ namespace eval ::tcl { # ::tcl::OptParseTest save -4 -pr 23 -libsok SybTcl\ # -nostatics false ch1 OptProc OptParseTest { - {subcommand -choice {save print} "sub command"} - {arg1 3 "some number"} - {-aflag} - {-intflag 7} - {-weirdflag "help string"} - {-noStatics "Not ok to load static packages"} - {-nestedloading1 true "OK to load into nested children"} - {-nestedloading2 -boolean true "OK to load into nested children"} - {-libsOK -choice {Tk SybTcl} - "List of packages that can be loaded"} - {-precision -int 12 "Number of digits of precision"} - {-intval 7 "An integer"} - {-scale -float 1.0 "Scale factor"} - {-zoom 1.0 "Zoom factor"} - {-arbitrary foobar "Arbitrary string"} - {-random -string 12 "Random string"} - {-listval -list {} "List value"} - {-blahflag -blah abc "Funny type"} + {subcommand -choice {save print} "sub command"} + {arg1 3 "some number"} + {-aflag} + {-intflag 7} + {-weirdflag "help string"} + {-noStatics "Not ok to load static packages"} + {-nestedloading1 true "OK to load into nested children"} + {-nestedloading2 -boolean true "OK to load into nested children"} + {-libsOK -choice {Tk SybTcl} + "List of packages that can be loaded"} + {-precision -int 12 "Number of digits of precision"} + {-intval 7 "An integer"} + {-scale -float 1.0 "Scale factor"} + {-zoom 1.0 "Zoom factor"} + {-arbitrary foobar "Arbitrary string"} + {-random -string 12 "Random string"} + {-listval -list {} "List value"} + {-blahflag -blah abc "Funny type"} {arg2 -boolean "a boolean"} {arg3 -choice "ch1 ch2"} {?optarg? -list {} "optional argument"} - } { + } { foreach v [info locals] { puts stderr [format "%14s : %s" $v [set $v]] } @@ -146,10 +146,10 @@ proc ::tcl::OptKeyRegister {desc {key ""}} { variable OptDesc variable OptDescN if {[string equal $key ""]} { - # in case a key given to us as a parameter was a number - while {[info exists OptDesc($OptDescN)]} {incr OptDescN} - set key $OptDescN - incr OptDescN + # in case a key given to us as a parameter was a number + while {[info exists OptDesc($OptDescN)]} {incr OptDescN} + set key $OptDescN + incr OptDescN } # program counter set program [list [list "P" 1]] @@ -167,31 +167,31 @@ proc ::tcl::OptKeyRegister {desc {key ""}} { # more items after 'args'... return -code error "'args' special argument must be the last one" } - set res [OptNormalizeOne $item] - set state [lindex $res 0] - if {$inflags} { - if {$state == "flags"} { + set res [OptNormalizeOne $item] + set state [lindex $res 0] + if {$inflags} { + if {$state == "flags"} { # add to 'subprogram' - lappend flagsprg $res - } else { - # put in the flags - # structure for flag programs items is a list of - # {subprgcounter {prg flag 1} {prg flag 2} {...}} - lappend program $flagsprg - # put the other regular stuff - lappend program $res + lappend flagsprg $res + } else { + # put in the flags + # structure for flag programs items is a list of + # {subprgcounter {prg flag 1} {prg flag 2} {...}} + lappend program $flagsprg + # put the other regular stuff + lappend program $res set inflags 0 set empty 0 - } - } else { - if {$state == "flags"} { - set inflags 1 - # sub program counter + first sub program - set flagsprg [list [list "P" 1] $res] - } else { - lappend program $res - set empty 0 - } + } + } else { + if {$state == "flags"} { + set inflags 1 + # sub program counter + first sub program + set flagsprg [list [list "P" 1] $res] + } else { + lappend program $res + set empty 0 + } } } if {$inflags} { @@ -219,11 +219,11 @@ proc ::tcl::OptKeyDelete {key} { # Get the parsed description stored under the given key. proc OptKeyGetDesc {descKey} { - variable OptDesc - if {![info exists OptDesc($descKey)]} { - return -code error "Unknown option description key \"$descKey\"" - } - set OptDesc($descKey) + variable OptDesc + if {![info exists OptDesc($descKey)]} { + return -code error "Unknown option description key \"$descKey\"" + } + set OptDesc($descKey) } # Parse entry point for people who don't want to register with a key, @@ -248,11 +248,11 @@ proc ::tcl::OptParse {desc arglist} { proc ::tcl::OptProc {name desc body} { set namespace [uplevel 1 [list ::namespace current]] if {[string match "::*" $name] || [string equal $namespace "::"]} { - # absolute name or global namespace, name is the key - set key $name + # absolute name or global namespace, name is the key + set key $name } else { - # we are relative to some non top level namespace: - set key "${namespace}::${name}" + # we are relative to some non top level namespace: + set key "${namespace}::${name}" } OptKeyRegister $desc $key uplevel 1 [list ::proc $name args "set Args \[::tcl::OptKeyParse $key \$args\]\n$body"] @@ -300,21 +300,21 @@ proc ::tcl::OptProcArgGiven {argname} { # Advance to next description proc OptNextDesc {descName} { - uplevel 1 [list Lvarincr $descName {0 1}] + uplevel 1 [list Lvarincr $descName {0 1}] } # Get the current description, eventually descend proc OptCurDesc {descriptions} { - lindex $descriptions [OptGetPrgCounter $descriptions] + lindex $descriptions [OptGetPrgCounter $descriptions] } # get the current description, eventually descend # through sub programs as needed. proc OptCurDescFinal {descriptions} { - set item [OptCurDesc $descriptions] + set item [OptCurDesc $descriptions] # Descend untill we get the actual item and not a sub program - while {[OptIsPrg $item]} { - set item [OptCurDesc $item] - } + while {[OptIsPrg $item]} { + set item [OptCurDesc $item] + } return $item } # Current final instruction adress @@ -332,7 +332,7 @@ proc ::tcl::OptProcArgGiven {argname} { proc OptCurSetValue {descriptionsName value} { upvar $descriptionsName descriptions # Get the current item full address. - set adress [OptCurAddr $descriptions] + set adress [OptCurAddr $descriptions] # Use the 3rd field of the item (see OptValue / OptNewInst). lappend adress 2 Lvarset descriptions $adress [list 1 $value] @@ -341,12 +341,12 @@ proc ::tcl::OptProcArgGiven {argname} { # Empty state means done/paste the end of the program. proc OptState {item} { - lindex $item 0 + lindex $item 0 } # current state proc OptCurState {descriptions} { - OptState [OptCurDesc $descriptions] + OptState [OptCurDesc $descriptions] } ####### @@ -354,11 +354,11 @@ proc ::tcl::OptProcArgGiven {argname} { # Returns the argument that has to be processed now. proc OptCurrentArg {lst} { - lindex $lst 0 + lindex $lst 0 } # Advance to next argument. proc OptNextArg {argsName} { - uplevel 1 [list Lvarpop1 $argsName] + uplevel 1 [list Lvarpop1 $argsName] } ####### @@ -377,7 +377,7 @@ proc ::tcl::OptProcArgGiven {argname} { # when needed... set state [OptCurState $descriptions] # We'll exit the loop in "OptDoOne" or when state is empty. - while 1 { + while 1 { set curitem [OptCurDesc $descriptions] # Do subprograms if needed, call ourselves on the sub branch while {[OptIsPrg $curitem]} { @@ -388,7 +388,7 @@ proc ::tcl::OptProcArgGiven {argname} { $curitem OptNextDesc descriptions set curitem [OptCurDesc $descriptions] - set state [OptCurState $descriptions] + set state [OptCurState $descriptions] } # puts "state = \"$state\" - arguments=($arguments)" if {[Lempty $state]} { @@ -398,20 +398,20 @@ proc ::tcl::OptProcArgGiven {argname} { # The following statement can make us terminate/continue # as it use return -code {break, continue, return and error} # codes - OptDoOne descriptions state arguments + OptDoOne descriptions state arguments # If we are here, no special return code where issued, # we'll step to next instruction : # puts "new state = \"$state\"" OptNextDesc descriptions set state [OptCurState $descriptions] - } + } } # Process one step for the state machine, # eventually consuming the current argument. proc OptDoOne {descriptionsName stateName argumentsName} { - upvar $argumentsName arguments - upvar $descriptionsName descriptions + upvar $argumentsName arguments + upvar $descriptionsName descriptions upvar $stateName state # the special state/instruction "args" eats all @@ -443,48 +443,48 @@ proc ::tcl::OptProcArgGiven {argname} { set arg [OptCurrentArg $arguments] } - switch $state { - flags { - # A non-dash argument terminates the options, as does -- - - # Still a flag ? - if {![OptIsFlag $arg]} { - # don't consume the argument, return to previous prg - return -code return - } - # consume the flag - OptNextArg arguments - if {[string equal "--" $arg]} { - # return from 'flags' state - return -code return - } - - set hits [OptHits descriptions $arg] - if {$hits > 1} { - return -code error [OptAmbigous $descriptions $arg] - } elseif {$hits == 0} { - return -code error [OptFlagUsage $descriptions $arg] - } + switch $state { + flags { + # A non-dash argument terminates the options, as does -- + + # Still a flag ? + if {![OptIsFlag $arg]} { + # don't consume the argument, return to previous prg + return -code return + } + # consume the flag + OptNextArg arguments + if {[string equal "--" $arg]} { + # return from 'flags' state + return -code return + } + + set hits [OptHits descriptions $arg] + if {$hits > 1} { + return -code error [OptAmbigous $descriptions $arg] + } elseif {$hits == 0} { + return -code error [OptFlagUsage $descriptions $arg] + } set item [OptCurDesc $descriptions] - if {[OptNeedValue $item]} { + if {[OptNeedValue $item]} { # we need a value, next state is set state flagValue - } else { - OptCurSetValue descriptions 1 - } + } else { + OptCurSetValue descriptions 1 + } # continue return -code continue - } + } flagValue - value { set item [OptCurDesc $descriptions] - # Test the values against their required type + # Test the values against their required type if {[catch {OptCheckType $arg\ [OptType $item] [OptTypeArgs $item]} val]} { return -code error [OptBadValue $item $arg $val] } - # consume the value - OptNextArg arguments + # consume the value + OptNextArg arguments # set the value OptCurSetValue descriptions $val # go to next state @@ -498,7 +498,7 @@ proc ::tcl::OptProcArgGiven {argname} { } optValue { set item [OptCurDesc $descriptions] - # Test the values against their required type + # Test the values against their required type if {![catch {OptCheckType $arg\ [OptType $item] [OptTypeArgs $item]} val]} { # right type, so : @@ -511,7 +511,7 @@ proc ::tcl::OptProcArgGiven {argname} { set state next; # not used, for debug only return ; # will go on next step } - } + } # If we reach this point: an unknown # state as been entered ! return -code error "Bug! unknown state in DoOne \"$state\"\ @@ -576,46 +576,46 @@ proc ::tcl::OptCheckType {arg type {typeArgs ""}} { # only types "any", "choice", and numbers can have leading "-" switch -exact -- $type { - int { - if {![string is integer -strict $arg]} { - error "not an integer" - } + int { + if {![string is integer -strict $arg]} { + error "not an integer" + } return $arg - } - float { - return [expr {double($arg)}] - } + } + float { + return [expr {double($arg)}] + } script - - list { + list { # if llength fail : malformed list - if {[llength $arg]==0 && [OptIsFlag $arg]} { + if {[llength $arg]==0 && [OptIsFlag $arg]} { error "no values with leading -" } return $arg - } - boolean { + } + boolean { if {![string is boolean -strict $arg]} { error "non canonic boolean" - } + } # convert true/false because expr/if is broken with "!,... return [expr {$arg ? 1 : 0}] - } - choice { - if {$arg ni $typeArgs} { - error "invalid choice" - } + } + choice { + if {$arg ni $typeArgs} { + error "invalid choice" + } return $arg - } + } any { return $arg } string - default { - if {[OptIsFlag $arg]} { - error "no values with leading -" - } + if {[OptIsFlag $arg]} { + error "no values with leading -" + } return $arg - } + } } return neverReached } @@ -625,17 +625,17 @@ proc ::tcl::OptCheckType {arg type {typeArgs ""}} { # returns the number of flags matching the given arg # sets the (local) prg counter to the list of matches proc OptHits {descName arg} { - upvar $descName desc - set hits 0 - set hitems {} + upvar $descName desc + set hits 0 + set hitems {} set i 1 set larg [string tolower $arg] set len [string length $larg] set last [expr {$len-1}] - foreach item [lrange $desc 1 end] { - set flag [OptName $item] + foreach item [lrange $desc 1 end] { + set flag [OptName $item] # lets try to match case insensitively # (string length ought to be cheap) set lflag [string tolower $flag] @@ -648,19 +648,19 @@ proc ::tcl::OptCheckType {arg type {typeArgs ""}} { } elseif {[string equal $larg [string range $lflag 0 $last]]} { lappend hitems $i incr hits - } + } incr i - } + } if {$hits} { OptSetPrgCounter desc $hitems } - return $hits + return $hits } # Extract fields from the list structure: proc OptName {item} { - lindex $item 1 + lindex $item 1 } proc OptHasBeenSet {item} { Lget $item {2 0} @@ -670,37 +670,37 @@ proc ::tcl::OptCheckType {arg type {typeArgs ""}} { } proc OptIsFlag {name} { - string match "-*" $name + string match "-*" $name } proc OptIsOpt {name} { - string match {\?*} $name + string match {\?*} $name } proc OptVarName {item} { - set name [OptName $item] - if {[OptIsFlag $name]} { - return [string range $name 1 end] - } elseif {[OptIsOpt $name]} { + set name [OptName $item] + if {[OptIsFlag $name]} { + return [string range $name 1 end] + } elseif {[OptIsOpt $name]} { return [string trim $name "?"] } else { - return $name - } + return $name + } } proc OptType {item} { - lindex $item 3 + lindex $item 3 } proc OptTypeArgs {item} { - lindex $item 4 + lindex $item 4 } proc OptHelp {item} { - lindex $item 5 + lindex $item 5 } proc OptNeedValue {item} { - expr {![string equal [OptType $item] boolflag]} + expr {![string equal [OptType $item] boolflag]} } proc OptDefaultValue {item} { - set val [OptTypeArgs $item] - switch -exact -- [OptType $item] { - choice {return [lindex $val 0]} + set val [OptTypeArgs $item] + switch -exact -- [OptType $item] { + choice {return [lindex $val 0]} boolean - boolflag { # convert back false/true to 0/1 because expr !$bool @@ -711,15 +711,15 @@ proc ::tcl::OptCheckType {arg type {typeArgs ""}} { return 0 } } - } - return $val + } + return $val } # Description format error helper proc OptOptUsage {item {what ""}} { - return -code error "invalid description format$what: $item\n\ - should be a list of {varname|-flagname ?-type? ?defaultvalue?\ - ?helpstring?}" + return -code error "invalid description format$what: $item\n\ + should be a list of {varname|-flagname ?-type? ?defaultvalue?\ + ?helpstring?}" } @@ -733,13 +733,13 @@ proc ::tcl::OptCheckType {arg type {typeArgs ""}} { # Translate one item to canonical form proc OptNormalizeOne {item} { - set lg [Lassign $item varname arg1 arg2 arg3] + set lg [Lassign $item varname arg1 arg2 arg3] # puts "called optnormalizeone '$item' v=($varname), lg=$lg" - set isflag [OptIsFlag $varname] + set isflag [OptIsFlag $varname] set isopt [OptIsOpt $varname] - if {$isflag} { - set state "flags" - } elseif {$isopt} { + if {$isflag} { + set state "flags" + } elseif {$isopt} { set state "optValue" } elseif {![string equal $varname "args"]} { set state "value" @@ -751,20 +751,20 @@ proc ::tcl::OptCheckType {arg type {typeArgs ""}} { # description writer's life easy, and our's difficult : # let's guess the missing arguments :-) - switch $lg { - 1 { - if {$isflag} { - return [OptNewInst $state $varname boolflag false ""] - } else { - return [OptNewInst $state $varname any "" ""] - } - } - 2 { - # varname default - # varname help - set type [OptGuessType $arg1] - if {[string equal $type "string"]} { - if {$isflag} { + switch $lg { + 1 { + if {$isflag} { + return [OptNewInst $state $varname boolflag false ""] + } else { + return [OptNewInst $state $varname any "" ""] + } + } + 2 { + # varname default + # varname help + set type [OptGuessType $arg1] + if {[string equal $type "string"]} { + if {$isflag} { set type boolflag set def false } else { @@ -772,67 +772,67 @@ proc ::tcl::OptCheckType {arg type {typeArgs ""}} { set def "" } set help $arg1 - } else { - set help "" - set def $arg1 - } - return [OptNewInst $state $varname $type $def $help] - } - 3 { - # varname type value - # varname value comment - - if {[regexp {^-(.+)$} $arg1 x type]} { + } else { + set help "" + set def $arg1 + } + return [OptNewInst $state $varname $type $def $help] + } + 3 { + # varname type value + # varname value comment + + if {[regexp {^-(.+)$} $arg1 x type]} { # flags/optValue as they are optional, need a "value", # on the contrary, for a variable (non optional), - # default value is pointless, 'cept for choices : + # default value is pointless, 'cept for choices : if {$isflag || $isopt || ($type == "choice")} { return [OptNewInst $state $varname $type $arg2 ""] } else { return [OptNewInst $state $varname $type "" $arg2] } - } else { - return [OptNewInst $state $varname\ + } else { + return [OptNewInst $state $varname\ [OptGuessType $arg1] $arg1 $arg2] - } - } - 4 { - if {[regexp {^-(.+)$} $arg1 x type]} { + } + } + 4 { + if {[regexp {^-(.+)$} $arg1 x type]} { return [OptNewInst $state $varname $type $arg2 $arg3] - } else { - return -code error [OptOptUsage $item] - } - } - default { - return -code error [OptOptUsage $item] - } - } + } else { + return -code error [OptOptUsage $item] + } + } + default { + return -code error [OptOptUsage $item] + } + } } # Auto magic lazy type determination proc OptGuessType {arg} { - if { $arg == "true" || $arg == "false" } { - return boolean - } - if {[string is integer -strict $arg]} { - return int - } - if {[string is double -strict $arg]} { - return float - } - return string + if { $arg == "true" || $arg == "false" } { + return boolean + } + if {[string is integer -strict $arg]} { + return int + } + if {[string is double -strict $arg]} { + return float + } + return string } # Error messages front ends proc OptAmbigous {desc arg} { - OptError "ambigous option \"$arg\", choose from:" [OptSelection $desc] + OptError "ambigous option \"$arg\", choose from:" [OptSelection $desc] } proc OptFlagUsage {desc arg} { - OptError "bad flag \"$arg\", must be one of" $desc + OptError "bad flag \"$arg\", must be one of" $desc } proc OptTooManyArgs {desc arguments} { - OptError "too many arguments (unexpected argument(s): $arguments),\ + OptError "too many arguments (unexpected argument(s): $arguments),\ usage:"\ $desc 1 } @@ -845,13 +845,13 @@ proc ::tcl::OptCheckType {arg type {typeArgs ""}} { } proc OptBadValue {item arg {err {}}} { # puts "bad val err = \"$err\"" - OptError "bad value \"$arg\" for [OptParamType $item]"\ + OptError "bad value \"$arg\" for [OptParamType $item]"\ [list $item] } proc OptMissingValue {descriptions} { # set item [OptCurDescFinal $descriptions] - set item [OptCurDesc $descriptions] - OptError "no value given for [OptParamType $item] \"[OptName $item]\"\ + set item [OptCurDesc $descriptions] + OptError "no value given for [OptParamType $item] \"[OptName $item]\"\ (use -help for full usage) :"\ [list $item] } @@ -943,7 +943,7 @@ proc ::tcl::Lempty {list} { # Gets the value of one leaf of a lists tree proc ::tcl::Lget {list indexLst} { if {[llength $indexLst] <= 1} { - return [lindex $list $indexLst] + return [lindex $list $indexLst] } Lget [lindex $list [lindex $indexLst 0]] [lrange $indexLst 1 end] } @@ -958,17 +958,17 @@ proc ::tcl::Lget {list indexLst} { proc ::tcl::Lvarset {listName indexLst newValue} { upvar $listName list if {[llength $indexLst] <= 1} { - Lvarset1nc list $indexLst $newValue + Lvarset1nc list $indexLst $newValue } else { - set idx [lindex $indexLst 0] - set targetList [lindex $list $idx] - # reduce refcount on targetList (not really usefull now, + set idx [lindex $indexLst 0] + set targetList [lindex $list $idx] + # reduce refcount on targetList (not really usefull now, # could be with optimizing compiler) # Lvarset1 list $idx {} - # recursively replace in targetList - Lvarset targetList [lrange $indexLst 1 end] $newValue - # put updated sub list back in the tree - Lvarset1nc list $idx $targetList + # recursively replace in targetList + Lvarset targetList [lrange $indexLst 1 end] $newValue + # put updated sub list back in the tree + Lvarset1nc list $idx $targetList } } # Set one cell to a value, eventually create all the needed elements @@ -979,13 +979,13 @@ proc ::tcl::Lvarset1 {listName index newValue} { if {$index < 0} {return -code error "invalid negative index"} set lg [llength $list] if {$index >= $lg} { - variable emptyList - for {set i $lg} {$i<$index} {incr i} { - lappend list $emptyList - } - lappend list $newValue + variable emptyList + for {set i $lg} {$i<$index} {incr i} { + lappend list $emptyList + } + lappend list $newValue } else { - set list [lreplace $list $index $index $newValue] + set list [lreplace $list $index $index $newValue] } } # same as Lvarset1 but no bound checking / creation @@ -998,16 +998,16 @@ proc ::tcl::Lvarset1nc {listName index newValue} { proc ::tcl::Lvarincr {listName indexLst {howMuch 1}} { upvar $listName list if {[llength $indexLst] <= 1} { - Lvarincr1 list $indexLst $howMuch + Lvarincr1 list $indexLst $howMuch } else { - set idx [lindex $indexLst 0] - set targetList [lindex $list $idx] - # reduce refcount on targetList - Lvarset1nc list $idx {} - # recursively replace in targetList - Lvarincr targetList [lrange $indexLst 1 end] $howMuch - # put updated sub list back in the tree - Lvarset1nc list $idx $targetList + set idx [lindex $indexLst 0] + set targetList [lindex $list $idx] + # reduce refcount on targetList + Lvarset1nc list $idx {} + # recursively replace in targetList + Lvarincr targetList [lrange $indexLst 1 end] $howMuch + # put updated sub list back in the tree + Lvarset1nc list $idx $targetList } } # Increments the value of one cell of a list @@ -1037,9 +1037,9 @@ proc ::tcl::Lassign {list args} { set i 0 set lg [llength $list] foreach vname $args { - if {$i>=$lg} break - uplevel 1 [list ::set $vname [lindex $list $i]] - incr i + if {$i>=$lg} break + uplevel 1 [list ::set $vname [lindex $list $i]] + incr i } return $lg } @@ -1051,7 +1051,7 @@ proc ::tcl::Lassign {list args} { proc ::tcl::SetMax {varname value} { upvar 1 $varname var if {![info exists var] || $value > $var} { - set var $value + set var $value } } @@ -1060,7 +1060,7 @@ proc ::tcl::SetMax {varname value} { proc ::tcl::SetMin {varname value} { upvar 1 $varname var if {![info exists var] || $value < $var} { - set var $value + set var $value } } diff --git a/library/package.tcl b/library/package.tcl index 17ace66..fd455fb 100644 --- a/library/package.tcl +++ b/library/package.tcl @@ -31,16 +31,16 @@ proc tcl::Pkg::CompareExtension {fileName {ext {}}} { global tcl_platform if {$ext eq ""} {set ext [info sharedlibextension]} if {$tcl_platform(platform) eq "windows"} { - return [string equal -nocase [file extension $fileName] $ext] + return [string equal -nocase [file extension $fileName] $ext] } else { - # Some unices add trailing numbers after the .so, so - # we could have something like '.so.1.2'. - set root $fileName - while {1} { - set currExt [file extension $root] - if {$currExt eq $ext} { - return 1 - } + # Some unices add trailing numbers after the .so, so + # we could have something like '.so.1.2'. + set root $fileName + while {1} { + set currExt [file extension $root] + if {$currExt eq $ext} { + return 1 + } # The current extension does not match; if it is not a numeric # value, quit, as we are only looking to ignore version number @@ -51,7 +51,7 @@ proc tcl::Pkg::CompareExtension {fileName {ext {}}} { if {![string is integer -strict [string range $currExt 1 end]]} { return 0 } - set root [file rootname $root] + set root [file rootname $root] } } } @@ -504,7 +504,7 @@ proc tclPkgUnknown {name args} { # In case of version conflict, silently ignore continue } - tclLog "error reading package index file $file: $msg" + tclLog "error reading package index file $file: $msg" } on ok {} { set procdDirs($dir) 1 } @@ -612,7 +612,7 @@ proc tcl::MacOSXPkgUnknown {original name args} { continue } on error msg { if {[regexp {version conflict for package} $msg]} { - # In case of version conflict, silently ignore + # In case of version conflict, silently ignore continue } tclLog "error reading package index file $file: $msg" diff --git a/library/platform/shell.tcl b/library/platform/shell.tcl index 60d5b37..526a7b1 100644 --- a/library/platform/shell.tcl +++ b/library/platform/shell.tcl @@ -131,7 +131,7 @@ proc ::platform::shell::RUN {shell code} { set e [TEMP] set code [catch { - exec $shell $c 2> $e + exec $shell $c 2> $e } res] file delete $c @@ -163,34 +163,34 @@ proc ::platform::shell::TEMP {} { set checked_dir_writable 0 set mypid [pid] for {set i 0} {$i < $maxtries} {incr i} { - set newname $prefix - for {set j 0} {$j < $nrand_chars} {incr j} { - append newname [string index $chars \ + set newname $prefix + for {set j 0} {$j < $nrand_chars} {incr j} { + append newname [string index $chars \ [expr {int(rand()*62)}]] - } + } set newname [file join $tmpdir $newname] - if {[file exists $newname]} { - after 1 - } else { - if {[catch {open $newname $access $permission} channel]} { - if {!$checked_dir_writable} { - set dirname [file dirname $newname] - if {![file writable $dirname]} { - return -code error "Directory $dirname is not writable" - } - set checked_dir_writable 1 - } - } else { - # Success + if {[file exists $newname]} { + after 1 + } else { + if {[catch {open $newname $access $permission} channel]} { + if {!$checked_dir_writable} { + set dirname [file dirname $newname] + if {![file writable $dirname]} { + return -code error "Directory $dirname is not writable" + } + set checked_dir_writable 1 + } + } else { + # Success close $channel - return [file normalize $newname] - } - } + return [file normalize $newname] + } + } } if {$channel ne ""} { - return -code error "Failed to open a temporary file: $channel" + return -code error "Failed to open a temporary file: $channel" } else { - return -code error "Failed to find an unused temporary file name" + return -code error "Failed to find an unused temporary file name" } } diff --git a/library/safe.tcl b/library/safe.tcl index cc4a194..a574a02 100644 --- a/library/safe.tcl +++ b/library/safe.tcl @@ -80,7 +80,7 @@ proc ::safe::InterpNested {} { proc ::safe::interpCreate {args} { variable AutoPathSync if {$AutoPathSync} { - set autoPath {} + set autoPath {} } set Args [::tcl::OptKeyParse ::safe::interpCreate $args] RejectExcessColons $child @@ -93,7 +93,7 @@ proc ::safe::interpCreate {args} { proc ::safe::interpInit {args} { variable AutoPathSync if {$AutoPathSync} { - set autoPath {} + set autoPath {} } set Args [::tcl::OptKeyParse ::safe::interpIC $args] if {![::interp exists $child]} { @@ -144,10 +144,10 @@ proc ::safe::interpConfigure {args} { [list -accessPath $state(access_path)] \ [list -statics $state(staticsok)] \ [list -nested $state(nestedok)] \ - [list -deleteHook $state(cleanupHook)] \ + [list -deleteHook $state(cleanupHook)] \ ] if {!$AutoPathSync} { - lappend TMP [list -autoPath $state(auto_path)] + lappend TMP [list -autoPath $state(auto_path)] } return [join $TMP] } @@ -176,9 +176,9 @@ proc ::safe::interpConfigure {args} { } -autoPath { if {$AutoPathSync} { - return -code error "unknown flag $name (bug)" + return -code error "unknown flag $name (bug)" } else { - return [list -autoPath $state(auto_path)] + return [list -autoPath $state(auto_path)] } } -statics { @@ -380,17 +380,17 @@ proc ::safe::InterpSetConfig {child access_path staticsok nestedok deletehook au # so by default it works the same). set access_path [AddSubDirs $access_path] } else { - set raw_auto_path $autoPath + set raw_auto_path $autoPath } if {$withAutoPath} { - set raw_auto_path $autoPath + set raw_auto_path $autoPath } Log $child "Setting accessPath=($access_path) staticsok=$staticsok\ nestedok=$nestedok deletehook=($deletehook)" NOTICE if {!$AutoPathSync} { - Log $child "Setting auto_path=($raw_auto_path)" NOTICE + Log $child "Setting auto_path=($raw_auto_path)" NOTICE } namespace upvar ::safe [VarName $child] state @@ -441,7 +441,7 @@ proc ::safe::InterpSetConfig {child access_path staticsok nestedok deletehook au # Prevent the addition of dirs on the tm list to the # result if they are already known. if {[dict exists $remap_access_path $dir]} { - if {$firstpass} { + if {$firstpass} { # $dir is in [::tcl::tm::list] and belongs in the child_tm_path. # Later passes handle subdirectories, which belong in the # access path but not in the module path. @@ -486,7 +486,7 @@ proc ::safe::InterpSetConfig {child access_path staticsok nestedok deletehook au set state(cleanupHook) $deletehook if {!$AutoPathSync} { - set state(auto_path) $raw_auto_path + set state(auto_path) $raw_auto_path } SyncAccessPath $child @@ -687,9 +687,9 @@ proc ::safe::interpDelete {child} { # Safe Base sub-interpreter, so each one is deleted cleanly and not by # the automatic mechanism built into [interp delete]. foreach sub [interp children $child] { - if {[info exists ::safe::[VarName [list $child $sub]]]} { - ::safe::interpDelete [list $child $sub] - } + if {[info exists ::safe::[VarName [list $child $sub]]]} { + ::safe::interpDelete [list $child $sub] + } } # If the child has a cleanup hook registered, call it. Check the @@ -1082,6 +1082,10 @@ proc ::safe::AliasSource {child args} { ::interp eval $child [list info script $file] } msg opt] if {$code == 0} { + # See [Bug 1d26e580cf] + if {[string index $contents 0] eq "\uFEFF"} { + set contents [string range $contents 1 end] + } set code [catch {::interp eval $child $contents} msg opt] set replacementMsg $msg } @@ -1280,14 +1284,14 @@ proc ::safe::AliasExeName {child} { proc ::safe::RejectExcessColons {child} { set stripped [regsub -all -- {:::*} $child ::] if {[string range $stripped end-1 end] eq {::}} { - return -code error {interpreter name must not end in "::"} + return -code error {interpreter name must not end in "::"} } if {$stripped ne $child} { - set msg {interpreter name has excess colons in namespace separators} - return -code error $msg + set msg {interpreter name has excess colons in namespace separators} + return -code error $msg } if {[string range $stripped 0 1] eq {::}} { - return -code error {interpreter name must not begin "::"} + return -code error {interpreter name must not begin "::"} } return } @@ -1315,7 +1319,7 @@ proc ::safe::Setup {} { {-deleteHook -script {} "delete hook"} } if {!$AutoPathSync} { - lappend OptList {-autoPath -list {} "::auto_path for the child"} + lappend OptList {-autoPath -list {} "::auto_path for the child"} } set temp [::tcl::OptKeyRegister $OptList] @@ -1373,26 +1377,26 @@ proc ::safe::setSyncMode {args} { if {[llength $args] == 0} { } elseif {[llength $args] == 1} { - set newValue [lindex $args 0] - if {![string is boolean -strict $newValue]} { - return -code error "new value must be a valid boolean" - } - set args [expr {$newValue && $newValue}] - if {([info vars ::safe::S*] ne {}) && ($args != $AutoPathSync)} { - return -code error \ - "cannot set new value while Safe Base child interpreters exist" - } - if {($args != $AutoPathSync)} { - set AutoPathSync {*}$args - ::tcl::OptKeyDelete ::safe::interpCreate - ::tcl::OptKeyDelete ::safe::interpIC - set TmpLog [setLogCmd] - Setup - setLogCmd $TmpLog - } + set newValue [lindex $args 0] + if {![string is boolean -strict $newValue]} { + return -code error "new value must be a valid boolean" + } + set args [expr {$newValue && $newValue}] + if {([info vars ::safe::S*] ne {}) && ($args != $AutoPathSync)} { + return -code error \ + "cannot set new value while Safe Base child interpreters exist" + } + if {($args != $AutoPathSync)} { + set AutoPathSync {*}$args + ::tcl::OptKeyDelete ::safe::interpCreate + ::tcl::OptKeyDelete ::safe::interpIC + set TmpLog [setLogCmd] + Setup + setLogCmd $TmpLog + } } else { - set msg {wrong # args: should be "safe::setSyncMode ?newValue?"} - return -code error $msg + set msg {wrong # args: should be "safe::setSyncMode ?newValue?"} + return -code error $msg } return $AutoPathSync diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl index 2fc5838..79492f6 100644 --- a/library/tcltest/tcltest.tcl +++ b/library/tcltest/tcltest.tcl @@ -515,7 +515,7 @@ namespace eval tcltest { unset $varName } namespace eval [namespace current] \ - [list upvar 0 Option($option) $varName] + [list upvar 0 Option($option) $varName] # Workaround for Bug (now Feature Request) 572889. Grrrr.... # Track all the variables tied to options lappend OptionControlledVariables $varName @@ -1158,15 +1158,15 @@ proc tcltest::SafeFetch {n1 n2 op} { proc tcltest::Asciify {s} { set print "" foreach c [split $s ""] { - if {(($c < "\x7F") && [string is print $c]) || ($c eq "\n")} { - append print $c - } elseif {$c < "\u0100"} { - append print \\x[format %02X [scan $c %c]] - } elseif {$c > "\uFFFF"} { - append print \\U[format %08X [scan $c %c]] - } else { - append print \\u[format %04X [scan $c %c]] - } + if {(($c < "\x7F") && [string is print $c]) || ($c eq "\n")} { + append print $c + } elseif {$c < "\u0100"} { + append print \\x[format %02X [scan $c %c]] + } elseif {$c > "\uFFFF"} { + append print \\U[format %08X [scan $c %c]] + } else { + append print \\u[format %04X [scan $c %c]] + } } return $print } @@ -1347,33 +1347,33 @@ proc tcltest::DefineConstraintInitializers {} { ConstraintInitializer unixExecs { set code 1 - if {$::tcl_platform(platform) eq "macintosh"} { + if {$::tcl_platform(platform) eq "macintosh"} { set code 0 - } - if {$::tcl_platform(platform) eq "windows"} { + } + if {$::tcl_platform(platform) eq "windows"} { if {[catch { - set file _tcl_test_remove_me.txt - makeFile {hello} $file + set file _tcl_test_remove_me.txt + makeFile {hello} $file }]} { - set code 0 + set code 0 } elseif { - [catch {exec cat $file}] || - [catch {exec echo hello}] || - [catch {exec sh -c echo hello}] || - [catch {exec wc $file}] || - [catch {exec sleep 1}] || - [catch {exec echo abc > $file}] || - [catch {exec chmod 644 $file}] || - [catch {exec rm $file}] || - [llength [auto_execok mkdir]] == 0 || - [llength [auto_execok fgrep]] == 0 || - [llength [auto_execok grep]] == 0 || - [llength [auto_execok ps]] == 0 + [catch {exec cat $file}] || + [catch {exec echo hello}] || + [catch {exec sh -c echo hello}] || + [catch {exec wc $file}] || + [catch {exec sleep 1}] || + [catch {exec echo abc > $file}] || + [catch {exec chmod 644 $file}] || + [catch {exec rm $file}] || + [llength [auto_execok mkdir]] == 0 || + [llength [auto_execok fgrep]] == 0 || + [llength [auto_execok grep]] == 0 || + [llength [auto_execok ps]] == 0 } { - set code 0 + set code 0 } removeFile $file - } + } set code } @@ -1548,8 +1548,8 @@ proc tcltest::ProcessFlags {flagArray} { # Call the hook catch { - array set flag $flagArray - processCmdLineArgsHook [array get flag] + array set flag $flagArray + processCmdLineArgsHook [array get flag] } return } @@ -1732,7 +1732,7 @@ proc tcltest::Eval {script {ignoreOutput 1}} { proc tcltest::CompareStrings {actual expected mode} { variable CustomMatch if {![info exists CustomMatch($mode)]} { - return -code error "No matching command registered for `-match $mode'" + return -code error "No matching command registered for `-match $mode'" } set match [namespace eval :: $CustomMatch($mode) [list $expected $actual]] if {[catch {expr {$match && $match}} result]} { @@ -1810,55 +1810,55 @@ proc tcltest::SubstArguments {argList} { set token "" while {[string length $argList]} { - # Look for the next word containing a quote: " { } - if {[regexp -indices {[^ \t\n]*[\"\{\}]+[^ \t\n]*} \ + # Look for the next word containing a quote: " { } + if {[regexp -indices {[^ \t\n]*[\"\{\}]+[^ \t\n]*} \ $argList all]} { - # Get the text leading up to this word, but not including + # Get the text leading up to this word, but not including # this word, from the argList. - set text [string range $argList 0 \ + set text [string range $argList 0 \ [expr {[lindex $all 0] - 1}]] - # Get the word with the quote - set word [string range $argList \ - [lindex $all 0] [lindex $all 1]] - - # Remove all text up to and including the word from the - # argList. - set argList [string range $argList \ - [expr {[lindex $all 1] + 1}] end] - } else { - # Take everything up to the end of the argList. - set text $argList - set word {} - set argList {} - } - - if {$token ne {}} { - # If we saw a word with quote before, then there is a - # multi-word token starting with that word. In this case, - # add the text and the current word to this token. - append token $text $word - } else { - # Add the text to the result. There is no need to parse - # the text because it couldn't be a part of any multi-word - # token. Then start a new multi-word token with the word - # because we need to pass this token to the Tcl parser to - # check for balancing quotes - append result $text - set token $word - } - - if { [catch {llength $token} length] == 0 && $length == 1} { - # The token is a valid list so add it to the result. - # lappend result [string trim $token] - append result \{$token\} - set token {} - } + # Get the word with the quote + set word [string range $argList \ + [lindex $all 0] [lindex $all 1]] + + # Remove all text up to and including the word from the + # argList. + set argList [string range $argList \ + [expr {[lindex $all 1] + 1}] end] + } else { + # Take everything up to the end of the argList. + set text $argList + set word {} + set argList {} + } + + if {$token ne {}} { + # If we saw a word with quote before, then there is a + # multi-word token starting with that word. In this case, + # add the text and the current word to this token. + append token $text $word + } else { + # Add the text to the result. There is no need to parse + # the text because it couldn't be a part of any multi-word + # token. Then start a new multi-word token with the word + # because we need to pass this token to the Tcl parser to + # check for balancing quotes + append result $text + set token $word + } + + if { [catch {llength $token} length] == 0 && $length == 1} { + # The token is a valid list so add it to the result. + # lappend result [string trim $token] + append result \{$token\} + set token {} + } } # If the last token has not been added to the list then there # is a problem. if { [string length $token] } { - error "incomplete token \"$token\"" + error "incomplete token \"$token\"" } return $result @@ -1914,7 +1914,7 @@ proc tcltest::SubstArguments {argList} { # Arguments: # name - Name of test, in the form foo-1.2. # description - Short textual description of the test, to -# help humans understand what it does. +# help humans understand what it does. # # Results: # None. @@ -2009,10 +2009,10 @@ proc tcltest::test {name description args} { foreach {strcode numcode} {ok 0 normal 0 error 1 return 2 break 3 continue 4} { set returnCodes [string map -nocase [list $strcode $numcode] $returnCodes] } - # errorCode without returnCode 1 is meaningless - if {$errorCode ne "*" && 1 ni $returnCodes} { - set returnCodes 1 - } + # errorCode without returnCode 1 is meaningless + if {$errorCode ne "*" && 1 ni $returnCodes} { + set returnCodes 1 + } } else { # This is parsing for the old test command format; it is here # for backward compatibility. @@ -2095,7 +2095,7 @@ proc tcltest::test {name description args} { } set errorCodeFailure 0 if {$processTest && !$setupFailure && !$codeFailure && $returnCode == 1 && \ - ![string match $errorCode $errorCodeRes(body)]} { + ![string match $errorCode $errorCodeRes(body)]} { set errorCodeFailure 1 } @@ -2128,7 +2128,7 @@ proc tcltest::test {name description args} { # check if the answer matched the expected answer # Only check if we ran the body of the test (no setup failure) if {!$processTest} { - set scriptFailure 0 + set scriptFailure 0 } elseif {$setupFailure || $codeFailure} { set scriptFailure 0 } elseif {[set scriptCompare [catch { @@ -2414,7 +2414,7 @@ proc tcltest::Skipped {name constraints} { # make sure that the constraints are satisfied. set doTest 0 - set constraints [string trim $constraints] + set constraints [string trim $constraints] if {[string match {*[$\[]*} $constraints] != 0} { # full expression, e.g. {$foo > [info tclversion]} catch {set doTest [uplevel #0 [list expr $constraints]]} diff --git a/macosx/tclMacOSXNotify.c b/macosx/tclMacOSXNotify.c index d8af241..f7a2324 100644 --- a/macosx/tclMacOSXNotify.c +++ b/macosx/tclMacOSXNotify.c @@ -1683,7 +1683,7 @@ Tcl_Sleep( SInt32 runLoopStatus; waitTime = vdelay.sec + 1.0e-6 * vdelay.usec; - now = CFAbsoluteTimeGetCurrent(); + now = CFAbsoluteTimeGetCurrent(); waitEnd = now + waitTime; if (runLoopTimer) { @@ -1713,7 +1713,7 @@ Tcl_Sleep( } } while (waitTime > 0); tsdPtr->sleeping = 0; - if (runLoopTimer) { + if (runLoopTimer) { CFRunLoopTimerSetNextFireDate(runLoopTimer, nextTimerFire); } } else { diff --git a/tests-perf/list.perf.tcl b/tests-perf/list.perf.tcl index 121a922..929e42e 100644 --- a/tests-perf/list.perf.tcl +++ b/tests-perf/list.perf.tcl @@ -95,12 +95,48 @@ proc test-lsearch-nf-non-opti-slow {{reptime 1000}} { } } +proc test-lseq {{reptime 1000}} { + _test_run $reptime { + setup { set i 0 } + { lseq 10 } + { lseq 0 count 10 } + { lseq 0 count 10 by 1 } + { lseq 0 9 } + { lseq 0 to 9 } + { lseq 0 9 1 } + { lseq 0 to 9 by 1 } + } +} + +proc test-lseq-expr {{reptime 1000}} { + _test_run $reptime { + setup { set i 0 } + { lseq [expr {$i+10}] } + { lseq {$i+10} } + { lseq [expr {$i+0}] count [expr {$i+10}] } + { lseq {$i+0} count {$i+10} } + { lseq [expr {$i+0}] count [expr {$i+10}] by [expr {$i+1}] } + { lseq {$i+0} count {$i+10} by {$i+1} } + { lseq [expr {$i+0}] [expr {$i+9}] } + { lseq {$i+0} {$i+9} } + { lseq [expr {$i+0}] to [expr {$i+9}] } + { lseq {$i+0} to {$i+9} } + { lseq [expr {$i+0}] [expr {$i+9}] [expr {$i+1}] } + { lseq {$i+0} {$i+9} {$i+1} } + { lseq [expr {$i+0}] to [expr {$i+9}] by [expr {$i+1}] } + { lseq {$i+0} to {$i+9} by {$i+1} } + } +} + proc test {{reptime 1000}} { test-lsearch-regress $reptime test-lsearch-nf-regress $reptime test-lsearch-nf-non-opti-fast $reptime test-lsearch-nf-non-opti-slow $reptime + test-lseq [expr {$reptime/2}] + test-lseq-expr [expr {$reptime/2}] + puts \n**OK** } diff --git a/tests/indexObj.test b/tests/indexObj.test index cf0f7df..c3f0676 100644 --- a/tests/indexObj.test +++ b/tests/indexObj.test @@ -20,7 +20,6 @@ testConstraint testindexobj [llength [info commands testindexobj]] testConstraint testgetintforindex [llength [info commands testgetintforindex]] testConstraint testparseargs [llength [info commands testparseargs]] testConstraint has64BitLengths [expr {$tcl_platform(pointerSize) == 8}] -testConstraint has32BitLengths [expr {$tcl_platform(pointerSize) == 4}] test indexObj-1.1 {exact match} testindexobj { testindexobj 1 1 xyz abc def xyz alm @@ -228,19 +227,24 @@ test indexObj-8.12 {Tcl_GetIntForIndex end} testgetintforindex { test indexObj-8.13 {Tcl_GetIntForIndex end} testgetintforindex { testgetintforindex end -2 } -2 -test indexObj-8.14 {Tcl_GetIntForIndex end+1} -constraints { - testgetintforindex has64BitLengths -} -body { +test indexObj-8.14 {Tcl_GetIntForIndex end+1} testgetintforindex { testgetintforindex end+1 -1 -} -result 9223372036854775807 -test indexObj-8.14.32bits {Tcl_GetIntForIndex end+1} -constraints { - testgetintforindex has32BitLengths -} -body { - testgetintforindex end+1 -1 -} -result 2147483647 +} [expr {[testConstraint has64BitLengths] ? 9223372036854775807 : 2147483647}] test indexObj-8.15 {Tcl_GetIntForIndex end+1} testgetintforindex { testgetintforindex end+1 -2 } -1 +test indexObj-8.16 {Tcl_GetIntForIndex integer} testgetintforindex { + testgetintforindex -1 -1 +} [expr {[testConstraint has64BitLengths] ? -9223372036854775808 : -2147483648}] +test indexObj-8.17 {Tcl_GetIntForIndex integer} testgetintforindex { + testgetintforindex -2 -1 +} [expr {[testConstraint has64BitLengths] ? -9223372036854775808 : -2147483648}] +test indexObj-8.18 {Tcl_GetIntForIndex n-m} testgetintforindex { + testgetintforindex 2-3 -1 +} [expr {[testConstraint has64BitLengths] ? -9223372036854775808 : -2147483648}] +test indexObj-8.19 {Tcl_GetIntForIndex n-m} testgetintforindex { + testgetintforindex 2-3 0 +} -1 # cleanup ::tcltest::cleanupTests diff --git a/tests/interp.test b/tests/interp.test index c299fd2..05c987c 100644 --- a/tests/interp.test +++ b/tests/interp.test @@ -20,7 +20,7 @@ catch [list package require -exact tcl::test [info patchlevel]] testConstraint testinterpdelete [llength [info commands testinterpdelete]] -set hidden_cmds {cd encoding exec exit fconfigure file glob load open pwd socket source tcl:encoding:dirs tcl:encoding:system tcl:file:atime tcl:file:attributes tcl:file:copy tcl:file:delete tcl:file:dirname tcl:file:executable tcl:file:exists tcl:file:extension tcl:file:isdirectory tcl:file:isfile tcl:file:link tcl:file:lstat tcl:file:mkdir tcl:file:mtime tcl:file:nativename tcl:file:normalize tcl:file:owned tcl:file:readable tcl:file:readlink tcl:file:rename tcl:file:rootname tcl:file:size tcl:file:stat tcl:file:tail tcl:file:tempdir tcl:file:tempfile tcl:file:type tcl:file:volumes tcl:file:writable tcl:info:cmdtype tcl:info:nameofexecutable tcl:process:autopurge tcl:process:list tcl:process:purge tcl:process:status tcl:zipfs:lmkimg tcl:zipfs:lmkzip tcl:zipfs:mkimg tcl:zipfs:mkkey tcl:zipfs:mkzip tcl:zipfs:mount tcl:zipfs:mount_data tcl:zipfs:unmount unload} +set hidden_cmds {cd encoding exec exit fconfigure file glob load open pwd socket source tcl:encoding:dirs tcl:encoding:system tcl:file:atime tcl:file:attributes tcl:file:copy tcl:file:delete tcl:file:dirname tcl:file:executable tcl:file:exists tcl:file:extension tcl:file:home tcl:file:isdirectory tcl:file:isfile tcl:file:link tcl:file:lstat tcl:file:mkdir tcl:file:mtime tcl:file:nativename tcl:file:normalize tcl:file:owned tcl:file:readable tcl:file:readlink tcl:file:rename tcl:file:rootname tcl:file:size tcl:file:stat tcl:file:tail tcl:file:tempdir tcl:file:tempfile tcl:file:tildeexpand tcl:file:type tcl:file:volumes tcl:file:writable tcl:info:cmdtype tcl:info:nameofexecutable tcl:process:autopurge tcl:process:list tcl:process:purge tcl:process:status tcl:zipfs:lmkimg tcl:zipfs:lmkzip tcl:zipfs:mkimg tcl:zipfs:mkkey tcl:zipfs:mkzip tcl:zipfs:mount tcl:zipfs:mount_data tcl:zipfs:unmount unload} proc _ms_limit_args {ms {t0 {}}} { if {$t0 eq {}} { set t0 [clock milliseconds] } diff --git a/tests/lseq.test b/tests/lseq.test index feb0a29..74fbdfa 100644 --- a/tests/lseq.test +++ b/tests/lseq.test @@ -109,13 +109,17 @@ test lseq-1.15 {count with decreasing step} { -result {5 3 1 -1 -3} } -test lseq-1.16 {large numbers} { +test lseq-1.16 {large doubles} { -body { lseq [expr {int(1e6)}] [expr {int(2e6)}] [expr {int(1e5)}] } -result {1000000 1100000 1200000 1300000 1400000 1500000 1600000 1700000 1800000 1900000 2000000} } +test lseq-1.16.2 {large numbers (bigints are not supported yet)} -body { + lseq 0xfffffffffffffffe 0xffffffffffffffff +} -returnCodes 1 -result {integer value too large to represent} + test lseq-1.17 {too many arguments} -body { lseq 12 to 24 by 2 with feeling } -returnCodes 1 -result {wrong # args: should be "lseq n ??op? n ??by? n??"} @@ -140,6 +144,35 @@ test lseq-1.22 {n n by -n} { lseq 84 66 by -3 } {84 81 78 75 72 69 66} +test lseq-1.23 {consistence, accept double count representable as integer (but use double in series)} { + list [lseq 0.0 2.0] [lseq 3.0] [lseq 0 count 3.0] \ + [lseq 0.0 count 3.0] [lseq 0 count 3.0 by 1.0] +} [lrepeat 5 {0.0 1.0 2.0}] +test lseq-1.24 {consistence, use double (even if representable as integer) in all variants, if contains a double somewhere} { + list [lseq 0.0 2] [lseq 0 2.0] [lseq 0.0 count 3] \ + [lseq 0 count 3 by 1.0] [lseq 0 .. 2.0] [lseq 0 to 2 by 1.0] +} [lrepeat 6 {0.0 1.0 2.0}] +test lseq-1.25 {consistence, use double (even if representable as integer) in all variants, if contains a double somewhere} { + list [lseq double(0) 2] [lseq 0 double(2)] [lseq double(0) count 3] \ + [lseq 0 count 3 by double(1)] [lseq 0 .. double(2)] [lseq 0 to 2 by double(1)] +} [lrepeat 6 {0.0 1.0 2.0}] +test lseq-1.26 {consistence, double always remains double} { + list [lseq 1 3.0 ] \ + [lseq 1 [expr {3.0+0}] ] \ + [lseq 1 {3.0+0} ] \ + [lseq 1.0 3.0 1] \ + [lseq [expr {1.0+0}] [expr {3.0+0}] 1] \ + [lseq {1.0+0} {3.0+0} 1] +} [lrepeat 6 {1.0 2.0 3.0}] +test lseq-1.27 {consistence, double always remains double} { + list [lseq 1e50 [expr {1e50+1}] ] \ + [lseq 1e50 {1e50+1} ] \ + [lseq [expr {1e50+0}] [expr {1e50+1}] 1] \ + [lseq {1e50+0} {1e50+1} 1] \ + [lseq [expr {1e50+0}] count 1 1] \ + [lseq {1e50+0} count 1 1] +} [lrepeat 6 [expr {1e50}]] + # # Short-hand use cases # @@ -221,6 +254,23 @@ test lseq-2.18 {signs} { } {{-10 -8 -6 -4 -2} {} {} {10 6 2} {-10 -7 -4 -1} {10 5}} +test lseq-2.19 {expressions as indices} { + list [lseq {1+1}] \ + [lseq {1+1} {2+2}] \ + [lseq {1+1} count {2+2}] \ + [lseq {1+1} {5+5} {2+2}] \ + [lseq {1+1} count {2+2} by {2+2}] +} {{0 1} {2 3 4} {2 3 4 5} {2 6 10} {2 6 10 14}} + +test lseq-2.20 {expressions as indices, no duplicative eval of expr} { + set i 1 + list [lseq {[incr i]}] $i [lseq {0 + [incr i]}] $i [lseq {0.0 + [incr i]}] $i +} {{0 1} 2 {0 1 2} 3 {0.0 1.0 2.0 3.0} 4} + +test lseq-3.0 {expr error: don't swalow expr error (here: divide by zero)} -body { + set i 0; lseq {3/$i} +} -returnCodes [catch {expr {3/0}} res] -result $res + test lseq-3.1 {experiement} -body { set ans {} foreach factor [lseq 2.0 10.0] { @@ -245,15 +295,15 @@ test lseq-3.1 {experiement} -body { test lseq-3.2 {error case} -body { lseq foo -} -returnCodes 1 -result {bad operation "foo": must be .., to, count, or by} +} -returnCodes 1 -match glob -result {invalid bareword "foo"*} test lseq-3.3 {error case} -body { lseq 10 foo -} -returnCodes 1 -result {bad operation "foo": must be .., to, count, or by} +} -returnCodes 1 -match glob -result {invalid bareword "foo"*} test lseq-3.4 {error case} -body { lseq 25 or 6 -} -returnCodes 1 -result {bad operation "or": must be .., to, count, or by} +} -returnCodes 1 -match glob -result {invalid bareword "or"*} test lseq-3.5 {simple count and step arguments} -body { set s [lseq 25 by 6] @@ -265,6 +315,9 @@ test lseq-3.5 {simple count and step arguments} -body { test lseq-3.6 {error case} -body { lseq 1 7 or 3 } -returnCodes 1 -result {bad operation "or": must be .., to, count, or by} +test lseq-3.6b {error case} -body { + lseq 1 to 7 or 3 +} -returnCodes 1 -result {bad operation "or": must be .., to, count, or by} test lseq-3.7 {lmap lseq} -body { lmap x [lseq 5] { expr {$x * $x} } diff --git a/tests/remote.tcl b/tests/remote.tcl index eee551a..b90a2be 100644 --- a/tests/remote.tcl +++ b/tests/remote.tcl @@ -40,9 +40,9 @@ proc __readAndExecute__ {s} { set l [gets $s] if {[string compare $l "--Marker--Marker--Marker--"] == 0} { - puts $s [__doCommands__ $command($s) $s] + puts $s [__doCommands__ $command($s) $s] puts $s "--Marker--Marker--Marker--" - set command($s) "" + set command($s) "" return } if {[string compare $l ""] == 0} { @@ -59,8 +59,8 @@ proc __readAndExecute__ {s} { puts "Server closing $s, eof from client" } close $s - unset command($s) - return + unset command($s) + return } append command($s) $l "\n" } diff --git a/tools/index.tcl b/tools/index.tcl index 07f5868..5426ee6 100644 --- a/tools/index.tcl +++ b/tools/index.tcl @@ -14,12 +14,12 @@ # state - state variable that controls action of text proc. # # topics - array indexed by (package,section,topic) with value -# of topic ID. +# of topic ID. # # keywords - array indexed by keyword string with value of topic ID. # -# curID - current topic ID, starts at 0 and is incremented for -# each new topic file. +# curID - current topic ID, starts at 0 and is incremented for +# each new topic file. # # curPkg - current package name (e.g. Tcl). # diff --git a/tools/makeTestCases.tcl b/tools/makeTestCases.tcl index 1eae645..d1221b8 100755 --- a/tools/makeTestCases.tcl +++ b/tools/makeTestCases.tcl @@ -215,7 +215,7 @@ proc testcases2 { f2 } { # Define the roman numerals set roman { - ? i ii iii iv v vi vii viii ix + ? i ii iii iv v vi vii viii ix x xi xii xiii xiv xv xvi xvii xviii xix xx xxi xxii xxiii xxiv xxv xxvi xxvii xxviii xxix xxx xxxi xxxii xxxiii xxxiv xxxv xxxvi xxxvii xxxviii xxxix @@ -228,7 +228,7 @@ proc testcases2 { f2 } { c } set romanc { - ? c cc ccc cd d dc dcc dccc cm + ? c cc ccc cd d dc dcc dccc cm m mc mcc mccc mcd md mdc mdcc mdccc mcm mm mmc mmcc mmccc mmcd mmd mmdc mmdcc mmdccc mmcm mmm mmmc mmmcc mmmccc mmmcd mmmd mmmdc mmmdcc mmmdccc mmmcm diff --git a/tools/tclOOScript.tcl b/tools/tclOOScript.tcl index 0b75882..0cbe5b7 100644 --- a/tools/tclOOScript.tcl +++ b/tools/tclOOScript.tcl @@ -1,8 +1,8 @@ # tclOOScript.h -- # -# This file contains support scripts for TclOO. They are defined here so -# that the code can be definitely run even in safe interpreters; TclOO's -# core setup is safe. +# This file contains support scripts for TclOO. They are defined here so +# that the code can be definitely run even in safe interpreters; TclOO's +# core setup is safe. # # Copyright © 2012-2019 Donal K. Fellows # Copyright © 2013 Andreas Kupries diff --git a/tools/tcltk-man2html.tcl b/tools/tcltk-man2html.tcl index 7b3558d..01478aa 100755 --- a/tools/tcltk-man2html.tcl +++ b/tools/tcltk-man2html.tcl @@ -610,8 +610,8 @@ array set remap_link_target { Tcl_Obj Tcl_NewObj Tcl_ObjType Tcl_RegisterObjType Tcl_OpenFileChannelProc Tcl_FSOpenFileChannel - errorinfo env - errorcode env + errorinfo env + errorcode env tcl_pkgpath env Tcl_Command Tcl_CreateObjCommand Tcl_CmdProc Tcl_CreateObjCommand diff --git a/unix/Makefile.in b/unix/Makefile.in index 093edf8..bd06089 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -4,7 +4,7 @@ # "./configure", which is a configuration script generated by the "autoconf" # program (constructs like "@foo@" will get replaced in the actual Makefile. -VERSION = @TCL_VERSION@ +VERSION = @TCL_VERSION@ MAJOR_VERSION = @TCL_MAJOR_VERSION@ MINOR_VERSION = @TCL_MINOR_VERSION@ PATCH_LEVEL = @TCL_PATCH_LEVEL@ @@ -1101,7 +1101,7 @@ install-libraries: libraries @if [ -n "$(TCL_MODULE_PATH)" -a -f $(TOP_DIR)/library/tm.tcl ] ; then \ echo "Customizing tcl module path"; \ echo "if {![interp issafe]} { ::tcl::tm::roots [list $(TCL_MODULE_PATH)] }" >> \ - "$(SCRIPT_INSTALL_DIR)/tm.tcl"; \ + "$(SCRIPT_INSTALL_DIR)/tm.tcl"; \ fi install-tzdata: diff --git a/unix/configure b/unix/configure index b470e3c..2ef18ad 100755 --- a/unix/configure +++ b/unix/configure @@ -5796,7 +5796,7 @@ then : ;; *) # Make sure only first arg gets _r - CC=`echo "$CC" | sed -e 's/^\([^ ]*\)/\1_r/'` + CC=`echo "$CC" | sed -e 's/^\([^ ]*\)/\1_r/'` ;; esac { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: Using $CC for compiling with threads" >&5 @@ -10016,7 +10016,7 @@ int main (void) { - socklen_t foo; + socklen_t foo; ; return 0; diff --git a/unix/configure.ac b/unix/configure.ac index 766392e..f2a1b58 100644 --- a/unix/configure.ac +++ b/unix/configure.ac @@ -404,7 +404,7 @@ AC_CACHE_CHECK([for socklen_t], tcl_cv_type_socklen_t, [ #include <sys/types.h> #include <sys/socket.h> ]], [[ - socklen_t foo; + socklen_t foo; ]])],[tcl_cv_type_socklen_t=yes],[tcl_cv_type_socklen_t=no])]) if test $tcl_cv_type_socklen_t = no; then AC_DEFINE(socklen_t, int, [Define as int if socklen_t is not available]) diff --git a/unix/dltest/embtest.c b/unix/dltest/embtest.c index ff58cc4..33f77a0 100644 --- a/unix/dltest/embtest.c +++ b/unix/dltest/embtest.c @@ -34,7 +34,7 @@ int main(int argc, char **argv) { exitcode = 1; } if (!exitcode) { - printf("All OK!\n"); + printf("All OK!\n"); } return exitcode; } diff --git a/unix/installManPage b/unix/installManPage index 3d5fa7b..3cb266d 100755 --- a/unix/installManPage +++ b/unix/installManPage @@ -12,8 +12,8 @@ Suffix="" while true; do case $1 in - -s | --symlinks ) Sym="-s " ;; - -z | --compress ) Gzip=$2; shift ;; + -s | --symlinks ) Sym="-s " ;; + -z | --compress ) Gzip=$2; shift ;; -e | --extension ) Gz=$2; shift ;; -x | --suffix ) Suffix=$2; shift ;; -*) cat <<EOF diff --git a/unix/tcl.m4 b/unix/tcl.m4 index 7b84923..2b2299e 100644 --- a/unix/tcl.m4 +++ b/unix/tcl.m4 @@ -990,7 +990,7 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ ;; *) # Make sure only first arg gets _r - CC=`echo "$CC" | sed -e 's/^\([[^ ]]*\)/\1_r/'` + CC=`echo "$CC" | sed -e 's/^\([[^ ]]*\)/\1_r/'` ;; esac AC_MSG_RESULT([Using $CC for compiling with threads]) diff --git a/unix/tclEpollNotfy.c b/unix/tclEpollNotfy.c index 2a1733a..8c392f0 100644 --- a/unix/tclEpollNotfy.c +++ b/unix/tclEpollNotfy.c @@ -207,10 +207,10 @@ PlatformEventsControl( newEvent.events |= EPOLLOUT; } if (isNew) { - newPedPtr = (struct PlatformEventData *) + newPedPtr = (struct PlatformEventData *) Tcl_Alloc(sizeof(struct PlatformEventData)); - newPedPtr->filePtr = filePtr; - newPedPtr->tsdPtr = tsdPtr; + newPedPtr->filePtr = filePtr; + newPedPtr->tsdPtr = tsdPtr; filePtr->pedPtr = newPedPtr; } newEvent.data.ptr = filePtr->pedPtr; @@ -263,7 +263,7 @@ PlatformEventsControl( * None. * * Side effects: - * While tsdPtr->notifierMutex is held: + * While tsdPtr->notifierMutex is held: * - The per-thread eventfd(2) is closed, if non-zero, and set to -1. * - The per-thread epoll(7) fd is closed, if non-zero, and set to 0. * - The per-thread epoll_event structs are freed, if any, and set to 0. @@ -367,7 +367,7 @@ PlatformEventsInit(void) filePtr->mask = TCL_READABLE; PlatformEventsControl(filePtr, tsdPtr, EPOLL_CTL_ADD, 1); if (!tsdPtr->readyEvents) { - tsdPtr->maxReadyEvents = 512; + tsdPtr->maxReadyEvents = 512; tsdPtr->readyEvents = (struct epoll_event *) Tcl_Alloc( tsdPtr->maxReadyEvents * sizeof(tsdPtr->readyEvents[0])); } diff --git a/unix/tclKqueueNotfy.c b/unix/tclKqueueNotfy.c index ba49842..a99f7bd 100644 --- a/unix/tclKqueueNotfy.c +++ b/unix/tclKqueueNotfy.c @@ -261,7 +261,7 @@ PlatformEventsControl( * None. * * Side effects: - * While tsdPtr->notifierMutex is held: + * While tsdPtr->notifierMutex is held: * The per-thread pipe(2) fds are closed, if non-zero, and set to -1. * The per-thread kqueue(2) fd is closed, if non-zero, and set to 0. * The per-thread kevent structs are freed, if any, and set to 0. diff --git a/unix/tclLoadDl.c b/unix/tclLoadDl.c index 23565c5..07bbc16 100644 --- a/unix/tclLoadDl.c +++ b/unix/tclLoadDl.c @@ -88,14 +88,14 @@ TclpDlopen( * Use (RTLD_NOW|RTLD_LOCAL) as default, see [Bug #3216070] */ if (flags & TCL_LOAD_GLOBAL) { - dlopenflags |= RTLD_GLOBAL; + dlopenflags |= RTLD_GLOBAL; } else { - dlopenflags |= RTLD_LOCAL; + dlopenflags |= RTLD_LOCAL; } if (flags & TCL_LOAD_LAZY) { - dlopenflags |= RTLD_LAZY; + dlopenflags |= RTLD_LAZY; } else { - dlopenflags |= RTLD_NOW; + dlopenflags |= RTLD_NOW; } handle = dlopen(native, dlopenflags); if (handle == NULL) { diff --git a/unix/tclLoadDyld.c b/unix/tclLoadDyld.c index 54290ec..5b1062e 100644 --- a/unix/tclLoadDyld.c +++ b/unix/tclLoadDyld.c @@ -197,14 +197,14 @@ TclpDlopen( */ if (flags & TCL_LOAD_GLOBAL) { - dlopenflags |= RTLD_GLOBAL; + dlopenflags |= RTLD_GLOBAL; } else { - dlopenflags |= RTLD_LOCAL; + dlopenflags |= RTLD_LOCAL; } if (flags & TCL_LOAD_LAZY) { - dlopenflags |= RTLD_LAZY; + dlopenflags |= RTLD_LAZY; } else { - dlopenflags |= RTLD_NOW; + dlopenflags |= RTLD_NOW; } dlHandle = dlopen(nativePath, dlopenflags); if (!dlHandle) { diff --git a/unix/tclLoadOSF.c b/unix/tclLoadOSF.c index 81f314f..9c34e73 100644 --- a/unix/tclLoadOSF.c +++ b/unix/tclLoadOSF.c @@ -128,7 +128,7 @@ TclpDlopen( */ if ((pkg = strrchr(fileName, '/')) == NULL) { - pkg = fileName; + pkg = fileName; } else { pkg++; } diff --git a/unix/tclUnixChan.c b/unix/tclUnixChan.c index edb1edb..693720c 100644 --- a/unix/tclUnixChan.c +++ b/unix/tclUnixChan.c @@ -161,22 +161,22 @@ static int TtySetOptionProc(void *instanceData, static const Tcl_ChannelType fileChannelType = { "file", /* Type name. */ - TCL_CHANNEL_VERSION_5, /* v5 channel */ - NULL, /* Close proc. */ - FileInputProc, /* Input proc. */ - FileOutputProc, /* Output proc. */ - NULL, + TCL_CHANNEL_VERSION_5, + NULL, /* Deprecated. */ + FileInputProc, + FileOutputProc, + NULL, /* Deprecated. */ NULL, /* Set option proc. */ - FileGetOptionProc, /* Get option proc. */ - FileWatchProc, /* Initialize notifier. */ - FileGetHandleProc, /* Get OS handles out of channel. */ - FileCloseProc, /* close2proc. */ - FileBlockModeProc, /* Set blocking or non-blocking mode.*/ - NULL, /* flush proc. */ - NULL, /* handler proc. */ - FileWideSeekProc, /* wide seek proc. */ - NULL, - FileTruncateProc /* truncate proc. */ + FileGetOptionProc, + FileWatchProc, + FileGetHandleProc, + FileCloseProc, + FileBlockModeProc, + NULL, /* Flush proc. */ + NULL, /* Bubbled event handler proc. */ + FileWideSeekProc, + NULL, /* Thread action proc. */ + FileTruncateProc }; #ifdef SUPPORTS_TTY @@ -186,23 +186,23 @@ static const Tcl_ChannelType fileChannelType = { */ static const Tcl_ChannelType ttyChannelType = { - "tty", /* Type name. */ - TCL_CHANNEL_VERSION_5, /* v5 channel */ - NULL, /* Close proc. */ - FileInputProc, /* Input proc. */ - FileOutputProc, /* Output proc. */ + "tty", + TCL_CHANNEL_VERSION_5, + NULL, /* Deprecated. */ + FileInputProc, + FileOutputProc, + NULL, /* Deprecated. */ + TtySetOptionProc, + TtyGetOptionProc, + FileWatchProc, + FileGetHandleProc, + TtyCloseProc, + FileBlockModeProc, + NULL, /* Flush proc. */ + NULL, /* Bubbled event handler proc. */ NULL, /* Seek proc. */ - TtySetOptionProc, /* Set option proc. */ - TtyGetOptionProc, /* Get option proc. */ - FileWatchProc, /* Initialize notifier. */ - FileGetHandleProc, /* Get OS handles out of channel. */ - TtyCloseProc, /* close2proc. */ - FileBlockModeProc, /* Set blocking or non-blocking mode.*/ - NULL, /* flush proc. */ - NULL, /* handler proc. */ - NULL, /* wide seek proc. */ - NULL, /* thread action proc. */ - NULL /* truncate proc. */ + NULL, /* Thread action proc. */ + NULL /* Truncate proc. */ }; #endif /* SUPPORTS_TTY */ @@ -225,7 +225,7 @@ static const Tcl_ChannelType ttyChannelType = { static int FileBlockModeProc( - void *instanceData, /* File state. */ + void *instanceData, /* File state. */ int mode) /* The mode to set. Can be TCL_MODE_BLOCKING * or TCL_MODE_NONBLOCKING. */ { @@ -258,7 +258,7 @@ FileBlockModeProc( static int FileInputProc( - void *instanceData, /* File state. */ + void *instanceData, /* File state. */ char *buf, /* Where to store data read. */ int toRead, /* How much space is available in the * buffer? */ @@ -308,7 +308,7 @@ FileInputProc( static int FileOutputProc( - void *instanceData, /* File state. */ + void *instanceData, /* File state. */ const char *buf, /* The data buffer. */ int toWrite, /* How many bytes to write? */ int *errorCodePtr) /* Where to store error code. */ @@ -355,7 +355,7 @@ FileOutputProc( static int FileCloseProc( - void *instanceData, /* File state. */ + void *instanceData, /* File state. */ TCL_UNUSED(Tcl_Interp *), int flags) { @@ -448,7 +448,7 @@ TtyCloseProc( static long long FileWideSeekProc( - void *instanceData, /* File state. */ + void *instanceData, /* File state. */ long long offset, /* Offset to seek to. */ int mode, /* Relative to where should we seek? Can be * one of SEEK_START, SEEK_CUR or SEEK_END. */ @@ -496,7 +496,7 @@ FileWatchNotifyChannelWrapper( static void FileWatchProc( - void *instanceData, /* The file state. */ + void *instanceData, /* The file state. */ int mask) /* Events of interest; an OR-ed combination of * TCL_READABLE, TCL_WRITABLE and * TCL_EXCEPTION. */ @@ -536,9 +536,9 @@ FileWatchProc( static int FileGetHandleProc( - void *instanceData, /* The file state. */ + void *instanceData, /* The file state. */ int direction, /* TCL_READABLE or TCL_WRITABLE */ - void **handlePtr) /* Where to store the handle. */ + void **handlePtr) /* Where to store the handle. */ { FileState *fsPtr = (FileState *)instanceData; @@ -758,7 +758,7 @@ TtyModemStatusStr( static int TtySetOptionProc( - void *instanceData, /* File state. */ + void *instanceData, /* File state. */ Tcl_Interp *interp, /* For error reporting - can be NULL. */ const char *optionName, /* Which option to set? */ const char *value) /* New value for option. */ @@ -1098,7 +1098,7 @@ TtySetOptionProc( static int TtyGetOptionProc( - void *instanceData, /* File state. */ + void *instanceData, /* File state. */ Tcl_Interp *interp, /* For error reporting - can be NULL. */ const char *optionName, /* Option to get. */ Tcl_DString *dsPtr) /* Where to store value(s). */ @@ -1637,22 +1637,18 @@ TtyParseMode( * not allow preprocessor directives in their arguments. */ - if ( -#if defined(PAREXT) - strchr("noems", parity) +#ifdef PAREXT +#define PARITY_CHARS "noems" +#define PARITY_MSG "n, o, e, m, or s" #else - strchr("noe", parity) +#define PARITY_CHARS "noe" +#define PARITY_MSG "n, o, or e" #endif /* PAREXT */ - == NULL) { + + if (strchr(PARITY_CHARS, parity) == NULL) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "%s parity: should be %s", bad, -#if defined(PAREXT) - "n, o, e, m, or s" -#else - "n, o, or e" -#endif /* PAREXT */ - )); + "%s parity: should be %s", bad, PARITY_MSG)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "SERIALMODE", (char *)NULL); } return TCL_ERROR; @@ -2054,7 +2050,7 @@ Tcl_GetOpenFile( * Ignored, we always check that * the channel is open for the requested * mode. */ - void **filePtr) /* Store pointer to FILE structure here. */ + void **filePtr) /* Store pointer to FILE structure here. */ { Tcl_Channel chan; int chanMode, fd; diff --git a/unix/tclUnixCompat.c b/unix/tclUnixCompat.c index 30ddb71..def69fa 100644 --- a/unix/tclUnixCompat.c +++ b/unix/tclUnixCompat.c @@ -994,17 +994,17 @@ TclWinCPUID( /* See: <http://en.wikipedia.org/wiki/CPUID> */ #if defined(__x86_64__) || defined(_M_AMD64) || defined (_M_X64) __asm__ __volatile__("movq %%rbx, %%rsi \n\t" /* save %rbx */ - "cpuid \n\t" - "xchgq %%rsi, %%rbx \n\t" /* restore the old %rbx */ - : "=a"(regsPtr[0]), "=S"(regsPtr[1]), "=c"(regsPtr[2]), "=d"(regsPtr[3]) - : "a"(index)); + "cpuid \n\t" + "xchgq %%rsi, %%rbx \n\t" /* restore the old %rbx */ + : "=a"(regsPtr[0]), "=S"(regsPtr[1]), "=c"(regsPtr[2]), "=d"(regsPtr[3]) + : "a"(index)); status = TCL_OK; #elif defined(__i386__) || defined(_M_IX86) __asm__ __volatile__("mov %%ebx, %%esi \n\t" /* save %ebx */ - "cpuid \n\t" - "xchg %%esi, %%ebx \n\t" /* restore the old %ebx */ - : "=a"(regsPtr[0]), "=S"(regsPtr[1]), "=c"(regsPtr[2]), "=d"(regsPtr[3]) - : "a"(index)); + "cpuid \n\t" + "xchg %%esi, %%ebx \n\t" /* restore the old %ebx */ + : "=a"(regsPtr[0]), "=S"(regsPtr[1]), "=c"(regsPtr[2]), "=d"(regsPtr[3]) + : "a"(index)); status = TCL_OK; #else (void)index; diff --git a/unix/tclUnixFCmd.c b/unix/tclUnixFCmd.c index b65cdb1..fab9c32 100644 --- a/unix/tclUnixFCmd.c +++ b/unix/tclUnixFCmd.c @@ -809,7 +809,7 @@ TclpObjCopyDirectory( * EEXIST: path is a non-empty directory. * EINVAL: path is a root directory. * ENOENT: path doesn't exist or is "". - * ENOTDIR: path is not a directory. + * ENOTDIR: path is not a directory. * * Side effects: * Directory removed. If an error occurs, the error will be returned @@ -953,12 +953,12 @@ TraverseUnixTree( * filled with UTF-8 name of file causing * error. */ int doRewind) /* Flag indicating that to ensure complete - * traversal of source hierarchy, the readdir - * loop should be rewound whenever - * traverseProc has returned TCL_OK; this is - * required when traverseProc modifies the - * source hierarchy, e.g. by deleting - * files. */ + * traversal of source hierarchy, the readdir + * loop should be rewound whenever + * traverseProc has returned TCL_OK; this is + * required when traverseProc modifies the + * source hierarchy, e.g. by deleting + * files. */ { Tcl_StatBuf statBuf; const char *source, *errfile; diff --git a/unix/tclUnixFile.c b/unix/tclUnixFile.c index 93f6aa8..e91ed41 100644 --- a/unix/tclUnixFile.c +++ b/unix/tclUnixFile.c @@ -13,8 +13,9 @@ #include "tclInt.h" #include "tclFileSystem.h" -static int NativeMatchType(Tcl_Interp *interp, const char* nativeEntry, - const char* nativeName, Tcl_GlobTypeData *types); +static int NativeMatchType(Tcl_Interp *interp, + const char* nativeEntry, const char* nativeName, + Tcl_GlobTypeData *types); /* *--------------------------------------------------------------------------- diff --git a/unix/tclUnixInit.c b/unix/tclUnixInit.c index 81e3af5..63167c6 100644 --- a/unix/tclUnixInit.c +++ b/unix/tclUnixInit.c @@ -54,11 +54,11 @@ static const char *const processors[NUMPROCESSORS] = { typedef struct { union { - unsigned int dwOemId; - struct { - int wProcessorArchitecture; - int wReserved; - }; + unsigned int dwOemId; + struct { + int wProcessorArchitecture; + int wReserved; + }; }; unsigned int dwPageSize; void *lpMinimumApplicationAddress; @@ -860,15 +860,15 @@ TclpSetVariables( } Tcl_ObjSetVar2(interp, Tcl_NewStringObj("tcl_pkgPath", -1), NULL, pkgListObj, TCL_GLOBAL_ONLY); { - /* Some platforms build configure scripts expect ~ expansion so do that */ - Tcl_Obj *origPaths; - Tcl_Obj *resolvedPaths; - - origPaths = Tcl_GetVar2Ex(interp, "tcl_pkgPath", NULL, TCL_GLOBAL_ONLY); - resolvedPaths = TclResolveTildePathList(origPaths); - if (resolvedPaths != origPaths && resolvedPaths != NULL) { - Tcl_SetVar2Ex(interp, "tcl_pkgPath", NULL, resolvedPaths, TCL_GLOBAL_ONLY); - } + /* Some platforms build configure scripts expect ~ expansion so do that */ + Tcl_Obj *origPaths; + Tcl_Obj *resolvedPaths; + + origPaths = Tcl_GetVar2Ex(interp, "tcl_pkgPath", NULL, TCL_GLOBAL_ONLY); + resolvedPaths = TclResolveTildePathList(origPaths); + if (resolvedPaths != origPaths && resolvedPaths != NULL) { + Tcl_SetVar2Ex(interp, "tcl_pkgPath", NULL, resolvedPaths, TCL_GLOBAL_ONLY); + } } #ifdef DJGPP diff --git a/unix/tclUnixNotfy.c b/unix/tclUnixNotfy.c index 984ee2f..8ffea58 100644 --- a/unix/tclUnixNotfy.c +++ b/unix/tclUnixNotfy.c @@ -360,12 +360,12 @@ AlertSingleThread( */ if (tsdPtr->prevPtr) { - tsdPtr->prevPtr->nextPtr = tsdPtr->nextPtr; + tsdPtr->prevPtr->nextPtr = tsdPtr->nextPtr; } else { - waitingListPtr = tsdPtr->nextPtr; + waitingListPtr = tsdPtr->nextPtr; } if (tsdPtr->nextPtr) { - tsdPtr->nextPtr->prevPtr = tsdPtr->prevPtr; + tsdPtr->nextPtr->prevPtr = tsdPtr->prevPtr; } tsdPtr->nextPtr = tsdPtr->prevPtr = NULL; tsdPtr->onList = 0; diff --git a/unix/tclUnixPipe.c b/unix/tclUnixPipe.c index ea1636e..a61c083 100644 --- a/unix/tclUnixPipe.c +++ b/unix/tclUnixPipe.c @@ -78,23 +78,23 @@ static int SetupStdFile(TclFile file, int type); */ static const Tcl_ChannelType pipeChannelType = { - "pipe", /* Type name. */ - TCL_CHANNEL_VERSION_5, /* v5 channel */ - NULL, /* Close proc. */ - PipeInputProc, /* Input proc. */ - PipeOutputProc, /* Output proc. */ - NULL, /* Seek proc. */ + "pipe", + TCL_CHANNEL_VERSION_5, + NULL, /* Deprecated. */ + PipeInputProc, + PipeOutputProc, + NULL, /* Deprecated. */ NULL, /* Set option proc. */ NULL, /* Get option proc. */ - PipeWatchProc, /* Initialize notifier. */ - PipeGetHandleProc, /* Get OS handles out of channel. */ - PipeClose2Proc, /* close2proc. */ - PipeBlockModeProc, /* Set blocking or non-blocking mode.*/ - NULL, /* flush proc. */ - NULL, /* handler proc. */ - NULL, /* wide seek proc */ - NULL, /* thread action proc */ - NULL /* truncation */ + PipeWatchProc, + PipeGetHandleProc, + PipeClose2Proc, + PipeBlockModeProc, + NULL, /* Flush proc. */ + NULL, /* Bubbled event handler proc. */ + NULL, /* Seek proc. */ + NULL, /* Thread action proc. */ + NULL /* Truncation proc. */ }; /* @@ -844,7 +844,7 @@ TclpCreateCommandChannel( * background exec). */ { char channelName[16 + TCL_INTEGER_SPACE]; - int channelId; + int fd; PipeState *statePtr = (PipeState *)Tcl_Alloc(sizeof(PipeState)); int mode; @@ -868,13 +868,13 @@ TclpCreateCommandChannel( */ if (readFile) { - channelId = GetFd(readFile); + fd = GetFd(readFile); } else if (writeFile) { - channelId = GetFd(writeFile); + fd = GetFd(writeFile); } else if (errorFile) { - channelId = GetFd(errorFile); + fd = GetFd(errorFile); } else { - channelId = 0; + fd = 0; } /* @@ -883,7 +883,7 @@ TclpCreateCommandChannel( * natural to use "pipe%d". */ - snprintf(channelName, sizeof(channelName), "file%d", channelId); + snprintf(channelName, sizeof(channelName), "file%d", fd); statePtr->channel = Tcl_CreateChannel(&pipeChannelType, channelName, statePtr, mode); return statePtr->channel; diff --git a/unix/tclUnixSock.c b/unix/tclUnixSock.c index 78ed008..f2b15b2 100644 --- a/unix/tclUnixSock.c +++ b/unix/tclUnixSock.c @@ -63,8 +63,7 @@ struct TcpState { * Only needed for server sockets */ - Tcl_TcpAcceptProc *acceptProc; - /* Proc to call on accept. */ + Tcl_TcpAcceptProc *acceptProc; /* Proc to call on accept. */ void *acceptProcData; /* The data for the accept proc. */ /* @@ -154,23 +153,23 @@ static Tcl_FileProc WrapNotify; */ static const Tcl_ChannelType tcpChannelType = { - "tcp", /* Type name. */ - TCL_CHANNEL_VERSION_5, /* v5 channel */ - NULL, /* Close proc. */ - TcpInputProc, /* Input proc. */ - TcpOutputProc, /* Output proc. */ + "tcp", + TCL_CHANNEL_VERSION_5, + NULL, /* Deprecated. */ + TcpInputProc, + TcpOutputProc, + NULL, /* Deprecated. */ + TcpSetOptionProc, + TcpGetOptionProc, + TcpWatchProc, + TcpGetHandleProc, + TcpClose2Proc, + TcpBlockModeProc, + NULL, /* Flush proc. */ + NULL, /* Bubbled event handler 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. */ + TcpThreadActionProc, + NULL /* Truncate proc. */ }; /* @@ -204,8 +203,8 @@ printaddrinfo( * * InitializeHostName -- * - * This routine sets the process global value of the name of the local - * host on which the process is running. + * This routine sets the process global value of the name of the local + * host on which the process is running. * * Results: * None. @@ -227,7 +226,7 @@ InitializeHostName( memset(&u, (int) 0, sizeof(struct utsname)); if (uname(&u) >= 0) { /* INTL: Native. */ - hp = TclpGetHostByName(u.nodename); /* INTL: Native. */ + hp = TclpGetHostByName(u.nodename); /* INTL: Native. */ if (hp == NULL) { /* * Sometimes the nodename is fully qualified, but gets truncated @@ -246,11 +245,11 @@ InitializeHostName( Tcl_Free(node); } } - if (hp != NULL) { + if (hp != NULL) { native = hp->h_name; - } else { + } else { native = u.nodename; - } + } } #else /* !NO_UNAME */ /* @@ -370,8 +369,8 @@ TcpBlockModeProc( SET_BITS(statePtr->flags, TCP_NONBLOCKING); } if (GOT_BITS(statePtr->flags, TCP_ASYNC_CONNECT)) { - statePtr->cachedBlocking = mode; - return 0; + statePtr->cachedBlocking = mode; + return 0; } if (TclUnixSetBlockingMode(statePtr->fds.fd, mode) < 0) { return errno; @@ -400,8 +399,8 @@ TcpBlockModeProc( * return any error code. * * Results: - * 0 if the connection has completed, -1 if still in progress or there is - * an error. + * 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 @@ -443,37 +442,37 @@ WaitForConnect( */ if (GOT_BITS(statePtr->flags, TCP_ASYNC_TEST_MODE) - && !(errorCodePtr != NULL - && !GOT_BITS(statePtr->flags, TCP_NONBLOCKING))) { + && !(errorCodePtr != NULL + && !GOT_BITS(statePtr->flags, TCP_NONBLOCKING))) { *errorCodePtr = EWOULDBLOCK; return -1; } if (errorCodePtr == NULL || GOT_BITS(statePtr->flags, TCP_NONBLOCKING)) { - timeout = 0; + timeout = 0; } else { - timeout = -1; + 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. - */ + 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 && GOT_BITS(statePtr->flags, TCP_ASYNC_CONNECT)); if (errorCodePtr != NULL) { - if (GOT_BITS(statePtr->flags, TCP_ASYNC_PENDING)) { - *errorCodePtr = EAGAIN; - return -1; - } else if (statePtr->connectError != 0) { - *errorCodePtr = ENOTCONN; - return -1; - } + if (GOT_BITS(statePtr->flags, TCP_ASYNC_PENDING)) { + *errorCodePtr = EAGAIN; + return -1; + } else if (statePtr->connectError != 0) { + *errorCodePtr = ENOTCONN; + return -1; + } } return 0; } @@ -627,10 +626,10 @@ TcpCloseProc( fds = next; } if (statePtr->addrlist != NULL) { - freeaddrinfo(statePtr->addrlist); + freeaddrinfo(statePtr->addrlist); } if (statePtr->myaddrlist != NULL) { - freeaddrinfo(statePtr->myaddrlist); + freeaddrinfo(statePtr->myaddrlist); } Tcl_Free(statePtr); return errorCode; @@ -706,7 +705,7 @@ IPv6AddressNeedsNumericRendering( struct in6_addr addr) { if (IN6_ARE_ADDR_EQUAL(&addr, &in6addr_any)) { - return 1; + return 1; } /* @@ -715,11 +714,11 @@ IPv6AddressNeedsNumericRendering( */ if (!IN6_IS_ADDR_V4MAPPED(&addr)) { - return 0; + return 0; } return (addr.s6_addr[12] == 0 && addr.s6_addr[13] == 0 - && addr.s6_addr[14] == 0 && addr.s6_addr[15] == 0); + && addr.s6_addr[14] == 0 && addr.s6_addr[15] == 0); } #if defined (__clang__) || ((__GNUC__) && ((__GNUC__ > 4) || ((__GNUC__ == 4) && (__GNUC_MINOR__ > 5)))) #pragma GCC diagnostic pop @@ -738,7 +737,7 @@ TcpHostPortList( int flags = 0; getnameinfo(&addr.sa, salen, nhost, sizeof(nhost), nport, sizeof(nport), - NI_NUMERICHOST | NI_NUMERICSERV); + NI_NUMERICHOST | NI_NUMERICSERV); Tcl_DStringAppendElement(dsPtr, nhost); /* @@ -747,14 +746,14 @@ TcpHostPortList( */ if (addr.sa.sa_family == AF_INET) { - if (addr.sa4.sin_addr.s_addr == INADDR_ANY) { - flags |= NI_NUMERICHOST; - } + if (addr.sa4.sin_addr.s_addr == INADDR_ANY) { + flags |= NI_NUMERICHOST; + } #ifndef NEED_FAKE_RFC2553 } else if (addr.sa.sa_family == AF_INET6) { - if (IPv6AddressNeedsNumericRendering(addr.sa6.sin6_addr)) { - flags |= NI_NUMERICHOST; - } + if (IPv6AddressNeedsNumericRendering(addr.sa6.sin6_addr)) { + flags |= NI_NUMERICHOST; + } #endif /* NEED_FAKE_RFC2553 */ } @@ -763,22 +762,22 @@ TcpHostPortList( */ if (interp != NULL && - Tcl_GetVar2(interp, SUPPRESS_RDNS_VAR, NULL, 0) != NULL) { - flags |= NI_NUMERICHOST; + Tcl_GetVar2(interp, SUPPRESS_RDNS_VAR, NULL, 0) != NULL) { + flags |= NI_NUMERICHOST; } if (getnameinfo(&addr.sa, salen, host, sizeof(host), NULL, 0, - flags) == 0) { - /* - * Reverse mapping worked. - */ + flags) == 0) { + /* + * Reverse mapping worked. + */ - Tcl_DStringAppendElement(dsPtr, host); + Tcl_DStringAppendElement(dsPtr, host); } else { - /* - * Reverse mapping failed - use the numeric rep once more. - */ + /* + * Reverse mapping failed - use the numeric rep once more. + */ - Tcl_DStringAppendElement(dsPtr, nhost); + Tcl_DStringAppendElement(dsPtr, nhost); } Tcl_DStringAppendElement(dsPtr, nport); } @@ -907,25 +906,25 @@ TcpGetOptionProc( socklen_t optlen = sizeof(int); WaitForConnect(statePtr, NULL); - if (GOT_BITS(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 { - int err; - - getsockopt(statePtr->fds.fd, SOL_SOCKET, SO_ERROR, (char *) &err, - &optlen); - errno = err; - } - if (errno != 0) { + if (GOT_BITS(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 { + int err; + + getsockopt(statePtr->fds.fd, SOL_SOCKET, SO_ERROR, (char *) &err, + &optlen); + errno = err; + } + if (errno != 0) { Tcl_DStringAppend(dsPtr, Tcl_ErrnoMsg(errno), TCL_INDEX_NONE); - } + } return TCL_OK; } @@ -934,13 +933,13 @@ TcpGetOptionProc( WaitForConnect(statePtr, NULL); Tcl_DStringAppend(dsPtr, GOT_BITS(statePtr->flags, TCP_ASYNC_CONNECT) ? "1" : "0", TCL_INDEX_NONE); - return TCL_OK; + return TCL_OK; } if ((len == 0) || ((len > 1) && (optionName[1] == 'p') && (strncmp(optionName, "-peername", len) == 0))) { - address peername; - socklen_t size = sizeof(peername); + address peername; + socklen_t size = sizeof(peername); WaitForConnect(statePtr, NULL); if (GOT_BITS(statePtr->flags, TCP_ASYNC_CONNECT)) { @@ -963,11 +962,11 @@ TcpGetOptionProc( Tcl_DStringAppendElement(dsPtr, "-peername"); Tcl_DStringStartSublist(dsPtr); } - TcpHostPortList(interp, dsPtr, peername, size); + TcpHostPortList(interp, dsPtr, peername, size); if (len) { - return TCL_OK; - } - Tcl_DStringEndSublist(dsPtr); + return TCL_OK; + } + Tcl_DStringEndSublist(dsPtr); } else { /* * getpeername failed - but if we were asked for all the options @@ -979,7 +978,7 @@ TcpGetOptionProc( if (len) { if (interp) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "can't get peername: %s", + "can't get peername: %s", Tcl_PosixError(interp))); } return TCL_ERROR; @@ -1004,7 +1003,7 @@ TcpGetOptionProc( * In async connect output an empty string */ - found = 1; + found = 1; } else { for (fds = &statePtr->fds; fds != NULL; fds = fds->next) { size = sizeof(sockname); @@ -1014,16 +1013,16 @@ TcpGetOptionProc( } } } - if (found) { - if (len) { - return TCL_OK; - } - Tcl_DStringEndSublist(dsPtr); - } else { - if (interp) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "can't get sockname: %s", Tcl_PosixError(interp))); - } + if (found) { + if (len) { + return TCL_OK; + } + Tcl_DStringEndSublist(dsPtr); + } else { + if (interp) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't get sockname: %s", Tcl_PosixError(interp))); + } return TCL_ERROR; } } @@ -1070,7 +1069,7 @@ TcpGetOptionProc( if (len > 0) { return Tcl_BadChannelOption(interp, optionName, - "connecting keepalive nodelay peername sockname"); + "connecting keepalive nodelay peername sockname"); } return TCL_OK; @@ -1177,22 +1176,22 @@ TcpWatchProc( TcpState *statePtr = (TcpState *)instanceData; if (statePtr->acceptProc != NULL) { - /* - * Make sure we don't mess with server sockets since they will never - * be readable or writable at the Tcl level. This keeps Tcl scripts - * from interfering with the -accept behavior (bug #3394732). - */ + /* + * Make sure we don't mess with server sockets since they will never + * be readable or writable at the Tcl level. This keeps Tcl scripts + * from interfering with the -accept behavior (bug #3394732). + */ - return; + return; } if (GOT_BITS(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. - */ + /* + * Async sockets use a FileHandler internally while connecting, so we + * need to cache this request until the connection has succeeded. + */ - statePtr->filehandlers = mask; + statePtr->filehandlers = mask; } else if (mask) { /* @@ -1314,14 +1313,14 @@ TcpConnect( static const int reuseaddr = 1; if (async_callback) { - goto reenter; + 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) { + statePtr->addr = statePtr->addr->ai_next) { + for (statePtr->myaddr = statePtr->myaddrlist; + statePtr->myaddr != NULL; + statePtr->myaddr = statePtr->myaddr->ai_next) { /* * No need to try combinations of local and remote addresses of * different families. @@ -1331,19 +1330,19 @@ TcpConnect( continue; } - /* - * Close the socket if it is still open from the last unsuccessful - * iteration. - */ + /* + * Close the socket if it is still open from the last unsuccessful + * iteration. + */ - if (statePtr->fds.fd >= 0) { + if (statePtr->fds.fd >= 0) { close(statePtr->fds.fd); statePtr->fds.fd = -1; - errno = 0; + errno = 0; } statePtr->fds.fd = socket(statePtr->addr->ai_family, SOCK_STREAM, - 0); + 0); if (statePtr->fds.fd < 0) { continue; } @@ -1362,28 +1361,28 @@ TcpConnect( TclSockMinimumBuffers(INT2PTR(statePtr->fds.fd), SOCKET_BUFSIZE); if (async) { - ret = TclUnixSetBlockingMode(statePtr->fds.fd, - TCL_MODE_NONBLOCKING); - if (ret < 0) { - continue; - } - } - - /* - * Must 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)); - ret = bind(statePtr->fds.fd, statePtr->myaddr->ai_addr, - statePtr->myaddr->ai_addrlen); - if (ret < 0) { - error = errno; - continue; - } + ret = TclUnixSetBlockingMode(statePtr->fds.fd, + TCL_MODE_NONBLOCKING); + if (ret < 0) { + continue; + } + } + + /* + * Must 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)); + ret = bind(statePtr->fds.fd, statePtr->myaddr->ai_addr, + statePtr->myaddr->ai_addrlen); + if (ret < 0) { + error = errno; + continue; + } /* * Attempt to connect. The connect may fail at present with an @@ -1393,35 +1392,35 @@ TcpConnect( */ ret = connect(statePtr->fds.fd, statePtr->addr->ai_addr, - statePtr->addr->ai_addrlen); - if (ret < 0) { - error = errno; - } + 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: - CLEAR_BITS(statePtr->flags, TCP_ASYNC_PENDING); - Tcl_DeleteFileHandler(statePtr->fds.fd); - - /* - * Read the error state from the socket to see if the async - * connection has succeeded or failed. As this clears the - * error condition, we cache the status in the socket state - * struct for later retrieval by [fconfigure -error]. - */ - - optlen = sizeof(int); - - getsockopt(statePtr->fds.fd, SOL_SOCKET, SO_ERROR, - (char *) &error, &optlen); - errno = error; - } + Tcl_CreateFileHandler(statePtr->fds.fd, + TCL_WRITABLE | TCL_EXCEPTION, TcpAsyncCallback, + statePtr); + errno = EWOULDBLOCK; + SET_BITS(statePtr->flags, TCP_ASYNC_PENDING); + return TCL_OK; + + reenter: + CLEAR_BITS(statePtr->flags, TCP_ASYNC_PENDING); + Tcl_DeleteFileHandler(statePtr->fds.fd); + + /* + * Read the error state from the socket to see if the async + * connection has succeeded or failed. As this clears the + * error condition, we cache the status in the socket state + * struct for later retrieval by [fconfigure -error]. + */ + + optlen = sizeof(int); + + getsockopt(statePtr->fds.fd, SOL_SOCKET, SO_ERROR, + (char *) &error, &optlen); + errno = error; + } if (error == 0) { goto out; } @@ -1432,43 +1431,43 @@ TcpConnect( statePtr->connectError = error; CLEAR_BITS(statePtr->flags, TCP_ASYNC_CONNECT); if (async_callback) { - /* - * An asynchonous connection has finally succeeded or failed. - */ - - 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, because - * upon reading of getsockopt(SO_ERROR), at least some OSes clear the - * writable state from the socket, and so a subsequent select() on - * behalf of a script level [fileevent] would not fire. It doesn't - * hurt that this is also called in the successful case and will save - * the event mechanism one roundtrip through select(). - */ + /* + * An asynchonous connection has finally succeeded or failed. + */ + + 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, because + * upon reading of getsockopt(SO_ERROR), at least some OSes clear the + * writable state from the socket, and so a subsequent select() on + * behalf of a script level [fileevent] would not fire. It doesn't + * hurt that this is also called in the successful case and will save + * the event mechanism one roundtrip through select(). + */ 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 - * invalid -myaddr was given. - */ - - if (interp != NULL) { - errno = error; - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "couldn't open socket: %s", Tcl_PosixError(interp))); - } - return TCL_ERROR; + /* + * Failure for either a synchronous connection, or an async one that + * failed before it could enter background mode, e.g. because an + * invalid -myaddr was given. + */ + + if (interp != NULL) { + errno = error; + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't open socket: %s", Tcl_PosixError(interp))); + } + return TCL_ERROR; } return TCL_OK; } @@ -1511,16 +1510,16 @@ Tcl_OpenTcpClient( */ 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; + || !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; } /* @@ -1540,14 +1539,14 @@ Tcl_OpenTcpClient( */ if (TcpConnect(interp, statePtr) != TCL_OK) { - TcpCloseProc(statePtr, NULL); - return NULL; + TcpCloseProc(statePtr, NULL); + return NULL; } snprintf(channelName, sizeof(channelName), SOCK_TEMPLATE, PTR2INT(statePtr)); statePtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName, - statePtr, TCL_READABLE | TCL_WRITABLE); + statePtr, TCL_READABLE | TCL_WRITABLE); if (Tcl_SetChannelOption(interp, statePtr->channel, "-translation", "auto crlf") == TCL_ERROR) { Tcl_CloseEx(NULL, statePtr->channel, 0); @@ -1577,7 +1576,7 @@ Tcl_MakeTcpClientChannel( void *sock) /* The socket to wrap up into a channel. */ { return (Tcl_Channel) TclpMakeTcpClientChannelMode(sock, - TCL_READABLE | TCL_WRITABLE); + TCL_READABLE | TCL_WRITABLE); } /* @@ -1684,17 +1683,17 @@ Tcl_OpenTcpServerEx( repeat: if (retry > 0) { - if (statePtr != NULL) { - TcpCloseProc(statePtr, NULL); - statePtr = NULL; - } - if (addrlist != NULL) { - freeaddrinfo(addrlist); - addrlist = NULL; - } - if (retry >= MAXRETRY) { - goto error; - } + if (statePtr != NULL) { + TcpCloseProc(statePtr, NULL); + statePtr = NULL; + } + if (addrlist != NULL) { + freeaddrinfo(addrlist); + addrlist = NULL; + } + if (retry >= MAXRETRY) { + goto error; + } } retry++; chosenport = 0; @@ -1705,14 +1704,14 @@ Tcl_OpenTcpServerEx( } if (!TclCreateSocketAddress(interp, &addrlist, myHost, port, 1, - &errorMsg)) { + &errorMsg)) { my_errno = errno; goto error; } for (addrPtr = addrlist; addrPtr != NULL; addrPtr = addrPtr->ai_next) { sock = socket(addrPtr->ai_family, addrPtr->ai_socktype, - addrPtr->ai_protocol); + addrPtr->ai_protocol); if (sock == -1) { if (howfar < SOCKET) { howfar = SOCKET; @@ -1760,100 +1759,100 @@ Tcl_OpenTcpServerEx( #endif } - /* - * Make sure we use the same port number when opening two server - * sockets for IPv4 and IPv6 on a random port. - * - * As sockaddr_in6 uses the same offset and size for the port member - * as sockaddr_in, we can handle both through the IPv4 API. - */ + /* + * Make sure we use the same port number when opening two server + * sockets for IPv4 and IPv6 on a random port. + * + * 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); + htons(chosenport); } #ifdef IPV6_V6ONLY /* - * Missing on: Solaris 2.8 - */ + * Missing on: Solaris 2.8 + */ - if (addrPtr->ai_family == AF_INET6) { - int v6only = 1; + if (addrPtr->ai_family == AF_INET6) { + int v6only = 1; - (void) setsockopt(sock, IPPROTO_IPV6, IPV6_V6ONLY, - &v6only, sizeof(v6only)); - } + (void) setsockopt(sock, IPPROTO_IPV6, IPV6_V6ONLY, + &v6only, sizeof(v6only)); + } #endif /* IPV6_V6ONLY */ status = bind(sock, addrPtr->ai_addr, addrPtr->ai_addrlen); - if (status == -1) { + if (status == -1) { if (howfar < BIND) { howfar = BIND; my_errno = errno; } - close(sock); - sock = -1; - if (port == 0 && errno == EADDRINUSE) { - goto repeat; - } - 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); - } - } - if (backlog < 0) { - backlog = SOMAXCONN; - } - status = listen(sock, backlog); - if (status < 0) { + close(sock); + sock = -1; + if (port == 0 && errno == EADDRINUSE) { + goto repeat; + } + 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); + } + } + if (backlog < 0) { + backlog = SOMAXCONN; + } + status = listen(sock, backlog); + if (status < 0) { if (howfar < LISTEN) { howfar = LISTEN; my_errno = errno; } - close(sock); - sock = -1; - if (port == 0 && errno == EADDRINUSE) { - goto repeat; - } - continue; - } - if (statePtr == NULL) { - /* - * Allocate a new TcpState for this socket. - */ - - statePtr = (TcpState *)Tcl_Alloc(sizeof(TcpState)); - memset(statePtr, 0, sizeof(TcpState)); - statePtr->acceptProc = acceptProc; - statePtr->acceptProcData = acceptProcData; - snprintf(channelName, sizeof(channelName), SOCK_TEMPLATE, PTR2INT(statePtr)); - newfds = &statePtr->fds; - } else { - newfds = (TcpFdList *)Tcl_Alloc(sizeof(TcpFdList)); - memset(newfds, (int) 0, sizeof(TcpFdList)); - fds->next = newfds; - } - newfds->fd = sock; - newfds->statePtr = statePtr; - fds = newfds; - - /* - * Set up the callback mechanism for accepting connections from new - * clients. - */ - - Tcl_CreateFileHandler(sock, TCL_READABLE, TcpAccept, fds); + close(sock); + sock = -1; + if (port == 0 && errno == EADDRINUSE) { + goto repeat; + } + continue; + } + if (statePtr == NULL) { + /* + * Allocate a new TcpState for this socket. + */ + + statePtr = (TcpState *)Tcl_Alloc(sizeof(TcpState)); + memset(statePtr, 0, sizeof(TcpState)); + statePtr->acceptProc = acceptProc; + statePtr->acceptProcData = acceptProcData; + snprintf(channelName, sizeof(channelName), SOCK_TEMPLATE, PTR2INT(statePtr)); + newfds = &statePtr->fds; + } else { + newfds = (TcpFdList *)Tcl_Alloc(sizeof(TcpFdList)); + memset(newfds, (int) 0, sizeof(TcpFdList)); + fds->next = newfds; + } + newfds->fd = sock; + newfds->statePtr = statePtr; + fds = newfds; + + /* + * Set up the callback mechanism for accepting connections from new + * clients. + */ + + Tcl_CreateFileHandler(sock, TCL_READABLE, TcpAccept, fds); } error: @@ -1866,15 +1865,15 @@ Tcl_OpenTcpServerEx( return statePtr->channel; } if (interp != NULL) { - Tcl_Obj *errorObj = Tcl_NewStringObj("couldn't open socket: ", TCL_INDEX_NONE); + Tcl_Obj *errorObj = Tcl_NewStringObj("couldn't open socket: ", TCL_INDEX_NONE); if (errorMsg == NULL) { - errno = my_errno; - Tcl_AppendToObj(errorObj, Tcl_PosixError(interp), TCL_INDEX_NONE); - } else { + errno = my_errno; + Tcl_AppendToObj(errorObj, Tcl_PosixError(interp), TCL_INDEX_NONE); + } else { Tcl_AppendToObj(errorObj, errorMsg, TCL_INDEX_NONE); } - Tcl_SetObjResult(interp, errorObj); + Tcl_SetObjResult(interp, errorObj); } if (sock != -1) { close(sock); @@ -1938,9 +1937,9 @@ TcpAccept( if (fds->statePtr->acceptProc != NULL) { getnameinfo(&addr.sa, len, host, sizeof(host), port, sizeof(port), - NI_NUMERICHOST|NI_NUMERICSERV); + NI_NUMERICHOST|NI_NUMERICSERV); fds->statePtr->acceptProc(fds->statePtr->acceptProcData, - newSockState->channel, host, atoi(port)); + newSockState->channel, host, atoi(port)); } } diff --git a/unix/tclUnixTest.c b/unix/tclUnixTest.c index b204c77..26c590d 100644 --- a/unix/tclUnixTest.c +++ b/unix/tclUnixTest.c @@ -549,7 +549,7 @@ TestalarmCmd( * None. * * Side effects: - * Calls the Tcl Async handler. + * Calls the Tcl Async handler. * *---------------------------------------------------------------------- */ @@ -566,7 +566,7 @@ AlarmHandler( * * TestgotsigCmd -- * - * Verify the signal was handled after the testalarm command. + * Verify the signal was handled after the testalarm command. * * Results: * None. diff --git a/unix/tclUnixTime.c b/unix/tclUnixTime.c index 20b9a67..29146aa 100644 --- a/unix/tclUnixTime.c +++ b/unix/tclUnixTime.c @@ -246,7 +246,7 @@ TclpWideClicksToNanoseconds( * and back. * * Results: - * 1 click in microseconds as double. + * 1 click in microseconds as double. * * Side effects: * None. diff --git a/win/Makefile.in b/win/Makefile.in index 18ce10d..98e2cec 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -79,10 +79,10 @@ CFLAGS_OPTIMIZE = @CFLAGS_OPTIMIZE@ # To change the compiler switches, for example to change from optimization to # debugging symbols, change the following line: -#CFLAGS = $(CFLAGS_DEBUG) -#CFLAGS = $(CFLAGS_OPTIMIZE) -#CFLAGS = $(CFLAGS_DEBUG) $(CFLAGS_OPTIMIZE) -CFLAGS = @CFLAGS@ @CFLAGS_DEFAULT@ -DMP_FIXED_CUTOFFS -D__USE_MINGW_ANSI_STDIO=0 +#CFLAGS = $(CFLAGS_DEBUG) +#CFLAGS = $(CFLAGS_OPTIMIZE) +#CFLAGS = $(CFLAGS_DEBUG) $(CFLAGS_OPTIMIZE) +CFLAGS = @CFLAGS@ @CFLAGS_DEFAULT@ -DMP_FIXED_CUTOFFS -D__USE_MINGW_ANSI_STDIO=0 # To compile without backward compatibility and deprecated code uncomment the # following @@ -162,7 +162,7 @@ TEST_LOAD_FACILITIES = package ifneeded tcl::test ${VERSION}@TCL_PATCH_LEVEL@ [l ZLIB_DLL_FILE = zlib1.dll TOMMATH_DLL_FILE = libtommath.dll -SHARED_LIBRARIES = $(TCL_DLL_FILE) @ZLIB_DLL_FILE@ @TOMMATH_DLL_FILE@ +SHARED_LIBRARIES = $(TCL_DLL_FILE) @ZLIB_DLL_FILE@ @TOMMATH_DLL_FILE@ STATIC_LIBRARIES = $(TCL_LIB_FILE) TCLSH = tclsh$(VER)${EXESUFFIX} @@ -617,7 +617,7 @@ ${TEST_DLL_FILE}: ${TCL_STUB_LIB_FILE} ${TCLTEST_OBJS} ${TEST_EXE_FILE}: ${TCL_STUB_LIB_FILE} ${TCLTEST_OBJS} tclTestMain.${OBJEXT} @$(RM) ${TEST_EXE_FILE} $(CC) $(CFLAGS) $(TCLTEST_OBJS) tclTestMain.$(OBJEXT) $(TCL_LIB_FILE) $(TCL_STUB_LIB_FILE) $(LIBS) \ - tclsh.$(RES) $(CC_EXENAME) $(LDFLAGS_CONSOLE) + tclsh.$(RES) $(CC_EXENAME) $(LDFLAGS_CONSOLE) $(COPY) tclsh.exe.manifest ${TEST_EXE_FILE}.manifest # use prebuilt zlib1.dll diff --git a/win/makefile.vc b/win/makefile.vc index 2a35668..d2826ea 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -57,7 +57,7 @@ # Any combination of the above may be used (comma separated).
# 'none' will over-ride everything to nothing.
#
-# noembed = Without this option, the Tcl core library scripts
+# noembed = Without this option, the Tcl core library scripts
# are embedded into the executable if "static" is
# specified in OPTS, or into the DLL otherwise. If
# "noembed" is specified, the scripts are not embedded
diff --git a/win/nmakehlp.c b/win/nmakehlp.c index b0799f8..4fc9f7a 100644 --- a/win/nmakehlp.c +++ b/win/nmakehlp.c @@ -90,7 +90,7 @@ main( case 'c': if (argc != 3) { chars = snprintf(msg, sizeof(msg) - 1, - "usage: %s -c <compiler option>\n" + "usage: %s -c <compiler option>\n" "Tests for whether cl.exe supports an option\n" "exitcodes: 0 == no, 1 == yes, 2 == error\n", argv[0]); WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, chars, @@ -271,7 +271,7 @@ CheckForCompilerFeature( if (!ok) { DWORD err = GetLastError(); int chars = snprintf(msg, sizeof(msg) - 1, - "Tried to launch: \"%s\", but got error [%lu]: ", cmdline, err); + "Tried to launch: \"%s\", but got error [%u]: ", cmdline, err); FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM|FORMAT_MESSAGE_IGNORE_INSERTS| FORMAT_MESSAGE_MAX_WIDTH_MASK, 0L, err, 0, (LPSTR)&msg[chars], @@ -318,11 +318,11 @@ CheckForCompilerFeature( */ return !(strstr(Out.buffer, "D4002") != NULL - || strstr(Err.buffer, "D4002") != NULL - || strstr(Out.buffer, "D9002") != NULL - || strstr(Err.buffer, "D9002") != NULL - || strstr(Out.buffer, "D2021") != NULL - || strstr(Err.buffer, "D2021") != NULL); + || strstr(Err.buffer, "D4002") != NULL + || strstr(Out.buffer, "D9002") != NULL + || strstr(Err.buffer, "D9002") != NULL + || strstr(Out.buffer, "D2021") != NULL + || strstr(Err.buffer, "D2021") != NULL); } static int @@ -405,7 +405,7 @@ CheckForLinkerFeature( if (!ok) { DWORD err = GetLastError(); int chars = snprintf(msg, sizeof(msg) - 1, - "Tried to launch: \"%s\", but got error [%lu]: ", cmdline, err); + "Tried to launch: \"%s\", but got error [%u]: ", cmdline, err); FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM|FORMAT_MESSAGE_IGNORE_INSERTS| FORMAT_MESSAGE_MAX_WIDTH_MASK, 0L, err, 0, (LPSTR)&msg[chars], @@ -600,9 +600,9 @@ list_free(list_item_t **listPtrPtr) * * Usage is something like: * nmakehlp -S << $** > $@ - * @PACKAGE_NAME@ $(PACKAGE_NAME) - * @PACKAGE_VERSION@ $(PACKAGE_VERSION) - * << + * @PACKAGE_NAME@ $(PACKAGE_NAME) + * @PACKAGE_VERSION@ $(PACKAGE_VERSION) + * << */ static int @@ -730,7 +730,7 @@ static int LocateDependencyHelper(const char *dir, const char *keypath) return 2; /* Have no real error reporting mechanism into nmake */ } dirlen = strlen(dir); - if (dirlen > sizeof(path) - 3) { + if ((dirlen + 3) > sizeof(path)) { return 2; } strncpy(path, dir, dirlen); @@ -747,8 +747,9 @@ static int LocateDependencyHelper(const char *dir, const char *keypath) #else hSearch = FindFirstFile(path, &finfo); #endif - if (hSearch == INVALID_HANDLE_VALUE) + if (hSearch == INVALID_HANDLE_VALUE) { return 1; /* Not found */ + } /* Loop through all subdirs checking if the keypath is under there */ ret = 1; /* Assume not found */ @@ -758,11 +759,13 @@ static int LocateDependencyHelper(const char *dir, const char *keypath) * We need to check it is a directory despite the * FindExSearchLimitToDirectories in the above call. See SDK docs */ - if ((finfo.dwFileAttributes & FILE_ATTRIBUTE_DIRECTORY) == 0) + if ((finfo.dwFileAttributes & FILE_ATTRIBUTE_DIRECTORY) == 0) { continue; + } sublen = strlen(finfo.cFileName); - if ((dirlen+1+sublen+1+keylen+1) > sizeof(path)) + if ((dirlen+1+sublen+1+keylen+1) > sizeof(path)) { continue; /* Path does not fit, assume not matched */ + } strncpy(path+dirlen+1, finfo.cFileName, sublen); path[dirlen+1+sublen] = '\\'; strncpy(path+dirlen+1+sublen+1, keypath, keylen+1); @@ -782,13 +785,13 @@ static int LocateDependencyHelper(const char *dir, const char *keypath) * LocateDependency -- * * Locates a dependency for a package. - * keypath - a relative path within the package directory - * that is used to confirm it is the correct directory. + * keypath - a relative path within the package directory + * that is used to confirm it is the correct directory. * The search path for the package directory is currently only - * the parent and grandparent of the current working directory. - * If found, the command prints - * name_DIRPATH=<full path of located directory> - * and returns 0. If not found, does not print anything and returns 1. + * the parent and grandparent of the current working directory. + * If found, the command prints + * name_DIRPATH=<full path of located directory> + * and returns 0. If not found, does not print anything and returns 1. */ static int LocateDependency(const char *keypath) { diff --git a/win/rules.vc b/win/rules.vc index 143ea9e..f1bcf4c 100644 --- a/win/rules.vc +++ b/win/rules.vc @@ -1248,7 +1248,7 @@ TKSTUBLIBNAME = tkstub.lib !endif
!if $(DOING_TK)
-WISH = $(OUT_DIR)\$(WISHNAME)
+WISH = $(OUT_DIR)\$(WISHNAME)
TKSTUBLIB = $(OUT_DIR)\$(TKSTUBLIBNAME)
TKIMPLIB = $(OUT_DIR)\$(TKIMPLIBNAME)
TKLIB = $(OUT_DIR)\$(TKLIBNAME)
@@ -19,17 +19,17 @@ LANGUAGE 0x9, 0x1 /* LANG_ENGLISH, SUBLANG_DEFAULT */ VS_VERSION_INFO VERSIONINFO - FILEVERSION TCL_MAJOR_VERSION,TCL_MINOR_VERSION,TCL_RELEASE_LEVEL,TCL_RELEASE_SERIAL + FILEVERSION TCL_MAJOR_VERSION,TCL_MINOR_VERSION,TCL_RELEASE_LEVEL,TCL_RELEASE_SERIAL PRODUCTVERSION TCL_MAJOR_VERSION,TCL_MINOR_VERSION,TCL_RELEASE_LEVEL,TCL_RELEASE_SERIAL - FILEFLAGSMASK 0x3fL + FILEFLAGSMASK 0x3fL #ifdef DEBUG - FILEFLAGS VS_FF_DEBUG + FILEFLAGS VS_FF_DEBUG #else - FILEFLAGS 0x0L + FILEFLAGS 0x0L #endif - FILEOS VOS__WINDOWS32 - FILETYPE VFT_DLL - FILESUBTYPE 0x0L + FILEOS VOS__WINDOWS32 + FILETYPE VFT_DLL + FILESUBTYPE 0x0L BEGIN BLOCK "StringFileInfo" BEGIN diff --git a/win/tclWinChan.c b/win/tclWinChan.c index 248ca5b..b81af7e 100644 --- a/win/tclWinChan.c +++ b/win/tclWinChan.c @@ -106,23 +106,23 @@ static Tcl_Channel OpenFileChannel(HANDLE handle, char *channelName, */ static const Tcl_ChannelType fileChannelType = { - "file", /* Type name. */ - TCL_CHANNEL_VERSION_5, /* v5 channel */ - NULL, /* Close proc. */ - FileInputProc, /* Input proc. */ - FileOutputProc, /* Output proc. */ - NULL, + "file", + TCL_CHANNEL_VERSION_5, + NULL, /* Deprecated. */ + FileInputProc, + FileOutputProc, + NULL, /* Deprecated. */ NULL, /* Set option proc. */ - FileGetOptionProc, /* Get option proc. */ - FileWatchProc, /* Set up the notifier to watch the channel. */ - FileGetHandleProc, /* Get an OS handle from channel. */ - FileCloseProc, /* close2proc. */ - FileBlockProc, /* Set blocking or non-blocking mode.*/ - NULL, /* flush proc. */ - NULL, /* handler proc. */ - FileWideSeekProc, /* Wide seek proc. */ - FileThreadActionProc, /* Thread action proc. */ - FileTruncateProc /* Truncate proc. */ + FileGetOptionProc, + FileWatchProc, + FileGetHandleProc, + FileCloseProc, + FileBlockProc, + NULL, /* Flush proc. */ + NULL, /* Bubbled event handler proc. */ + FileWideSeekProc, + FileThreadActionProc, + FileTruncateProc }; /* diff --git a/win/tclWinConsole.c b/win/tclWinConsole.c index 8b289b1..ee04b05 100644 --- a/win/tclWinConsole.c +++ b/win/tclWinConsole.c @@ -176,7 +176,7 @@ typedef struct ConsoleHandleInfo { * is queued and dropped on receipt. */ typedef struct ConsoleChannelInfo { - HANDLE handle; /* Console handle */ + HANDLE handle; /* Console handle */ Tcl_ThreadId threadId; /* Id of owning thread */ struct ConsoleChannelInfo *nextWatchingChannelPtr; /* Pointer to next channel watching events. */ @@ -298,23 +298,23 @@ static ConsoleChannelInfo *gWatchingChannelList; */ static const Tcl_ChannelType consoleChannelType = { - "console", /* Type name. */ - TCL_CHANNEL_VERSION_5, /* v5 channel */ - NULL, /* Close proc. */ - ConsoleInputProc, /* Input proc. */ - ConsoleOutputProc, /* Output proc. */ - NULL, /* Seek proc. */ - ConsoleSetOptionProc, /* Set option proc. */ - ConsoleGetOptionProc, /* Get option proc. */ - ConsoleWatchProc, /* Set up notifier to watch the channel. */ - ConsoleGetHandleProc, /* Get an OS handle from channel. */ - ConsoleCloseProc, /* close2proc. */ - ConsoleBlockModeProc, /* Set blocking or non-blocking mode. */ - NULL, /* Flush proc. */ - NULL, /* Handler proc. */ - NULL, /* Wide seek proc. */ - ConsoleThreadActionProc, /* Thread action proc. */ - NULL /* Truncation proc. */ + "console", + TCL_CHANNEL_VERSION_5, + NULL, /* Deprecated. */ + ConsoleInputProc, + ConsoleOutputProc, + NULL, /* Deprecated. */ + ConsoleSetOptionProc, + ConsoleGetOptionProc, + ConsoleWatchProc, + ConsoleGetHandleProc, + ConsoleCloseProc, + ConsoleBlockModeProc, + NULL, /* Flush proc. */ + NULL, /* Bubbled event handler proc. */ + NULL, /* Seek proc. */ + ConsoleThreadActionProc, + NULL /* Truncation proc. */ }; /* @@ -2067,7 +2067,8 @@ AllocateConsoleHandleInfo( *------------------------------------------------------------------------ */ static ConsoleHandleInfo * -FindConsoleInfo(const ConsoleChannelInfo *chanInfoPtr) +FindConsoleInfo( + const ConsoleChannelInfo *chanInfoPtr) { ConsoleHandleInfo *handleInfoPtr; for (handleInfoPtr = gConsoleHandleInfoList; handleInfoPtr; handleInfoPtr = handleInfoPtr->nextPtr) { diff --git a/win/tclWinPipe.c b/win/tclWinPipe.c index dbf3324..eeb06f8 100644 --- a/win/tclWinPipe.c +++ b/win/tclWinPipe.c @@ -201,23 +201,23 @@ static void PipeThreadActionProc(void *instanceData, */ static const Tcl_ChannelType pipeChannelType = { - "pipe", /* Type name. */ - TCL_CHANNEL_VERSION_5, /* v5 channel */ - NULL, /* Close proc. */ - PipeInputProc, /* Input proc. */ - PipeOutputProc, /* Output proc. */ - NULL, /* Seek proc. */ + "pipe", + TCL_CHANNEL_VERSION_5, + NULL, /* Deprecated. */ + PipeInputProc, + PipeOutputProc, + NULL, /* Deprecated. */ NULL, /* Set option proc. */ NULL, /* Get option proc. */ - PipeWatchProc, /* Set up notifier to watch the channel. */ - PipeGetHandleProc, /* Get an OS handle from channel. */ - PipeClose2Proc, /* close2proc */ - PipeBlockModeProc, /* Set blocking or non-blocking mode.*/ - NULL, /* flush proc. */ - NULL, /* handler proc. */ - NULL, /* wide seek proc */ - PipeThreadActionProc, /* thread action proc */ - NULL /* truncate */ + PipeWatchProc, + PipeGetHandleProc, + PipeClose2Proc, + PipeBlockModeProc, + NULL, /* Flush proc. */ + NULL, /* Bubbled event handler proc. */ + NULL, /* Seek proc. */ + PipeThreadActionProc, + NULL /* Truncate proc. */ }; /* @@ -1462,7 +1462,7 @@ QuoteCmdLineBackslash( Tcl_DStringAppend(dsPtr, start, (int) (current - start)); } } else { - if (bspos > start) { /* part before first backslash */ + if (bspos > start) { /* part before first backslash */ Tcl_DStringAppend(dsPtr, start, (int) (bspos - start)); } while (bspos++ < current) { /* each backslash twice */ @@ -1505,7 +1505,7 @@ QuoteCmdLinePart( TclDStringAppendLiteral(dsPtr, "\""); /* opening escape quote-char */ do { - *bspos = NULL; + *bspos = NULL; special++; if (*special == '\\') { /* @@ -1810,7 +1810,7 @@ TclpCreateCommandChannel( SetThreadPriority(infoPtr->readThread, THREAD_PRIORITY_HIGHEST); infoPtr->validMask |= TCL_READABLE; } else { - infoPtr->readTI = NULL; + infoPtr->readTI = NULL; infoPtr->readThread = 0; } if (writeFile != NULL) { @@ -1825,8 +1825,8 @@ TclpCreateCommandChannel( SetThreadPriority(infoPtr->writeThread, THREAD_PRIORITY_HIGHEST); infoPtr->validMask |= TCL_WRITABLE; } else { - infoPtr->writeTI = NULL; - infoPtr->writeThread = 0; + infoPtr->writeTI = NULL; + infoPtr->writeThread = 0; } /* @@ -3397,10 +3397,10 @@ TclPipeThreadWaitForSignal( if (state != PTI_STATE_STOP) { *pipeTIPtr = NULL; } else { - pipeTI->evWakeUp = NULL; + pipeTI->evWakeUp = NULL; } if (wakeEvent) { - SetEvent(wakeEvent); + SetEvent(wakeEvent); } return 0; } diff --git a/win/tclWinPort.h b/win/tclWinPort.h index 8ab4548..0f22138 100644 --- a/win/tclWinPort.h +++ b/win/tclWinPort.h @@ -114,7 +114,7 @@ typedef DWORD_PTR * PDWORD_PTR; */ #ifndef ENOTEMPTY -# define ENOTEMPTY 41 /* Directory not empty */ +# define ENOTEMPTY 41 /* Directory not empty */ #endif #ifndef EREMOTE # define EREMOTE 66 /* The object is remote */ diff --git a/win/tclWinSerial.c b/win/tclWinSerial.c index e27937e..fe35c36 100644 --- a/win/tclWinSerial.c +++ b/win/tclWinSerial.c @@ -202,23 +202,23 @@ static int SerialBlockingWrite(SerialInfo *infoPtr, LPVOID buf, */ static const Tcl_ChannelType serialChannelType = { - "serial", /* Type name. */ - TCL_CHANNEL_VERSION_5, /* v5 channel */ - NULL, /* Close proc. */ - SerialInputProc, /* Input proc. */ - SerialOutputProc, /* Output proc. */ + "serial", + TCL_CHANNEL_VERSION_5, + NULL, /* Deprecated. */ + SerialInputProc, + SerialOutputProc, + NULL, /* Deprecated. */ + SerialSetOptionProc, + SerialGetOptionProc, + SerialWatchProc, + SerialGetHandleProc, + SerialCloseProc, + SerialBlockProc, + NULL, /* Flush proc. */ + NULL, /* Bubbled event handler proc. */ NULL, /* Seek proc. */ - SerialSetOptionProc, /* Set option proc. */ - SerialGetOptionProc, /* Get option proc. */ - SerialWatchProc, /* Set up notifier to watch the channel. */ - SerialGetHandleProc, /* Get an OS handle from channel. */ - SerialCloseProc, /* close2proc. */ - SerialBlockProc, /* Set blocking or non-blocking mode.*/ - NULL, /* flush proc. */ - NULL, /* handler proc. */ - NULL, /* wide seek proc */ - SerialThreadActionProc, /* thread action proc */ - NULL /* truncate */ + SerialThreadActionProc, + NULL /* Truncate proc. */ }; /* @@ -620,7 +620,7 @@ SerialCloseProc( serialPtr->validMask &= ~TCL_READABLE; if (serialPtr->writeThread) { - TclPipeThreadStop(&serialPtr->writeTI, serialPtr->writeThread); + TclPipeThreadStop(&serialPtr->writeTI, serialPtr->writeThread); CloseHandle(serialPtr->osWrite.hEvent); CloseHandle(serialPtr->evWritable); diff --git a/win/tclWinSock.c b/win/tclWinSock.c index c05f550..11c43f0 100644 --- a/win/tclWinSock.c +++ b/win/tclWinSock.c @@ -270,23 +270,23 @@ static Tcl_DriverGetHandleProc TcpGetHandleProc; */ static const Tcl_ChannelType tcpChannelType = { - "tcp", /* Type name. */ - TCL_CHANNEL_VERSION_5, /* v5 channel */ - NULL, /* Old close proc. Deprecated. */ - TcpInputProc, /* Input proc. */ - TcpOutputProc, /* Output proc. */ + "tcp", + TCL_CHANNEL_VERSION_5, + NULL, /* Deprecated. */ + TcpInputProc, + TcpOutputProc, + NULL, /* Deprecated. */ + TcpSetOptionProc, + TcpGetOptionProc, + TcpWatchProc, + TcpGetHandleProc, + TcpClose2Proc, + TcpBlockModeProc, + NULL, /* Flush proc. */ + NULL, /* Bubbled event handler proc. */ NULL, /* Seek proc. */ - TcpSetOptionProc, /* Set option proc. */ - TcpGetOptionProc, /* Get option proc. */ - TcpWatchProc, /* Initialize notifier. */ - TcpGetHandleProc, /* Get OS handles out of channel. */ - TcpClose2Proc, /* New 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. */ + TcpThreadActionProc, + NULL /* Truncate proc. */ }; /* @@ -618,8 +618,8 @@ TcpBlockModeProc( * return any error code. * * Results: - * 0 if the connection has completed, -1 if still in progress or there is - * an error. + * 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 diff --git a/win/tclWinTime.c b/win/tclWinTime.c index 5636dc0..8cc4489 100644 --- a/win/tclWinTime.c +++ b/win/tclWinTime.c @@ -35,7 +35,7 @@ typedef struct { HANDLE readyEvent; /* System event used to trigger the requesting * thread when the clock calibration procedure * is initialized for the first time. */ - HANDLE exitEvent; /* Event to signal out of an exit handler to + HANDLE exitEvent; /* Event to signal out of an exit handler to * tell the calibration loop to terminate. */ LARGE_INTEGER nominalFreq; /* Nominal frequency of the system performance * counter, that is, the value returned from @@ -109,7 +109,7 @@ static struct { static void StopCalibration(void *clientData); static DWORD WINAPI CalibrationThread(LPVOID arg); -static void UpdateTimeEachSecond(void); +static void UpdateTimeEachSecond(void); static void ResetCounterSamples(unsigned long long fileTime, long long perfCounter, long long perfFreq); static long long AccumulateSample(long long perfCounter, @@ -278,7 +278,7 @@ TclpGetWideClicks(void) wideClick.microsecsScale = 1; return TclpGetMicroseconds(); } else { - return TclpGetMicroseconds(); + return TclpGetMicroseconds(); } } @@ -292,7 +292,7 @@ TclpGetWideClicks(void) * and back. * * Results: - * 1 click in microseconds as double. + * 1 click in microseconds as double. * * Side effects: * None. @@ -304,7 +304,7 @@ double TclpWideClickInMicrosec(void) { if (!wideClick.initialized) { - (void) TclpGetWideClicks(); /* initialize */ + (void) TclpGetWideClicks(); /* initialize */ } return wideClick.microsecsScale; } @@ -870,7 +870,7 @@ UpdateTimeEachSecond(void) if (curFileTime.QuadPart > lastFileTime.QuadPart && curFileTime.QuadPart < lastFileTime.QuadPart + (timeInfo.calibrationInterv * 10000000)) { - /* + /* * Look again in next one second. */ @@ -940,13 +940,13 @@ UpdateTimeEachSecond(void) tdiff = vt0 - curFileTime.QuadPart; if (tdiff > 10000000 || tdiff < -10000000) { - /* + /* * Jump to current system time, use curent estimated frequency. */ - vt0 = curFileTime.QuadPart; + vt0 = curFileTime.QuadPart; } else { - /* + /* * Calculate new frequency and estimate drift to the next second. */ @@ -1015,11 +1015,11 @@ UpdateTimeEachSecond(void) vt1 = vt0 - curFileTime.QuadPart; if (vt1 > 10000000 || vt1 < -10000000) { - /* + /* * Larger jump resp. shift relative new file-time. */ - vt0 = curFileTime.QuadPart; + vt0 = curFileTime.QuadPart; } } } diff --git a/win/tclsh.rc b/win/tclsh.rc index f439d08..77d2d73 100644 --- a/win/tclsh.rc +++ b/win/tclsh.rc @@ -26,17 +26,17 @@ LANGUAGE 0x9, 0x1 /* LANG_ENGLISH, SUBLANG_DEFAULT */ VS_VERSION_INFO VERSIONINFO - FILEVERSION TCL_MAJOR_VERSION,TCL_MINOR_VERSION,TCL_RELEASE_LEVEL,TCL_RELEASE_SERIAL + FILEVERSION TCL_MAJOR_VERSION,TCL_MINOR_VERSION,TCL_RELEASE_LEVEL,TCL_RELEASE_SERIAL PRODUCTVERSION TCL_MAJOR_VERSION,TCL_MINOR_VERSION,TCL_RELEASE_LEVEL,TCL_RELEASE_SERIAL - FILEFLAGSMASK 0x3fL + FILEFLAGSMASK 0x3fL #ifdef DEBUG - FILEFLAGS VS_FF_DEBUG + FILEFLAGS VS_FF_DEBUG #else - FILEFLAGS 0x0L + FILEFLAGS 0x0L #endif - FILEOS VOS__WINDOWS32 - FILETYPE VFT_APP - FILESUBTYPE 0x0L + FILEOS VOS__WINDOWS32 + FILETYPE VFT_APP + FILESUBTYPE 0x0L BEGIN BLOCK "StringFileInfo" BEGIN diff --git a/win/tcltest.rc b/win/tcltest.rc index 847a250..ea55a62 100644 --- a/win/tcltest.rc +++ b/win/tcltest.rc @@ -26,17 +26,17 @@ LANGUAGE 0x9, 0x1 /* LANG_ENGLISH, SUBLANG_DEFAULT */ VS_VERSION_INFO VERSIONINFO - FILEVERSION TCL_MAJOR_VERSION,TCL_MINOR_VERSION,TCL_RELEASE_LEVEL,TCL_RELEASE_SERIAL + FILEVERSION TCL_MAJOR_VERSION,TCL_MINOR_VERSION,TCL_RELEASE_LEVEL,TCL_RELEASE_SERIAL PRODUCTVERSION TCL_MAJOR_VERSION,TCL_MINOR_VERSION,TCL_RELEASE_LEVEL,TCL_RELEASE_SERIAL - FILEFLAGSMASK 0x3fL + FILEFLAGSMASK 0x3fL #ifdef DEBUG - FILEFLAGS VS_FF_DEBUG + FILEFLAGS VS_FF_DEBUG #else - FILEFLAGS 0x0L + FILEFLAGS 0x0L #endif - FILEOS VOS__WINDOWS32 - FILETYPE VFT_APP - FILESUBTYPE 0x0L + FILEOS VOS__WINDOWS32 + FILETYPE VFT_APP + FILESUBTYPE 0x0L BEGIN BLOCK "StringFileInfo" BEGIN |