Many hyperlinks are disabled.
Use anonymous login
to enable hyperlinks.
Comment: | Merge trunk |
---|---|
Downloads: | Tarball | ZIP archive | SQL archive |
Timelines: | family | ancestors | descendants | both | tip-697 |
Files: | files | file ages | folders |
SHA3-256: |
19ff51752bec3accb7a4340c6c52d15c |
User & Date: | jan.nijtmans 2024-06-19 09:25:51 |
2024-06-19
| ||
10:32 | TIP #697: 32-bit truncation in format and scan (let's gain some time) check-in: 810eb78647 user: jan.nijtmans tags: trunk, main | |
09:25 | Merge trunk Closed-Leaf check-in: 19ff51752b user: jan.nijtmans tags: tip-697 | |
2024-06-18
| ||
22:41 | Fix some more indenting check-in: 229a985faf user: jan.nijtmans tags: trunk, main | |
2024-05-31
| ||
14:39 | Rebase to 9.0 check-in: 7083ff878b user: jan.nijtmans tags: tip-697 | |
Changes to compat/fake-rfc2553.c.
︙ | ︙ | |||
39 40 41 42 43 44 45 | TCL_DECLARE_MUTEX(netdbMutex) #ifndef HAVE_GETNAMEINFO #ifndef HAVE_STRLCPY static size_t strlcpy(char *dst, const char *src, size_t siz) { | | | | | | | | | | | | | | | | | | | | | 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 | TCL_DECLARE_MUTEX(netdbMutex) #ifndef HAVE_GETNAMEINFO #ifndef HAVE_STRLCPY static size_t strlcpy(char *dst, const char *src, size_t 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); } /* 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 */ } #endif int fake_getnameinfo(const struct sockaddr *sa, size_t salen, char *host, size_t hostlen, char *serv, size_t servlen, int flags) { struct sockaddr_in *sin = (struct sockaddr_in *)sa; struct hostent *hp; char tmpserv[16]; (void)salen; if (sa->sa_family != AF_UNSPEC && sa->sa_family != AF_INET) |
︙ | ︙ |
Changes to doc/Access.3.
︙ | ︙ | |||
29 30 31 32 33 34 35 | file exists and has read, write and execute permissions, respectively. \fBF_OK\fR just requests a check for the existence of the file. .AP "struct stat" *statPtr out The structure that contains the result. .BE .SH DESCRIPTION .PP | | | 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 | file exists and has read, write and execute permissions, respectively. \fBF_OK\fR just requests a check for the existence of the file. .AP "struct stat" *statPtr out The structure that contains the result. .BE .SH DESCRIPTION .PP 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. .SS "OBSOLETE FUNCTIONS" .PP There are two reasons for calling \fBTcl_Access\fR and \fBTcl_Stat\fR rather than calling system level functions \fBaccess\fR and \fBstat\fR directly. |
︙ | ︙ |
Changes to doc/AddErrInfo.3.
︙ | ︙ | |||
24 25 26 27 28 29 30 | .sp \fBTcl_AppendObjToErrorInfo\fR(\fIinterp, objPtr\fR) .sp \fBTcl_AddObjErrorInfo\fR(\fIinterp, message, length\fR) .sp \fBTcl_SetObjErrorCode\fR(\fIinterp, errorObjPtr\fR) .sp | | | 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 | .sp \fBTcl_AppendObjToErrorInfo\fR(\fIinterp, objPtr\fR) .sp \fBTcl_AddObjErrorInfo\fR(\fIinterp, message, length\fR) .sp \fBTcl_SetObjErrorCode\fR(\fIinterp, errorObjPtr\fR) .sp \fBTcl_SetErrorCode\fR(\fIinterp, element, element, ... \fB(char *)NULL\fR) .sp int \fBTcl_GetErrorLine\fR(\fIinterp\fR) .sp \fBTcl_SetErrorLine\fR(\fIinterp, lineNum\fR) .sp const char * |
︙ | ︙ | |||
63 64 65 66 67 68 69 | The number of bytes to copy from \fImessage\fR when appending to the \fB\-errorinfo\fR return option. If negative, all bytes up to the first null byte are used. .AP Tcl_Obj *errorObjPtr in 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. | | | 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 | The number of bytes to copy from \fImessage\fR when appending to the \fB\-errorinfo\fR return option. If negative, all bytes up to the first null byte are used. .AP Tcl_Obj *errorObjPtr in 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 (char *)NULL. .AP int lineNum The line number of a script where an error occurred. .AP "const char" *script in Pointer to first character in script containing command (must be <= \fIcommand\fR). .AP "const char" *command in Pointer to first character in the command that generated the error; must |
︙ | ︙ |
Changes to doc/Alloc.3.
︙ | ︙ | |||
9 10 11 12 13 14 15 | .BS .SH NAME Tcl_Alloc, Tcl_Free, Tcl_Realloc, Tcl_AttemptAlloc, Tcl_AttemptRealloc, Tcl_GetMemoryInfo \- allocate or free heap memory .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp | | | | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 | .BS .SH NAME Tcl_Alloc, Tcl_Free, Tcl_Realloc, Tcl_AttemptAlloc, Tcl_AttemptRealloc, Tcl_GetMemoryInfo \- allocate or free heap memory .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp void * \fBTcl_Alloc\fR(\fIsize\fR) .sp \fBTcl_Free\fR(\fIptr\fR) .sp void * \fBTcl_Realloc\fR(\fIptr, size\fR) .sp void * \fBTcl_AttemptAlloc\fR(\fIsize\fR) .sp void * \fBTcl_AttemptRealloc\fR(\fIptr, size\fR) .sp \fBTcl_GetMemoryInfo\fR(\fIdsPtr\fR) .fi .SH ARGUMENTS .AS char *size .AP "size_t" size in Size in bytes of the memory block to allocate. .AP void *ptr in Pointer to memory block to free or realloc. .AP Tcl_DString *dsPtr in Initialized DString pointer. .BE .SH DESCRIPTION .PP |
︙ | ︙ |
Changes to doc/Eval.3.
︙ | ︙ | |||
33 34 35 36 37 38 39 | int \fBTcl_GlobalEval\fR(\fIinterp, script\fR) .sp int \fBTcl_GlobalEvalObj\fR(\fIinterp, objPtr\fR) .sp int | | | 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 | int \fBTcl_GlobalEval\fR(\fIinterp, script\fR) .sp int \fBTcl_GlobalEvalObj\fR(\fIinterp, objPtr\fR) .sp int \fBTcl_VarEval\fR(\fIinterp, part, part, ... \fB(char *)NULL\fR) .fi .SH ARGUMENTS .AS Tcl_Interp **termPtr .AP Tcl_Interp *interp in Interpreter in which to execute the script. The interpreter's result is modified to hold the result or error message from the script. .AP Tcl_Obj *objPtr in |
︙ | ︙ | |||
134 135 136 137 138 139 140 | equivalent to using the \fBTCL_EVAL_GLOBAL\fR flag (see below). .PP \fBTcl_VarEval\fR takes any number of string arguments 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. | | | 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 | equivalent to using the \fBTCL_EVAL_GLOBAL\fR flag (see below). .PP \fBTcl_VarEval\fR takes any number of string arguments 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 (char *)NULL to indicate the end of arguments. .SH "FLAG BITS" .PP Any OR'ed combination of the following values may be used for the \fIflags\fR argument to procedures such as \fBTcl_EvalObjEx\fR: .TP 23 |
︙ | ︙ |
Changes to doc/ObjectType.3.
︙ | ︙ | |||
150 151 152 153 154 155 156 | .CE where the contents are exactly the existing contents of the union in the \fIinternalRep\fR field of the \fITcl_Obj\fR struct. 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 | | | 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 | .CE where the contents are exactly the existing contents of the union in the \fIinternalRep\fR field of the \fITcl_Obj\fR struct. 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 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 extensions to look up their Tcl_ObjType by name with the \fBTcl_GetObjType\fR routine. The \fBTcl_ObjType\fR structure is defined as follows: .PP |
︙ | ︙ |
Changes to doc/Preserve.3.
︙ | ︙ | |||
77 78 79 80 81 82 83 | .PP All the work of freeing the object is carried out by \fIfreeProc\fR. \fIFreeProc\fR must have arguments and result that match the type \fBTcl_FreeProc\fR: .PP .CS typedef void \fBTcl_FreeProc\fR( | | < < < | 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 | .PP All the work of freeing the object is carried out by \fIfreeProc\fR. \fIFreeProc\fR must have arguments and result that match the type \fBTcl_FreeProc\fR: .PP .CS typedef void \fBTcl_FreeProc\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. .PP When the \fIclientData\fR argument to \fBTcl_EventuallyFree\fR refers to storage allocated and returned by a prior call to \fBTcl_Alloc\fR or another function of the Tcl library, then the \fIfreeProc\fR argument should be given the special value of \fBTCL_DYNAMIC\fR. .PP |
︙ | ︙ |
Changes to doc/SaveInterpState.3.
1 2 3 | '\" '\" Copyright (c) 1997 Sun Microsystems, Inc. '\" Contributions from Don Porter, NIST, 2004. (not subject to US copyright) | < | < | | | > | | > | > > > > > > > > | > | < > > | | > | > | > | > | | > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 | '\" '\" Copyright (c) 1997 Sun Microsystems, Inc. '\" Contributions from Don Porter, NIST, 2004. (not subject to US copyright) '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH Tcl_SaveInterpState 3 8.1 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME Tcl_SaveInterpState, Tcl_RestoreInterpState, Tcl_DiscardInterpState \- save and restore an interpreter's state .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp Tcl_InterpState \fBTcl_SaveInterpState\fR(\fIinterp, status\fR) .sp int \fBTcl_RestoreInterpState\fR(\fIinterp, state\fR) .sp \fBTcl_DiscardInterpState\fR(\fIstate\fR) .fi .SH ARGUMENTS .AS Tcl_InterpState savedPtr .AP Tcl_Interp *interp in Interpreter for which state should be saved. .AP int status in Return code value to save as part of interpreter state. .AP Tcl_InterpState state in Saved state token to be restored or discarded. .BE .SH DESCRIPTION .PP 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 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_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 \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 |
Changes to doc/SetResult.3.
︙ | ︙ | |||
20 21 22 23 24 25 26 | \fBTcl_GetObjResult\fR(\fIinterp\fR) .sp \fBTcl_SetResult\fR(\fIinterp, result, freeProc\fR) .sp const char * \fBTcl_GetStringResult\fR(\fIinterp\fR) .sp | | | | > | | | | > | | | | > | > | > | > | > | < > | > > > > > > > > | | > > > | > | > > > | | > | | | | > > | > | > > | > > > > | > | | > | > > > > > | > > | | | > | | | | > > > | | < < > | | > | | > > | > | > > | | | > | | | > > > > > > > > > > | > > > > > > > > > > > > > > > > > > | | | > > > > > > > > > > > > > > > > > > > > > > > > > > | 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 | \fBTcl_GetObjResult\fR(\fIinterp\fR) .sp \fBTcl_SetResult\fR(\fIinterp, result, freeProc\fR) .sp const char * \fBTcl_GetStringResult\fR(\fIinterp\fR) .sp \fBTcl_AppendResult\fR(\fIinterp, result, result, ... , \fB(char *)NULL\fR) .sp \fBTcl_ResetResult\fR(\fIinterp\fR) .sp \fBTcl_TransferResult\fR(\fIsourceInterp, code, targetInterp\fR) .sp \fBTcl_AppendElement\fR(\fIinterp, element\fR) .fi .SH ARGUMENTS .AS Tcl_FreeProc sourceInterp out .AP Tcl_Interp *interp out Interpreter whose result is to be modified or read. .AP Tcl_Obj *objPtr in Tcl value to become result for \fIinterp\fR. .AP char *result in String value to become result for \fIinterp\fR or to be appended to the existing result. .AP "const char" *element in String value to append as a list element to the existing result of \fIinterp\fR. .AP Tcl_FreeProc *freeProc in 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 Interpreter that the result and return options should be transferred from. .AP Tcl_Interp *targetInterp in 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 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 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 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 \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 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 \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( void *\fIblockPtr\fR); .CE .PP 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 .SH KEYWORDS append, command, element, list, value, result, return value, interpreter |
Changes to doc/StringObj.3.
︙ | ︙ | |||
15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 | .sp Tcl_Obj * \fBTcl_NewStringObj\fR(\fIbytes, length\fR) .sp Tcl_Obj * \fBTcl_NewUnicodeObj\fR(\fIunicode, numChars\fR) .sp \fBTcl_SetStringObj\fR(\fIobjPtr, bytes, length\fR) .sp \fBTcl_SetUnicodeObj\fR(\fIobjPtr, unicode, numChars\fR) .sp char * \fBTcl_GetStringFromObj\fR(\fIobjPtr, lengthPtr\fR) .sp char * \fBTcl_GetString\fR(\fIobjPtr\fR) | > > | 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 | .sp Tcl_Obj * \fBTcl_NewStringObj\fR(\fIbytes, length\fR) .sp 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 * \fBTcl_GetStringFromObj\fR(\fIobjPtr, lengthPtr\fR) .sp char * \fBTcl_GetString\fR(\fIobjPtr\fR) |
︙ | ︙ | |||
40 41 42 43 44 45 46 47 48 49 50 51 52 | .sp Tcl_Size \fBTcl_GetCharLength\fR(\fIobjPtr\fR) .sp Tcl_Obj * \fBTcl_GetRange\fR(\fIobjPtr, first, last\fR) .sp \fBTcl_AppendToObj\fR(\fIobjPtr, bytes, length\fR) .sp \fBTcl_AppendUnicodeToObj\fR(\fIobjPtr, unicode, numChars\fR) .sp \fBTcl_AppendObjToObj\fR(\fIobjPtr, appendObjPtr\fR) .sp | > > > > | > > > | 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 | .sp Tcl_Size \fBTcl_GetCharLength\fR(\fIobjPtr\fR) .sp 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 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 * \fBTcl_Format\fR(\fIinterp, format, objc, objv\fR) .sp int \fBTcl_AppendFormatToObj\fR(\fIinterp, objPtr, format, objc, objv\fR) .sp 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 \fBTcl_AttemptSetObjLength\fR(\fIobjPtr, newLength\fR) .sp Tcl_Obj * \fBTcl_ConcatObj\fR(\fIobjc, objv\fR) |
︙ | ︙ | |||
238 239 240 241 242 243 244 | \fIobjPtr\fR. .PP \fBTcl_AppendStringsToObj\fR is similar to \fBTcl_AppendToObj\fR 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 | | | 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 | \fIobjPtr\fR. .PP \fBTcl_AppendStringsToObj\fR is similar to \fBTcl_AppendToObj\fR 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 (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. This can be handy when the string to be appended might be very large, but the value being constructed should not be allowed to grow without bound. A common usage is when constructing an error message, where the end result should be kept short enough to be read. |
︙ | ︙ |
Changes to doc/Thread.3.
︙ | ︙ | |||
72 73 74 75 76 77 78 | .AP int *result out The referred storage is used to place the exit code of the thread waited upon into it. .BE .SH INTRODUCTION Beginning with the 8.1 release, the Tcl core is thread safe, which allows you to incorporate Tcl into multithreaded applications without | | < < < | 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 | .AP int *result out The referred storage is used to place the exit code of the thread waited upon into it. .BE .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. .PP An important constraint of the Tcl threads implementation is that \fIonly the thread that created a Tcl interpreter can use that interpreter\fR. In other words, multiple threads can not access the same Tcl interpreter. (However, a single thread can safely create and use multiple interpreters.) .SH DESCRIPTION |
︙ | ︙ |
Changes to doc/chan.n.
1 2 | '\" '\" Copyright (c) 2005-2006 Donal K. Fellows | < | | | | > | | > | < | | | | | > > | | | | | | > > | > | | | > | | | > < > > | | > < | < | < < | > | > > > > > > > | < > < < < > > > > < < > > > > | | > | | | | | | | | > > | > | | > | | > > | | > | | | | | | > | | > | > > | | | > > | | | | > > > | > > > > > | > | > > | | | > > | | < < < | > | < | > | | | | | | | > | | | | | | > | > | > | < > | > > | | | > > | | | > | | | | | | > > | | > | | < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 | '\" '\" Copyright (c) 2005-2006 Donal K. Fellows '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. .TH chan n 8.5 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME chan \- Read, write and manipulate channels .SH SYNOPSIS \fBchan \fIoption\fR ?\fIarg arg ...\fR? .BE .SH DESCRIPTION .PP 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 \fIchannelId\fR . 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 \fIchannelId\fR ?\fIdirection\fR? . 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 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. From 8.6 on (TIP#398), nonblocking channels are no longer switched to blocking mode when exiting; this guarantees a timely exit even when the peer or a communication channel is stalled. To ensure proper flushing of stalled nonblocking channels on exit, one must now either (a) actively switch them back to blocking or (b) use the environment variable \fBTCL_FLUSH_NONBLOCKING_ON_EXIT\fR, which when set and not equal to .QW \fB0\fR restores the previous behavior. .RE .\" METHOD: configure .TP \fBchan configure \fIchannelId\fR ?\fIoptionName\fR? ?\fIvalue\fR? ?\fIoptionName value\fR?... . Query or set the configuration options of the channel named \fIchannelId\fR. .RS .PP 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 . 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 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 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 . 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 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 . 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 \fB\-profile\fI profile\fR . Specifies the encoding profile to be used on the channel. The encoding transforms in use for the channel's input and output will then be subject to the rules of that profile. Any failures will result in a channel error. See \fBPROFILES\fR in the \fBencoding(n)\fR documentation for details about encoding profiles. .VE "TCL8.7 TIP656" .\" OPTION: -translation .TP \fB\-translation\fI translation\fR .TP \fB\-translation\fR \fB{\fIinTranslation outTranslation\fB}\fR . 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 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 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 to \fBiso8859-1\fR. With this one setting, a channel is fully configured for binary input and output: Each byte read from the channel becomes the Unicode character having the same value as that byte, and each character written to the channel becomes a single byte in the output. This makes it possible to work seamlessly with binary data as long as each character 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 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 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 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 \fBchan copy \fIinputChan outputChan\fR ?\fB\-size \fIsize\fR? ?\fB\-command \fIcallback\fR? . Reads characters from \fIinputChan\fR and writes them to \fIoutputChan\fR until all characters are copied, blocking until the copy is complete and returning |
︙ | ︙ | |||
270 271 272 273 274 275 276 | .QW "channel busy" error. .RE .\" METHOD: create .TP \fBchan create \fImode cmdPrefix\fR . | | | > > | > > > > > | > | | > | > | < > > > | > > | | > > | < > > | > > | | | > | | | > | > > > > | | > > | | > | | | | | > | < < | | | > | | | < < < | | < > > > > | | < > | | | < | | | > | | | > | > | | < | > > > > > | > > > | > > > > > | | | > > > | | 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 | .QW "channel busy" error. .RE .\" METHOD: create .TP \fBchan create \fImode cmdPrefix\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 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 , 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 \fIchannelId\fR . 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 \fIchannelId event\fR ?\fIscript\fR? . 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 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" \&. 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 be readable if there is unread data in an input buffer, except in the special case where the most recent attempt to read from the channel was a \fBchan gets\fR call that could not find a complete line in the input buffer. This feature allows a file to be read a line at a time in non-blocking mode using events. A channel is also considered to be readable if an end of file or error condition is present on the underlying file or device. It is important for \fIscript\fR to check for these conditions and handle them appropriately; for example, if 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 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 \fIchannelId\fR . 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 \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 corresponding to end-of-line sequence is not included as part of the line. If the \fIvarName\fR argument is specified, the line is stored in the variable of that name and the command returns the length of the line. If \fIvarName\fR is not specified, the command returns the line itself as the result of the command. |
︙ | ︙ | |||
430 431 432 433 434 435 436 | unchanged and it is possible to introspect, and in some cases recover, by changing the encoding in use. See \fBENCODING ERROR EXAMPLES\fR later. .RE .\" METHOD: names .TP \fBchan names\fR ?\fIpattern\fR? . | | > | | > | < < | < | | | > | < | | < | | | > | | < | | < | > | | | < < | < < < < < < < > | | > | | | | | > | > | < < > | > | | > | < | > > > > > | | > > > | < > > | | | | > | < > | > > | > > | | | > | > > > | | | < > > | | | > > | < | > > > | | | | | | | | > | | | | > | | > > | > | | | | | | > > | | > > > > > > | | > > > > > > > > > | | > > | | | | | > | > | > > > > | > > | > | > | | | | | > | | | > > | | | > > | 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 | unchanged and it is possible to introspect, and in some cases recover, by changing the encoding in use. See \fBENCODING ERROR EXAMPLES\fR later. .RE .\" METHOD: names .TP \fBchan names\fR ?\fIpattern\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 channelId\fR . 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 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 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 \fIchannelId\fR . 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 \fIchannelId eventSpec\fR . 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 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 \fIchannelId cmdPrefix\fR . 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? ?\fIchannelId\fR? \fIstring\fR . 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 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 data cannot be encoded in the encoding configured for the channel. Data may be partially written to the channel in this case. .RE .\" METHOD: read .TP \fBchan read \fIchannelId\fR ?\fInumChars\fR? .TP \fBchan read \fR?\fB\-nonewline\fR? \fIchannelId\fR . 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 \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 When reading from a serial port, most applications should configure the serial port channel to be non-blocking, like this: .PP .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 errors are encountered in the channel input data. If the channel is in blocking mode, the error is thrown after advancing the file pointer to the beginning of the invalid data. The successfully decoded leading portion of the data prior to the error location is returned as the value of the \fB\-data\fR key of the error option dictionary. If the channel is in non-blocking mode, the successfully decoded portion of data is returned by the command without an error exception being raised. A subsequent read will start at the invalid data and immediately raise a \fBEILSEQ\fR POSIX error exception. Unlike the blocking channel case, the \fB\-data\fR key is not present in the error option dictionary. In the case of exception thrown due to encoding errors, it is possible to introspect, and in some cases recover, by changing the encoding in use. See \fBENCODING ERROR EXAMPLES\fR later. .RE .\" METHOD: seek .TP \fBchan seek \fIchannelId offset\fR ?\fIorigin\fR? . 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 new access position will be \fIoffset\fR bytes from the start of the underlying file or device. .IP \fBcurrent\fR 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 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 \fIchannelId\fR . 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 \fIchannelId\fR ?\fIlength\fR? . 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" .PP Instruct Tcl to always send output to \fBstdout\fR immediately, whether or not it is to a terminal: .PP |
︙ | ︙ | |||
749 750 751 752 753 754 755 | .CE .PP A network server that echoes its input line-by-line without preventing servicing of other connections at the same time: .PP .CS # This is a very simple logger... | | | 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 | .CE .PP A network server that echoes its input line-by-line without preventing servicing of other connections at the same time: .PP .CS # This is a very simple logger... proc log {message} { \fBchan puts\fR stdout $message } # This is called whenever a new client connects to the server proc connect {chan host port} { set clientName [format <%s:%d> $host $port] log "connection from $clientName" |
︙ | ︙ | |||
872 873 874 875 876 877 878 | example that when the error is reported the file position remains unchanged so that the \fBchan gets\fR during recovery returns the full line. .PP .CS % set f [open test_A_195_B.txt r] file384b6a8 | | | | | | | 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 | example that when the error is reported the file position remains unchanged so that the \fBchan gets\fR during recovery returns the full line. .PP .CS % set f [open test_A_195_B.txt r] file384b6a8 % chan configure $f -encoding utf-8 % catch {chan gets $f} e d 1 % set d -code 1 -level 0 -errorstack {INNER {invokeStk1 gets file384b6a8}} -errorcode {POSIX EILSEQ {invalid or incomplete multibyte or wide character}} -errorinfo {...} -errorline 1 % chan tell $f 0 % chan configure $f -encoding binary % chan gets $f AÃB .CE .PP The following example is similar to the above but demonstrates recovery after a blocking read. The successfully decoded data "A" is returned in the error options dictionary key \fB\-data\fR. The file position is advanced on the encoding error position 1. The data at the error position is thus recovered by the next \fBchan read\fR command. .PP .CS % set f [open test_A_195_B.txt r] file35a65a0 % chan configure $f -encoding utf-8 -blocking 1 % catch {chan read $f} e d 1 % set d -data A -code 1 -level 0 -errorstack {INNER {invokeStk1 read file35a65a0}} -errorcode {POSIX EILSEQ {invalid or incomplete multibyte or wide character}} -errorinfo {...} -errorline 1 % chan tell $f 1 % chan configure $f -encoding binary % chan read $f ÃB % chan close $f .CE .PP Finally the same example, but this time with a non-blocking channel. .PP .CS % set f [open test_A_195_B.txt r] file35a65a0 % chan configure $f -encoding utf-8 -blocking 0 % chan read $f A % chan tell $f 1 % catch {chan read $f} e d 1 % set d |
︙ | ︙ |
Changes to doc/configurable.n.
1 | '\" | | | 1 2 3 4 5 6 7 8 9 | '\" '\" 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. '\" .TH configurable n 0.4 TclOO "TclOO Commands" .so man.macros .BS |
︙ | ︙ |
Changes to doc/encoding.n.
1 2 | '\" '\" Copyright (c) 1998 Scriptics Corporation. | < | | | < < < < < | < | < < < | < < < < | < | < < > | < < < < | > > | > > | | > | | > | > > | > > | | < | > > | | > > | < > > | | | | > > | > | | < | | | > > > | | > > > > > > > > > > > > > > | > | < < > > | < > > < > > | | > | < | | | | | | | < > | | < | > > > > | > | | | < > | | | < > | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 | '\" '\" Copyright (c) 1998 Scriptics Corporation. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH encoding n "8.1" Tcl "Tcl Built-In Commands" .so man.macros .BS .SH NAME encoding \- Manipulate encodings .SH SYNOPSIS \fBencoding \fIoption\fR ?\fIarg arg ...\fR? .BE .SH INTRODUCTION .PP 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 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 .VE "TCL8.7 TIP607, TIP656" . 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" 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 . 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" 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? . 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 containing the names of all of the encodings that are currently available. The encodings .QW utf-8 and .QW iso8859-1 are guaranteed to be present in the list. .\" METHOD: profiles .TP \fBencoding profiles\fR .VS "TCL8.7 TIP656" 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? . 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" 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" . .IP \(bu .VS "TCL8.7 TIP656" 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" .IP \(bu .VS "TCL8.7 TIP656" 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 . 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 code points comprising a Tcl string. .PP .CS proc codepoints s {join [lmap c [split $s {}] { string cat U+ [format %.6X [scan $c %c]]}] } .CE .PP 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"] U+00306F .CE .PP The result is the unicode codepoint .QW "\eu306F" , which is the Hiragana letter HA. .VS "TCL8.7 TIP607, TIP656" .PP Example 2: Error handling based on profiles: .PP The letter \fBA\fR is Unicode character U+0041 and the byte "\ex80" is invalid |
︙ | ︙ | |||
190 191 192 193 194 195 196 | % codepoints [\fBencoding convertfrom\fR -profile strict ascii A\ex80] unexpected byte sequence starting at index 1: '\ex80' .CE .PP Example 3: Get partial data and the error location: .PP .CS | | | | 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 | % codepoints [\fBencoding convertfrom\fR -profile strict ascii A\ex80] unexpected byte sequence starting at index 1: '\ex80' .CE .PP Example 3: Get partial data and the error location: .PP .CS % codepoints [\fBencoding convertfrom\fR -profile strict -failindex idx ascii AB\ex80] U+000041 U+000042 % set idx 2 .CE .PP Example 4: Encode a character that is not representable in ISO8859-1: .PP .CS % \fBencoding convertto\fR iso8859-1 A\eu0141 A? % \fBencoding convertto\fR -profile strict iso8859-1 A\eu0141 unexpected character at index 1: 'U+000141' % \fBencoding convertto\fR -profile strict -failindex idx iso8859-1 A\eu0141 A % set idx 1 .CE .VE "TCL8.7 TIP607, TIP656" .PP .SH "SEE ALSO" Tcl_GetEncoding(3), fconfigure(n) .SH KEYWORDS encoding, unicode .\" Local Variables: .\" mode: nroff .\" End: |
Changes to doc/expr.n.
︙ | ︙ | |||
329 330 331 332 333 334 335 | tcl::mathfunc::hypot $x $y .CE .PP See the \fBmathfunc\fR(n) documentation for the math functions that are available by default. .SS "TYPES, OVERFLOW, AND PRECISION" .PP | < < < < < < < < | 329 330 331 332 333 334 335 336 337 338 339 340 341 342 | tcl::mathfunc::hypot $x $y .CE .PP See the \fBmathfunc\fR(n) documentation for the math functions that are available by default. .SS "TYPES, OVERFLOW, AND PRECISION" .PP Internal floating-point computations are performed using the \fIdouble\fR C type. When converting a string to floating-point value, exponent overflow is detected and results in the \fIdouble\fR value of \fBInf\fR or \fB\-Inf\fR as appropriate. Floating-point overflow and underflow are detected to the degree supported by the hardware, which is generally fairly reliable. |
︙ | ︙ |
Changes to doc/http.n.
︙ | ︙ | |||
255 256 257 258 259 260 261 | .\" OPTION: -useragent .TP \fB\-useragent\fI string\fR . 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) | | | 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 | .\" OPTION: -useragent .TP \fB\-useragent\fI string\fR . 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.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. .\" OPTION: -zip .TP \fB\-zip\fI boolean\fR . |
︙ | ︙ |
Changes to doc/safe.n.
︙ | ︙ | |||
507 508 509 510 511 512 513 | Example of use with "Sync Mode" off: when initializing a safe interpreter with a non-empty access path, the ::auto_path will be set to {} unless its own value is also specified: .RS .PP .CS safe::interpCreate foo -accessPath { | | | | | | | | | | | | | | 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 | Example of use with "Sync Mode" off: when initializing a safe interpreter with a non-empty access path, the ::auto_path will be set to {} unless its own value is also specified: .RS .PP .CS safe::interpCreate foo -accessPath { /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/tcl9.0 /usr/local/TclHome/lib } # The two commands can be combined: safe::interpCreate foo -accessPath { /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/tcl9.0 /usr/local/TclHome/lib } .CE .RE .PP Example of use with "Sync Mode" off: the command \fBsafe::interpAddToAccessPath\fR does not change the safe interpreter's |
︙ | ︙ |
Changes to doc/scan.n.
︙ | ︙ | |||
69 70 71 72 73 74 75 | at most once and the empty positions will be filled in with empty strings. .SS "OPTIONAL SIZE MODIFIER" .PP 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. | | | | | | < | | | | | > > | 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 | at most once and the empty positions will be filled in with empty strings. .SS "OPTIONAL SIZE MODIFIER" .PP 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, \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: .IP \fBd\fR The input substring must be a decimal integer. It is read in and the integer value is stored in the variable, truncated as required by the size modifier value. |
︙ | ︙ |
Changes to doc/socket.n.
︙ | ︙ | |||
257 258 259 260 261 262 263 | set sockChan [\fBsocket\fR $server 9900] gets $sockChan line1 gets $sockChan line2 close $sockChan puts "The time on $server is $line1" puts "That is [lindex $line2 0]s since the server started" .CE | < < | 257 258 259 260 261 262 263 264 265 266 267 268 269 270 | set sockChan [\fBsocket\fR $server 9900] gets $sockChan line1 gets $sockChan line2 close $sockChan puts "The time on $server is $line1" puts "That is [lindex $line2 0]s since the server started" .CE .SH "SEE ALSO" chan(n), flush(n), open(n), read(n) .SH KEYWORDS asynchronous I/O, bind, channel, connection, domain name, host, network address, socket, tcp '\" Local Variables: '\" mode: nroff |
︙ | ︙ |
Changes to doc/transchan.n.
︙ | ︙ | |||
8 9 10 11 12 13 14 | .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME transchan \- command handler API of channel transforms .SH SYNOPSIS .nf | | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME transchan \- command handler API of channel transforms .SH SYNOPSIS .nf \fBchan push \fIchannelId cmdPrefix\fR \fIcmdPrefix \fBclear \fIhandle\fR \fIcmdPrefix \fBdrain \fIhandle\fR \fIcmdPrefix \fBfinalize \fIhandle\fR \fIcmdPrefix \fBflush \fIhandle\fR \fIcmdPrefix \fBinitialize \fIhandle mode\fR \fIcmdPrefix \fBlimit? \fIhandle\fR |
︙ | ︙ |
Changes to generic/regc_color.c.
︙ | ︙ | |||
426 427 428 429 430 431 432 | return sco; } /* - subrange - allocate new subcolors to this range of chrs, fill in arcs ^ static void subrange(struct vars *, pchr, pchr, struct state *, | | | 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 | return sco; } /* - subrange - allocate new subcolors to this range of chrs, fill in arcs ^ static void subrange(struct vars *, pchr, pchr, struct state *, ^ struct state *); */ static void subrange( struct vars *v, pchr from, pchr to, struct state *lp, |
︙ | ︙ | |||
685 686 687 688 689 690 691 | a->colorchain = NULL; /* paranoia */ a->colorchainRev = NULL; } /* - rainbow - add arcs of all full colors (but one) between specified states ^ static void rainbow(struct nfa *, struct colormap *, int, pcolor, | | | 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 | a->colorchain = NULL; /* paranoia */ a->colorchainRev = NULL; } /* - 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 *); */ static void rainbow( struct nfa *nfa, struct colormap *cm, int type, pcolor but, /* COLORLESS if no exceptions */ |
︙ | ︙ | |||
712 713 714 715 716 717 718 | } } /* - colorcomplement - add arcs of complementary colors * The calling sequence ought to be reconciled with cloneouts(). ^ static void colorcomplement(struct nfa *, struct colormap *, int, | | | 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 | } } /* - 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 *); */ static void colorcomplement( struct nfa *nfa, struct colormap *cm, int type, struct state *of, /* complements of this guy's PLAIN outarcs */ |
︙ | ︙ |
Changes to generic/regc_locale.c.
︙ | ︙ | |||
1183 1184 1185 1186 1187 1188 1189 | } for (i=0 ; i<NUM_UPPER_CHAR ; i++) { addchr(cv, upperCharTable[i]); } } break; case CC_PRINT: | | | | | | | | | | | | | | | | | | | | 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 | } for (i=0 ; i<NUM_UPPER_CHAR ; i++) { addchr(cv, upperCharTable[i]); } } 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; case CC_GRAPH: cv = getcvec(v, NUM_GRAPH_CHAR, NUM_GRAPH_RANGE); if (cv) { for (i=0 ; i<NUM_GRAPH_RANGE ; i++) { addrange(cv, graphRangeTable[i].start, graphRangeTable[i].end); } |
︙ | ︙ |
Changes to generic/regc_nfa.c.
︙ | ︙ | |||
566 567 568 569 570 571 572 | } return NULL; } /* - cparc - allocate a new arc within an NFA, copying details from old one ^ static void cparc(struct nfa *, struct arc *, struct state *, | | | 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 | } return NULL; } /* - cparc - allocate a new arc within an NFA, copying details from old one ^ static void cparc(struct nfa *, struct arc *, struct state *, ^ struct state *); */ static void cparc( struct nfa *nfa, struct arc *oa, struct state *from, struct state *to) |
︙ | ︙ | |||
637 638 639 640 641 642 643 | const struct arc *bb = *((const struct arc * const *) b); /* we check the fields in the order they are most likely to be different */ if (aa->from->no < bb->from->no) { return -1; } if (aa->from->no > bb->from->no) { | | | | | | | 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 | const struct arc *bb = *((const struct arc * const *) b); /* we check the fields in the order they are most likely to be different */ if (aa->from->no < bb->from->no) { return -1; } if (aa->from->no > bb->from->no) { return 1; } if (aa->co < bb->co) { return -1; } if (aa->co > bb->co) { return 1; } if (aa->type < bb->type) { return -1; } if (aa->type > bb->type) { return 1; } return 0; } /* * sortouts - sort the out arcs of a state by to/color/type */ |
︙ | ︙ | |||
1114 1115 1116 1117 1118 1119 1120 | /* With not too many arcs, just do them one at a time */ struct arc *a; for (a = oldState->outs; a != NULL; a = a->outchain) { cparc(nfa, a, newState, a->to); } } else { | | | 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 | /* With not too many arcs, just do them one at a time */ struct arc *a; for (a = oldState->outs; a != NULL; a = a->outchain) { 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. */ struct arc *oa; struct arc *na; |
︙ | ︙ | |||
1173 1174 1175 1176 1177 1178 1179 | } } } /* - cloneouts - copy out arcs of a state to another state pair, modifying type ^ static void cloneouts(struct nfa *, struct state *, struct state *, | | | 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 | } } } /* - 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); */ static void cloneouts( struct nfa *nfa, struct state *old, struct state *from, struct state *to, |
︙ | ︙ | |||
1263 1264 1265 1266 1267 1268 1269 | /* - dupnfa - duplicate sub-NFA * Another recursive traversal, this time using tmp to point to duplicates as * 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 *, | | | 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 | /* - dupnfa - duplicate sub-NFA * Another recursive traversal, this time using tmp to point to duplicates as * 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 *); */ static void dupnfa( struct nfa *nfa, struct state *start, /* duplicate of subNFA starting here */ struct state *stop, /* and stopping here */ struct state *from, /* stringing duplicate from here */ |
︙ | ︙ | |||
1595 1596 1597 1598 1599 1600 1601 | s = newstate(nfa); if (NISERR()) { return 0; } s->tmp = *intermediates; *intermediates = s; } | | | | | 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 | s = newstate(nfa); if (NISERR()) { return 0; } s->tmp = *intermediates; *intermediates = s; } cparc(nfa, con, a->from, s); cparc(nfa, a, s, to); freearc(nfa, a); break; default: assert(NOTREACHED); break; } } /* |
︙ | ︙ | |||
1775 1776 1777 1778 1779 1780 1781 | if (NISERR()) { return 0; } s->tmp = *intermediates; *intermediates = s; } cparc(nfa, con, s, a->to); | | | | | 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 | if (NISERR()) { return 0; } s->tmp = *intermediates; *intermediates = s; } cparc(nfa, con, s, a->to); cparc(nfa, a, from, s); freearc(nfa, a); break; default: assert(NOTREACHED); break; } } /* |
︙ | ︙ | |||
2017 2018 2019 2020 2021 2022 2023 | /* Add s2's original inarcs to arcarray[], but ignore empties */ for (a = inarcsorig[s2->no]; a != NULL; a = a->inchain) { if (a->type != EMPTY) { arcarray[arccount++] = a; } } | | | | | | | 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 | /* Add s2's original inarcs to arcarray[], but ignore empties */ for (a = inarcsorig[s2->no]; a != NULL; a = a->inchain) { if (a->type != EMPTY) { arcarray[arccount++] = a; } } /* 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 */ prevnins = s->nins; /* Add non-duplicate inarcs to target state */ mergeins(nfa, s, arcarray, arccount); |
︙ | ︙ | |||
2181 2182 2183 2184 2185 2186 2187 | for (a = s->outs; a != NULL && !NISERR(); a = nexta) { nexta = a->outchain; if (isconstraintarc(a)) { if (a->to == s) { freearc(nfa, a); } else { hasconstraints = 1; | | | | | | 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 2192 2193 2194 2195 2196 2197 2198 2199 2200 | for (a = s->outs; a != NULL && !NISERR(); a = nexta) { nexta = a->outchain; if (isconstraintarc(a)) { if (a->to == s) { 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); } } /* Nothing to do if no remaining constraint arcs */ if (NISERR() || !hasconstraints) { return; } |
︙ | ︙ | |||
2231 2232 2233 2234 2235 2236 2237 | s->tmp = NULL; if ((s->nins == 0 || s->nouts == 0) && !s->flag) { dropstate(nfa, s); } } if (f != NULL) { | | | 2231 2232 2233 2234 2235 2236 2237 2238 2239 2240 2241 2242 2243 2244 2245 | s->tmp = NULL; if ((s->nins == 0 || s->nouts == 0) && !s->flag) { dropstate(nfa, s); } } if (f != NULL) { dumpnfa(nfa, f); } } /* * findconstraintloop - recursively find a loop of constraint arcs * * If we find a loop, break it by calling breakconstraintloop(), then |
︙ | ︙ | |||
2721 2722 2723 2724 2725 2726 2727 | } nfa->nstates = n; } /* - markreachable - recursive marking of reachable states ^ static void markreachable(struct nfa *, struct state *, struct state *, | | | 2721 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734 2735 | } nfa->nstates = n; } /* - markreachable - recursive marking of reachable states ^ static void markreachable(struct nfa *, struct state *, struct state *, ^ struct state *); */ static void markreachable( struct nfa *nfa, struct state *s, struct state *okay, /* consider only states with this mark */ struct state *mark) /* the value to mark with */ |
︙ | ︙ | |||
2745 2746 2747 2748 2749 2750 2751 | markreachable(nfa, a->to, okay, mark); } } /* - markcanreach - recursive marking of states which can reach here ^ static void markcanreach(struct nfa *, struct state *, struct state *, | | | 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 | markreachable(nfa, a->to, okay, mark); } } /* - markcanreach - recursive marking of states which can reach here ^ static void markcanreach(struct nfa *, struct state *, struct state *, ^ struct state *); */ static void markcanreach( struct nfa *nfa, struct state *s, struct state *okay, /* consider only states with this mark */ struct state *mark) /* the value to mark with */ |
︙ | ︙ |
Changes to generic/regcomp.c.
︙ | ︙ | |||
640 641 642 643 644 645 646 | /* - parse - parse an RE * This is actually just the top level, which parses a bunch of branches tied * 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 *, | | | 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 | /* - parse - parse an RE * This is actually just the top level, which parses a bunch of branches tied * 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 *); */ static struct subre * parse( struct vars *v, int stopper, /* EOS or ')' */ int type, /* LACON (lookahead subRE) or PLAIN */ struct state *init, /* initial state */ |
︙ | ︙ | |||
722 723 724 725 726 727 728 | /* - parsebranch - parse one branch of an RE * This mostly manages concatenation, working closely with parseqatom(). * 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 *, | | | 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 | /* - parsebranch - parse one branch of an RE * This mostly manages concatenation, working closely with parseqatom(). * 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); */ static struct subre * parsebranch( struct vars *v, int stopper, /* EOS or ')' */ int type, /* LACON (lookahead subRE) or PLAIN */ struct state *left, /* leftmost state */ |
︙ | ︙ | |||
771 772 773 774 775 776 777 | /* - parseqatom - parse one quantified atom or constraint of an RE * The bookkeeping near the end cooperates very closely with parsebranch(); in * 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 *, | | | 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 | /* - parseqatom - parse one quantified atom or constraint of an RE * The bookkeeping near the end cooperates very closely with parsebranch(); in * 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 *); */ static void parseqatom( struct vars *v, int stopper, /* EOS or ')' */ int type, /* LACON (lookahead subRE) or PLAIN */ struct state *lp, /* left state to hang it on */ |
︙ | ︙ | |||
1645 1646 1647 1648 1649 1650 1651 | dovec(v, allcases(v, c), lp, rp); } /* - dovec - fill in arcs for each element of a cvec ^ static void dovec(struct vars *, struct cvec *, struct state *, | | | 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 | dovec(v, allcases(v, c), lp, rp); } /* - dovec - fill in arcs for each element of a cvec ^ static void dovec(struct vars *, struct cvec *, struct state *, ^ struct state *); */ static void dovec( struct vars *v, struct cvec *cv, struct state *lp, struct state *rp) |
︙ | ︙ |
Changes to generic/rege_dfa.c.
︙ | ︙ | |||
155 156 157 158 159 160 161 | return NULL; } /* - shortest - shortest-preferred matching engine ^ static chr *shortest(struct vars *, struct dfa *, chr *, chr *, chr *, | | | 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 | return NULL; } /* - shortest - shortest-preferred matching engine ^ static chr *shortest(struct vars *, struct dfa *, chr *, chr *, chr *, ^ chr **, int *); */ static chr * /* endpoint, or NULL */ shortest( struct vars *const v, struct dfa *const d, chr *const start, /* where the match should start */ chr *const min, /* match must end at or after here */ |
︙ | ︙ | |||
304 305 306 307 308 309 310 | } return nopr; } /* - newDFA - set up a fresh DFA ^ static struct dfa *newDFA(struct vars *, struct cnfa *, | | | 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 | } return nopr; } /* - newDFA - set up a fresh DFA ^ static struct dfa *newDFA(struct vars *, struct cnfa *, ^ struct colormap *, struct smalldfa *); */ static struct dfa * newDFA( struct vars *const v, struct cnfa *const cnfa, struct colormap *const cm, struct smalldfa *sml) /* preallocated space, may be NULL */ |
︙ | ︙ | |||
473 474 475 476 477 478 479 | d->lastnopr = NULL; return ss; } /* - miss - handle a cache miss ^ static struct sset *miss(struct vars *, struct dfa *, struct sset *, | | | 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 | d->lastnopr = NULL; return ss; } /* - miss - handle a cache miss ^ static struct sset *miss(struct vars *, struct dfa *, struct sset *, ^ pcolor, chr *, chr *); */ static struct sset * /* NULL if goes to empty set */ miss( struct vars *const v, /* used only for debug flags */ struct dfa *const d, struct sset *const css, const pcolor co, |
︙ | ︙ |
Changes to generic/tcl.h.
︙ | ︙ | |||
1101 1102 1103 1104 1105 1106 1107 | * hash table will attempt to rectify this by * randomising the bits and then using the upper * N bits as the index into the table. * TCL_HASH_KEY_SYSTEM_HASH - If this flag is set then all memory internally * allocated for the hash table that is not for an * entry will use the system heap. * TCL_HASH_KEY_DIRECT_COMPARE - | | | 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 | * hash table will attempt to rectify this by * randomising the bits and then using the upper * N bits as the index into the table. * TCL_HASH_KEY_SYSTEM_HASH - If this flag is set then all memory internally * 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 * by compare of their key.oneWordValue values, * before call of compareKeysProc (much slower * than a direct compare, so it is speed-up only * flag). Don't use it if keys contain values rather * than pointers. */ |
︙ | ︙ | |||
1246 1247 1248 1249 1250 1251 1252 | * dictionaries. These fields should not be accessed by code outside * tclDictObj.c */ typedef struct { void *next; /* Search position for underlying hash * table. */ | | | 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 | * dictionaries. These fields should not be accessed by code outside * tclDictObj.c */ typedef struct { void *next; /* Search position for underlying hash * table. */ 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; /* *---------------------------------------------------------------------------- * Flag values to pass to Tcl_DoOneEvent to disable searches for some kinds of |
︙ | ︙ | |||
1994 1995 1996 1997 1998 1999 2000 | * stream. Tells the conversion routine to * perform any finalization that needs to occur * after the last byte is converted and then to * reset to an initial state. If the source * buffer contains the entire input stream to be * converted, this flag should be set. * TCL_ENCODING_STOPONERROR - Not used any more. | | | 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 | * stream. Tells the conversion routine to * perform any finalization that needs to occur * after the last byte is converted and then to * reset to an initial state. If the source * 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 * 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 * needed. If clear, a byte is reserved in the * dst space for NUL termination, and a * terminating NUL is appended. * TCL_ENCODING_CHAR_LIMIT - If set and dstCharsPtr is not NULL, then |
︙ | ︙ |
Changes to generic/tclArithSeries.c.
︙ | ︙ | |||
227 228 229 230 231 232 233 | } /* *---------------------------------------------------------------------- * * ArithSeriesLen -- * | | | | | | < | | | < | | 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 | } /* *---------------------------------------------------------------------- * * 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. * * 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. * * Side effects: * None. * *---------------------------------------------------------------------- */ static Tcl_WideInt ArithSeriesLenInt( Tcl_WideInt start, Tcl_WideInt end, |
︙ | ︙ | |||
379 380 381 382 383 384 385 | * * NewArithSeriesInt -- * * Creates a new ArithSeries object. The returned object has * refcount = 0. * * Results: | < | | | | 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 | * * NewArithSeriesInt -- * * Creates a new ArithSeries object. The returned object has * refcount = 0. * * Results: * A Tcl_Obj pointer to the created ArithSeries object. * A NULL pointer of the range is invalid. * * Side Effects: * None. * *---------------------------------------------------------------------- */ static Tcl_Obj * NewArithSeriesInt( Tcl_WideInt start, Tcl_WideInt end, |
︙ | ︙ | |||
421 422 423 424 425 426 427 | arithSeriesRepPtr->start = start; arithSeriesRepPtr->end = end; arithSeriesRepPtr->step = step; arithSeriesObj->internalRep.twoPtrValue.ptr1 = arithSeriesRepPtr; arithSeriesObj->internalRep.twoPtrValue.ptr2 = NULL; arithSeriesObj->typePtr = &arithSeriesType; if (length > 0) { | | < | | < | < | 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 | arithSeriesRepPtr->start = start; arithSeriesRepPtr->end = end; arithSeriesRepPtr->step = step; arithSeriesObj->internalRep.twoPtrValue.ptr1 = arithSeriesRepPtr; arithSeriesObj->internalRep.twoPtrValue.ptr2 = NULL; arithSeriesObj->typePtr = &arithSeriesType; if (length > 0) { Tcl_InvalidateStringRep(arithSeriesObj); } return arithSeriesObj; } /* *---------------------------------------------------------------------- * * NewArithSeriesDbl -- * * Creates a new ArithSeries object with doubles. The returned object has * refcount = 0. * * Results: * A Tcl_Obj pointer to the created ArithSeries object. * A NULL pointer of the range is invalid. * * Side Effects: * None. *---------------------------------------------------------------------- */ static Tcl_Obj * NewArithSeriesDbl( double start, double end, double step, Tcl_WideInt len) { |
︙ | ︙ | |||
481 482 483 484 485 486 487 | arithSeriesRepPtr->step = step; arithSeriesRepPtr->precision = maxPrecision(start, end, step); arithSeriesObj->internalRep.twoPtrValue.ptr1 = arithSeriesRepPtr; arithSeriesObj->internalRep.twoPtrValue.ptr2 = NULL; arithSeriesObj->typePtr = &arithSeriesType; if (length > 0) { | | < < | < | | > > | > > | > > > | > < | | < | | < < > | > > | > > | | | > > | | 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 | arithSeriesRepPtr->step = step; arithSeriesRepPtr->precision = maxPrecision(start, end, step); arithSeriesObj->internalRep.twoPtrValue.ptr1 = arithSeriesRepPtr; arithSeriesObj->internalRep.twoPtrValue.ptr2 = NULL; arithSeriesObj->typePtr = &arithSeriesType; if (length > 0) { Tcl_InvalidateStringRep(arithSeriesObj); } return arithSeriesObj; } /* *---------------------------------------------------------------------- * * assignNumber -- * * Create the appropriate Tcl_Obj value for the given numeric values. * Used locally only for decoding [lseq] numeric arguments. * refcount = 0. * * Results: * A Tcl_Obj pointer. No assignment on error. * * Side Effects: * None. *---------------------------------------------------------------------- */ static int assignNumber( Tcl_Interp *interp, int useDoubles, Tcl_WideInt *intNumberPtr, double *dblNumberPtr, Tcl_Obj *numberObj) { void *clientData; int tcl_number_type; 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) { *dblNumberPtr = *(double *)clientData; } else { *dblNumberPtr = (double)*(Tcl_WideInt *)clientData; } } else { if (tcl_number_type == TCL_NUMBER_INT) { *intNumberPtr = *(Tcl_WideInt *)clientData; } else { *intNumberPtr = (Tcl_WideInt)*(double *)clientData; } } return TCL_OK; } /* *---------------------------------------------------------------------- * * TclNewArithSeriesObj -- * * Creates a new ArithSeries object. Some arguments may be NULL and will * be computed based on the other given arguments. * refcount = 0. * * Results: * A Tcl_Obj pointer to the created ArithSeries object. * NULL if the range is invalid. * * Side Effects: * None. *---------------------------------------------------------------------- */ Tcl_Obj * TclNewArithSeriesObj( Tcl_Interp *interp, /* For error reporting */ int useDoubles, /* Flag indicates values start, ** end, step, are treated as doubles */ Tcl_Obj *startObj, /* Starting value */ Tcl_Obj *endObj, /* Ending limit */ Tcl_Obj *stepObj, /* increment value */ Tcl_Obj *lenObj) /* Number of elements */ { double dstart, dend, dstep; Tcl_WideInt start, end, step; Tcl_WideInt len = -1; Tcl_Obj *objPtr; if (startObj) { if (assignNumber(interp, useDoubles, &start, &dstart, startObj) != TCL_OK) { return NULL; } } else { start = 0; dstart = start; } if (stepObj) { if (assignNumber(interp, useDoubles, &step, &dstep, stepObj) != TCL_OK) { return NULL; } if (useDoubles) { step = dstep; } else { dstep = step; } if (dstep == 0) { TclNewObj(objPtr); return objPtr; } } if (endObj) { if (assignNumber(interp, useDoubles, &end, &dend, endObj) != TCL_OK) { return NULL; } } if (lenObj) { if (TCL_OK != Tcl_GetWideIntFromObj(interp, lenObj, &len)) { return NULL; } } if (startObj && endObj) { if (!stepObj) { if (useDoubles) { dstep = (dstart < dend) ? 1.0 : -1.0; |
︙ | ︙ | |||
637 638 639 640 641 642 643 | } } if (len > TCL_SIZE_MAX) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "max length of a Tcl list exceeded", TCL_AUTO_LENGTH)); Tcl_SetErrorCode(interp, "TCL", "MEMORY", (void *)NULL); | | < | < | < | < | | | 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 | } } if (len > TCL_SIZE_MAX) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "max length of a Tcl list exceeded", TCL_AUTO_LENGTH)); Tcl_SetErrorCode(interp, "TCL", "MEMORY", (void *)NULL); return NULL; } objPtr = (useDoubles) ? NewArithSeriesDbl(dstart, dend, dstep, len) : NewArithSeriesInt(start, end, step, len); return objPtr; } /* *---------------------------------------------------------------------- * * TclArithSeriesObjIndex -- * * Returns the element with the specified index in the list * represented by the specified Arithmetic Sequence object. * If the index is out of range, TCL_ERROR is returned, * otherwise TCL_OK is returned and the integer value of the * element is stored in *element. * * Results: * 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. * *---------------------------------------------------------------------- */ int TclArithSeriesObjIndex( TCL_UNUSED(Tcl_Interp *), Tcl_Obj *arithSeriesObj, /* List obj */ |
︙ | ︙ | |||
701 702 703 704 705 706 707 | *---------------------------------------------------------------------- * * ArithSeriesObjLength * * Returns the length of the arithmetic series. * * Results: | < | < | | 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 | *---------------------------------------------------------------------- * * ArithSeriesObjLength * * Returns the length of the arithmetic series. * * Results: * The length of the series as Tcl_WideInt. * * Side Effects: * None. * *---------------------------------------------------------------------- */ Tcl_Size ArithSeriesObjLength( Tcl_Obj *arithSeriesObj) { |
︙ | ︙ | |||
728 729 730 731 732 733 734 | * * TclArithSeriesObjStep -- * * Return a Tcl_Obj with the step value from the give ArithSeries Obj. * refcount = 0. * * Results: | < | | < | | 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 | * * TclArithSeriesObjStep -- * * Return a Tcl_Obj with the step value from the give ArithSeries Obj. * refcount = 0. * * Results: * A Tcl_Obj pointer to the created ArithSeries object. * A NULL pointer of the range is invalid. * * Side Effects: * None. *---------------------------------------------------------------------- */ int TclArithSeriesObjStep( Tcl_Obj *arithSeriesObj, Tcl_Obj **stepObj) |
︙ | ︙ | |||
758 759 760 761 762 763 764 | } /* *---------------------------------------------------------------------- * * SetArithSeriesFromAny -- * | | | | | < | < | | 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 | } /* *---------------------------------------------------------------------- * * 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. * * This function is here just to populate the Type structure. * * Results: * The result is always TCL_ERROR. But see Side Effects. * * Side effects: * Tcl Panic if called. * *---------------------------------------------------------------------- */ static int SetArithSeriesFromAny( TCL_UNUSED(Tcl_Interp *), /* Used for error reporting if not NULL. */ |
︙ | ︙ | |||
848 849 850 851 852 853 854 | TclArithSeriesObjIndex(interp, arithSeriesObj, fromIdx, &startObj); Tcl_IncrRefCount(startObj); TclArithSeriesObjIndex(interp, arithSeriesObj, toIdx, &endObj); Tcl_IncrRefCount(endObj); TclArithSeriesObjStep(arithSeriesObj, &stepObj); Tcl_IncrRefCount(stepObj); | | | | | | | 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 | TclArithSeriesObjIndex(interp, arithSeriesObj, fromIdx, &startObj); Tcl_IncrRefCount(startObj); TclArithSeriesObjIndex(interp, arithSeriesObj, toIdx, &endObj); Tcl_IncrRefCount(endObj); TclArithSeriesObjStep(arithSeriesObj, &stepObj); Tcl_IncrRefCount(stepObj); 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 newSlicePtr ? TCL_OK : TCL_ERROR; } /* * In-place is possible. */ /* |
︙ | ︙ | |||
1059 1060 1061 1062 1063 1064 1065 | TclSetIntObj(stepObj, step); } if (Tcl_IsShared(arithSeriesObj) || (arithSeriesObj->refCount > 1)) { Tcl_Obj *lenObj; TclNewIntObj(lenObj, len); | | | < < | 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 | TclSetIntObj(stepObj, step); } if (Tcl_IsShared(arithSeriesObj) || (arithSeriesObj->refCount > 1)) { Tcl_Obj *lenObj; TclNewIntObj(lenObj, len); resultObj = TclNewArithSeriesObj(interp, isDouble, startObj, endObj, stepObj, lenObj); Tcl_DecrRefCount(lenObj); } else { /* * In-place is possible. */ TclInvalidateStringRep(arithSeriesObj); |
︙ | ︙ | |||
1093 1094 1095 1096 1097 1098 1099 | Tcl_DecrRefCount(startObj); Tcl_DecrRefCount(endObj); Tcl_DecrRefCount(stepObj); *newObjPtr = resultObj; | | | 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 | Tcl_DecrRefCount(startObj); Tcl_DecrRefCount(endObj); Tcl_DecrRefCount(stepObj); *newObjPtr = resultObj; return resultObj ? TCL_OK : TCL_ERROR; } /* *---------------------------------------------------------------------- * * UpdateStringOfArithSeries -- * |
︙ | ︙ | |||
1115 1116 1117 1118 1119 1120 1121 | * Side effects: * The object's string is set to a valid string that results from * the list-to-string conversion. This string will be empty if the * list has no elements. The list internal representation * should not be NULL and we assume it is not NULL. * * Notes: | | | | | | | 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 | * Side effects: * The object's string is set to a valid string that results from * the list-to-string conversion. This string will be empty if the * list has no elements. The list internal representation * 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. * *---------------------------------------------------------------------- */ static void UpdateStringOfArithSeries( Tcl_Obj *arithSeriesObjPtr) { |
︙ | ︙ |
Changes to generic/tclAssembly.c.
︙ | ︙ | |||
47 48 49 50 51 52 53 | * State identified for a basic block's catch context. */ 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 */ | | | 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 | * State identified for a basic block's catch context. */ 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 * may be executed after an exception fires */ } BasicBlockCatchState; /* * Structure that defines a basic block - a linear sequence of bytecode * instructions with no jumps in or out (including not changing the * state of any exception range). |
︙ | ︙ | |||
1926 1927 1928 1929 1930 1931 1932 | */ DEBUG_PRINT("basic block %p has %d exceptions starting at %d\n", curr_bb, exceptionCount, savedExceptArrayNext); curr_bb->foreignExceptionBase = savedExceptArrayNext; curr_bb->foreignExceptionCount = exceptionCount; curr_bb->foreignExceptions = | | | 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 | */ DEBUG_PRINT("basic block %p has %d exceptions starting at %d\n", curr_bb, exceptionCount, savedExceptArrayNext); curr_bb->foreignExceptionBase = savedExceptArrayNext; curr_bb->foreignExceptionCount = exceptionCount; curr_bb->foreignExceptions = (ExceptionRange*)Tcl_Alloc(exceptionCount * sizeof(ExceptionRange)); memcpy(curr_bb->foreignExceptions, envPtr->exceptArrayPtr + savedExceptArrayNext, exceptionCount * sizeof(ExceptionRange)); for (i = 0; i < exceptionCount; ++i) { curr_bb->foreignExceptions[i].nestingLevel -= envPtr->exceptDepth; } envPtr->exceptArrayNext = savedExceptArrayNext; |
︙ | ︙ |
Changes to generic/tclBasic.c.
︙ | ︙ | |||
315 316 317 318 319 320 321 | */ {"append", Tcl_AppendObjCmd, TclCompileAppendCmd, NULL, CMD_IS_SAFE}, {"apply", Tcl_ApplyObjCmd, NULL, TclNRApplyObjCmd, CMD_IS_SAFE}, {"break", Tcl_BreakObjCmd, TclCompileBreakCmd, NULL, CMD_IS_SAFE}, {"catch", Tcl_CatchObjCmd, TclCompileCatchCmd, TclNRCatchObjCmd, CMD_IS_SAFE}, {"concat", Tcl_ConcatObjCmd, TclCompileConcatCmd, NULL, CMD_IS_SAFE}, | | | 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 | */ {"append", Tcl_AppendObjCmd, TclCompileAppendCmd, NULL, CMD_IS_SAFE}, {"apply", Tcl_ApplyObjCmd, NULL, TclNRApplyObjCmd, CMD_IS_SAFE}, {"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}, {"continue", Tcl_ContinueObjCmd, TclCompileContinueCmd, NULL, CMD_IS_SAFE}, {"coroinject", NULL, NULL, TclNRCoroInjectObjCmd, CMD_IS_SAFE}, {"coroprobe", NULL, NULL, TclNRCoroProbeObjCmd, CMD_IS_SAFE}, {"coroutine", NULL, NULL, TclNRCoroutineObjCmd, CMD_IS_SAFE}, {"error", Tcl_ErrorObjCmd, TclCompileErrorCmd, NULL, CMD_IS_SAFE}, {"eval", Tcl_EvalObjCmd, NULL, TclNREvalObjCmd, CMD_IS_SAFE}, {"expr", Tcl_ExprObjCmd, TclCompileExprCmd, TclNRExprObjCmd, CMD_IS_SAFE}, |
︙ | ︙ | |||
341 342 343 344 345 346 347 | {"lindex", Tcl_LindexObjCmd, TclCompileLindexCmd, NULL, CMD_IS_SAFE}, {"linsert", Tcl_LinsertObjCmd, TclCompileLinsertCmd, NULL, CMD_IS_SAFE}, {"list", Tcl_ListObjCmd, TclCompileListCmd, NULL, CMD_IS_SAFE|CMD_COMPILES_EXPANDED}, {"llength", Tcl_LlengthObjCmd, TclCompileLlengthCmd, NULL, CMD_IS_SAFE}, {"lmap", Tcl_LmapObjCmd, TclCompileLmapCmd, TclNRLmapCmd, CMD_IS_SAFE}, {"lpop", Tcl_LpopObjCmd, NULL, NULL, CMD_IS_SAFE}, {"lrange", Tcl_LrangeObjCmd, TclCompileLrangeCmd, NULL, CMD_IS_SAFE}, | | | 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 | {"lindex", Tcl_LindexObjCmd, TclCompileLindexCmd, NULL, CMD_IS_SAFE}, {"linsert", Tcl_LinsertObjCmd, TclCompileLinsertCmd, NULL, CMD_IS_SAFE}, {"list", Tcl_ListObjCmd, TclCompileListCmd, NULL, CMD_IS_SAFE|CMD_COMPILES_EXPANDED}, {"llength", Tcl_LlengthObjCmd, TclCompileLlengthCmd, NULL, CMD_IS_SAFE}, {"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}, {"lrepeat", Tcl_LrepeatObjCmd, NULL, NULL, CMD_IS_SAFE}, {"lreplace", Tcl_LreplaceObjCmd, TclCompileLreplaceCmd, NULL, CMD_IS_SAFE}, {"lreverse", Tcl_LreverseObjCmd, NULL, NULL, CMD_IS_SAFE}, {"lsearch", Tcl_LsearchObjCmd, NULL, NULL, CMD_IS_SAFE}, {"lseq", Tcl_LseqObjCmd, NULL, NULL, CMD_IS_SAFE}, {"lset", Tcl_LsetObjCmd, TclCompileLsetCmd, NULL, CMD_IS_SAFE}, {"lsort", Tcl_LsortObjCmd, NULL, NULL, CMD_IS_SAFE}, |
︙ | ︙ | |||
429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 | {"file", "attributes"}, {"file", "copy"}, {"file", "delete"}, {"file", "dirname"}, {"file", "executable"}, {"file", "exists"}, {"file", "extension"}, {"file", "isdirectory"}, {"file", "isfile"}, {"file", "link"}, {"file", "lstat"}, {"file", "mtime"}, {"file", "mkdir"}, {"file", "nativename"}, {"file", "normalize"}, {"file", "owned"}, {"file", "readable"}, {"file", "readlink"}, {"file", "rename"}, {"file", "rootname"}, {"file", "size"}, {"file", "stat"}, {"file", "tail"}, {"file", "tempdir"}, {"file", "tempfile"}, {"file", "type"}, {"file", "volumes"}, {"file", "writable"}, /* [info] has two unsafe commands */ {"info", "cmdtype"}, {"info", "nameofexecutable"}, /* [tcl::process] has ONLY unsafe commands! */ | > > | 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 | {"file", "attributes"}, {"file", "copy"}, {"file", "delete"}, {"file", "dirname"}, {"file", "executable"}, {"file", "exists"}, {"file", "extension"}, {"file", "home"}, {"file", "isdirectory"}, {"file", "isfile"}, {"file", "link"}, {"file", "lstat"}, {"file", "mtime"}, {"file", "mkdir"}, {"file", "nativename"}, {"file", "normalize"}, {"file", "owned"}, {"file", "readable"}, {"file", "readlink"}, {"file", "rename"}, {"file", "rootname"}, {"file", "size"}, {"file", "stat"}, {"file", "tail"}, {"file", "tempdir"}, {"file", "tempfile"}, {"file", "tildeexpand"}, {"file", "type"}, {"file", "volumes"}, {"file", "writable"}, /* [info] has two unsafe commands */ {"info", "cmdtype"}, {"info", "nameofexecutable"}, /* [tcl::process] has ONLY unsafe commands! */ |
︙ | ︙ | |||
745 746 747 748 749 750 751 | for (p = strchr(buildData, '.'); p++; p = strchr(p, '.')) { if (!strncmp(p, arg, len) && ((p[len] == '.') || (p[len] == '-') || (p[len] == '\0'))) { if (p[len] == '-') { p += len; q = strchr(++p, '.'); if (!q) { | | | 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 | for (p = strchr(buildData, '.'); p++; p = strchr(p, '.')) { if (!strncmp(p, arg, len) && ((p[len] == '.') || (p[len] == '-') || (p[len] == '\0'))) { if (p[len] == '-') { p += len; q = strchr(++p, '.'); if (!q) { q = p + strlen(p); } memcpy(buf, p, q - p); buf[q - p] = '\0'; Tcl_SetObjResult(interp, Tcl_NewStringObj(buf, TCL_INDEX_NONE)); } else { Tcl_SetObjResult(interp, Tcl_NewBooleanObj(1)); } |
︙ | ︙ | |||
8864 8865 8866 8867 8868 8869 8870 | /* * The tailcall data is in a Tcl list: the first element is the * namespace, the rest the command to be tailcalled. */ nsObjPtr = Tcl_NewStringObj(nsPtr->fullName, TCL_INDEX_NONE); listPtr = Tcl_NewListObj(objc, objv); | | | 8866 8867 8868 8869 8870 8871 8872 8873 8874 8875 8876 8877 8878 8879 8880 | /* * The tailcall data is in a Tcl list: the first element is the * namespace, the rest the command to be tailcalled. */ nsObjPtr = Tcl_NewStringObj(nsPtr->fullName, TCL_INDEX_NONE); listPtr = Tcl_NewListObj(objc, objv); TclListObjSetElement(interp, listPtr, 0, nsObjPtr); iPtr->varFramePtr->tailcallPtr = listPtr; } return TCL_RETURN; } /* |
︙ | ︙ |
Changes to generic/tclClock.c.
︙ | ︙ | |||
124 125 126 127 128 129 130 | * is "::tcl::clock::<name>". When NULL marks * the end of the table. */ Tcl_ObjCmdProc *objCmdProc; /* Function that implements the command. This * will always have the ClockClientData sent * 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 | | | 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 | * is "::tcl::clock::<name>". When NULL marks * the end of the table. */ Tcl_ObjCmdProc *objCmdProc; /* Function that implements the command. This * will always have the ClockClientData sent * 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) */ }; static const struct ClockCommand clockCommands[] = { {"add", ClockAddObjCmd, TclCompileBasicMin1ArgCmd, NULL}, {"clicks", ClockClicksObjCmd, TclCompileClockClicksCmd, NULL}, {"format", ClockFormatObjCmd, TclCompileBasicMin1ArgCmd, NULL}, {"getenv", ClockGetenvObjCmd, TclCompileBasicMin1ArgCmd, NULL}, |
︙ | ︙ | |||
253 254 255 256 257 258 259 | /* * Install the commands. */ #define TCL_CLOCK_PREFIX_LEN 14 /* == strlen("::tcl::clock::") */ memcpy(cmdName, "::tcl::clock::", TCL_CLOCK_PREFIX_LEN); for (clockCmdPtr=clockCommands ; clockCmdPtr->name!=NULL ; clockCmdPtr++) { | | | 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 | /* * Install the commands. */ #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; strcpy(cmdName + TCL_CLOCK_PREFIX_LEN, clockCmdPtr->name); if (!(clientData = clockCmdPtr->clientData)) { clientData = data; data->refCount++; } cmdPtr = (Command *)Tcl_CreateObjCommand(interp, cmdName, |
︙ | ︙ | |||
434 435 436 437 438 439 440 | *loaded = 1; if (timezoneObj == dataPtr->lastSetupTimeZoneUnnorm && dataPtr->lastSetupTimeZone != NULL) { return dataPtr->lastSetupTimeZone; } if (timezoneObj == dataPtr->prevSetupTimeZoneUnnorm && dataPtr->prevSetupTimeZone != NULL) { | | | 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 | *loaded = 1; if (timezoneObj == dataPtr->lastSetupTimeZoneUnnorm && dataPtr->lastSetupTimeZone != NULL) { return dataPtr->lastSetupTimeZone; } if (timezoneObj == dataPtr->prevSetupTimeZoneUnnorm && dataPtr->prevSetupTimeZone != NULL) { return dataPtr->prevSetupTimeZone; } if (timezoneObj == dataPtr->gmtSetupTimeZoneUnnorm && dataPtr->gmtSetupTimeZone != NULL) { return dataPtr->literals[LIT_GMT]; } if (timezoneObj == dataPtr->lastSetupTimeZone || timezoneObj == dataPtr->prevSetupTimeZone |
︙ | ︙ | |||
644 645 646 647 648 649 650 | TclSetObjRef(dataPtr->prevUsedLocaleUnnorm, localeObj); return dataPtr->prevUsedLocale; } if ((localeObj->length == 1 /* C */ && strcasecmp(loc, Literals[LIT_C]) == 0) || (dataPtr->defaultLocale && (loc2 = TclGetString(dataPtr->defaultLocale)) | | | 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 | TclSetObjRef(dataPtr->prevUsedLocaleUnnorm, localeObj); return dataPtr->prevUsedLocale; } if ((localeObj->length == 1 /* C */ && strcasecmp(loc, Literals[LIT_C]) == 0) || (dataPtr->defaultLocale && (loc2 = TclGetString(dataPtr->defaultLocale)) && localeObj->length == dataPtr->defaultLocale->length && strcasecmp(loc, loc2) == 0)) { *mcDictObj = dataPtr->defaultLocaleDict; return dataPtr->defaultLocale ? dataPtr->defaultLocale : dataPtr->literals[LIT_C]; } if (localeObj->length == 7 /* current */ |
︙ | ︙ | |||
1319 1320 1321 1322 1323 1324 1325 | /* if loaded (setup already called for this TZ) */ if (loaded) { return callargs[1]; } /* before setup just take a look in TZData variable */ if (Tcl_ObjGetVar2(interp, dataPtr->literals[LIT_TZDATA], timezoneObj, 0)) { | | | | 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 | /* if loaded (setup already called for this TZ) */ if (loaded) { return callargs[1]; } /* 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); return callargs[1]; } /* setup now */ callargs[0] = dataPtr->literals[LIT_SETUPTIMEZONE]; if (Tcl_EvalObjv(interp, 2, callargs, 0) == TCL_OK) { /* save unnormalized last used */ TclSetObjRef(dataPtr->lastSetupTimeZoneUnnorm, timezoneObj); |
︙ | ︙ | |||
3301 3302 3303 3304 3305 3306 3307 | }; int optionIndex; /* Index of an option. */ int saw = 0; /* Flag == 1 if option was seen already. */ Tcl_Size i, baseIdx; Tcl_WideInt baseVal; /* Base time, expressed in seconds from the Epoch */ if (operation == CLC_OP_SCN) { | | | | | 3301 3302 3303 3304 3305 3306 3307 3308 3309 3310 3311 3312 3313 3314 3315 3316 3317 3318 | }; int optionIndex; /* Index of an option. */ int saw = 0; /* Flag == 1 if option was seen already. */ Tcl_Size i, baseIdx; 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; } else { /* clock value (as current base) */ opts->baseObj = objv[(baseIdx = 1)]; saw |= 1 << CLC_ARGS_BASE; } /* * Extract values for the keywords. */ |
︙ | ︙ |
Changes to generic/tclClockFmt.c.
︙ | ︙ | |||
18 19 20 21 22 23 24 25 26 | * Miscellaneous forward declarations and functions used within this file */ 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); TCL_DECLARE_MUTEX(ClockFmtMutex); /* Serializes access to common format list. */ | > > > < < | | > > > > > > > | 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 | * Miscellaneous forward declarations and functions used within this file */ 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. */ #ifndef TCL_CLOCK_FULL_COMPAT #define TCL_CLOCK_FULL_COMPAT 1 #endif /* * Derivation of tclStringHashKeyType with extra memory management trickery. */ 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))) #define WideFieldAt(info, offset) \ ((Tcl_WideInt *) (((char *) (info)) + (offset))) /* |
︙ | ︙ | |||
539 540 541 542 543 544 545 | * The return value is a pointer to the created entry. * *---------------------------------------------------------------------- */ static Tcl_HashEntry * ClockFmtScnStorageAllocProc( | | | 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 | * The return value is a pointer to the created entry. * *---------------------------------------------------------------------- */ static Tcl_HashEntry * ClockFmtScnStorageAllocProc( TCL_UNUSED(Tcl_HashTable *),/* Hash table. */ void *keyPtr) /* Key to store in the hash table entry. */ { ClockFmtScnStorage *fss; const char *string = (const char *) keyPtr; Tcl_HashEntry *hPtr; unsigned size = strlen(string) + 1; unsigned allocsize = sizeof(ClockFmtScnStorage) + sizeof(Tcl_HashEntry); |
︙ | ︙ | |||
754 755 756 757 758 759 760 | * If format object is not localizable, it is equal the given format * pointer (special case to fast fallback by not-localizable formats). * * Results: * Returns tcl object with key or format object if not localizable. * * Side effects: | | | 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 | * If format object is not localizable, it is equal the given format * pointer (special case to fast fallback by not-localizable formats). * * Results: * Returns tcl object with key or format object if not localizable. * * Side effects: * Converts given format object to ClockFmtObjType on demand for caching * the key inside its internal representation. * *---------------------------------------------------------------------- */ Tcl_Obj* ClockFrmObjGetLocFmtKey( |
︙ | ︙ | |||
800 801 802 803 804 805 806 | * reference in the first pointer of internal representation of given * object. * * Results: * Returns scan/format storage pointer to ClockFmtScnStorage. * * Side effects: | | < < < < < | 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 | * reference in the first pointer of internal representation of given * object. * * Results: * Returns scan/format storage pointer to ClockFmtScnStorage. * * Side effects: * Converts given format object to ClockFmtObjType on demand for caching * the format storage reference inside its internal representation. * Increments objRefCount of the ClockFmtScnStorage reference. * *---------------------------------------------------------------------- */ static ClockFmtScnStorage * FindOrCreateFmtScnStorage( Tcl_Interp *interp, Tcl_Obj *objPtr) { const char *strFmt = TclGetString(objPtr); ClockFmtScnStorage *fss = NULL; int isNew; Tcl_HashEntry *hPtr; Tcl_MutexLock(&ClockFmtMutex); /* if not yet initialized */ if (!initialized) { /* initialize hash table */ Tcl_InitCustomHashTable(&FmtScnHashTable, TCL_CUSTOM_TYPE_KEYS, &ClockFmtScnStorageHashKeyType); initialized = 1; } |
︙ | ︙ | |||
1237 1238 1239 1240 1241 1242 1243 | } return TCL_RETURN; } #if 0 /* currently unused */ static int | | > | > > | > | 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 | } return TCL_RETURN; } #if 0 /* currently unused */ static int LocaleListSearch( ClockFmtScnCmdArgs *opts, DateInfo *info, int mcKey, int *val, int minLen, int maxLen) { Tcl_Obj **lstv; Tcl_Size lstc; Tcl_Obj *valObj; /* get msgcat value */ valObj = ClockMCGet(opts, mcKey); |
︙ | ︙ | |||
1412 1413 1414 1415 1416 1417 1418 | * * Find largest part of the input string from start regarding lengths * in the given localized string indexed tree (utf-8, case sensitive). * * Results: * TCL_OK - match found and the index stored in *val, * TCL_RETURN - not matched or ambigous, | | | 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 | * * Find largest part of the input string from start regarding lengths * in the given localized string indexed tree (utf-8, case sensitive). * * Results: * TCL_OK - match found and the index stored in *val, * TCL_RETURN - not matched or ambigous, * TCL_ERROR - in error case. * * Side effects: * Input points to end of the found token in string. * *---------------------------------------------------------------------- */ |
︙ | ︙ | |||
1766 1767 1768 1769 1770 1771 1772 | } /* calendar JD */ yydate.julianDay = intJD; return TCL_OK; } s = p; while (p < end && isdigit(UCHAR(*p))) { | | | 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 | } /* calendar JD */ yydate.julianDay = intJD; return TCL_OK; } s = p; while (p < end && isdigit(UCHAR(*p))) { fractJDDiv *= 10; p++; } if (Clock_str2int(&fractJD, s, p, 1) != TCL_OK) { return TCL_RETURN; } yyInput = p; |
︙ | ︙ | |||
2645 2646 2647 2648 2649 2650 2651 | } else { yyYear += info->dateCentury * 100; } } } if (flags & (CLF_ISO8601WEEK | CLF_ISO8601YEAR)) { if ((flags & (CLF_ISO8601YEAR | CLF_YEAR)) == CLF_YEAR) { | | | | 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 | } else { yyYear += info->dateCentury * 100; } } } if (flags & (CLF_ISO8601WEEK | CLF_ISO8601YEAR)) { if ((flags & (CLF_ISO8601YEAR | CLF_YEAR)) == CLF_YEAR) { /* for calculations expected iso year */ info->date.iso8601Year = yyYear; } else if (info->date.iso8601Year < 100) { if (!(flags & CLF_ISO8601CENTURY)) { if (info->date.iso8601Year >= dataPtr->yearOfCenturySwitch) { info->date.iso8601Year -= 100; } info->date.iso8601Year += dataPtr->currentYearCentury; } else { info->date.iso8601Year += info->dateCentury * 100; } } if ((flags & (CLF_ISO8601YEAR | CLF_YEAR)) == CLF_ISO8601YEAR) { /* for calculations expected year (e. g. CLF_ISO8601WEEK not set) */ yyYear = info->date.iso8601Year; } } } } /* if no time - reset time */ |
︙ | ︙ | |||
2858 2859 2860 2861 2862 2863 2864 | Tcl_WideInt intJD = dateFmt->date.julianDay; int fractJD; /* Convert to JDN parts (regarding start offset) and time fraction */ fractJD = dateFmt->date.secondOfDay - (int)tok->map->offs; /* 0 for calendar or 43200 for astro JD */ if (fractJD < 0) { | | | 2865 2866 2867 2868 2869 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 | Tcl_WideInt intJD = dateFmt->date.julianDay; int fractJD; /* Convert to JDN parts (regarding start offset) and time fraction */ fractJD = dateFmt->date.secondOfDay - (int)tok->map->offs; /* 0 for calendar or 43200 for astro JD */ if (fractJD < 0) { intJD--; fractJD += SECONDS_PER_DAY; } if (fractJD && intJD < 0) { /* avoid jump over 0, by negative JD's */ intJD++; if (intJD == 0) { /* -0.0 / -0.9 has zero integer part, so append "-" extra */ if (FrmResultAllocate(dateFmt, 1) != TCL_OK) { |
︙ | ︙ |
Changes to generic/tclCmdAH.c.
︙ | ︙ | |||
26 27 28 29 30 31 32 | struct ForeachState { Tcl_Obj *bodyPtr; /* The script body of the command. */ Tcl_Size bodyIdx; /* The argument index of the body. */ Tcl_Size j, maxj; /* Number of loop iterations. */ Tcl_Size numLists; /* Count of value lists. */ Tcl_Size *index; /* Array of value list indices. */ | | | 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 | struct ForeachState { Tcl_Obj *bodyPtr; /* The script body of the command. */ Tcl_Size bodyIdx; /* The argument index of the body. */ 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_Obj ***varvList; /* Array of var name lists. */ Tcl_Obj **vCopyList; /* Copies of var name list arguments. */ Tcl_Size *argcList; /* Array of value list sizes. */ Tcl_Obj ***argvList; /* Array of value lists. */ Tcl_Obj **aCopyList; /* Copies of value list arguments. */ Tcl_Obj *resultList; /* List of result values from the loop body, * or NULL if we're not collecting them |
︙ | ︙ |
Changes to generic/tclCmdIL.c.
︙ | ︙ | |||
98 99 100 101 102 103 104 | /* * Definitions for [lseq] command */ static const char *const seq_operations[] = { "..", "to", "count", "by", NULL }; | | < | < < < | | 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 | /* * Definitions for [lseq] command */ static const char *const seq_operations[] = { "..", "to", "count", "by", NULL }; typedef enum { LSEQ_DOTS, LSEQ_TO, LSEQ_COUNT, LSEQ_BY } SequenceOperators; typedef enum { NoneArg, NumericArg, RangeKeywordArg, ErrArg, LastArg = 8 } SequenceDecoded; /* * Forward declarations for procedures defined in this file: */ static int DictionaryCompare(const char *left, const char *right); |
︙ | ︙ | |||
4023 4024 4025 4026 4027 4028 4029 | * Return Value * 0 - failure, unexpected value * 1 - value is a number * 2 - value is an operand keyword * 3 - value is a by keyword * * The decoded value will be assigned to the appropriate | | > | > | > | > > | | | < > > > | > | > | | < < | < | | < | < < < > | < < < < | | < < < < < < | < | < < | > > > > | | > | < | | < < | | | < < < < | < | < | 4019 4020 4021 4022 4023 4024 4025 4026 4027 4028 4029 4030 4031 4032 4033 4034 4035 4036 4037 4038 4039 4040 4041 4042 4043 4044 4045 4046 4047 4048 4049 4050 4051 4052 4053 4054 4055 4056 4057 4058 4059 4060 4061 4062 4063 4064 4065 4066 4067 4068 4069 4070 4071 4072 4073 4074 4075 4076 4077 4078 4079 4080 4081 4082 4083 4084 4085 4086 4087 4088 4089 4090 4091 4092 4093 | * Return Value * 0 - failure, unexpected value * 1 - value is a number * 2 - value is an operand keyword * 3 - value is a by keyword * * The decoded value will be assigned to the appropriate * 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 result = TCL_ERROR; SequenceOperators opmode; void *internalPtr; if (allowedArgs & NumericArg) { /* speed-up a bit (and avoid shimmer for compiled expressions) */ if (TclHasInternalRep(argPtr, &tclExprCodeType)) { goto doExpr; } result = Tcl_GetNumberFromObj(NULL, argPtr, &internalPtr, keywordIndexPtr); if (result == TCL_OK) { *numValuePtr = argPtr; Tcl_IncrRefCount(argPtr); return NumericArg; } } 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; } 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; } 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; } } /* *---------------------------------------------------------------------- * * Tcl_LseqObjCmd -- * |
︙ | ︙ | |||
4148 4149 4150 4151 4152 4153 4154 | Tcl_Obj *const objv[]) /* The argument objects. */ { Tcl_Obj *elementCount = NULL; Tcl_Obj *start = NULL, *end = NULL, *step = NULL; Tcl_WideInt values[5]; Tcl_Obj *numValues[5]; Tcl_Obj *numberObj; | | > | | | | | > | | | | > > | < | | | | | | | | | > | > > > > > | < | | | | | | < < < | < < | | | | | < | | < < < < < < < | 4130 4131 4132 4133 4134 4135 4136 4137 4138 4139 4140 4141 4142 4143 4144 4145 4146 4147 4148 4149 4150 4151 4152 4153 4154 4155 4156 4157 4158 4159 4160 4161 4162 4163 4164 4165 4166 4167 4168 4169 4170 4171 4172 4173 4174 4175 4176 4177 4178 4179 4180 4181 4182 4183 4184 4185 4186 4187 4188 4189 4190 4191 4192 4193 4194 4195 4196 4197 4198 4199 4200 4201 4202 4203 4204 4205 4206 4207 4208 4209 4210 4211 | Tcl_Obj *const objv[]) /* The argument objects. */ { Tcl_Obj *elementCount = NULL; Tcl_Obj *start = NULL, *end = NULL, *step = NULL; Tcl_WideInt values[5]; Tcl_Obj *numValues[5]; Tcl_Obj *numberObj; 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 */ #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 * what kind of argument each one is. Encode each argument as a decimal * digit. */ if (objc > 6) { /* 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; } } /* * The key encoding defines a valid set of arguments, or indicates an * error condition; process the values accordningly. */ switch (arg_key) { /* lseq n */ case 1: start = zero; elementCount = numValues[0]; end = NULL; step = one; break; |
︙ | ︙ | |||
4342 4343 4344 4345 4346 4347 4348 | break; default: goto done; break; } break; | < < < < < < < < < < < < < < < < < < < < < < < < < < > > > > > > > > > > > > > > > > > > > > > > | > > | > > > > > | > | | | | 4319 4320 4321 4322 4323 4324 4325 4326 4327 4328 4329 4330 4331 4332 4333 4334 4335 4336 4337 4338 4339 4340 4341 4342 4343 4344 4345 4346 4347 4348 4349 4350 4351 4352 4353 4354 4355 4356 4357 4358 4359 4360 4361 4362 4363 4364 4365 4366 4367 4368 4369 4370 4371 4372 4373 4374 4375 4376 4377 4378 4379 4380 4381 4382 4383 4384 4385 4386 4387 4388 4389 4390 | break; default: goto done; break; } 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. */ arithSeriesPtr = TclNewArithSeriesObj(interp, useDoubles, start, end, step, elementCount); status = TCL_ERROR; if (arithSeriesPtr) { status = TCL_OK; Tcl_SetObjResult(interp, arithSeriesPtr); } done: // 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); } /* Undef constants */ #undef zero #undef one return status; } /* *---------------------------------------------------------------------- * |
︙ | ︙ |
Changes to generic/tclCmdMZ.c.
︙ | ︙ | |||
2761 2762 2763 2764 2765 2766 2767 | goto str_cmp_args; } i++; if (TclGetWideIntFromObj(interp, objv[i], &wreqlength) != TCL_OK) { return TCL_ERROR; } if ((Tcl_WideUInt)wreqlength > TCL_SIZE_MAX) { | | | | 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 2771 2772 2773 2774 2775 2776 2777 | goto str_cmp_args; } i++; if (TclGetWideIntFromObj(interp, objv[i], &wreqlength) != TCL_OK) { return TCL_ERROR; } if ((Tcl_WideUInt)wreqlength > TCL_SIZE_MAX) { *reqlength = -1; } else { *reqlength = wreqlength; } } else { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad option \"%s\": must be -nocase or -length", string)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "option", string, (char *)NULL); |
︙ | ︙ |
Changes to generic/tclCompCmds.c.
︙ | ︙ | |||
375 376 377 378 379 380 381 | * a non-local variable: upvar from a local one! This consumes the * variable name that was left at stacktop. */ localIndex = TclFindCompiledLocal(varTokenPtr->start, varTokenPtr->size, 1, envPtr); PushStringLiteral(envPtr, "0"); | | | | | 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 | * a non-local variable: upvar from a local one! This consumes the * variable name that was left at stacktop. */ 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); } /* * Prepare for the internal foreach. */ keyVar = AnonymousLocal(envPtr); |
︙ | ︙ | |||
3411 3412 3413 3414 3415 3416 3417 | * * TclLocalScalarFromToken -- * * Get the index into the table of compiled locals that corresponds * to a local scalar variable name. * * Results: | | | | | | 3411 3412 3413 3414 3415 3416 3417 3418 3419 3420 3421 3422 3423 3424 3425 3426 3427 3428 | * * TclLocalScalarFromToken -- * * Get the index into the table of compiled locals that corresponds * 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. * * Side effects: * May add an entry into the table of compiled locals. * *---------------------------------------------------------------------- */ |
︙ | ︙ |
Changes to generic/tclCompile.h.
︙ | ︙ | |||
30 31 32 33 34 35 36 | * what level of tracing is desired: * 0: no compilation tracing * 1: summarize compilation of top level cmds and proc bodies * 2: display all instructions of each ByteCode compiled * This variable is linked to the Tcl variable "tcl_traceCompile". */ | | | | 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 | * what level of tracing is desired: * 0: no compilation tracing * 1: summarize compilation of top level cmds and proc bodies * 2: display all instructions of each ByteCode compiled * This variable is linked to the Tcl variable "tcl_traceCompile". */ MODULE_SCOPE int tclTraceCompile; /* * Variable that controls whether execution tracing is enabled and, if so, * what level of tracing is desired: * 0: no execution tracing * 1: trace invocations of Tcl procs only * 2: trace invocations of all (not compiled away) commands * 3: display each instruction executed * This variable is linked to the Tcl variable "tcl_traceExec". */ MODULE_SCOPE int tclTraceExec; #endif /* * The type of lambda expressions. Note that every lambda will *always* have a * string representation. */ |
︙ | ︙ | |||
321 322 323 324 325 326 327 | int mallocedCodeArray; /* Set 1 if code array was expanded and * codeStart points into the heap.*/ #if TCL_MAJOR_VERSION > 8 int mallocedExceptArray; /* 1 if ExceptionRange array was expanded and * exceptArrayPtr points in heap, else 0. */ #endif LiteralEntry *literalArrayPtr; | | | | 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 | int mallocedCodeArray; /* Set 1 if code array was expanded and * codeStart points into the heap.*/ #if TCL_MAJOR_VERSION > 8 int mallocedExceptArray; /* 1 if ExceptionRange array was expanded and * exceptArrayPtr points in heap, else 0. */ #endif LiteralEntry *literalArrayPtr; /* 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 * array. */ Tcl_Size exceptArrayNext; /* Next free ExceptionRange array index. * exceptArrayNext is the number of ranges and * (exceptArrayNext-1) is the index of the * current range's array entry. */ Tcl_Size exceptArrayEnd; /* Index after the last ExceptionRange array * entry. */ |
︙ | ︙ | |||
478 479 480 481 482 483 484 | unsigned char *codeStart; /* Points to the first byte of the code. This * is just after the final ByteCode member * cmdMapPtr. */ Tcl_Obj **objArrayPtr; /* Points to the start of the literal object * array. This is just after the last code * byte. */ ExceptionRange *exceptArrayPtr; | | | 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 | unsigned char *codeStart; /* Points to the first byte of the code. This * is just after the final ByteCode member * cmdMapPtr. */ Tcl_Obj **objArrayPtr; /* Points to the start of the literal object * array. This is just after the last code * byte. */ ExceptionRange *exceptArrayPtr; /* 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 * array. This is just after the last entry in * the ExceptionRange array. */ unsigned char *codeDeltaStart; /* Points to the first of a sequence of bytes |
︙ | ︙ |
Changes to generic/tclDate.c.
︙ | ︙ | |||
2645 2646 2647 2648 2649 2650 2651 | /* ignore spaces at begin */ yyInput = bypassSpaces(yyInput); /* parse */ status = yyparse(info); if (status == 1) { | | | 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 | /* ignore spaces at begin */ yyInput = bypassSpaces(yyInput); /* parse */ status = yyparse(info); if (status == 1) { const char *msg = NULL; if (info->errFlags & CLF_HAVEDATE) { msg = "more than one date in string"; } else if (info->errFlags & CLF_TIME) { msg = "more than one time of day in string"; } else if (info->errFlags & CLF_ZONE) { msg = "more than one time zone in string"; } else if (info->errFlags & CLF_DAYOFWEEK) { |
︙ | ︙ |
Changes to generic/tclDictObj.c.
︙ | ︙ | |||
76 77 78 79 80 81 82 | {"getdef", DictGetDefCmd, TclCompileDictGetWithDefaultCmd, NULL,NULL,0}, {"getwithdefault", DictGetDefCmd, TclCompileDictGetWithDefaultCmd, NULL, NULL, 0 }, {"incr", DictIncrCmd, TclCompileDictIncrCmd, NULL, NULL, 0 }, {"info", DictInfoCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0 }, {"keys", DictKeysCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0 }, {"lappend", DictLappendCmd, TclCompileDictLappendCmd, NULL, NULL, 0 }, | | | 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 | {"getdef", DictGetDefCmd, TclCompileDictGetWithDefaultCmd, NULL,NULL,0}, {"getwithdefault", DictGetDefCmd, TclCompileDictGetWithDefaultCmd, NULL, NULL, 0 }, {"incr", DictIncrCmd, TclCompileDictIncrCmd, NULL, NULL, 0 }, {"info", DictInfoCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0 }, {"keys", DictKeysCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0 }, {"lappend", DictLappendCmd, TclCompileDictLappendCmd, NULL, 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 }, {"set", DictSetCmd, TclCompileDictSetCmd, NULL, NULL, 0 }, {"size", DictSizeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0 }, {"unset", DictUnsetCmd, TclCompileDictUnsetCmd, NULL, NULL, 0 }, {"update", DictUpdateCmd, TclCompileDictUpdateCmd, NULL, NULL, 0 }, |
︙ | ︙ | |||
125 126 127 128 129 130 131 | * dictionary. Used for doing traversal of the * entries in the order that they are * created. */ ChainEntry *entryChainTail; /* Other end of linked list of all entries in * the dictionary. Used for doing traversal of * the entries in the order that they are * created. */ | | | 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 | * dictionary. Used for doing traversal of the * entries in the order that they are * created. */ ChainEntry *entryChainTail; /* Other end of linked list of all entries in * the dictionary. Used for doing traversal of * the entries in the order that they are * created. */ 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 * dictionaries. */ } Dict; /* |
︙ | ︙ | |||
1054 1055 1056 1057 1058 1059 1060 | * 'tclDicttype'. * * *---------------------------------------------------------------------- */ Tcl_Size | | > | 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 | * 'tclDicttype'. * * *---------------------------------------------------------------------- */ Tcl_Size TclDictGetSize( Tcl_Obj *dictPtr) { Dict *dict; DictGetInternalRep(dictPtr, dict); return dict->table.numEntries; } /* |
︙ | ︙ |
Changes to generic/tclEncoding.c.
︙ | ︙ | |||
30 31 32 33 34 35 36 | * into UTF-8. */ Tcl_EncodingConvertProc *fromUtfProc; /* Function to convert from UTF-8 into * external encoding. */ Tcl_EncodingFreeProc *freeProc; /* If non-NULL, function to call when this * encoding is deleted. */ | | | | 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 | * into UTF-8. */ Tcl_EncodingConvertProc *fromUtfProc; /* Function to convert from UTF-8 into * external encoding. */ Tcl_EncodingFreeProc *freeProc; /* If non-NULL, function to call when this * encoding is deleted. */ void *clientData; /* Arbitrary value associated with encoding * type. Passed to conversion functions. */ 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 * negative. This number can be 1, 2, or 4. */ LengthProc *lengthProc; /* Function to compute length of * null-terminated strings in this encoding. * If nullSize is 1, this is strlen; if |
︙ | ︙ | |||
115 116 117 118 119 120 121 | * conversion. */ char prefixBytes[256]; /* If a byte in the input stream is the first * character of one of the escape sequences in * the following array, the corresponding * entry in this array is 1, otherwise it is * 0. */ int numSubTables; /* Length of following array. */ | | > | 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 | * conversion. */ char prefixBytes[256]; /* If a byte in the input stream is the first * character of one of the escape sequences in * the following array, the corresponding * entry in this array is 1, otherwise it is * 0. */ int numSubTables; /* Length of following array. */ EscapeSubTable subTables[TCLFLEXARRAY]; /* Information about each EscapeSubTable used * by this encoding type. The actual size is * as large as necessary to hold all * EscapeSubTables. */ } EscapeEncodingData; /* * Constants used when loading an encoding file to identify the type of the |
︙ | ︙ | |||
197 198 199 200 201 202 203 | int value; } encodingProfiles[] = { {"replace", TCL_ENCODING_PROFILE_REPLACE}, {"strict", TCL_ENCODING_PROFILE_STRICT}, {"tcl8", TCL_ENCODING_PROFILE_TCL8}, }; | | | | | | | | 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 | int value; } encodingProfiles[] = { {"replace", TCL_ENCODING_PROFILE_REPLACE}, {"strict", TCL_ENCODING_PROFILE_STRICT}, {"tcl8", TCL_ENCODING_PROFILE_TCL8}, }; #define PROFILE_TCL8(flags_) \ (ENCODING_PROFILE_GET(flags_) == TCL_ENCODING_PROFILE_TCL8) #define PROFILE_REPLACE(flags_) \ (ENCODING_PROFILE_GET(flags_) == TCL_ENCODING_PROFILE_REPLACE) #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) /* * The following variable is used in the sparse matrix code for a * TableEncoding to represent a page in the table that has no entries. */ static unsigned short emptyPage[256]; |
︙ | ︙ | |||
255 256 257 258 259 260 261 | static Tcl_EncodingConvertProc UtfToUtf16Proc; static Tcl_EncodingConvertProc UtfToUcs2Proc; static Tcl_EncodingConvertProc UtfToUtfProc; static Tcl_EncodingConvertProc Iso88591FromUtfProc; static Tcl_EncodingConvertProc Iso88591ToUtfProc; /* | | | | | 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 | static Tcl_EncodingConvertProc UtfToUtf16Proc; static Tcl_EncodingConvertProc UtfToUcs2Proc; static Tcl_EncodingConvertProc UtfToUtfProc; 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]. */ static const Tcl_ObjType encodingType = { "encoding", FreeEncodingInternalRep, DupEncodingInternalRep, NULL, |
︙ | ︙ | |||
506 507 508 509 510 511 512 | /* * NOTE: THESE BIT DEFINITIONS SHOULD NOT OVERLAP WITH INTERNAL USE BITS * DEFINED IN tcl.h (TCL_ENCODING_* et al). Be cognizant of this * when adding bits. TODO - should really be defined in a single file. * * To prevent conflicting bits, only define bits within 0xff00 mask here. */ | > | | > | > > | 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 | /* * NOTE: THESE BIT DEFINITIONS SHOULD NOT OVERLAP WITH INTERNAL USE BITS * DEFINED IN tcl.h (TCL_ENCODING_* et al). Be cognizant of this * when adding bits. TODO - should really be defined in a single file. * * To prevent conflicting bits, only define bits within 0xff00 mask here. */ 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) { Tcl_EncodingType type; TableEncodingData *dataPtr; unsigned size; |
︙ | ︙ | |||
561 562 563 564 565 566 567 | type.clientData = INT2PTR(ENCODING_UTF); tclUtf8Encoding = Tcl_CreateEncoding(&type); type.clientData = NULL; type.encodingName = "cesu-8"; Tcl_CreateEncoding(&type); type.toUtfProc = Utf16ToUtfProc; | | | | | | | | | | | | | | 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 | type.clientData = INT2PTR(ENCODING_UTF); tclUtf8Encoding = Tcl_CreateEncoding(&type); type.clientData = NULL; type.encodingName = "cesu-8"; Tcl_CreateEncoding(&type); type.toUtfProc = Utf16ToUtfProc; type.fromUtfProc = UtfToUcs2Proc; type.freeProc = NULL; type.nullSize = 2; type.encodingName = "ucs-2le"; type.clientData = INT2PTR(TCL_ENCODING_LE); Tcl_CreateEncoding(&type); type.encodingName = "ucs-2be"; type.clientData = NULL; Tcl_CreateEncoding(&type); type.encodingName = "ucs-2"; type.clientData = INT2PTR(leFlags); Tcl_CreateEncoding(&type); type.toUtfProc = Utf32ToUtfProc; type.fromUtfProc = UtfToUtf32Proc; type.freeProc = NULL; type.nullSize = 4; type.encodingName = "utf-32le"; type.clientData = INT2PTR(TCL_ENCODING_LE); Tcl_CreateEncoding(&type); type.encodingName = "utf-32be"; type.clientData = NULL; Tcl_CreateEncoding(&type); type.encodingName = "utf-32"; type.clientData = INT2PTR(leFlags); Tcl_CreateEncoding(&type); type.toUtfProc = Utf16ToUtfProc; type.fromUtfProc = UtfToUtf16Proc; type.freeProc = NULL; type.nullSize = 2; type.encodingName = "utf-16le"; type.clientData = INT2PTR(TCL_ENCODING_LE); Tcl_CreateEncoding(&type); type.encodingName = "utf-16be"; type.clientData = NULL; Tcl_CreateEncoding(&type); type.encodingName = "utf-16"; type.clientData = INT2PTR(leFlags); Tcl_CreateEncoding(&type); #ifndef TCL_NO_DEPRECATED type.encodingName = "unicode"; Tcl_CreateEncoding(&type); #endif /* * Need the iso8859-1 encoding in order to process binary data, so force * it to always be embedded. Note that this encoding *must* be a proper * table encoding or some of the escape encodings crash! Hence the ugly |
︙ | ︙ | |||
920 921 922 923 924 925 926 | /* *------------------------------------------------------------------------- * * Tcl_GetEncodingNulLength -- * * Given an encoding, return the number of nul bytes used for the | | | 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 | /* *------------------------------------------------------------------------- * * Tcl_GetEncodingNulLength -- * * Given an encoding, return the number of nul bytes used for the * string termination. * * Results: * The number of nul bytes used for the string termination. * * Side effects: * None. * |
︙ | ︙ | |||
1120 1121 1122 1123 1124 1125 1126 | * "flags" controls the behavior if any of the bytes in * the source buffer are invalid or cannot be represented in utf-8. * Possible flags values: * target encoding. It should be composed by OR-ing the following: * - *At most one* of TCL_ENCODING_PROFILE{DEFAULT,TCL8,STRICT} * * Results: | | | | | | | | < | | | | | | | | | | | | | | 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 | * "flags" controls the behavior if any of the bytes in * the source buffer are invalid or cannot be represented in utf-8. * Possible flags values: * target encoding. It should be composed by OR-ing the following: * - *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. * * 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. * *------------------------------------------------------------------------- */ int Tcl_ExternalToUtfDStringEx( 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. */ Tcl_Size srcLen, /* Source string length in bytes, or < 0 for * encoding-specific string length. */ 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 * be NULL. */ { char *dst; Tcl_EncodingState state; const Encoding *encodingPtr; int result; Tcl_Size dstLen, soFar; |
︙ | ︙ | |||
1227 1228 1229 1230 1231 1232 1233 | Tcl_DStringSetLength(dstPtr, soFar); if (errorLocPtr) { /* * Do not write error message into interpreter if caller * wants to know error location. */ | | > | > | > | 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 | Tcl_DStringSetLength(dstPtr, soFar); if (errorLocPtr) { /* * Do not write error message into interpreter if caller * wants to know error location. */ *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); 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); } } if (result != TCL_OK) { errno = (result == TCL_CONVERT_NOSPACE) ? ENOMEM : EILSEQ; } return result; } |
︙ | ︙ | |||
1283 1284 1285 1286 1287 1288 1289 | int Tcl_ExternalToUtf( TCL_UNUSED(Tcl_Interp *), /* TODO: Re-examine this. */ Tcl_Encoding encoding, /* The encoding for the source string, or NULL * for the default system encoding. */ const char *src, /* Source string in specified encoding. */ | | | > | 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 | int Tcl_ExternalToUtf( TCL_UNUSED(Tcl_Interp *), /* TODO: Re-examine this. */ 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. */ int flags, /* Conversion control flags. */ Tcl_EncodingState *statePtr,/* Place for conversion routine to store state * information used during a piecewise * conversion. Contents of statePtr are * initialized and/or reset by conversion * routine under control of flags argument. */ char *dst, /* Output buffer in which converted string is |
︙ | ︙ | |||
1436 1437 1438 1439 1440 1441 1442 | * Convert a source buffer from UTF-8 to the specified encoding. * The parameter flags controls the behavior, if any of the bytes in * the source buffer are invalid or cannot be represented in the * target encoding. It should be composed by OR-ing the following: * - *At most one* of TCL_ENCODING_PROFILE_* * * Results: | | | | | | | | < | | | | | | | | | | | | | | 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 | * Convert a source buffer from UTF-8 to the specified encoding. * The parameter flags controls the behavior, if any of the bytes in * the source buffer are invalid or cannot be represented in the * target encoding. It should be composed by OR-ing the following: * - *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. * * 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. * *------------------------------------------------------------------------- */ int Tcl_UtfToExternalDStringEx( 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. */ Tcl_Size srcLen, /* Source string length in bytes, or < 0 for * strlen(). */ 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 * be NULL. */ { char *dst; Tcl_EncodingState state; const Encoding *encodingPtr; int result; const char *srcStart = src; |
︙ | ︙ | |||
1543 1544 1545 1546 1547 1548 1549 | Tcl_DStringSetLength(dstPtr, i--); } if (errorLocPtr) { /* * Do not write error message into interpreter if caller * wants to know error location. */ | | > | > | 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 | Tcl_DStringSetLength(dstPtr, i--); } if (errorLocPtr) { /* * Do not write error message into interpreter if caller * wants to know error location. */ *errorLocPtr = result == TCL_OK ? TCL_INDEX_NONE : nBytesProcessed; } else { /* Caller wants error message on failure */ if (result != TCL_OK && interp != NULL) { Tcl_Size pos = Tcl_NumUtfChars(srcStart, nBytesProcessed); int ucs4; char buf[TCL_INTEGER_SPACE]; TclUtfToUniChar(&srcStart[nBytesProcessed], &ucs4); snprintf(buf, sizeof(buf), "%" TCL_SIZE_MODIFIER "d", nBytesProcessed); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "unexpected character at index %" TCL_SIZE_MODIFIER "u: 'U+%06X'", pos, ucs4)); Tcl_SetErrorCode(interp, "TCL", "ENCODING", "ILLEGALSEQUENCE", buf, (void *)NULL); } |
︙ | ︙ | |||
1603 1604 1605 1606 1607 1608 1609 | int Tcl_UtfToExternal( TCL_UNUSED(Tcl_Interp *), /* TODO: Re-examine this. */ Tcl_Encoding encoding, /* The encoding for the converted string, or * NULL for the default system encoding. */ const char *src, /* Source string in UTF-8. */ | | | | 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 | int Tcl_UtfToExternal( TCL_UNUSED(Tcl_Interp *), /* TODO: Re-examine this. */ 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(). */ int flags, /* Conversion control flags. */ Tcl_EncodingState *statePtr,/* Place for conversion routine to store state * information used during a piecewise * conversion. Contents of statePtr are * initialized and/or reset by conversion * routine under control of flags argument. */ char *dst, /* Output buffer in which converted string |
︙ | ︙ | |||
1812 1813 1814 1815 1816 1817 1818 | TclSetProcessGlobalValue(&encodingFileMap, map); } } if ((NULL == chan) && (interp != NULL)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "unknown encoding \"%s\"", name)); | | > | 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 | TclSetProcessGlobalValue(&encodingFileMap, map); } } if ((NULL == chan) && (interp != NULL)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "unknown encoding \"%s\"", name)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ENCODING", name, (void *)NULL); } Tcl_DecrRefCount(fileNameObj); Tcl_DecrRefCount(searchPath); return chan; } |
︙ | ︙ | |||
1886 1887 1888 1889 1890 1891 1892 | case 'E': encoding = LoadEscapeEncoding(name, chan); break; } if ((encoding == NULL) && (interp != NULL)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "invalid encoding file \"%s\"", name)); | | > | 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 | case 'E': encoding = LoadEscapeEncoding(name, chan); break; } 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_CloseEx(NULL, chan, 0); return encoding; } /* |
︙ | ︙ | |||
2276 2277 2278 2279 2280 2281 2282 | /* * To avoid infinite recursion in [encoding system iso2022-*] */ e = (Encoding *) Tcl_GetEncoding(NULL, est.name); if ((e != NULL) && (e->toUtfProc != TableToUtfProc) && (e->toUtfProc != Iso88591ToUtfProc)) { | | | | 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 | /* * To avoid infinite recursion in [encoding system iso2022-*] */ e = (Encoding *) Tcl_GetEncoding(NULL, est.name); if ((e != NULL) && (e->toUtfProc != TableToUtfProc) && (e->toUtfProc != Iso88591ToUtfProc)) { Tcl_FreeEncoding((Tcl_Encoding) e); e = NULL; } est.encodingPtr = e; Tcl_DStringAppend(&escapeData, (char *) &est, sizeof(est)); } } Tcl_Free(argv); Tcl_DStringFree(&lineString); |
︙ | ︙ | |||
2464 2465 2466 2467 2468 2469 2470 | result = TCL_CONVERT_MULTIBYTE; break; } if (dst > dstEnd) { result = TCL_CONVERT_NOSPACE; break; } | > | | | | | | | 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 2491 2492 2493 2494 2495 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 | result = TCL_CONVERT_MULTIBYTE; break; } if (dst > dstEnd) { result = TCL_CONVERT_NOSPACE; break; } 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. */ *dst++ = *src++; } else if ((UCHAR(*src) == 0xC0) && (src + 1 < srcEnd) && (UCHAR(src[1]) == 0x80) && (!(flags & ENCODING_INPUT) || !PROFILE_TCL8(profile))) { /* Special sequence \xC0\x80 */ if (!PROFILE_TCL8(profile) && (flags & ENCODING_INPUT)) { if (PROFILE_REPLACE(profile)) { dst += Tcl_UniCharToUtf(UNICODE_REPLACE_CHAR, dst); src += 2; } else { /* PROFILE_STRICT */ result = TCL_CONVERT_SYNTAX; break; } } else { /* * Convert 0xC080 to real nulls when we are in output mode, * irrespective of the profile. */ *dst++ = 0; |
︙ | ︙ | |||
2505 2506 2507 2508 2509 2510 2511 | * the user has explicitly asked to be told. */ if (flags & ENCODING_INPUT) { /* Incomplete bytes for modified UTF-8 target */ if (PROFILE_STRICT(profile)) { result = (flags & TCL_ENCODING_CHAR_LIMIT) | | | | > | > | > | 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 | * the user has explicitly asked to be told. */ if (flags & ENCODING_INPUT) { /* Incomplete bytes for modified UTF-8 target */ if (PROFILE_STRICT(profile)) { result = (flags & TCL_ENCODING_CHAR_LIMIT) ? TCL_CONVERT_MULTIBYTE : TCL_CONVERT_SYNTAX; break; } } if (PROFILE_REPLACE(profile)) { ch = UNICODE_REPLACE_CHAR; ++src; } else { /* TCL_ENCODING_PROFILE_TCL8 */ char chbuf[2]; chbuf[0] = UCHAR(*src++); chbuf[1] = 0; TclUtfToUniChar(chbuf, &ch); } dst += Tcl_UniCharToUtf(ch, dst); } else { size_t len = TclUtfToUniChar(src, &ch); if (flags & ENCODING_INPUT) { if (((len < 2) && (ch != 0)) || ((ch > 0xFFFF) && !(flags & ENCODING_UTF))) { if (PROFILE_STRICT(profile)) { result = TCL_CONVERT_SYNTAX; break; } else if (PROFILE_REPLACE(profile)) { ch = UNICODE_REPLACE_CHAR; } } } const char *saveSrc = src; src += len; if (!(flags & ENCODING_UTF) && !(flags & ENCODING_INPUT) && (ch > 0x3FF)) { if (ch > 0xFFFF) { /* CESU-8 6-byte sequence for chars > U+FFFF */ ch -= 0x10000; *dst++ = 0xED; *dst++ = (char) (((ch >> 16) & 0x0F) | 0xA0); *dst++ = (char) (((ch >> 10) & 0x3F) | 0x80); ch = (ch & 0x0CFF) | 0xDC00; } *dst++ = (char)(((ch >> 12) | 0xE0) & 0xEF); *dst++ = (char)(((ch >> 6) | 0x80) & 0xBF); *dst++ = (char)((ch | 0x80) & 0xBF); continue; } else if (SURROGATE(ch)) { if (PROFILE_STRICT(profile)) { result = (flags & ENCODING_INPUT) ? TCL_CONVERT_SYNTAX : TCL_CONVERT_UNKNOWN; src = saveSrc; break; } else if (PROFILE_REPLACE(profile)) { ch = UNICODE_REPLACE_CHAR; } } dst += Tcl_UniCharToUtf(ch, dst); |
︙ | ︙ | |||
2585 2586 2587 2588 2589 2590 2591 | * None. * *------------------------------------------------------------------------- */ static int Utf32ToUtfProc( | | | 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 | * None. * *------------------------------------------------------------------------- */ static int Utf32ToUtfProc( 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. */ TCL_UNUSED(Tcl_EncodingState *), char *dst, /* Output buffer in which converted string is * stored. */ int dstLen, /* The maximum length of output buffer in |
︙ | ︙ | |||
2639 2640 2641 2642 2643 2644 2645 | for (numChars = 0; src < srcEnd && numChars <= charLimit; numChars++) { if (dst > dstEnd) { result = TCL_CONVERT_NOSPACE; break; } if (flags & TCL_ENCODING_LE) { | | > | > | 2654 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 | for (numChars = 0; src < srcEnd && numChars <= charLimit; numChars++) { if (dst > dstEnd) { result = TCL_CONVERT_NOSPACE; break; } if (flags & TCL_ENCODING_LE) { 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); } if ((unsigned)ch > 0x10FFFF) { if (PROFILE_STRICT(flags)) { result = TCL_CONVERT_SYNTAX; break; } ch = UNICODE_REPLACE_CHAR; |
︙ | ︙ | |||
2714 2715 2716 2717 2718 2719 2720 | * None. * *------------------------------------------------------------------------- */ static int UtfToUtf32Proc( | | | 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 | * None. * *------------------------------------------------------------------------- */ static int UtfToUtf32Proc( 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. */ TCL_UNUSED(Tcl_EncodingState *), char *dst, /* Output buffer in which converted string is * stored. */ int dstLen, /* The maximum length of output buffer in |
︙ | ︙ | |||
2813 2814 2815 2816 2817 2818 2819 | * None. * *------------------------------------------------------------------------- */ static int Utf16ToUtfProc( | | | 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 | * None. * *------------------------------------------------------------------------- */ static int Utf16ToUtfProc( 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. */ TCL_UNUSED(Tcl_EncodingState *), char *dst, /* Output buffer in which converted string is * stored. */ int dstLen, /* The maximum length of output buffer in |
︙ | ︙ | |||
2871 2872 2873 2874 2875 2876 2877 | srcStart = src; srcEnd = src + srcLen; dstStart = dst; dstEnd = dst + dstLen - TCL_UTF_MAX; | | > | | | | > | > > | 2888 2889 2890 2891 2892 2893 2894 2895 2896 2897 2898 2899 2900 2901 2902 2903 2904 2905 2906 2907 2908 2909 2910 2911 2912 2913 2914 2915 2916 2917 2918 2919 2920 2921 2922 2923 2924 2925 2926 2927 2928 2929 2930 2931 2932 2933 2934 2935 2936 2937 2938 2939 | srcStart = src; srcEnd = src + srcLen; dstStart = dst; dstEnd = dst + dstLen - TCL_UTF_MAX; for (numChars = 0; src < srcEnd && numChars <= charLimit; src += 2, numChars++) { if (dst > dstEnd) { result = TCL_CONVERT_NOSPACE; break; } unsigned short prev = ch; if (flags & TCL_ENCODING_LE) { ch = (src[1] & 0xFF) << 8 | (src[0] & 0xFF); } else { ch = (src[0] & 0xFF) << 8 | (src[1] & 0xFF); } 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 */ 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. */ ch = UNICODE_REPLACE_CHAR; dst--; dst += Tcl_UniCharToUtf(ch, dst); src -= 2; numChars--; continue; } else { /* * Bug [10c2c17c32]. If Hi surrogate not followed by Lo * surrogate, finish 3-byte UTF-8 */ dst += Tcl_UniCharToUtf(-1, dst); } } /* * Special case for 1-byte utf chars for speed. Make sure we work with * unsigned short-size data. |
︙ | ︙ | |||
2991 2992 2993 2994 2995 2996 2997 | * None. * *------------------------------------------------------------------------- */ static int UtfToUtf16Proc( | | | 3012 3013 3014 3015 3016 3017 3018 3019 3020 3021 3022 3023 3024 3025 3026 | * None. * *------------------------------------------------------------------------- */ static int UtfToUtf16Proc( 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. */ TCL_UNUSED(Tcl_EncodingState *), char *dst, /* Output buffer in which converted string is * stored. */ int dstLen, /* The maximum length of output buffer in |
︙ | ︙ | |||
3099 3100 3101 3102 3103 3104 3105 | * None. * *------------------------------------------------------------------------- */ static int UtfToUcs2Proc( | | | 3120 3121 3122 3123 3124 3125 3126 3127 3128 3129 3130 3131 3132 3133 3134 | * None. * *------------------------------------------------------------------------- */ static int UtfToUcs2Proc( 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. */ TCL_UNUSED(Tcl_EncodingState *), char *dst, /* Output buffer in which converted string is * stored. */ int dstLen, /* The maximum length of output buffer in |
︙ | ︙ | |||
3203 3204 3205 3206 3207 3208 3209 | * None. * *------------------------------------------------------------------------- */ static int TableToUtfProc( | | | 3224 3225 3226 3227 3228 3229 3230 3231 3232 3233 3234 3235 3236 3237 3238 | * None. * *------------------------------------------------------------------------- */ static int TableToUtfProc( void *clientData, /* TableEncodingData that specifies * encoding. */ const char *src, /* Source string in specified encoding. */ int srcLen, /* Source string length in bytes. */ int flags, /* Conversion control flags. */ TCL_UNUSED(Tcl_EncodingState *), char *dst, /* Output buffer in which converted string is * stored. */ |
︙ | ︙ | |||
3266 3267 3268 3269 3270 3271 3272 | break; } else if (PROFILE_STRICT(flags)) { result = TCL_CONVERT_SYNTAX; break; } else if (PROFILE_REPLACE(flags)) { ch = UNICODE_REPLACE_CHAR; } else { | | > | 3287 3288 3289 3290 3291 3292 3293 3294 3295 3296 3297 3298 3299 3300 3301 3302 | break; } else if (PROFILE_STRICT(flags)) { result = TCL_CONVERT_SYNTAX; break; } else if (PROFILE_REPLACE(flags)) { ch = UNICODE_REPLACE_CHAR; } else { /* For prefix bytes, we don't fallback to cp1252, see * [1355b9a874] */ ch = byte; } } else { ch = toUnicode[byte][*((unsigned char *)++src)]; } } else { ch = pageZero[byte]; |
︙ | ︙ | |||
3331 3332 3333 3334 3335 3336 3337 | * None. * *------------------------------------------------------------------------- */ static int TableFromUtfProc( | | | 3353 3354 3355 3356 3357 3358 3359 3360 3361 3362 3363 3364 3365 3366 3367 | * None. * *------------------------------------------------------------------------- */ static int TableFromUtfProc( void *clientData, /* TableEncodingData that specifies * encoding. */ const char *src, /* Source string in UTF-8. */ int srcLen, /* Source string length in bytes. */ int flags, /* Conversion control flags. */ TCL_UNUSED(Tcl_EncodingState *), char *dst, /* Output buffer in which converted string is * stored. */ |
︙ | ︙ | |||
3623 3624 3625 3626 3627 3628 3629 | * Memory freed. * *--------------------------------------------------------------------------- */ static void TableFreeProc( | | | 3645 3646 3647 3648 3649 3650 3651 3652 3653 3654 3655 3656 3657 3658 3659 | * Memory freed. * *--------------------------------------------------------------------------- */ static void TableFreeProc( void *clientData) /* TableEncodingData that specifies * encoding. */ { TableEncodingData *dataPtr = (TableEncodingData *)clientData; /* * Make sure we aren't freeing twice on shutdown. [Bug 219314] */ |
︙ | ︙ | |||
3658 3659 3660 3661 3662 3663 3664 | * None. * *------------------------------------------------------------------------- */ static int EscapeToUtfProc( | | | 3680 3681 3682 3683 3684 3685 3686 3687 3688 3689 3690 3691 3692 3693 3694 | * None. * *------------------------------------------------------------------------- */ static int EscapeToUtfProc( void *clientData, /* EscapeEncodingData that specifies * encoding. */ const char *src, /* Source string in specified encoding. */ int srcLen, /* Source string length in bytes. */ int flags, /* Conversion control flags. */ Tcl_EncodingState *statePtr,/* Place for conversion routine to store state * information used during a piecewise * conversion. Contents of statePtr are |
︙ | ︙ | |||
3871 3872 3873 3874 3875 3876 3877 | * None. * *------------------------------------------------------------------------- */ static int EscapeFromUtfProc( | | | 3893 3894 3895 3896 3897 3898 3899 3900 3901 3902 3903 3904 3905 3906 3907 | * None. * *------------------------------------------------------------------------- */ static int EscapeFromUtfProc( void *clientData, /* EscapeEncodingData that specifies * encoding. */ const char *src, /* Source string in UTF-8. */ int srcLen, /* Source string length in bytes. */ int flags, /* Conversion control flags. */ Tcl_EncodingState *statePtr,/* Place for conversion routine to store state * information used during a piecewise * conversion. Contents of statePtr are |
︙ | ︙ | |||
3938 3939 3940 3941 3942 3943 3944 | memcpy(dst, dataPtr->init, dataPtr->initLen); dst += dataPtr->initLen; } else { state = PTR2INT(*statePtr); } encodingPtr = GetTableEncoding(dataPtr, state); | | | 3960 3961 3962 3963 3964 3965 3966 3967 3968 3969 3970 3971 3972 3973 3974 | memcpy(dst, dataPtr->init, dataPtr->initLen); dst += dataPtr->initLen; } else { state = PTR2INT(*statePtr); } encodingPtr = GetTableEncoding(dataPtr, state); tableDataPtr = (TableEncodingData *) encodingPtr->clientData; tablePrefixBytes = tableDataPtr->prefixBytes; tableFromUnicode = (const unsigned short *const *) tableDataPtr->fromUnicode; for (numChars = 0; src < srcEnd; numChars++) { unsigned len; int word; |
︙ | ︙ | |||
3966 3967 3968 3969 3970 3971 3972 | if ((word == 0) && (ch != 0)) { int oldState; const EscapeSubTable *subTablePtr; oldState = state; for (state = 0; state < dataPtr->numSubTables; state++) { encodingPtr = GetTableEncoding(dataPtr, state); | | | | 3988 3989 3990 3991 3992 3993 3994 3995 3996 3997 3998 3999 4000 4001 4002 4003 4004 4005 4006 4007 4008 4009 4010 4011 4012 4013 4014 4015 4016 | if ((word == 0) && (ch != 0)) { int oldState; const EscapeSubTable *subTablePtr; oldState = state; for (state = 0; state < dataPtr->numSubTables; state++) { encodingPtr = GetTableEncoding(dataPtr, state); tableDataPtr = (TableEncodingData *) encodingPtr->clientData; word = tableDataPtr->fromUnicode[(ch >> 8)][ch & 0xFF]; if (word != 0) { break; } } if (word == 0) { state = oldState; if (PROFILE_STRICT(flags)) { result = TCL_CONVERT_UNKNOWN; break; } encodingPtr = GetTableEncoding(dataPtr, state); tableDataPtr = (TableEncodingData *) encodingPtr->clientData; word = tableDataPtr->fallback; } tablePrefixBytes = (const char *) tableDataPtr->prefixBytes; tableFromUnicode = (const unsigned short *const *) tableDataPtr->fromUnicode; |
︙ | ︙ | |||
4082 4083 4084 4085 4086 4087 4088 | * Memory is freed. * *--------------------------------------------------------------------------- */ static void EscapeFreeProc( | | | 4104 4105 4106 4107 4108 4109 4110 4111 4112 4113 4114 4115 4116 4117 4118 | * Memory is freed. * *--------------------------------------------------------------------------- */ static void EscapeFreeProc( void *clientData) /* EscapeEncodingData that specifies * encoding. */ { EscapeEncodingData *dataPtr = (EscapeEncodingData *)clientData; EscapeSubTable *subTablePtr; int i; if (dataPtr == NULL) { |
︙ | ︙ | |||
4287 4288 4289 4290 4291 4292 4293 | * *------------------------------------------------------------------------ */ int TclEncodingProfileNameToId( Tcl_Interp *interp, /* For error messages. May be NULL */ const char *profileName, /* Name of profile */ | | | > | > | > | 4309 4310 4311 4312 4313 4314 4315 4316 4317 4318 4319 4320 4321 4322 4323 4324 4325 4326 4327 4328 4329 4330 4331 4332 4333 4334 4335 4336 4337 4338 4339 4340 4341 4342 4343 4344 4345 4346 4347 4348 4349 4350 | * *------------------------------------------------------------------------ */ int TclEncodingProfileNameToId( Tcl_Interp *interp, /* For error messages. May be NULL */ const char *profileName, /* Name of profile */ int *profilePtr) /* Output */ { size_t i; size_t numProfiles = sizeof(encodingProfiles) / sizeof(encodingProfiles[0]); for (i = 0; i < numProfiles; ++i) { if (!strcmp(profileName, encodingProfiles[i].name)) { *profilePtr = encodingProfiles[i].value; return TCL_OK; } } if (interp) { /* This code assumes at least two profiles :-) */ Tcl_Obj *errorObj = Tcl_ObjPrintf("bad profile name \"%s\": must be", profileName); for (i = 0; i < (numProfiles - 1); ++i) { Tcl_AppendStringsToObj( errorObj, " ", encodingProfiles[i].name, ",", (void *)NULL); } Tcl_AppendStringsToObj( errorObj, " or ", encodingProfiles[numProfiles-1].name, (void *)NULL); Tcl_SetObjResult(interp, errorObj); Tcl_SetErrorCode( interp, "TCL", "ENCODING", "PROFILE", profileName, (void *)NULL); } return TCL_ERROR; } /* *------------------------------------------------------------------------ * |
︙ | ︙ | |||
4338 4339 4340 4341 4342 4343 4344 | const char * TclEncodingProfileIdToName( Tcl_Interp *interp, /* For error messages. May be NULL */ int profileValue) /* Profile #define value */ { size_t i; | | > | | > | | | | 4363 4364 4365 4366 4367 4368 4369 4370 4371 4372 4373 4374 4375 4376 4377 4378 4379 4380 4381 4382 4383 4384 4385 4386 4387 4388 4389 4390 4391 4392 4393 4394 4395 4396 4397 4398 4399 4400 4401 4402 4403 4404 4405 4406 4407 4408 4409 4410 4411 4412 4413 4414 4415 4416 4417 4418 4419 4420 4421 4422 | const char * TclEncodingProfileIdToName( Tcl_Interp *interp, /* For error messages. May be NULL */ int profileValue) /* Profile #define value */ { size_t i; for (i = 0; i < sizeof(encodingProfiles) / sizeof(encodingProfiles[0]); ++i) { if (profileValue == encodingProfiles[i].value) { return encodingProfiles[i].name; } } if (interp) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "Internal error. Bad profile id \"%d\".", profileValue)); Tcl_SetErrorCode( interp, "TCL", "ENCODING", "PROFILEID", (void *)NULL); } return NULL; } /* *------------------------------------------------------------------------ * * TclGetEncodingProfiles -- * * Get the list of supported encoding profiles. * * Results: * None. * * Side effects: * The list of profile names is stored in the interpreter result. * *------------------------------------------------------------------------ */ void 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_SetObjResult(interp, objPtr); } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
Changes to generic/tclEnsemble.c.
︙ | ︙ | |||
14 15 16 17 18 19 20 21 22 23 24 25 26 27 | #include "tclCompile.h" /* * Declarations for functions local to this file: */ static inline Tcl_Obj * NewNsObj(Tcl_Namespace *namespacePtr); static inline int EnsembleUnknownCallback(Tcl_Interp *interp, EnsembleConfig *ensemblePtr, int objc, Tcl_Obj *const objv[], Tcl_Obj **prefixObjPtr); static int NsEnsembleImplementationCmdNR(void *clientData, Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]); static void BuildEnsembleConfig(EnsembleConfig *ensemblePtr); static int NsEnsembleStringOrder(const void *strPtr1, | > > > > > > > > > | 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 | #include "tclCompile.h" /* * Declarations for functions local to this file: */ 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); static int NsEnsembleImplementationCmdNR(void *clientData, Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]); static void BuildEnsembleConfig(EnsembleConfig *ensemblePtr); static int NsEnsembleStringOrder(const void *strPtr1, |
︙ | ︙ | |||
81 82 83 84 85 86 87 | FreeEnsembleCmdRep, /* freeIntRepProc */ DupEnsembleCmdRep, /* dupIntRepProc */ NULL, /* updateStringProc */ NULL, /* setFromAnyProc */ TCL_OBJTYPE_V0 }; | | | | | | > | | | | | | | | > > > > > > > > > > > > | | 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 | FreeEnsembleCmdRep, /* freeIntRepProc */ DupEnsembleCmdRep, /* dupIntRepProc */ NULL, /* updateStringProc */ NULL, /* setFromAnyProc */ TCL_OBJTYPE_V0 }; #define ECRSetInternalRep(objPtr, ecRepPtr) \ do { \ Tcl_ObjInternalRep ir; \ ir.twoPtrValue.ptr1 = (ecRepPtr); \ ir.twoPtrValue.ptr2 = NULL; \ Tcl_StoreInternalRep((objPtr), &ensembleCmdType, &ir); \ } while (0) #define ECRGetInternalRep(objPtr, ecRepPtr) \ do { \ const Tcl_ObjInternalRep *irPtr; \ irPtr = TclFetchInternalRep((objPtr), &ensembleCmdType); \ (ecRepPtr) = irPtr ? (EnsembleCmdRep *) \ irPtr->twoPtrValue.ptr1 : NULL; \ } while (0) /* * The internal rep for caching ensemble subcommand lookups and spelling * corrections. */ 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. */ } 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) { Namespace *nsPtr = (Namespace *) namespacePtr; if (namespacePtr == TclGetGlobalNamespace(nsPtr->interp)) { return Tcl_NewStringObj("::", 2); } return Tcl_NewStringObj(nsPtr->fullName, TCL_AUTO_LENGTH); } /* *---------------------------------------------------------------------- * * TclNamespaceEnsembleCmd -- * |
︙ | ︙ | |||
153 154 155 156 157 158 159 | int TclNamespaceEnsembleCmd( TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { | < | < | < < < < | < | | < < < < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 | int TclNamespaceEnsembleCmd( TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { Namespace *nsPtr = (Namespace *) TclGetCurrentNamespace(interp); Tcl_Command token; /* The ensemble command. */ enum EnsSubcmds index; if (nsPtr == NULL || nsPtr->flags & NS_DEAD) { if (!Tcl_InterpDeleted(interp)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "tried to manipulate ensemble of deleted namespace", TCL_AUTO_LENGTH)); Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "DEAD", (char *)NULL); } return TCL_ERROR; } if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?arg ...?"); return TCL_ERROR; } else if (Tcl_GetIndexFromObj(interp, objv[1], ensembleSubcommands, "subcommand", 0, &index) != TCL_OK) { return TCL_ERROR; } switch (index) { case ENS_CREATE: /* * Check that we've got option-value pairs... [Bug 1558654] */ if (objc & 1) { Tcl_WrongNumArgs(interp, 2, objv, "?option value ...?"); return TCL_ERROR; } token = InitEnsembleFromOptions(interp, objc - 2, objv + 2); if (token == NULL) { return TCL_ERROR; } /* * Tricky! Must ensure that the result is not shared (command delete * traces could have corrupted the pristine object that we started * with). [Snit test rename-1.5] */ Tcl_ResetResult(interp); Tcl_GetCommandFullName(interp, token, Tcl_GetObjResult(interp)); return TCL_OK; case ENS_EXISTS: if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "cmdname"); return TCL_ERROR; } Tcl_SetObjResult(interp, Tcl_NewBooleanObj( |
︙ | ︙ | |||
399 400 401 402 403 404 405 | } token = Tcl_FindEnsemble(interp, objv[2], TCL_LEAVE_ERR_MSG); if (token == NULL) { return TCL_ERROR; } if (objc == 4) { | < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 | } token = Tcl_FindEnsemble(interp, objv[2], TCL_LEAVE_ERR_MSG); if (token == NULL) { return TCL_ERROR; } if (objc == 4) { return ReadOneEnsembleOption(interp, token, objv[3]); } else if (objc == 3) { return ReadAllEnsembleOptions(interp, token); } else { return SetEnsembleConfigOptions(interp, token, objc - 3, objv + 3); } 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; } do { Tcl_Obj **listv; const char *cmd; if (TclListObjGetElements(interp, listObj, &len, &listv) != TCL_OK) { goto mapError; } 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; } 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; 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.) */ 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); } 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; /* * 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; } do { if (TclListObjLength(interp, listObj, &len) != TCL_OK) { goto finishSearchAndError; } 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 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); } 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; 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; } } /* * 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; } /* *---------------------------------------------------------------------- * * TclCreateEnsembleInNs -- * * Like Tcl_CreateEnsemble, but additionally accepts as an argument the |
︙ | ︙ | |||
680 681 682 683 684 685 686 | Tcl_Interp *interp, const char *name, /* Simple name of command to create (no * namespace components). */ Tcl_Namespace *nameNsPtr, /* Name of namespace to create the command * in. */ Tcl_Namespace *ensembleNsPtr, /* Name of the namespace for the ensemble. */ | | > | | 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 | Tcl_Interp *interp, const char *name, /* Simple name of command to create (no * namespace components). */ Tcl_Namespace *nameNsPtr, /* Name of namespace to create the command * in. */ Tcl_Namespace *ensembleNsPtr, /* Name of the namespace for the ensemble. */ 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)); token = TclNRCreateCommandInNs(interp, name, (Tcl_Namespace *) nameNsPtr, TclEnsembleImplementationCmd, NsEnsembleImplementationCmdNR, ensemblePtr, DeleteEnsembleConfig); if (token == NULL) { Tcl_Free(ensemblePtr); return NULL; } |
︙ | ︙ | |||
740 741 742 743 744 745 746 | * Value * * The token for the command created. * * Effect * The ensemble is created and marked for compilation. * | < | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 | * Value * * The token for the command created. * * Effect * The ensemble is created and marked for compilation. * *---------------------------------------------------------------------- */ Tcl_Command Tcl_CreateEnsemble( Tcl_Interp *interp, 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; const char * simpleName; if (nsPtr == NULL) { nsPtr = (Namespace *) TclGetCurrentNamespace(interp); } TclGetNamespaceForQualName(interp, name, nsPtr, TCL_CREATE_NS_IF_UNKNOWN, &foundNsPtr, &altNsPtr, &actualNsPtr, &simpleName); return TclCreateEnsembleInNs(interp, simpleName, (Tcl_Namespace *) foundNsPtr, (Tcl_Namespace *) nsPtr, flags); } /* *---------------------------------------------------------------------- * * 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. |
︙ | ︙ | |||
785 786 787 788 789 790 791 | * *---------------------------------------------------------------------- */ int Tcl_SetEnsembleSubcommandList( Tcl_Interp *interp, | | < | < < | < < | < < < < < < < < < | 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 | * *---------------------------------------------------------------------- */ int Tcl_SetEnsembleSubcommandList( Tcl_Interp *interp, Tcl_Command token, /* The ensemble command to write to. */ Tcl_Obj *subcmdList) { EnsembleConfig *ensemblePtr = GetEnsembleFromCommand(interp, token); Tcl_Obj *oldList; if (ensemblePtr == NULL) { return TCL_ERROR; } if (subcmdList != NULL) { Tcl_Size length; if (TclListObjLength(interp, subcmdList, &length) != TCL_OK) { return TCL_ERROR; } if (length < 1) { subcmdList = NULL; } } oldList = ensemblePtr->subcmdList; ensemblePtr->subcmdList = subcmdList; if (subcmdList != NULL) { Tcl_IncrRefCount(subcmdList); } if (oldList != NULL) { TclDecrRefCount(oldList); } /* * Trigger an eventual recomputation of the ensemble command set. Note * that this is slightly tricky, as it means that we are not actually * counting the number of namespace export actions, but it is the simplest * way to go! */ ensemblePtr->nsPtr->exportLookupEpoch++; BumpEpochIfNecessary(interp, token); return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_SetEnsembleParameterList -- |
︙ | ︙ | |||
860 861 862 863 864 865 866 | * *---------------------------------------------------------------------- */ int Tcl_SetEnsembleParameterList( Tcl_Interp *interp, | | < | < < | < < | < < < < < < < < < | 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 | * *---------------------------------------------------------------------- */ int Tcl_SetEnsembleParameterList( Tcl_Interp *interp, Tcl_Command token, /* The ensemble command to write to. */ Tcl_Obj *paramList) { EnsembleConfig *ensemblePtr = GetEnsembleFromCommand(interp, token); Tcl_Obj *oldList; Tcl_Size length; if (ensemblePtr == NULL) { return TCL_ERROR; } if (paramList == NULL) { length = 0; } else { if (TclListObjLength(interp, paramList, &length) != TCL_OK) { return TCL_ERROR; } if (length < 1) { paramList = NULL; } } oldList = ensemblePtr->parameterList; ensemblePtr->parameterList = paramList; if (paramList != NULL) { Tcl_IncrRefCount(paramList); } if (oldList != NULL) { TclDecrRefCount(oldList); } ensemblePtr->numParameters = length; /* * Trigger an eventual recomputation of the ensemble command set. Note * that this is slightly tricky, as it means that we are not actually * counting the number of namespace export actions, but it is the simplest * way to go! */ ensemblePtr->nsPtr->exportLookupEpoch++; BumpEpochIfNecessary(interp, token); return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_SetEnsembleMappingDict -- |
︙ | ︙ | |||
937 938 939 940 941 942 943 | * *---------------------------------------------------------------------- */ int Tcl_SetEnsembleMappingDict( Tcl_Interp *interp, | | < | < < | < | 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 | * *---------------------------------------------------------------------- */ int Tcl_SetEnsembleMappingDict( Tcl_Interp *interp, Tcl_Command token, /* The ensemble command to write to. */ Tcl_Obj *mapDict) { EnsembleConfig *ensemblePtr = GetEnsembleFromCommand(interp, token); Tcl_Obj *oldDict; if (ensemblePtr == NULL) { return TCL_ERROR; } if (mapDict != NULL) { Tcl_Size size; int done; Tcl_DictSearch search; Tcl_Obj *valuePtr; |
︙ | ︙ | |||
973 974 975 976 977 978 979 | Tcl_DictObjDone(&search); return TCL_ERROR; } bytes = TclGetString(cmdObjPtr); if (bytes[0] != ':' || bytes[1] != ':') { Tcl_SetObjResult(interp, Tcl_NewStringObj( "ensemble target is not a fully-qualified command", | | < | < < < < < < < < < | 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 | Tcl_DictObjDone(&search); return TCL_ERROR; } bytes = TclGetString(cmdObjPtr); if (bytes[0] != ':' || bytes[1] != ':') { Tcl_SetObjResult(interp, Tcl_NewStringObj( "ensemble target is not a fully-qualified command", TCL_AUTO_LENGTH)); Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "UNQUALIFIED_TARGET", (char *)NULL); Tcl_DictObjDone(&search); return TCL_ERROR; } } if (size < 1) { mapDict = NULL; } } oldDict = ensemblePtr->subcommandDict; ensemblePtr->subcommandDict = mapDict; if (mapDict != NULL) { Tcl_IncrRefCount(mapDict); } if (oldDict != NULL) { TclDecrRefCount(oldDict); } /* * Trigger an eventual recomputation of the ensemble command set. Note * that this is slightly tricky, as it means that we are not actually * counting the number of namespace export actions, but it is the simplest * way to go! */ ensemblePtr->nsPtr->exportLookupEpoch++; BumpEpochIfNecessary(interp, token); return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_SetEnsembleUnknownHandler -- |
︙ | ︙ | |||
1037 1038 1039 1040 1041 1042 1043 | * *---------------------------------------------------------------------- */ int Tcl_SetEnsembleUnknownHandler( Tcl_Interp *interp, | | < | < < | < < | 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 | * *---------------------------------------------------------------------- */ int Tcl_SetEnsembleUnknownHandler( Tcl_Interp *interp, Tcl_Command token, /* The ensemble command to write to. */ Tcl_Obj *unknownList) { EnsembleConfig *ensemblePtr = GetEnsembleFromCommand(interp, token); Tcl_Obj *oldList; if (ensemblePtr == NULL) { return TCL_ERROR; } if (unknownList != NULL) { Tcl_Size length; if (TclListObjLength(interp, unknownList, &length) != TCL_OK) { return TCL_ERROR; } if (length < 1) { unknownList = NULL; } } oldList = ensemblePtr->unknownHandler; ensemblePtr->unknownHandler = unknownList; if (unknownList != NULL) { Tcl_IncrRefCount(unknownList); } if (oldList != NULL) { TclDecrRefCount(oldList); |
︙ | ︙ | |||
1103 1104 1105 1106 1107 1108 1109 | * *---------------------------------------------------------------------- */ int Tcl_SetEnsembleFlags( Tcl_Interp *interp, | | < | | < < | < < < < | 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 | * *---------------------------------------------------------------------- */ int Tcl_SetEnsembleFlags( Tcl_Interp *interp, Tcl_Command token, /* The ensemble command to write to. */ int flags) { EnsembleConfig *ensemblePtr = GetEnsembleFromCommand(interp, token); int changedFlags = flags ^ ensemblePtr->flags; if (ensemblePtr == NULL) { return TCL_ERROR; } /* * This API refuses to set the ENSEMBLE_DEAD flag... */ ensemblePtr->flags &= ENSEMBLE_DEAD; ensemblePtr->flags |= flags & ~ENSEMBLE_DEAD; |
︙ | ︙ | |||
1142 1143 1144 1145 1146 1147 1148 | /* * If the ENSEMBLE_COMPILE flag status was changed, install or remove the * compiler function and bump the interpreter's compilation epoch so that * bytecode gets regenerated. */ | | < | < < < | < | < | 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 | /* * If the ENSEMBLE_COMPILE flag status was changed, install or remove the * compiler function and bump the interpreter's compilation epoch so that * bytecode gets regenerated. */ if (changedFlags & ENSEMBLE_COMPILE) { ((Command*) ensemblePtr->token)->compileProc = ((flags & ENSEMBLE_COMPILE) ? TclCompileEnsemble : NULL); ((Interp *) interp)->compileEpoch++; } return TCL_OK; } /* *---------------------------------------------------------------------- |
︙ | ︙ | |||
1180 1181 1182 1183 1184 1185 1186 | * *---------------------------------------------------------------------- */ int Tcl_GetEnsembleSubcommandList( Tcl_Interp *interp, | | < | < | < < < < < < | 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 | * *---------------------------------------------------------------------- */ int Tcl_GetEnsembleSubcommandList( Tcl_Interp *interp, Tcl_Command token, /* The ensemble command to read from. */ Tcl_Obj **subcmdListPtr) { EnsembleConfig *ensemblePtr = GetEnsembleFromCommand(interp, token); if (ensemblePtr == NULL) { return TCL_ERROR; } *subcmdListPtr = ensemblePtr->subcmdList; return TCL_OK; } /* *---------------------------------------------------------------------- * |
︙ | ︙ | |||
1222 1223 1224 1225 1226 1227 1228 | * *---------------------------------------------------------------------- */ int Tcl_GetEnsembleParameterList( Tcl_Interp *interp, | | < | < | < < < < < < | 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 | * *---------------------------------------------------------------------- */ int Tcl_GetEnsembleParameterList( Tcl_Interp *interp, Tcl_Command token, /* The ensemble command to read from. */ Tcl_Obj **paramListPtr) { EnsembleConfig *ensemblePtr = GetEnsembleFromCommand(interp, token); if (ensemblePtr == NULL) { return TCL_ERROR; } *paramListPtr = ensemblePtr->parameterList; return TCL_OK; } /* *---------------------------------------------------------------------- * |
︙ | ︙ | |||
1264 1265 1266 1267 1268 1269 1270 | * *---------------------------------------------------------------------- */ int Tcl_GetEnsembleMappingDict( Tcl_Interp *interp, | | < | < | < < < < < < | 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 | * *---------------------------------------------------------------------- */ int Tcl_GetEnsembleMappingDict( Tcl_Interp *interp, Tcl_Command token, /* The ensemble command to read from. */ Tcl_Obj **mapDictPtr) { EnsembleConfig *ensemblePtr = GetEnsembleFromCommand(interp, token); if (ensemblePtr == NULL) { return TCL_ERROR; } *mapDictPtr = ensemblePtr->subcommandDict; return TCL_OK; } /* *---------------------------------------------------------------------- * |
︙ | ︙ | |||
1305 1306 1307 1308 1309 1310 1311 | * *---------------------------------------------------------------------- */ int Tcl_GetEnsembleUnknownHandler( Tcl_Interp *interp, | | < | < | < < < < < < | 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 | * *---------------------------------------------------------------------- */ int Tcl_GetEnsembleUnknownHandler( Tcl_Interp *interp, Tcl_Command token, /* The ensemble command to read from. */ Tcl_Obj **unknownListPtr) { EnsembleConfig *ensemblePtr = GetEnsembleFromCommand(interp, token); if (ensemblePtr == NULL) { return TCL_ERROR; } *unknownListPtr = ensemblePtr->unknownHandler; return TCL_OK; } /* *---------------------------------------------------------------------- * |
︙ | ︙ | |||
1346 1347 1348 1349 1350 1351 1352 | * *---------------------------------------------------------------------- */ int Tcl_GetEnsembleFlags( Tcl_Interp *interp, | | < | < | < < < < < < | 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 | * *---------------------------------------------------------------------- */ int Tcl_GetEnsembleFlags( Tcl_Interp *interp, Tcl_Command token, /* The ensemble command to read from. */ int *flagsPtr) { EnsembleConfig *ensemblePtr = GetEnsembleFromCommand(interp, token); if (ensemblePtr == NULL) { return TCL_ERROR; } *flagsPtr = ensemblePtr->flags; return TCL_OK; } /* *---------------------------------------------------------------------- * |
︙ | ︙ | |||
1387 1388 1389 1390 1391 1392 1393 | * *---------------------------------------------------------------------- */ int Tcl_GetEnsembleNamespace( Tcl_Interp *interp, | | < | < | < < < < < < | 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 | * *---------------------------------------------------------------------- */ int Tcl_GetEnsembleNamespace( Tcl_Interp *interp, Tcl_Command token, /* The ensemble command to read from. */ Tcl_Namespace **namespacePtrPtr) { EnsembleConfig *ensemblePtr = GetEnsembleFromCommand(interp, token); if (ensemblePtr == NULL) { return TCL_ERROR; } *namespacePtrPtr = (Tcl_Namespace *) ensemblePtr->nsPtr; return TCL_OK; } /* *---------------------------------------------------------------------- * |
︙ | ︙ | |||
1435 1436 1437 1438 1439 1440 1441 | Tcl_Interp *interp, /* Where to do the lookup, and where to write * the errors if TCL_LEAVE_ERR_MSG is set in * the flags. */ Tcl_Obj *cmdNameObj, /* Name of command to look up. */ int flags) /* Either 0 or TCL_LEAVE_ERR_MSG; other flags * are probably not useful. */ { | | < | | | | | | | | 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 | Tcl_Interp *interp, /* Where to do the lookup, and where to write * the errors if TCL_LEAVE_ERR_MSG is set in * the flags. */ Tcl_Obj *cmdNameObj, /* Name of command to look up. */ int flags) /* Either 0 or TCL_LEAVE_ERR_MSG; other flags * are probably not useful. */ { Tcl_Command token; token = Tcl_FindCommand(interp, TclGetString(cmdNameObj), NULL, flags); if (token == NULL) { return NULL; } if (((Command *) token)->objProc != TclEnsembleImplementationCmd) { /* * Reuse existing infrastructure for following import link chains * rather than duplicating it. */ token = TclGetOriginalCommand(token); if (token == NULL || ((Command *) token)->objProc != TclEnsembleImplementationCmd) { if (flags & TCL_LEAVE_ERR_MSG) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "\"%s\" is not an ensemble command", TclGetString(cmdNameObj))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ENSEMBLE", TclGetString(cmdNameObj), (char *)NULL); } return NULL; } } return token; } /* *---------------------------------------------------------------------- * * Tcl_IsEnsemble -- * |
︙ | ︙ | |||
1486 1487 1488 1489 1490 1491 1492 | * None * *---------------------------------------------------------------------- */ int Tcl_IsEnsemble( | | | 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 | * None * *---------------------------------------------------------------------- */ int Tcl_IsEnsemble( Tcl_Command token) /* The command to check. */ { Command *cmdPtr = (Command *) token; if (cmdPtr->objProc == TclEnsembleImplementationCmd) { return 1; } cmdPtr = (Command *) TclGetOriginalCommand((Tcl_Command) cmdPtr); |
︙ | ︙ | |||
1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 | * * The 'name' parameter may be a single command name or a list if * creating an ensemble subcommand (see the binary implementation). * * Currently, the TCL_ENSEMBLE_PREFIX ensemble flag is only used on * top-level ensemble commands. * * Results: * Handle for the new ensemble, or NULL on failure. * * Side effects: * May advance the bytecode compilation epoch. * *---------------------------------------------------------------------- */ Tcl_Command TclMakeEnsemble( Tcl_Interp *interp, | > > > > > | | | | | | 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 | * * The 'name' parameter may be a single command name or a list if * creating an ensemble subcommand (see the binary implementation). * * 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. * * Side effects: * May advance the bytecode compilation epoch. * *---------------------------------------------------------------------- */ Tcl_Command TclMakeEnsemble( Tcl_Interp *interp, const char *name, /* The ensemble name (as explained above) */ const EnsembleImplMap map[])/* The subcommands to create */ { Tcl_Command ensemble; Tcl_Namespace *ns; Tcl_DString buf, hiddenBuf; const char **nameParts = NULL; const char *cmdName = NULL; Tcl_Size i, nameCount = 0; int ensembleFlags = 0, hiddenLen; /* * Construct the path for the ensemble namespace and create it. */ Tcl_DStringInit(&buf); Tcl_DStringInit(&hiddenBuf); TclDStringAppendLiteral(&hiddenBuf, "tcl:"); Tcl_DStringAppend(&hiddenBuf, name, TCL_AUTO_LENGTH); TclDStringAppendLiteral(&hiddenBuf, ":"); hiddenLen = Tcl_DStringLength(&hiddenBuf); if (name[0] == ':' && name[1] == ':') { /* * An absolute name, so use it directly. */ cmdName = name; Tcl_DStringAppend(&buf, name, TCL_AUTO_LENGTH); ensembleFlags = TCL_ENSEMBLE_PREFIX; } else { /* * Not an absolute name, so do munging of it. Note that this treats a * multi-word list differently to a single word. */ TclDStringAppendLiteral(&buf, "::tcl"); if (Tcl_SplitList(NULL, name, &nameCount, &nameParts) != TCL_OK) { Tcl_Panic("invalid ensemble name '%s'", name); } for (i = 0; i < nameCount; ++i) { TclDStringAppendLiteral(&buf, "::"); Tcl_DStringAppend(&buf, nameParts[i], TCL_AUTO_LENGTH); } } ns = Tcl_FindNamespace(interp, Tcl_DStringValue(&buf), NULL, TCL_CREATE_NS_IF_UNKNOWN); if (!ns) { Tcl_Panic("unable to find or create %s namespace!", |
︙ | ︙ | |||
1617 1618 1619 1620 1621 1622 1623 | Command *cmdPtr; TclDStringAppendLiteral(&buf, "::"); TclNewObj(mapDict); for (i=0 ; map[i].name != NULL ; i++) { TclNewStringObj(toObj, Tcl_DStringValue(&buf), Tcl_DStringLength(&buf)); | | | > | 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 | Command *cmdPtr; TclDStringAppendLiteral(&buf, "::"); TclNewObj(mapDict); for (i=0 ; map[i].name != NULL ; i++) { TclNewStringObj(toObj, Tcl_DStringValue(&buf), Tcl_DStringLength(&buf)); Tcl_AppendToObj(toObj, map[i].name, TCL_AUTO_LENGTH); TclDictPut(NULL, mapDict, map[i].name, toObj); if (map[i].proc || map[i].nreProc) { /* * If the command is unsafe, hide it when we're in a safe * interpreter. The code to do this is really hokey! It also * doesn't work properly yet; this function is always * currently called before the safe-interp flag is set so the * Tcl_IsSafe check fails. */ if (map[i].unsafe && Tcl_IsSafe(interp)) { cmdPtr = (Command *) Tcl_NRCreateCommand(interp, "___tmp", map[i].proc, map[i].nreProc, map[i].clientData, NULL); Tcl_DStringSetLength(&hiddenBuf, hiddenLen); if (Tcl_HideCommand(interp, "___tmp", Tcl_DStringAppend(&hiddenBuf, map[i].name, TCL_AUTO_LENGTH))) { Tcl_Panic("%s", Tcl_GetStringResult(interp)); } } else { /* * Not hidden, so just create it. Yay! */ |
︙ | ︙ | |||
1697 1698 1699 1700 1701 1702 1703 | { return Tcl_NRCallObjProc(interp, NsEnsembleImplementationCmdNR, clientData, objc, objv); } static int NsEnsembleImplementationCmdNR( | | | | 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 | { return Tcl_NRCallObjProc(interp, NsEnsembleImplementationCmdNR, clientData, objc, objv); } static int NsEnsembleImplementationCmdNR( void *clientData, /* The ensemble this is the impl. of. */ Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { EnsembleConfig *ensemblePtr = (EnsembleConfig *) clientData; /* The ensemble itself. */ Tcl_Obj *prefixObj; /* An object containing the prefix words of * the command that implements the * subcommand. */ Tcl_HashEntry *hPtr; /* Used for efficient lookup of fully * specified but not yet cached command * names. */ |
︙ | ︙ | |||
1731 1732 1733 1734 1735 1736 1737 | * No subcommand argument. Make error message. */ Tcl_DString buf; /* Message being built */ Tcl_DStringInit(&buf); if (ensemblePtr->parameterList) { | < | | > | 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 | * No subcommand argument. Make error message. */ Tcl_DString buf; /* Message being built */ Tcl_DStringInit(&buf); if (ensemblePtr->parameterList) { TclDStringAppendObj(&buf, ensemblePtr->parameterList); TclDStringAppendLiteral(&buf, " "); } TclDStringAppendLiteral(&buf, "subcommand ?arg ...?"); Tcl_WrongNumArgs(interp, 1, objv, Tcl_DStringValue(&buf)); Tcl_DStringFree(&buf); return TCL_ERROR; } if (ensemblePtr->nsPtr->flags & NS_DEAD) { /* * Don't know how we got here, but make things give up quickly. */ if (!Tcl_InterpDeleted(interp)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "ensemble activated for deleted namespace", TCL_AUTO_LENGTH)); Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "DEAD", (char *)NULL); } return TCL_ERROR; } /* * If the table of subcommands is valid just lookup up the command there |
︙ | ︙ | |||
1772 1773 1774 1775 1776 1777 1778 | * is an ensembleCmd, just call it. */ EnsembleCmdRep *ensembleCmd; ECRGetInternalRep(subObj, ensembleCmd); if (ensembleCmd) { if (ensembleCmd->epoch == ensemblePtr->epoch && | | | < | 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 | * is an ensembleCmd, just call it. */ EnsembleCmdRep *ensembleCmd; ECRGetInternalRep(subObj, ensembleCmd); if (ensembleCmd) { if (ensembleCmd->epoch == ensemblePtr->epoch && 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); } goto runResultingSubcommand; } } } else { BuildEnsembleConfig(ensemblePtr); ensemblePtr->epoch = ensemblePtr->nsPtr->exportLookupEpoch; } /* * Look in the hashtable for the named subcommand. This is the fastest * path if there is no cache in operation. */ hPtr = Tcl_FindHashEntry(&ensemblePtr->subcommandTable, TclGetString(subObj)); if (hPtr != NULL) { /* * Cache ensemble in the subcommand object for later. */ MakeCachedEnsembleCommand(subObj, ensemblePtr, hPtr, NULL); } else if (!(ensemblePtr->flags & TCL_ENSEMBLE_PREFIX)) { /* |
︙ | ︙ | |||
1863 1864 1865 1866 1867 1868 1869 | fullName); } /* * Record the spelling correction for usage message. */ | | | | 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 | fullName); } /* * Record the spelling correction for usage message. */ fix = Tcl_NewStringObj(fullName, TCL_AUTO_LENGTH); /* * Cache for later in the subcommand object. */ MakeCachedEnsembleCommand(subObj, ensemblePtr, hPtr, fix); TclSpellFix(interp, objv, objc, subIdx, subObj, fix); } prefixObj = (Tcl_Obj *) Tcl_GetHashValue(hPtr); Tcl_IncrRefCount(prefixObj); runResultingSubcommand: /* * Execute the subcommand by populating an array of objects, which might * not be the same length as the number of arguments to this ensemble * command, and then handing it to the main command-lookup engine. In |
︙ | ︙ | |||
1930 1931 1932 1933 1934 1935 1936 | /* * Hand off to the target command. */ TclSkipTailcall(interp); TclListObjGetElements(NULL, copyPtr, ©Objc, ©Objv); | | | 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 | /* * Hand off to the target command. */ TclSkipTailcall(interp); TclListObjGetElements(NULL, copyPtr, ©Objc, ©Objv); ((Interp *) interp)->lookupNsPtr = ensemblePtr->nsPtr; return TclNREvalObjv(interp, copyObjc, copyObjv, TCL_EVAL_INVOKE, NULL); } unknownOrAmbiguousSubcommand: /* * The named subcommand did not match any exported command. If there is a * handler registered unknown subcommands, call it, but not more than once |
︙ | ︙ | |||
1974 1975 1976 1977 1978 1979 1980 | ensemblePtr->nsPtr->fullName)); return TCL_ERROR; } errorObj = Tcl_ObjPrintf("unknown%s subcommand \"%s\": must be ", (ensemblePtr->flags & TCL_ENSEMBLE_PREFIX ? " or ambiguous" : ""), TclGetString(subObj)); if (ensemblePtr->subcommandTable.numEntries == 1) { | | > | > | 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 | ensemblePtr->nsPtr->fullName)); return TCL_ERROR; } errorObj = Tcl_ObjPrintf("unknown%s subcommand \"%s\": must be ", (ensemblePtr->flags & TCL_ENSEMBLE_PREFIX ? " or ambiguous" : ""), TclGetString(subObj)); if (ensemblePtr->subcommandTable.numEntries == 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], TCL_AUTO_LENGTH); Tcl_AppendToObj(errorObj, ", ", 2); } Tcl_AppendPrintfToObj(errorObj, "or %s", ensemblePtr->subcommandArrayPtr[i]); } Tcl_SetObjResult(interp, errorObj); return TCL_ERROR; |
︙ | ︙ | |||
2180 2181 2182 2183 2184 2185 2186 | } } search = iPtr->ensembleRewrite.sourceObjs; if (search[0] == NULL) { store = (Tcl_Obj **) search[2]; } else { | | | | 2243 2244 2245 2246 2247 2248 2249 2250 2251 2252 2253 2254 2255 2256 2257 2258 2259 | } } search = iPtr->ensembleRewrite.sourceObjs; if (search[0] == NULL) { store = (Tcl_Obj **) search[2]; } else { Tcl_Obj **tmp = (Tcl_Obj **) Tcl_Alloc(3 * sizeof(Tcl_Obj *)); store = (Tcl_Obj **) Tcl_Alloc(size * sizeof(Tcl_Obj *)); memcpy(store, iPtr->ensembleRewrite.sourceObjs, size * sizeof(Tcl_Obj *)); /* * Awful casting abuse here! Note that the NULL in the first element * indicates that the initial objects are a raw array in the second * element and the rewritten ones are a raw array in the third. |
︙ | ︙ | |||
2205 2206 2207 2208 2209 2210 2211 2212 2213 2214 2215 2216 2217 2218 | } store[idx] = fix; Tcl_IncrRefCount(fix); TclNRAddCallback(interp, TclNRReleaseValues, fix, NULL, NULL, NULL); } Tcl_Obj *const * TclEnsembleGetRewriteValues( Tcl_Interp *interp) /* Current interpreter. */ { Interp *iPtr = (Interp *) interp; Tcl_Obj *const *origObjv = iPtr->ensembleRewrite.sourceObjs; if (origObjv[0] == NULL) { | > > > > > > > > > > > | < | | 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 2325 2326 2327 2328 2329 2330 2331 2332 2333 2334 2335 | } store[idx] = fix; Tcl_IncrRefCount(fix); 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]; } return origObjv; } /* *---------------------------------------------------------------------- * * TclFetchEnsembleRoot -- * * Returns the root of ensemble rewriting, if any. * If no root exists, returns objv instead. * * Results: * None. * * Side effects: * None. * *---------------------------------------------------------------------- */ Tcl_Obj *const * TclFetchEnsembleRoot( Tcl_Interp *interp, Tcl_Obj *const *objv, Tcl_Size objc, Tcl_Size *objcPtr) { Tcl_Obj *const *sourceObjs; Interp *iPtr = (Interp *) interp; if (iPtr->ensembleRewrite.sourceObjs) { *objcPtr = objc + iPtr->ensembleRewrite.numRemovedObjs - iPtr->ensembleRewrite.numInsertedObjs; if (iPtr->ensembleRewrite.sourceObjs[0] == NULL) { sourceObjs = (Tcl_Obj *const *) iPtr->ensembleRewrite.sourceObjs[1]; } else { sourceObjs = iPtr->ensembleRewrite.sourceObjs; } return sourceObjs; } *objcPtr = objc; return objv; |
︙ | ︙ | |||
2284 2285 2286 2287 2288 2289 2290 | * * ---------------------------------------------------------------------- */ static inline int EnsembleUnknownCallback( Tcl_Interp *interp, | | | | | > > | 2357 2358 2359 2360 2361 2362 2363 2364 2365 2366 2367 2368 2369 2370 2371 2372 2373 2374 2375 2376 | * * ---------------------------------------------------------------------- */ static inline int EnsembleUnknownCallback( Tcl_Interp *interp, 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; Tcl_Size i, prefixObjc; Tcl_Obj **paramv, *unknownCmd, *ensObj; /* |
︙ | ︙ | |||
2320 2321 2322 2323 2324 2325 2326 | Tcl_Preserve(ensemblePtr); TclSkipTailcall(interp); result = Tcl_EvalObjv(interp, paramc, paramv, 0); if ((result == TCL_OK) && (ensemblePtr->flags & ENSEMBLE_DEAD)) { if (!Tcl_InterpDeleted(interp)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( | | > | 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 2407 2408 2409 2410 | Tcl_Preserve(ensemblePtr); TclSkipTailcall(interp); result = Tcl_EvalObjv(interp, paramc, paramv, 0); if ((result == TCL_OK) && (ensemblePtr->flags & ENSEMBLE_DEAD)) { if (!Tcl_InterpDeleted(interp)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "unknown subcommand handler deleted its ensemble", TCL_AUTO_LENGTH)); Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "UNKNOWN_DELETED", (char *)NULL); } result = TCL_ERROR; } Tcl_Release(ensemblePtr); |
︙ | ︙ | |||
2368 2369 2370 2371 2372 2373 2374 | * Convert exceptional result to an error. */ if (!Tcl_InterpDeleted(interp)) { if (result != TCL_ERROR) { Tcl_ResetResult(interp); Tcl_SetObjResult(interp, Tcl_NewStringObj( | | > | > | > | > | 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 2470 2471 | * Convert exceptional result to an error. */ if (!Tcl_InterpDeleted(interp)) { if (result != TCL_ERROR) { Tcl_ResetResult(interp); Tcl_SetObjResult(interp, Tcl_NewStringObj( "unknown subcommand handler returned bad code: ", TCL_AUTO_LENGTH)); switch (result) { case TCL_RETURN: Tcl_AppendToObj(Tcl_GetObjResult(interp), "return", TCL_AUTO_LENGTH); break; case TCL_BREAK: Tcl_AppendToObj(Tcl_GetObjResult(interp), "break", TCL_AUTO_LENGTH); break; case TCL_CONTINUE: Tcl_AppendToObj(Tcl_GetObjResult(interp), "continue", TCL_AUTO_LENGTH); break; default: Tcl_AppendPrintfToObj(Tcl_GetObjResult(interp), "%d", result); } Tcl_AddErrorInfo(interp, "\n result of " "ensemble unknown subcommand handler: "); Tcl_AppendObjToErrorInfo(interp, unknownCmd); |
︙ | ︙ | |||
2417 2418 2419 2420 2421 2422 2423 | * ensembleCmd. * *---------------------------------------------------------------------- */ static void MakeCachedEnsembleCommand( | | | | | > | | 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 | * ensembleCmd. * *---------------------------------------------------------------------- */ static void MakeCachedEnsembleCommand( 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; ECRGetInternalRep(objPtr, ensembleCmd); if (ensembleCmd) { TclCleanupCommandMacro(ensembleCmd->token); if (ensembleCmd->fix) { Tcl_DecrRefCount(ensembleCmd->fix); } } else { /* * Replace any old internal representation with a new one. */ ensembleCmd = (EnsembleCmdRep *) Tcl_Alloc(sizeof(EnsembleCmdRep)); ECRSetInternalRep(objPtr, ensembleCmd); } /* * Populate the internal rep. */ |
︙ | ︙ | |||
2474 2475 2476 2477 2478 2479 2480 | * Memory is eventually deallocated. * *---------------------------------------------------------------------- */ static void ClearTable( | | | | | | | | | | | | | 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 | * Memory is eventually deallocated. * *---------------------------------------------------------------------- */ static void ClearTable( 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); 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) /* Ensemble to delete. */ { EnsembleConfig *ensemblePtr = (EnsembleConfig *) clientData; Namespace *nsPtr = ensemblePtr->nsPtr; /* Unlink from the ensemble chain if it not already marked as unlinked. */ if (ensemblePtr->next != ensemblePtr) { EnsembleConfig *ensPtr = (EnsembleConfig *) nsPtr->ensembles; |
︙ | ︙ | |||
2575 2576 2577 2578 2579 2580 2581 | * may be an expensive operation. * *---------------------------------------------------------------------- */ static void BuildEnsembleConfig( | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 2721 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 2771 2772 2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 | * may be an expensive operation. * *---------------------------------------------------------------------- */ static void BuildEnsembleConfig( EnsembleConfig *ensemblePtr)/* Ensemble to set up. */ { Tcl_HashSearch search; /* Used for scanning the commands in * the namespace for this ensemble. */ Tcl_Size i, j; int isNew; Tcl_HashTable *hash = &ensemblePtr->subcommandTable; Tcl_HashEntry *hPtr; Tcl_Obj *mapDict = ensemblePtr->subcommandDict; Tcl_Obj *subList = ensemblePtr->subcmdList; ClearTable(ensemblePtr); 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, 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; } /* * 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, 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); } } else { /* * Use the array of patterns and the hash table whose keys are the * commands exported by the namespace. The corresponding values do not * matter here. Filter the commands in the namespace against the * patterns in the export list to find out what commands are actually * exported. Use an intermediate hash table to make memory management * easier and to make exact matching much easier. * * Suggestion for future enhancement: Compute the unique prefixes and * place them in the hash too for even faster matching. */ hPtr = Tcl_FirstHashEntry(&ensemblePtr->nsPtr->cmdTable, &search); for (; hPtr!= NULL ; hPtr=Tcl_NextHashEntry(&search)) { 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, ensemblePtr->nsPtr->exportArrayPtr[i])) { hPtr = Tcl_CreateHashEntry(hash, nsCmdName, &isNew); /* |
︙ | ︙ | |||
2748 2749 2750 2751 2752 2753 2754 | * the error message either. * * Do this by filling an array with the names: Use the hash keys * directly to save a copy since any time we change the array we change * the hash too, and vice versa, and run quicksort over the array. */ | | | | 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 | * the error message either. * * Do this by filling an array with the names: Use the hash keys * directly to save a copy since any time we change the array we change * the hash too, and vice versa, and run quicksort over the array. */ ensemblePtr->subcommandArrayPtr = (char **) Tcl_Alloc(sizeof(char *) * hash->numEntries); /* * Fill the array from both ends as this reduces the likelihood of * performance problems in qsort(). This makes this code much more opaque, * but the naive alternatve: * * for (hPtr=Tcl_FirstHashEntry(hash,&search),i=0 ; |
︙ | ︙ | |||
2773 2774 2775 2776 2777 2778 2779 | * to have awful runtime behaviour. */ i = 0; j = hash->numEntries; hPtr = Tcl_FirstHashEntry(hash, &search); while (hPtr != NULL) { | | > | > > | | | | 2854 2855 2856 2857 2858 2859 2860 2861 2862 2863 2864 2865 2866 2867 2868 2869 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 2880 2881 2882 2883 2884 2885 2886 2887 2888 2889 2890 2891 2892 2893 2894 2895 2896 2897 2898 2899 2900 2901 2902 2903 2904 2905 | * to have awful runtime behaviour. */ i = 0; j = hash->numEntries; hPtr = Tcl_FirstHashEntry(hash, &search); while (hPtr != NULL) { ensemblePtr->subcommandArrayPtr[i++] = (char *) Tcl_GetHashKey(hash, hPtr); hPtr = Tcl_NextHashEntry(&search); if (hPtr == NULL) { break; } ensemblePtr->subcommandArrayPtr[--j] = (char *) Tcl_GetHashKey(hash, hPtr); hPtr = Tcl_NextHashEntry(&search); } if (hash->numEntries > 1) { qsort(ensemblePtr->subcommandArrayPtr, hash->numEntries, sizeof(char *), NsEnsembleStringOrder); } } /* *---------------------------------------------------------------------- * * NsEnsembleStringOrder -- * * 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, * and 0 if they are equal. * * Side effects: * None. * *---------------------------------------------------------------------- */ static int NsEnsembleStringOrder( const void *strPtr1, /* Points to first array entry */ const void *strPtr2) /* Points to second array entry */ { return strcmp(*(const char **)strPtr1, *(const char **)strPtr2); } /* *---------------------------------------------------------------------- * |
︙ | ︙ | |||
2869 2870 2871 2872 2873 2874 2875 | static void DupEnsembleCmdRep( Tcl_Obj *objPtr, Tcl_Obj *copyPtr) { EnsembleCmdRep *ensembleCmd; | | > | 2953 2954 2955 2956 2957 2958 2959 2960 2961 2962 2963 2964 2965 2966 2967 2968 | static void DupEnsembleCmdRep( Tcl_Obj *objPtr, Tcl_Obj *copyPtr) { EnsembleCmdRep *ensembleCmd; EnsembleCmdRep *ensembleCopy = (EnsembleCmdRep *) Tcl_Alloc(sizeof(EnsembleCmdRep)); ECRGetInternalRep(objPtr, ensembleCmd); ECRSetInternalRep(copyPtr, ensembleCopy); ensembleCopy->epoch = ensembleCmd->epoch; ensembleCopy->token = ensembleCmd->token; ensembleCopy->token->refCount++; |
︙ | ︙ | |||
3136 3137 3138 3139 3140 3141 3142 | oldCmdPtr = cmdPtr; Tcl_IncrRefCount(targetCmdObj); newCmdPtr = (Command *) Tcl_GetCommandFromObj(interp, targetCmdObj); TclDecrRefCount(targetCmdObj); if (newCmdPtr == NULL || Tcl_IsSafe(interp) || newCmdPtr->nsPtr->flags & NS_SUPPRESS_COMPILATION || newCmdPtr->flags & CMD_HAS_EXEC_TRACES | | | 3221 3222 3223 3224 3225 3226 3227 3228 3229 3230 3231 3232 3233 3234 3235 | oldCmdPtr = cmdPtr; Tcl_IncrRefCount(targetCmdObj); newCmdPtr = (Command *) Tcl_GetCommandFromObj(interp, targetCmdObj); TclDecrRefCount(targetCmdObj); 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) { /* * Maps to an undefined command or a command without a compiler. * Cannot compile. */ goto cleanup; } |
︙ | ︙ | |||
3188 3189 3190 3191 3192 3193 3194 | } /* * Throw out any line information generated by the failed compile attempt. */ while (mapPtr->nuloc > eclIndex + 1) { | | | | | 3273 3274 3275 3276 3277 3278 3279 3280 3281 3282 3283 3284 3285 3286 3287 3288 3289 | } /* * Throw out any line information generated by the failed compile attempt. */ while (mapPtr->nuloc > eclIndex + 1) { mapPtr->nuloc--; Tcl_Free(mapPtr->loc[mapPtr->nuloc].line); mapPtr->loc[mapPtr->nuloc].line = NULL; } /* * Reset the index of next command. Toss out any from failed nested * partial compiles. */ |
︙ | ︙ | |||
3404 3405 3406 3407 3408 3409 3410 | * difference. Hence the call to TclContinuationsEnterDerived... */ TclListObjGetElements(NULL, replacements, &numWords, &words); for (i = 0, tokPtr = parsePtr->tokenPtr; i < parsePtr->numWords; i++, tokPtr = TokenAfter(tokPtr)) { if (i > 0 && i <= numWords) { | | | 3489 3490 3491 3492 3493 3494 3495 3496 3497 3498 3499 3500 3501 3502 3503 | * difference. Hence the call to TclContinuationsEnterDerived... */ TclListObjGetElements(NULL, replacements, &numWords, &words); for (i = 0, tokPtr = parsePtr->tokenPtr; i < parsePtr->numWords; i++, tokPtr = TokenAfter(tokPtr)) { if (i > 0 && i <= numWords) { bytes = TclGetStringFromObj(words[i - 1], &length); PushLiteral(envPtr, bytes, length); continue; } SetLineInformation(i); if (tokPtr->type == TCL_TOKEN_SIMPLE_WORD) { int literal = TclRegisterLiteral(envPtr, |
︙ | ︙ | |||
3446 3447 3448 3449 3450 3451 3452 | TclEmitPush(cmdLit, envPtr); TclDecrRefCount(objPtr); /* * Do the replacing dispatch. */ | | > | 3531 3532 3533 3534 3535 3536 3537 3538 3539 3540 3541 3542 3543 3544 3545 3546 | TclEmitPush(cmdLit, envPtr); TclDecrRefCount(objPtr); /* * Do the replacing dispatch. */ TclEmitInvoke(envPtr, INST_INVOKE_REPLACE, parsePtr->numWords, numWords + 1); } /* * Helpers that do issuing of instructions for commands that "don't have * compilers" (well, they do; these). They all work by just generating base * code to invoke the command; they're intended for ensemble subcommands so * that the costs of INST_INVOKE_REPLACE can be avoided where we can work out |
︙ | ︙ |
Changes to generic/tclExecute.c.
︙ | ︙ | |||
655 656 657 658 659 660 661 | static Tcl_NRPostProc TEBCresume; /* * The structure below defines a bytecode Tcl object type to hold the * compiled bytecode for Tcl expressions. */ | | | 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 | static Tcl_NRPostProc TEBCresume; /* * The structure below defines a bytecode Tcl object type to hold the * compiled bytecode for Tcl expressions. */ const Tcl_ObjType tclExprCodeType = { "exprcode", FreeExprCodeInternalRep, /* freeIntRepProc */ DupExprCodeInternalRep, /* dupIntRepProc */ NULL, /* updateStringProc */ NULL, /* setFromAnyProc */ TCL_OBJTYPE_V0 }; |
︙ | ︙ | |||
1413 1414 1415 1416 1417 1418 1419 | * to avoid compiler warning. */ /* * Get the expression ByteCode from the object. If it exists, make sure it * is valid in the current context. */ | | | | 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 | * to avoid compiler warning. */ /* * Get the expression ByteCode from the object. If it exists, make sure it * is valid in the current context. */ ByteCodeGetInternalRep(objPtr, &tclExprCodeType, codePtr); if (codePtr != NULL) { Namespace *namespacePtr = iPtr->varFramePtr->nsPtr; if (((Interp *) *codePtr->interpHandle != iPtr) || (codePtr->compileEpoch != iPtr->compileEpoch) || (codePtr->nsPtr != namespacePtr) || (codePtr->nsEpoch != namespacePtr->resolverEpoch) || (codePtr->localCachePtr != iPtr->varFramePtr->localCachePtr)) { Tcl_StoreInternalRep(objPtr, &tclExprCodeType, NULL); codePtr = NULL; } } if (codePtr == NULL) { /* * TIP #280: No invoker (yet) - Expression compilation. |
︙ | ︙ | |||
1456 1457 1458 1459 1460 1461 1462 | /* * Add a "done" instruction as the last instruction and change the * object into a ByteCode object. Ownership of the literal objects and * aux data items is given to the ByteCode object. */ TclEmitOpcode(INST_DONE, &compEnv); | | | 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 | /* * Add a "done" instruction as the last instruction and change the * object into a ByteCode object. Ownership of the literal objects and * aux data items is given to the ByteCode object. */ TclEmitOpcode(INST_DONE, &compEnv); codePtr = TclInitByteCodeObj(objPtr, &tclExprCodeType, &compEnv); TclFreeCompileEnv(&compEnv); if (iPtr->varFramePtr->localCachePtr) { codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr; codePtr->localCachePtr->refCount++; } TclDebugPrintByteCodeObj(objPtr); } |
︙ | ︙ | |||
1525 1526 1527 1528 1529 1530 1531 | */ static void FreeExprCodeInternalRep( Tcl_Obj *objPtr) { ByteCode *codePtr; | | | 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 | */ static void FreeExprCodeInternalRep( Tcl_Obj *objPtr) { ByteCode *codePtr; ByteCodeGetInternalRep(objPtr, &tclExprCodeType, codePtr); assert(codePtr != NULL); TclReleaseByteCode(codePtr); } /* *---------------------------------------------------------------------- |
︙ | ︙ | |||
3947 3948 3949 3950 3951 3952 3953 | cleanup = 2; part1Ptr = OBJ_UNDER_TOS; objPtr = OBJ_AT_TOS; TRACE(("\"%.30s\" \"%.30s\" => ", O2S(part1Ptr), O2S(objPtr))); varPtr = TclObjLookupVarEx(interp, part1Ptr, NULL, 0, NULL, /*createPart1*/1, /*createPart2*/0, &arrayPtr); doConst: | | | 3947 3948 3949 3950 3951 3952 3953 3954 3955 3956 3957 3958 3959 3960 3961 | cleanup = 2; part1Ptr = OBJ_UNDER_TOS; objPtr = OBJ_AT_TOS; TRACE(("\"%.30s\" \"%.30s\" => ", O2S(part1Ptr), O2S(objPtr))); varPtr = TclObjLookupVarEx(interp, part1Ptr, NULL, 0, NULL, /*createPart1*/1, /*createPart2*/0, &arrayPtr); doConst: if (TclIsVarConstant(varPtr)) { TRACE_APPEND(("\n")); NEXT_INST_V(pcAdjustment, cleanup, 0); } if (TclIsVarArray(varPtr)) { msgPart = "variable is array"; goto constError; } else if (TclIsVarArrayElement(varPtr)) { |
︙ | ︙ | |||
7861 7862 7863 7864 7865 7866 7867 | /* * WidePwrSmallExpon -- * * Helper to calculate small powers of integers whose result is wide. */ static inline Tcl_WideInt | | > > | | 7861 7862 7863 7864 7865 7866 7867 7868 7869 7870 7871 7872 7873 7874 7875 7876 7877 7878 | /* * WidePwrSmallExpon -- * * Helper to calculate small powers of integers whose result is wide. */ static inline Tcl_WideInt WidePwrSmallExpon( Tcl_WideInt w1, long exponent) { Tcl_WideInt wResult; wResult = w1 * w1; /* b**2 */ switch (exponent) { case 2: break; case 3: |
︙ | ︙ |
Changes to generic/tclGetDate.y.
︙ | ︙ | |||
1021 1022 1023 1024 1025 1026 1027 | /* ignore spaces at begin */ yyInput = bypassSpaces(yyInput); /* parse */ status = yyparse(info); if (status == 1) { | | | 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 | /* ignore spaces at begin */ yyInput = bypassSpaces(yyInput); /* parse */ status = yyparse(info); if (status == 1) { const char *msg = NULL; if (info->errFlags & CLF_HAVEDATE) { msg = "more than one date in string"; } else if (info->errFlags & CLF_TIME) { msg = "more than one time of day in string"; } else if (info->errFlags & CLF_ZONE) { msg = "more than one time zone in string"; } else if (info->errFlags & CLF_DAYOFWEEK) { |
︙ | ︙ |
Changes to generic/tclHash.c.
︙ | ︙ | |||
40 41 42 43 44 45 46 | /* * Prototypes for the string hash key methods. */ static Tcl_HashEntry * AllocStringEntry(Tcl_HashTable *tablePtr, void *keyPtr); | < < | 40 41 42 43 44 45 46 47 48 49 50 51 52 53 | /* * Prototypes for the string hash key methods. */ static Tcl_HashEntry * AllocStringEntry(Tcl_HashTable *tablePtr, void *keyPtr); /* * Function prototypes for static functions in this file: */ static Tcl_HashEntry * BogusFind(Tcl_HashTable *tablePtr, const char *key); static Tcl_HashEntry * BogusCreate(Tcl_HashTable *tablePtr, const char *key, |
︙ | ︙ | |||
76 77 78 79 80 81 82 | NULL, /* AllocOneWordKey, */ /* allocEntryProc */ NULL /* FreeOneWordKey, */ /* freeEntryProc */ }; const Tcl_HashKeyType tclStringHashKeyType = { TCL_HASH_KEY_TYPE_VERSION, /* version */ 0, /* flags */ | | | | 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 | NULL, /* AllocOneWordKey, */ /* allocEntryProc */ NULL /* FreeOneWordKey, */ /* freeEntryProc */ }; const Tcl_HashKeyType tclStringHashKeyType = { TCL_HASH_KEY_TYPE_VERSION, /* version */ 0, /* flags */ TclHashStringKey, /* hashKeyProc */ TclCompareStringKeys, /* compareKeysProc */ AllocStringEntry, /* allocEntryProc */ NULL /* freeEntryProc */ }; /* *---------------------------------------------------------------------- * |
︙ | ︙ | |||
552 553 554 555 556 557 558 | * None. * *---------------------------------------------------------------------- */ Tcl_HashEntry * Tcl_NextHashEntry( | | < | 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 | * None. * *---------------------------------------------------------------------- */ Tcl_HashEntry * Tcl_NextHashEntry( Tcl_HashSearch *searchPtr) /* Place to store information about progress * through the table. Must have been * initialized by calling * Tcl_FirstHashEntry. */ { Tcl_HashEntry *hPtr; Tcl_HashTable *tablePtr = searchPtr->tablePtr; |
︙ | ︙ | |||
667 668 669 670 671 672 673 | * *---------------------------------------------------------------------- */ static Tcl_HashEntry * AllocArrayEntry( Tcl_HashTable *tablePtr, /* Hash table. */ | | | 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 | * *---------------------------------------------------------------------- */ static Tcl_HashEntry * AllocArrayEntry( Tcl_HashTable *tablePtr, /* Hash table. */ void *keyPtr) /* Key to store in the hash table entry. */ { Tcl_HashEntry *hPtr; size_t count = tablePtr->keyType * sizeof(int); size_t size = offsetof(Tcl_HashEntry, key) + count; if (size < sizeof(Tcl_HashEntry)) { size = sizeof(Tcl_HashEntry); |
︙ | ︙ | |||
703 704 705 706 707 708 709 | * None. * *---------------------------------------------------------------------- */ static int CompareArrayKeys( | | | 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 | * None. * *---------------------------------------------------------------------- */ static int CompareArrayKeys( void *keyPtr, /* New key to compare. */ Tcl_HashEntry *hPtr) /* Existing key to compare. */ { size_t count = hPtr->tablePtr->keyType * sizeof(int); return !memcmp(keyPtr, hPtr->key.string, count); } |
︙ | ︙ | |||
732 733 734 735 736 737 738 | * *---------------------------------------------------------------------- */ static size_t HashArrayKey( Tcl_HashTable *tablePtr, /* Hash table. */ | | | 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 | * *---------------------------------------------------------------------- */ static size_t HashArrayKey( Tcl_HashTable *tablePtr, /* Hash table. */ void *keyPtr) /* Key from which to compute hash value. */ { const int *array = (const int *) keyPtr; size_t result; int count; for (result = 0, count = tablePtr->keyType; count > 0; count--, array++) { |
︙ | ︙ | |||
764 765 766 767 768 769 770 | * *---------------------------------------------------------------------- */ static Tcl_HashEntry * AllocStringEntry( TCL_UNUSED(Tcl_HashTable *), | | | | | | | | | | | 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 | * *---------------------------------------------------------------------- */ static Tcl_HashEntry * AllocStringEntry( TCL_UNUSED(Tcl_HashTable *), void *keyPtr) /* Key to store in the hash table entry. */ { const char *string = (const char *) keyPtr; Tcl_HashEntry *hPtr; size_t size, allocsize; allocsize = size = strlen(string) + 1; if (size < sizeof(hPtr->key)) { allocsize = sizeof(hPtr->key); } hPtr = (Tcl_HashEntry *)Tcl_Alloc(offsetof(Tcl_HashEntry, key) + allocsize); memset(hPtr, 0, offsetof(Tcl_HashEntry, key) + allocsize); memcpy(hPtr->key.string, string, size); Tcl_SetHashValue(hPtr, NULL); return hPtr; } /* *---------------------------------------------------------------------- * * TclCompareStringKeys -- * * Compares two string keys. * * Results: * The return value is 0 if they are different and 1 if they are the * same. * * Side effects: * None. * *---------------------------------------------------------------------- */ int TclCompareStringKeys( void *keyPtr, /* New key to compare. */ Tcl_HashEntry *hPtr) /* Existing key to compare. */ { return !strcmp((char *)keyPtr, hPtr->key.string); } /* *---------------------------------------------------------------------- * * TclHashStringKey -- * * Compute a one-word summary of a text string, which can be used to * generate a hash index. * * Results: * The return value is a one-word summary of the information in string. * * Side effects: * None. * *---------------------------------------------------------------------- */ size_t TclHashStringKey( TCL_UNUSED(Tcl_HashTable *), void *keyPtr) /* Key from which to compute hash value. */ { const char *string = (const char *)keyPtr; size_t result; char c; /* * I tried a zillion different hash functions and asked many other people |
︙ | ︙ |
Changes to generic/tclIO.c.
︙ | ︙ | |||
1526 1527 1528 1529 1530 1531 1532 | if (interp == NULL) { return TCL_ERROR; } ChanGetInternalRep(objPtr, resPtr); if (resPtr) { /* | | | | 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 | if (interp == NULL) { return TCL_ERROR; } ChanGetInternalRep(objPtr, resPtr); if (resPtr) { /* * Confirm validity of saved lookup results. */ statePtr = resPtr->statePtr; if ((resPtr->interp == interp) /* Same interp context */ /* No epoch change in channel since lookup */ && (resPtr->epoch == statePtr->epoch)) { /* * Have a valid saved lookup. Jump to end to return it. |
︙ | ︙ | |||
1595 1596 1597 1598 1599 1600 1601 | *---------------------------------------------------------------------- */ Tcl_Channel Tcl_CreateChannel( const Tcl_ChannelType *typePtr, /* The channel type record. */ const char *chanName, /* Name of channel to record. */ | | | 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 | *---------------------------------------------------------------------- */ 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. */ int mask) /* TCL_READABLE & TCL_WRITABLE to indicate if * the channel is readable, writable. */ { Channel *chanPtr; /* The channel structure newly created. */ ChannelState *statePtr; /* The stack-level independent state info for * the channel. */ const char *name; |
︙ | ︙ | |||
1805 1806 1807 1808 1809 1810 1811 | Tcl_Channel Tcl_StackChannel( Tcl_Interp *interp, /* The interpreter we are working in */ const Tcl_ChannelType *typePtr, /* The channel type record for the new * channel. */ | | | 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 | Tcl_Channel Tcl_StackChannel( Tcl_Interp *interp, /* The interpreter we are working in */ const Tcl_ChannelType *typePtr, /* The channel type record for the new * channel. */ void *instanceData, /* Instance specific data for the new * channel. */ int mask, /* TCL_READABLE & TCL_WRITABLE to indicate if * the channel is readable, writable. */ Tcl_Channel prevChan) /* The channel structure to replace */ { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); Channel *chanPtr, *prevChanPtr; |
︙ | ︙ | |||
4510 4511 4512 4513 4514 4515 4516 | if (IsBufferFull(bufPtr)) { if (FlushChannel(NULL, chanPtr, 0) != 0) { return -1; } flushed += statePtr->bufSize; /* | | | | | | | | | | | 4510 4511 4512 4513 4514 4515 4516 4517 4518 4519 4520 4521 4522 4523 4524 4525 4526 4527 4528 4529 4530 4531 4532 | if (IsBufferFull(bufPtr)) { if (FlushChannel(NULL, chanPtr, 0) != 0) { return -1; } 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. */ if (needNlFlush && (saved == 0 || src[-1] != '\n')) { needNlFlush = 0; } } } if (((flushed < total) && GotFlag(statePtr, CHANNEL_UNBUFFERED)) || |
︙ | ︙ | |||
10002 10003 10004 10005 10006 10007 10008 | * Stores up to "bytesToRead" bytes in memory pointed to by "dst". * These bytes come from reading the channel "chanPtr" and * performing the configured translations. No encoding conversions * are applied to the bytes being read. * * Results: * The number of bytes actually stored (<= bytesToRead), | | | | | 10002 10003 10004 10005 10006 10007 10008 10009 10010 10011 10012 10013 10014 10015 10016 10017 10018 10019 10020 10021 | * Stores up to "bytesToRead" bytes in memory pointed to by "dst". * These bytes come from reading the channel "chanPtr" and * performing the configured translations. No encoding conversions * are applied to the bytes being read. * * Results: * The number of 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 * that occurred. * * The number of bytes stored can be less than the number * requested when * - EOF is reached on the channel; or * - the channel is non-blocking, and we've read all we can * without blocking. * - a channel reading error occurs (and we return TCL_INDEX_NONE) * * Side effects: * May cause input to be buffered. |
︙ | ︙ | |||
10086 10087 10088 10089 10090 10091 10092 | ChannelBuffer *bufPtr = statePtr->inQueueHead; /* * Don't read more data if we have what we need. */ while (!bufPtr || /* We got no buffer! OR */ | | | 10086 10087 10088 10089 10090 10091 10092 10093 10094 10095 10096 10097 10098 10099 10100 | ChannelBuffer *bufPtr = statePtr->inQueueHead; /* * Don't read more data if we have what we need. */ while (!bufPtr || /* We got no buffer! OR */ (!IsBufferFull(bufPtr) && /* Our buffer has room AND */ ((Tcl_Size) BytesLeft(bufPtr) < bytesToRead))) { /* Not enough bytes in it yet * to fill the dst */ int code; moreData: code = GetInput(chanPtr); |
︙ | ︙ | |||
10758 10759 10760 10761 10762 10763 10764 | * None. * *---------------------------------------------------------------------- */ const char * Tcl_ChannelName( | | > | 10758 10759 10760 10761 10762 10763 10764 10765 10766 10767 10768 10769 10770 10771 10772 10773 | * None. * *---------------------------------------------------------------------- */ const char * Tcl_ChannelName( const Tcl_ChannelType *chanTypePtr) /* Pointer to channel type. */ { return chanTypePtr->typeName; } /* *---------------------------------------------------------------------- * |
︙ | ︙ |
Changes to generic/tclIO.h.
︙ | ︙ | |||
35 36 37 38 39 40 41 | * Buffers data being sent to or from a channel. */ 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. */ | | | | | 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 | * Buffers data being sent to or from a channel. */ 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 * 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 * buffer occupies this space + bufSize-1 * bytes. This must be the last field in the * structure. */ } ChannelBuffer; #define CHANNELBUFFER_HEADER_SIZE offsetof(ChannelBuffer, buf) |
︙ | ︙ | |||
92 93 94 95 96 97 98 | * data specific to the channel but which belongs to the generic part of the * Tcl channel mechanism, and it points at an instance specific (and type * specific) instance data, and at a channel type structure. */ typedef struct Channel { struct ChannelState *state; /* Split out state information */ | | | 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 | * data specific to the channel but which belongs to the generic part of the * Tcl channel mechanism, and it points at an instance specific (and type * specific) instance data, and at a channel type structure. */ typedef struct Channel { struct ChannelState *state; /* Split out state information */ 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 * upon. This reference is NULL for normal * channels. See Tcl_StackChannel. */ struct Channel *upChanPtr; /* Refers to the channel above stacked this * one. NULL for the top most channel. */ |
︙ | ︙ | |||
156 157 158 159 160 161 162 | TclEolTranslation outputTranslation; /* What translation to use for generating end * of line sequences in output? */ int inEofChar; /* If nonzero, use this as a signal of EOF on * input. */ #if TCL_MAJOR_VERSION < 9 int outEofChar; /* If nonzero, append this to the channel when | | > | 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 | TclEolTranslation outputTranslation; /* What translation to use for generating end * of line sequences in output? */ int inEofChar; /* If nonzero, use this as a signal of EOF on * 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 */ #endif int unreportedError; /* Non-zero if an error report was deferred * because it happened in the background. The * value is the POSIX error code. */ Tcl_Size refCount; /* How many interpreters hold references to * this IO channel? */ struct CloseCallback *closeCbPtr; |
︙ | ︙ | |||
210 211 212 213 214 215 216 | /* * TIP #219 ... Info for the I/O system ... * Error message set by channel drivers, for the propagation of arbitrary * Tcl errors. This information, if present (chanMsg not NULL), takes * precedence over a Posix error code returned by a channel operation. */ | | | | 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 | /* * TIP #219 ... Info for the I/O system ... * Error message set by channel drivers, for the propagation of arbitrary * Tcl errors. This information, if present (chanMsg not NULL), takes * 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 * because it happened in the background. The * value is the chanMg, if any. #219's * companion to 'unreportedError'. */ size_t epoch; /* Used to test validity of stored channelname * lookup results. */ int maxPerms; /* TIP #220: Max access privileges * the channel was created with. */ |
︙ | ︙ |
Changes to generic/tclIOCmd.c.
︙ | ︙ | |||
35 36 37 38 39 40 41 | static Tcl_ThreadDataKey dataKey; /* * Static functions for this file: */ static Tcl_ExitProc FinalizeIOCmdTSD; | | | 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 | static Tcl_ThreadDataKey dataKey; /* * Static functions for this file: */ static Tcl_ExitProc FinalizeIOCmdTSD; static Tcl_TcpAcceptProc AcceptCallbackProc; static Tcl_ObjCmdProc ChanPendingObjCmd; static Tcl_ObjCmdProc ChanTruncateObjCmd; static void RegisterTcpServerInterpCleanup( Tcl_Interp *interp, AcceptCallback *acceptCallbackPtr); static Tcl_InterpDeleteProc TcpAcceptCallbacksDeleteProc; static void TcpServerCloseProc(void *callbackData); |
︙ | ︙ |
Changes to generic/tclIOGT.c.
︙ | ︙ | |||
111 112 113 114 115 116 117 | /* * This structure describes the channel type structure for Tcl-based * transformations. */ static const Tcl_ChannelType transformChannelType = { | | | | | | | | | | | | | | | | | | 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 | /* * This structure describes the channel type structure for Tcl-based * transformations. */ static const Tcl_ChannelType transformChannelType = { "transform", TCL_CHANNEL_VERSION_5, NULL, /* Deprecated. */ TransformInputProc, TransformOutputProc, NULL, /* Deprecated. */ TransformSetOptionProc, TransformGetOptionProc, TransformWatchProc, TransformGetFileHandleProc, TransformCloseProc, TransformBlockModeProc, NULL, /* Flush proc. */ TransformNotifyProc, TransformWideSeekProc, NULL, /* Thread action proc. */ NULL /* Truncate proc. */ }; /* * Possible values for 'flags' field in control structure, see below. */ #define CHANNEL_ASYNC (1<<0) /* Non-blocking mode. */ |
︙ | ︙ | |||
846 847 848 849 850 851 852 | * contains the POSIX error code if an error occurred, or zero. * *---------------------------------------------------------------------- */ static long long TransformWideSeekProc( | | | | 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 | * contains the POSIX error code if an error occurred, or zero. * *---------------------------------------------------------------------- */ static long long TransformWideSeekProc( 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); Tcl_DriverWideSeekProc *parentWideSeekProc = Tcl_ChannelWideSeekProc(parentType); void *parentData = Tcl_GetChannelInstanceData(parent); if ((offset == 0) && (mode == SEEK_CUR)) { /* * This is no seek but a request to tell the caller the current |
︙ | ︙ | |||
901 902 903 904 905 906 907 | * If we have a wide seek capability, we should stick with that. */ if (parentWideSeekProc == NULL) { *errorCodePtr = EINVAL; return -1; } | | | 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 | * If we have a wide seek capability, we should stick with that. */ if (parentWideSeekProc == NULL) { *errorCodePtr = EINVAL; return -1; } return parentWideSeekProc(parentData, offset, mode, errorCodePtr); } /* *---------------------------------------------------------------------- * * TransformSetOptionProc -- * |
︙ | ︙ |
Changes to generic/tclIORChan.c.
︙ | ︙ | |||
55 56 57 58 59 60 61 | static int ReflectTruncate(void *clientData, long long length); /* * The C layer channel type/driver definition used by the reflection. */ | | | | | | | | | | | | | | | | | | | | | 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 | static int ReflectTruncate(void *clientData, long long length); /* * The C layer channel type/driver definition used by the reflection. */ 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, #else NULL, /* Thread action proc */ #endif ReflectTruncate /* Truncate proc. */ }; /* * Instance data for a reflected channel. =========================== */ typedef struct { |
︙ | ︙ | |||
663 664 665 666 667 668 669 | Tcl_ResetResult(interp); /* * Everything is fine now. */ | | | | 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 | Tcl_ResetResult(interp); /* * Everything is fine now. */ chan = Tcl_CreateChannel(&reflectedChannelType, TclGetString(rcId), rcPtr, mode); rcPtr->chan = chan; TclChannelPreserve(chan); chanPtr = (Channel *) chan; if ((methods & NULLABLE_METHODS) != NULLABLE_METHODS) { /* * Some of the nullable methods are not supported. We clone the * channel type, null the associated C functions, and use the result * as the actual channel type. */ Tcl_ChannelType *clonePtr = (Tcl_ChannelType *)Tcl_Alloc(sizeof(Tcl_ChannelType)); memcpy(clonePtr, &reflectedChannelType, sizeof(Tcl_ChannelType)); if (!(methods & FLAG(METH_CONFIGURE))) { clonePtr->setOptionProc = NULL; } if (!(methods & FLAG(METH_CGET)) && !(methods & FLAG(METH_CGETALL))) { clonePtr->getOptionProc = NULL; |
︙ | ︙ | |||
1175 1176 1177 1178 1179 1180 1181 | if (result != TCL_OK) { FreeReceivedError(&p); } } #endif tctPtr = ((Channel *)rcPtr->chan)->typePtr; | | | 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 | if (result != TCL_OK) { FreeReceivedError(&p); } } #endif tctPtr = ((Channel *)rcPtr->chan)->typePtr; if (tctPtr && tctPtr != &reflectedChannelType) { Tcl_Free((void *)tctPtr); ((Channel *)rcPtr->chan)->typePtr = NULL; } Tcl_EventuallyFree(rcPtr, FreeReflectedChannel); return EOK; } |
︙ | ︙ | |||
1244 1245 1246 1247 1248 1249 1250 | Tcl_GetChannelName(rcPtr->chan)); if (hPtr) { Tcl_DeleteHashEntry(hPtr); } } #endif tctPtr = ((Channel *)rcPtr->chan)->typePtr; | | | 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 | Tcl_GetChannelName(rcPtr->chan)); if (hPtr) { Tcl_DeleteHashEntry(hPtr); } } #endif tctPtr = ((Channel *)rcPtr->chan)->typePtr; if (tctPtr && tctPtr != &reflectedChannelType) { Tcl_Free((void *)tctPtr); ((Channel *)rcPtr->chan)->typePtr = NULL; } Tcl_EventuallyFree(rcPtr, FreeReflectedChannel); return (result == TCL_OK) ? EOK : EINVAL; } |
︙ | ︙ |
Changes to generic/tclIORTrans.c.
︙ | ︙ | |||
51 52 53 54 55 56 57 | void **handle); static int ReflectNotify(void *clientData, int mask); /* * The C layer channel type/driver definition used by the reflection. */ | | | | | | | | | | | | | | | | | | | 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 | void **handle); static int ReflectNotify(void *clientData, int mask); /* * The C layer channel type/driver definition used by the reflection. */ 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, ReflectSeekWide, NULL, /* Thread action proc. */ NULL /* Truncate proc. */ }; /* * Structure of the buffer to hold transform results to be consumed by higher * layers upon reading from the channel, plus the functions to manage such. */ |
︙ | ︙ | |||
674 675 676 677 678 679 680 | /* * Everything is fine now. */ rtPtr->methods = methods; rtPtr->mode = mode; | | | 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 | /* * Everything is fine now. */ rtPtr->methods = methods; rtPtr->mode = mode; rtPtr->chan = Tcl_StackChannel(interp, &reflectedTransformType, rtPtr, mode, rtPtr->parent); /* * Register the transform in our our map for proper handling of deleted * interpreters and/or threads. */ |
︙ | ︙ | |||
1370 1371 1372 1373 1374 1375 1376 | * non-NULL... */ if (Tcl_ChannelWideSeekProc(parent->typePtr) == NULL) { *errorCodePtr = EINVAL; curPos = -1; } else { | | | | 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 | * non-NULL... */ if (Tcl_ChannelWideSeekProc(parent->typePtr) == NULL) { *errorCodePtr = EINVAL; curPos = -1; } else { curPos = Tcl_ChannelWideSeekProc(parent->typePtr)(parent->instanceData, offset, seekMode, errorCodePtr); } if (curPos == -1) { Tcl_SetErrno(*errorCodePtr); } *errorCodePtr = EOK; Tcl_Release(rtPtr); |
︙ | ︙ |
Changes to generic/tclIOUtil.c.
︙ | ︙ | |||
3460 3461 3462 3463 3464 3465 3466 | * from the virtual filesystem to a native filesystem. * *---------------------------------------------------------------------- */ static void * DivertFindSymbol( | | | 3460 3461 3462 3463 3464 3465 3466 3467 3468 3469 3470 3471 3472 3473 3474 | * from the virtual filesystem to a native filesystem. * *---------------------------------------------------------------------- */ static void * DivertFindSymbol( Tcl_Interp *interp, /* The relevant interpreter. */ Tcl_LoadHandle loadHandle, /* A handle to the diverted module. */ const char *symbol) /* The name of symbol to resolve. */ { FsDivertLoad *tvdlPtr = (FsDivertLoad *) loadHandle->clientData; Tcl_LoadHandle originalHandle = tvdlPtr->loadHandle; return originalHandle->findSymbolProcPtr(interp, originalHandle, symbol); |
︙ | ︙ |
Changes to generic/tclInt.h.
︙ | ︙ | |||
1087 1088 1089 1090 1091 1092 1093 | } ActiveInterpTrace; /* * Flag values designating types of execution traces. See tclTrace.c for * related flag values. * * TCL_TRACE_ENTER_EXEC - triggers enter/enterstep traces. | | | | 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 | } ActiveInterpTrace; /* * Flag values designating types of execution traces. See tclTrace.c for * related flag values. * * TCL_TRACE_ENTER_EXEC - triggers enter/enterstep traces. * - passed to Tcl_CreateObjTrace to set up * "enterstep" traces. * TCL_TRACE_LEAVE_EXEC - triggers leave/leavestep traces. * - passed to Tcl_CreateObjTrace to set up * "leavestep" traces. */ #define TCL_TRACE_ENTER_EXEC 1 #define TCL_TRACE_LEAVE_EXEC 2 #if TCL_MAJOR_VERSION > 8 |
︙ | ︙ | |||
1542 1543 1544 1545 1546 1547 1548 | /* * The type of procedures called by the Tcl bytecode compiler to compile * commands. Pointers to these procedures are kept in the Command structure * describing each command. The integer value returned by a CompileProc must * be one of the following: * * TCL_OK Compilation completed normally. | | | | | | | | | | | 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 | /* * The type of procedures called by the Tcl bytecode compiler to compile * commands. Pointers to these procedures are kept in the Command structure * describing each command. The integer value returned by a CompileProc must * 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. */ typedef int (CompileProc)(Tcl_Interp *interp, Tcl_Parse *parsePtr, struct Command *cmdPtr, struct CompileEnv *compEnvPtr); /* * The type of procedure called from the compilation hook point in |
︙ | ︙ | |||
2162 2163 2164 2165 2166 2167 2168 | Tcl_Obj *const *sourceObjs; /* What arguments were actually input into the * *root* ensemble command? (Nested ensembles * don't rewrite this.) NULL if we're not * processing an ensemble. */ Tcl_Size numRemovedObjs;/* How many arguments have been stripped off * because of ensemble processing. */ | | > | 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 2176 2177 | Tcl_Obj *const *sourceObjs; /* What arguments were actually input into the * *root* ensemble command? (Nested ensembles * don't rewrite this.) NULL if we're not * 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 * inserted by an ensemble. */ } ensembleRewrite; /* * TIP #219: Global info for the I/O system. */ |
︙ | ︙ | |||
2920 2921 2922 2923 2924 2925 2926 | Tcl_Size epoch; /* Epoch counter to detect changes in the * global value. */ TCL_HASH_TYPE numBytes; /* Length of the global string. */ char *value; /* The global string value. */ Tcl_Encoding encoding; /* system encoding when global string was * initialized. */ TclInitProcessGlobalValueProc *proc; | | | 2921 2922 2923 2924 2925 2926 2927 2928 2929 2930 2931 2932 2933 2934 2935 | Tcl_Size epoch; /* Epoch counter to detect changes in the * global value. */ TCL_HASH_TYPE numBytes; /* Length of the global string. */ char *value; /* The global string value. */ Tcl_Encoding encoding; /* system encoding when global string was * initialized. */ TclInitProcessGlobalValueProc *proc; /* A procedure to initialize the global string * copy when a "get" request comes in before * any "set" request has been received. */ Tcl_Mutex mutex; /* Enforce orderly access from multiple * threads. */ Tcl_ThreadDataKey key; /* Key for per-thread data holding the * (Tcl_Obj) copy for each thread. */ } ProcessGlobalValue; |
︙ | ︙ | |||
3105 3106 3107 3108 3109 3110 3111 3112 3113 3114 3115 3116 3117 3118 | * Variables denoting the Tcl object types defined in the core. */ 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 tclIntType; MODULE_SCOPE const Tcl_ObjType tclIndexType; MODULE_SCOPE const Tcl_ObjType tclListType; MODULE_SCOPE const Tcl_ObjType tclDictType; MODULE_SCOPE const Tcl_ObjType tclProcBodyType; MODULE_SCOPE const Tcl_ObjType tclStringType; MODULE_SCOPE const Tcl_ObjType tclEnsembleCmdType; | > | 3106 3107 3108 3109 3110 3111 3112 3113 3114 3115 3116 3117 3118 3119 3120 | * Variables denoting the Tcl object types defined in the core. */ 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; MODULE_SCOPE const Tcl_ObjType tclDictType; MODULE_SCOPE const Tcl_ObjType tclProcBodyType; MODULE_SCOPE const Tcl_ObjType tclStringType; MODULE_SCOPE const Tcl_ObjType tclEnsembleCmdType; |
︙ | ︙ | |||
3401 3402 3403 3404 3405 3406 3407 3408 3409 3410 3411 3412 3413 3414 | MODULE_SCOPE char * TclGetStringStorage(Tcl_Obj *objPtr, Tcl_Size *sizePtr); MODULE_SCOPE int TclGetLoadedLibraries(Tcl_Interp *interp, const char *targetName, const char *packageName); MODULE_SCOPE int TclGetWideBitsFromObj(Tcl_Interp *, Tcl_Obj *, Tcl_WideInt *); MODULE_SCOPE int TclIncrObj(Tcl_Interp *interp, Tcl_Obj *valuePtr, Tcl_Obj *incrPtr); MODULE_SCOPE Tcl_Obj * TclIncrObjVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *incrPtr, int flags); MODULE_SCOPE Tcl_ObjCmdProc TclInfoExistsCmd; MODULE_SCOPE Tcl_ObjCmdProc TclInfoCoroutineCmd; MODULE_SCOPE Tcl_Obj * TclInfoFrame(Tcl_Interp *interp, CmdFrame *framePtr); | > > | 3403 3404 3405 3406 3407 3408 3409 3410 3411 3412 3413 3414 3415 3416 3417 3418 | MODULE_SCOPE char * TclGetStringStorage(Tcl_Obj *objPtr, Tcl_Size *sizePtr); MODULE_SCOPE int TclGetLoadedLibraries(Tcl_Interp *interp, const char *targetName, 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, Tcl_Obj *part2Ptr, Tcl_Obj *incrPtr, int flags); MODULE_SCOPE Tcl_ObjCmdProc TclInfoExistsCmd; MODULE_SCOPE Tcl_ObjCmdProc TclInfoCoroutineCmd; MODULE_SCOPE Tcl_Obj * TclInfoFrame(Tcl_Interp *interp, CmdFrame *framePtr); |
︙ | ︙ | |||
3482 3483 3484 3485 3486 3487 3488 | const char *expected, const char *bytes, Tcl_Size numBytes, const char **endPtrPtr, int flags); MODULE_SCOPE void TclParseInit(Tcl_Interp *interp, const char *string, Tcl_Size numBytes, Tcl_Parse *parsePtr); 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); | | | < | 3486 3487 3488 3489 3490 3491 3492 3493 3494 3495 3496 3497 3498 3499 3500 3501 3502 3503 3504 3505 | const char *expected, const char *bytes, Tcl_Size numBytes, const char **endPtrPtr, int flags); MODULE_SCOPE void TclParseInit(Tcl_Interp *interp, const char *string, Tcl_Size numBytes, Tcl_Parse *parsePtr); 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 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 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, Tcl_Size len); MODULE_SCOPE void TclpAlertNotifier(void *clientData); MODULE_SCOPE void * TclpNotifierData(void); MODULE_SCOPE void TclpServiceModeHook(int mode); |
︙ | ︙ |
Changes to generic/tclLink.c.
︙ | ︙ | |||
105 106 107 108 109 110 111 | static int SetInvalidRealFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); /* * A marker type used to flag weirdnesses so we can pass them around right. */ | | | 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 | static int SetInvalidRealFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); /* * A marker type used to flag weirdnesses so we can pass them around right. */ static const Tcl_ObjType invalidRealType = { "invalidReal", /* name */ NULL, /* freeIntRepProc */ NULL, /* dupIntRepProc */ NULL, /* updateStringProc */ NULL, /* setFromAnyProc */ TCL_OBJTYPE_V0 }; |
︙ | ︙ |
Changes to generic/tclListObj.c.
︙ | ︙ | |||
262 263 264 265 266 267 268 | * * Side effects: * The memory may be freed. * *------------------------------------------------------------------------ */ static inline void | | > | 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 | * * Side effects: * The memory may be freed. * *------------------------------------------------------------------------ */ static inline void ListSpanDecrRefs( ListSpan *spanPtr) { if (spanPtr->refCount <= 1) { Tcl_Free(spanPtr); } else { spanPtr->refCount -= 1; } } |
︙ | ︙ | |||
339 340 341 342 343 344 345 | * * Side effects: * See comments for ListRepUnsharedFreeUnreferenced. * *------------------------------------------------------------------------ */ static inline void | | > | 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 | * * Side effects: * See comments for ListRepUnsharedFreeUnreferenced. * *------------------------------------------------------------------------ */ static inline void ListRepFreeUnreferenced( const ListRep *repPtr) { if (! ListRepIsShared(repPtr) && repPtr->spanPtr) { /* T:listrep-1.5.1 */ ListRepUnsharedFreeUnreferenced(repPtr); } } |
︙ | ︙ | |||
488 489 490 491 492 493 494 | * * Side effects: * Error message and code are stored in the interpreter if not NULL. * *------------------------------------------------------------------------ */ static int | | > | < | | 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 | * * Side effects: * Error message and code are stored in the interpreter if not NULL. * *------------------------------------------------------------------------ */ static int ListLimitExceededError( Tcl_Interp *interp) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "max length of a Tcl list exceeded", -1)); Tcl_SetErrorCode(interp, "TCL", "MEMORY", (char *)NULL); } return TCL_ERROR; } /* *------------------------------------------------------------------------ |
︙ | ︙ | |||
519 520 521 522 523 524 525 | * Side effects: * The contents of the ListRep's ListStore area are shifted down in the * storage area. The ListRep's ListSpan is updated accordingly. * *------------------------------------------------------------------------ */ static inline void | | > > | 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 | * Side effects: * The contents of the ListRep's ListStore area are shifted down in the * storage area. The ListRep's ListSpan is updated accordingly. * *------------------------------------------------------------------------ */ static inline void ListRepUnsharedShiftDown( ListRep *repPtr, Tcl_Size shiftCount) { ListStore *storePtr; LISTREP_CHECK(repPtr); LIST_ASSERT(!ListRepIsShared(repPtr)); storePtr = repPtr->storePtr; |
︙ | ︙ | |||
574 575 576 577 578 579 580 | * The contents of the ListRep's ListStore area are shifted up in the * storage area. The ListRep's ListSpan is updated accordingly. * *------------------------------------------------------------------------ */ #if 0 static inline void | | > > | 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 | * The contents of the ListRep's ListStore area are shifted up in the * storage area. The ListRep's ListSpan is updated accordingly. * *------------------------------------------------------------------------ */ #if 0 static inline void ListRepUnsharedShiftUp( ListRep *repPtr, Tcl_Size shiftCount) { ListStore *storePtr; LISTREP_CHECK(repPtr); LIST_ASSERT(!ListRepIsShared(repPtr)); LIST_COUNT_ASSERT(shiftCount); |
︙ | ︙ | |||
620 621 622 623 624 625 626 | * * Side effects: * Panics if any invariant is not met. * *------------------------------------------------------------------------ */ static void | | > > > | 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 | * * Side effects: * Panics if any invariant is not met. * *------------------------------------------------------------------------ */ static void ListRepValidate( const ListRep *repPtr, const char *file, int lineNum) { ListStore *storePtr = repPtr->storePtr; const char *condition; (void)storePtr; /* To stop gcc from whining about unused vars */ #define INVARIANT(cond_) \ |
︙ | ︙ | |||
685 686 687 688 689 690 691 | * Side effects: * Will panic if internal structure is not consistent or if object * cannot be converted to a list object. * *------------------------------------------------------------------------ */ void | | > > | 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 | * Side effects: * Will panic if internal structure is not consistent or if object * cannot be converted to a list object. * *------------------------------------------------------------------------ */ void TclListObjValidate( Tcl_Interp *interp, Tcl_Obj *listObj) { ListRep listRep; if (TclListObjGetRep(interp, listObj, &listRep) != TCL_OK) { Tcl_Panic("Object passed to TclListObjValidate cannot be converted to " "a list object."); } ListRepValidate(&listRep, __FILE__, __LINE__); |
︙ | ︙ | |||
1664 1665 1666 1667 1668 1669 1670 | { ListRep listRep; if (TclObjTypeHasProc(objPtr, getElementsProc)) { return TclObjTypeGetElements(interp, objPtr, objcPtr, objvPtr); } if (TclListObjGetRep(interp, objPtr, &listRep) != TCL_OK) { | | | 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 | { ListRep listRep; if (TclObjTypeHasProc(objPtr, getElementsProc)) { return TclObjTypeGetElements(interp, objPtr, objcPtr, objvPtr); } if (TclListObjGetRep(interp, objPtr, &listRep) != TCL_OK) { return TCL_ERROR; } ListRepElements(&listRep, *objcPtr, *objvPtr); return TCL_OK; } /* *---------------------------------------------------------------------- |
︙ | ︙ | |||
1726 1727 1728 1729 1730 1731 1732 | * * TclListObjAppendElements -- * * Appends multiple elements to a Tcl_Obj list object. If * the passed Tcl_Obj is not a list object, it will be converted to one * and an error raised if the conversion fails. * | | | | 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 | * * TclListObjAppendElements -- * * Appends multiple elements to a Tcl_Obj list object. If * 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. * * Results: * On success, TCL_OK is returned with the specified elements appended. * On failure, TCL_ERROR is returned with an error message in the * interpreter if not NULL. * * Side effects: |
︙ | ︙ | |||
1914 1915 1916 1917 1918 1919 1920 | } /* *---------------------------------------------------------------------- * * Tcl_ListObjIndex -- * | | | | < | < | < | | | < | | 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 | } /* *---------------------------------------------------------------------- * * Tcl_ListObjIndex -- * * 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: * If 'listPtr' is not already of type 'tclListType', it is converted. * *---------------------------------------------------------------------- */ int Tcl_ListObjIndex( Tcl_Interp *interp, /* Used to report errors if not NULL. */ Tcl_Obj *listObj, /* List object to index into. */ |
︙ | ︙ | |||
2913 2914 2915 2916 2917 2918 2919 | * invalidated if the operation succeeds. */ retValueObj = subListObj; result = TCL_OK; /* Allocate if static array for pending invalidations is too small */ | | | 2920 2921 2922 2923 2924 2925 2926 2927 2928 2929 2930 2931 2932 2933 2934 | * invalidated if the operation succeeds. */ retValueObj = subListObj; result = TCL_OK; /* Allocate if static array for pending invalidations is too small */ if (indexCount > (Tcl_Size) (sizeof(pendingInvalidates) / sizeof(pendingInvalidates[0]))) { pendingInvalidatesPtr = (Tcl_Obj **) Tcl_Alloc(indexCount * sizeof(*pendingInvalidatesPtr)); } /* * Loop through all the index arguments, and for each one dive into the |
︙ | ︙ | |||
3020 3021 3022 3023 3024 3025 3026 | * so far is replace a list element with an unshared copy. The * list value remains the same, so the string rep. is still * valid, and unchanged, which is good because if this whole * routine returns NULL, we'd like to leave no change to the * 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 | | | < | 3027 3028 3029 3030 3031 3032 3033 3034 3035 3036 3037 3038 3039 3040 3041 3042 | * so far is replace a list element with an unshared copy. The * list value remains the same, so the string rep. is still * valid, and unchanged, which is good because if this whole * routine returns NULL, we'd like to leave no change to the * 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 * pendingInvalidatesPtr[] so we can spoil them at that time. */ pendingInvalidatesPtr[numPendingInvalidates] = parentList; ++numPendingInvalidates; } } while (indexCount > 0); |
︙ | ︙ |
Changes to generic/tclParse.c.
︙ | ︙ | |||
1035 1036 1037 1038 1039 1040 1041 | * None. * *---------------------------------------------------------------------- */ static int ParseTokens( | | | 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 | * None. * *---------------------------------------------------------------------- */ static int ParseTokens( 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 * CHAR_TYPE contains any of the bits in * mask. */ int flags, /* OR-ed bits indicating what substitutions to * perform: TCL_SUBST_COMMANDS, |
︙ | ︙ | |||
1527 1528 1529 1530 1531 1532 1533 | * *---------------------------------------------------------------------- */ const char * Tcl_ParseVar( Tcl_Interp *interp, /* Context for looking up variable. */ | | | 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 | * *---------------------------------------------------------------------- */ const char * Tcl_ParseVar( Tcl_Interp *interp, /* Context for looking up variable. */ 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 * variable specifier. */ { Tcl_Obj *objPtr; int code; |
︙ | ︙ |
Changes to generic/tclParse.h.
1 | /* | | > | | | | | | | | | | > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | /* * Minimal set of shared flag definitions and declarations so that multiple * source files can make use of the parsing table in tclParse.c */ 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)] MODULE_SCOPE const unsigned char tclCharTypeTable[]; |
Changes to generic/tclPathObj.c.
︙ | ︙ | |||
36 37 38 39 40 41 42 | /* * Define the 'path' object type, which Tcl uses to represent file paths * internally. */ static const Tcl_ObjType fsPathType = { | | | | | | | 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 | /* * Define the 'path' object type, which Tcl uses to represent file paths * internally. */ static const Tcl_ObjType fsPathType = { "path", /* name */ FreeFsPathInternalRep, /* freeIntRepProc */ DupFsPathInternalRep, /* dupIntRepProc */ UpdateStringOfFsPath, /* updateStringProc */ SetFsPathFromAny, /* setFromAnyProc */ TCL_OBJTYPE_V0 }; /* * struct FsPath -- * * Internal representation of a Tcl_Obj of fsPathType |
︙ | ︙ | |||
2343 2344 2345 2346 2347 2348 2349 | * Memory may be allocated. * *--------------------------------------------------------------------------- */ static void UpdateStringOfFsPath( | | | 2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 2355 2356 2357 | * Memory may be allocated. * *--------------------------------------------------------------------------- */ static void UpdateStringOfFsPath( Tcl_Obj *pathPtr) /* path obj with string rep to update. */ { FsPath *fsPathPtr = PATHOBJ(pathPtr); Tcl_Size cwdLen; Tcl_Obj *copy; if (PATHFLAGS(pathPtr) == 0 || fsPathPtr->cwdPtr == NULL) { if (fsPathPtr->translatedPathPtr == NULL) { |
︙ | ︙ | |||
2465 2466 2467 2468 2469 2470 2471 | * Returns TCL_OK on success with home directory path in *dsPtr * and TCL_ERROR on failure with error message in interp if non-NULL. * *---------------------------------------------------------------------- */ int MakeTildeRelativePath( | | | | | | | 2465 2466 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 | * Returns TCL_OK on success with home directory path in *dsPtr * and TCL_ERROR on failure with error message in interp if non-NULL. * *---------------------------------------------------------------------- */ 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 */ { const char *dir; Tcl_DString dirString; Tcl_DStringInit(dsPtr); Tcl_DStringInit(&dirString); |
︙ | ︙ | |||
2533 2534 2535 2536 2537 2538 2539 | * Returns a Tcl_Obj containing the home directory of a user * or NULL on failure with error message in interp if non-NULL. * *---------------------------------------------------------------------- */ Tcl_Obj * TclGetHomeDirObj( | | | | 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 | * Returns a Tcl_Obj containing the home directory of a user * or NULL on failure with error message in interp if non-NULL. * *---------------------------------------------------------------------- */ Tcl_Obj * TclGetHomeDirObj( Tcl_Interp *interp, /* May be NULL. Only used for error messages */ const char *user) /* User name. NULL -> current user */ { Tcl_DString dirString; if (MakeTildeRelativePath(interp, user, NULL, &dirString) != TCL_OK) { return NULL; } return Tcl_DStringToObj(&dirString); |
︙ | ︙ | |||
2565 2566 2567 2568 2569 2570 2571 | * Returns NULL if the path begins with a ~ that cannot be resolved * and stores an error message in interp if non-NULL. * *---------------------------------------------------------------------- */ Tcl_Obj * TclResolveTildePath( | | | 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 | * Returns NULL if the path begins with a ~ that cannot be resolved * and stores an error message in interp if non-NULL. * *---------------------------------------------------------------------- */ Tcl_Obj * TclResolveTildePath( Tcl_Interp *interp, /* May be NULL. Only used for error messages */ Tcl_Obj *pathObj) { const char *path; Tcl_Size len; Tcl_Size split; Tcl_DString resolvedPath; |
︙ | ︙ |
Changes to generic/tclPipe.c.
︙ | ︙ | |||
1017 1018 1019 1020 1021 1022 1023 | *---------------------------------------------------------------------- */ Tcl_Channel Tcl_OpenCommandChannel( Tcl_Interp *interp, /* Interpreter for error reporting. Can NOT be * NULL. */ | | | 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 | *---------------------------------------------------------------------- */ Tcl_Channel Tcl_OpenCommandChannel( Tcl_Interp *interp, /* Interpreter for error reporting. Can NOT be * NULL. */ 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. */ { TclFile *inPipePtr, *outPipePtr, *errFilePtr; TclFile inPipe, outPipe, errFile; Tcl_Size numPids; |
︙ | ︙ |
Changes to generic/tclPkgConfig.c.
︙ | ︙ | |||
18 19 20 21 22 23 24 | * * - TCL_THREADS OSCMa compilation as threaded core. * - TCL_MEM_DEBUG OSCMa memory debugging. * - TCL_COMPILE_DEBUG OSCMa debugging of bytecode compiler. * - TCL_COMPILE_STATS OSCMa bytecode compiler statistics. * * - TCL_CFG_DO64BIT NSCMdt tcl is compiled for a 64bit system. | | | 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 | * * - TCL_THREADS OSCMa compilation as threaded core. * - TCL_MEM_DEBUG OSCMa memory debugging. * - TCL_COMPILE_DEBUG OSCMa debugging of bytecode compiler. * - 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. * - TCL_CFG_OPTIMIZED NSCMdt tcl is compiled with cc optimizations on * - TCL_CFG_PROFILED NSCMdt tcl is compiled with profiling info. * * - CFG_RUNTIME_* Paths to various stuff at runtime. * - CFG_INSTALL_* Paths to various stuff at installation time. * * - TCL_CFGVAL_ENCODING string containing the encoding used for the |
︙ | ︙ |
Changes to generic/tclPreserve.c.
︙ | ︙ | |||
17 18 19 20 21 22 23 | /* * The following data structure is used to keep track of all the Tcl_Preserve * calls that are still in effect. It grows as needed to accommodate any * number of calls in effect. */ typedef struct { | | | > | | 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 | /* * The following data structure is used to keep track of all the Tcl_Preserve * calls that are still in effect. It grows as needed to accommodate any * number of calls in effect. */ typedef struct { 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 * called while a Tcl_Preserve call was in * effect, so the structure must be freed when * refCount becomes zero. */ Tcl_FreeProc *freeProc; /* Function to call to free. */ } Reference; /* * Global data structures used to hold the list of preserved data references. * These variables are protected by "preserveMutex". */ 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 * refArray. */ TCL_DECLARE_MUTEX(preserveMutex)/* To protect the above statics */ #define INITIAL_SIZE 2 /* Initial number of reference slots to make */ /* * The following data structure is used to keep track of whether an arbitrary |
︙ | ︙ | |||
113 114 115 116 117 118 119 | * until at least the matching call to Tcl_Release. * *---------------------------------------------------------------------- */ void Tcl_Preserve( | | | 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 | * until at least the matching call to Tcl_Release. * *---------------------------------------------------------------------- */ void Tcl_Preserve( void *clientData) /* Pointer to malloc'ed block of memory. */ { Reference *refPtr; size_t i; /* * See if there is already a reference for this pointer. If so, just * increment its reference count. |
︙ | ︙ | |||
176 177 178 179 180 181 182 | * call to Tcl_Preserve is still in effect, the block of memory is freed. * *---------------------------------------------------------------------- */ void Tcl_Release( | | | 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 | * call to Tcl_Preserve is still in effect, the block of memory is freed. * *---------------------------------------------------------------------- */ void Tcl_Release( void *clientData) /* Pointer to malloc'ed block of memory. */ { Reference *refPtr; size_t i; Tcl_MutexLock(&preserveMutex); for (i=0, refPtr=refArray ; i<inUse ; i++, refPtr++) { int mustFree; |
︙ | ︙ | |||
255 256 257 258 259 260 261 | * Ptr may be released by calling free(). * *---------------------------------------------------------------------- */ void Tcl_EventuallyFree( | | | 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 | * Ptr may be released by calling free(). * *---------------------------------------------------------------------- */ void Tcl_EventuallyFree( void *clientData, /* Pointer to malloc'ed block of memory. */ Tcl_FreeProc *freeProc) /* Function to actually do free. */ { Reference *refPtr; size_t i; /* * See if there is a reference for this pointer. If so, set its "mustFree" |
︙ | ︙ |
Changes to generic/tclProc.c.
︙ | ︙ | |||
1631 1632 1633 1634 1635 1636 1637 | return TclNRInterpProcCore(interp, objv[0], 1, &MakeProcError); } static int NRInterpProc( void *clientData, /* Record describing procedure to be * interpreted. */ | | | 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 | return TclNRInterpProcCore(interp, objv[0], 1, &MakeProcError); } static int NRInterpProc( void *clientData, /* Record describing procedure to be * interpreted. */ Tcl_Interp *interp, /* Interpreter in which procedure was * invoked. */ int objc, /* Count of number of arguments to this * procedure. */ Tcl_Obj *const objv[]) /* Argument value objects. */ { int result = TclPushProcCallFrame(clientData, interp, objc, objv, /*isLambda*/ 0); |
︙ | ︙ | |||
2104 2105 2106 2107 2108 2109 2110 | * procedure completes. * *---------------------------------------------------------------------- */ void TclProcDeleteProc( | | | 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 2118 | * procedure completes. * *---------------------------------------------------------------------- */ void TclProcDeleteProc( void *clientData) /* Procedure to be deleted. */ { Proc *procPtr = (Proc *)clientData; if (procPtr->refCount-- <= 1) { TclProcCleanupProc(procPtr); } } |
︙ | ︙ |
Changes to generic/tclRegexp.c.
︙ | ︙ | |||
99 100 101 102 103 104 105 | /* * The regular expression Tcl object type. This serves as a cache of the * compiled form of the regular expression. */ const Tcl_ObjType tclRegexpType = { | | | | | | | 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 | /* * The regular expression Tcl object type. This serves as a cache of the * compiled form of the regular expression. */ const Tcl_ObjType tclRegexpType = { "regexp", /* name */ FreeRegexpInternalRep, /* freeIntRepProc */ DupRegexpInternalRep, /* dupIntRepProc */ NULL, /* updateStringProc */ SetRegexpFromAny, /* setFromAnyProc */ TCL_OBJTYPE_V0 }; #define RegexpSetInternalRep(objPtr, rePtr) \ do { \ Tcl_ObjInternalRep ir; \ (rePtr)->refCount++; \ |
︙ | ︙ |
Changes to generic/tclResult.c.
︙ | ︙ | |||
384 385 386 387 388 389 390 | * It also clears any error information for the interpreter. * *---------------------------------------------------------------------- */ void Tcl_ResetResult( | | | 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 | * It also clears any error information for the interpreter. * *---------------------------------------------------------------------- */ void Tcl_ResetResult( Tcl_Interp *interp) /* Interpreter for which to clear result. */ { Interp *iPtr = (Interp *) interp; ResetObjResult(iPtr); if (iPtr->errorCode) { /* Legacy support */ if (iPtr->flags & ERR_LEGACY_COPY) { |
︙ | ︙ | |||
437 438 439 440 441 442 443 | * the interpreter. * *---------------------------------------------------------------------- */ static void ResetObjResult( | | | 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 | * the interpreter. * *---------------------------------------------------------------------- */ static void ResetObjResult( Interp *iPtr) /* Points to the interpreter whose result * object should be reset. */ { Tcl_Obj *objResultPtr = iPtr->objResultPtr; if (Tcl_IsShared(objResultPtr)) { TclDecrRefCount(objResultPtr); TclNewObj(objResultPtr); |
︙ | ︙ | |||
756 757 758 759 760 761 762 | /* * Reset while keeping the list internalrep as much as possible. */ Tcl_ListObjReplace(interp, iPtr->errorStack, 0, len, valueObjc, valueObjv); | | | 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 | /* * Reset while keeping the list internalrep as much as possible. */ Tcl_ListObjReplace(interp, iPtr->errorStack, 0, len, valueObjc, valueObjv); } Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORCODE], &valuePtr); if (valuePtr != NULL) { Tcl_SetObjErrorCode(interp, valuePtr); } else { Tcl_SetErrorCode(interp, "NONE", (void *)NULL); } |
︙ | ︙ |
Changes to generic/tclScan.c.
︙ | ︙ | |||
12 13 14 15 16 17 18 | #include "tclInt.h" #include "tclTomMath.h" #include <assert.h> /* * Flag values used by Tcl_ScanObjCmd. */ | | | | | | | | > | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 | #include "tclInt.h" #include "tclTomMath.h" #include <assert.h> /* * 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. */ 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 * character set. */ typedef struct { |
︙ | ︙ | |||
353 354 355 356 357 358 359 | * Parse any width specifier. */ if ((ch < 0x80) && isdigit(UCHAR(ch))) { /* INTL: "C" locale. */ /* Note ull >= 0 because of isdigit check above */ unsigned long long ull; ull = strtoull( | | | < | | < | | | 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 | * Parse any width specifier. */ if ((ch < 0x80) && isdigit(UCHAR(ch))) { /* INTL: "C" locale. */ /* Note ull >= 0 because of isdigit check above */ unsigned long long ull; ull = strtoull( 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_SetErrorCode( interp, "TCL", "FORMAT", "WIDTHLIMIT", (char *)NULL); goto error; } flags |= SCAN_WIDTH; format += TclUtfToUniChar(format, &ch); } /* |
︙ | ︙ | |||
1002 1003 1004 1005 1006 1007 1008 | if (TclGetString(objPtr)[0] == '-') { value = INT_MIN; } else { value = INT_MAX; } } if ((flags & SCAN_UNSIGNED) && (value < 0)) { | > > > > > > > > > > > | > | 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 | if (TclGetString(objPtr)[0] == '-') { value = INT_MIN; } else { value = INT_MAX; } } if ((flags & SCAN_UNSIGNED) && (value < 0)) { #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); } } objs[objIndex++] = objPtr; break; |
︙ | ︙ | |||
1092 1093 1094 1095 1096 1097 1098 | } } else { /* * Here no vars were specified, we want a list returned (inline scan) * We create an empty Tcl_Obj to fill missing values rather than * allocating a new Tcl_Obj every time. See test scan-bigdata-XX. */ | | < < > > | < | 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 | } } else { /* * Here no vars were specified, we want a list returned (inline scan) * 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 = NULL; TclNewObj(objPtr); for (i = 0; code == TCL_OK && i < totalVars; i++) { if (objs[i] != NULL) { code = Tcl_ListObjAppendElement(interp, objPtr, objs[i]); Tcl_DecrRefCount(objs[i]); } else { /* * More %-specifiers than matching chars, so we just spit out * empty strings for these. */ if (!emptyObj) { TclNewObj(emptyObj); } code = Tcl_ListObjAppendElement(interp, objPtr, emptyObj); } } if (code != TCL_OK) { /* If error'ed out, free up remaining. i contains last index freed */ while (++i < totalVars) { if (objs[i] != NULL) { Tcl_DecrRefCount(objs[i]); } } |
︙ | ︙ |
Changes to generic/tclStrToD.c.
︙ | ︙ | |||
120 121 122 123 124 125 126 | #define TWO_OVER_3LOG10 0.28952965460216784 #define LOG10_3HALVES_PLUS_FUDGE 0.1760912590558 /* * Definitions of the parts of an IEEE754-format floating point number. */ | | | 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 | #define TWO_OVER_3LOG10 0.28952965460216784 #define LOG10_3HALVES_PLUS_FUDGE 0.1760912590558 /* * Definitions of the parts of an IEEE754-format floating point number. */ #define SIGN_BIT 0x80000000 /* Mask for the sign bit in the first word of * a double. */ #define EXP_MASK 0x7FF00000 /* Mask for the exponent field in the first * word of a double. */ #define EXP_SHIFT 20 /* Shift count to make the exponent an * integer. */ |
︙ | ︙ | |||
304 305 306 307 308 309 310 | long exponent); #ifdef IEEE_FLOATING_POINT static double MakeNaN(int signum, Tcl_WideUInt tag); #endif static double RefineApproximation(double approx, mp_int *exactSignificand, int exponent); static mp_err MulPow5(mp_int *, unsigned, mp_int *) MP_WUR; | | | 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 | long exponent); #ifdef IEEE_FLOATING_POINT static double MakeNaN(int signum, Tcl_WideUInt tag); #endif 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 RequiredPrecision(Tcl_WideUInt); static void DoubleToExpAndSig(double, Tcl_WideUInt *, int *, int *); static void TakeAbsoluteValue(Double *, int *); static char * FormatInfAndNaN(Double *, int *, char **); static char * FormatZero(int *, char **); static int ApproximateLog10(Tcl_WideUInt, int, int); |
︙ | ︙ | |||
1692 1693 1694 1695 1696 1697 1698 | * With gcc on x86, the floating point rounding mode is double-extended. * This causes the result of double-precision calculations to be rounded * twice: once to the precision of double-extended and then again to the * precision of double. Double-rounding introduces gratuitous errors of 1 * 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. */ | | | 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 | * With gcc on x86, the floating point rounding mode is double-extended. * This causes the result of double-precision calculations to be rounded * twice: once to the precision of double-extended and then again to the * precision of double. Double-rounding introduces gratuitous errors of 1 * 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. */ /* * Test for zero significand, which requires explicit construction * of -0.0. (Unary minus returns a positive zero.) */ if (significand == 0) { return copysign(0.0, -signum); |
︙ | ︙ | |||
2205 2206 2207 2208 2209 2210 2211 | * Stores base*5**n in result. * *---------------------------------------------------------------------- */ static inline mp_err MulPow5( | | | 2205 2206 2207 2208 2209 2210 2211 2212 2213 2214 2215 2216 2217 2218 2219 | * Stores base*5**n in result. * *---------------------------------------------------------------------- */ static inline mp_err MulPow5( mp_int *base, /* Number to multiply. */ unsigned n, /* Power of 5 to multiply by. */ mp_int *result) /* Place to store the result. */ { mp_int *p = base; int n13 = n / 13; int r = n % 13; mp_err err = MP_OKAY; |
︙ | ︙ | |||
2648 2649 2650 2651 2652 2653 2654 | * one too high. * *---------------------------------------------------------------------- */ static inline void SetPrecisionLimits( | | | 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 2662 | * one too high. * *---------------------------------------------------------------------- */ static inline void SetPrecisionLimits( 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 * adjusted if needed). */ int *iPtr, /* OUT: Maximum number of digits to return. */ int *iLimPtr, /* OUT: Number of digits of significance if * the bignum method is used.*/ |
︙ | ︙ | |||
2702 2703 2704 2705 2706 2707 2708 | * "1" and moves the decimal point (*kPtr) one place to the right. * *---------------------------------------------------------------------- */ static inline char * BumpUp( | | | 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 2713 2714 2715 2716 | * "1" and moves the decimal point (*kPtr) one place to the right. * *---------------------------------------------------------------------- */ static inline char * BumpUp( 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. */ { while (*--s == '9') { if (s == retval) { ++(*kPtr); |
︙ | ︙ | |||
3429 3430 3431 3432 3433 3434 3435 | /* * Compare B and S-m - which is the same as comparing B+m and S - which we * do by computing b+m and doing a bitwhack compare against * 2**(MP_DIGIT_BIT*sd) */ | | > | 3429 3430 3431 3432 3433 3434 3435 3436 3437 3438 3439 3440 3441 3442 3443 3444 | /* * Compare B and S-m - which is the same as comparing B+m and S - which we * do by computing b+m and doing a bitwhack compare against * 2**(MP_DIGIT_BIT*sd) */ 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) { /* >= 2s */ return 1; } for (i = sd-1; i >= 0; --i) { |
︙ | ︙ | |||
4149 4150 4151 4152 4153 4154 4155 | } if (mp_init_u64(&b, bw) != MP_OKAY) { mp_clear(&dig); return NULL; } err = mp_mul_2d(&b, b2, &b); if (err == MP_OKAY) { | | | 4150 4151 4152 4153 4154 4155 4156 4157 4158 4159 4160 4161 4162 4163 4164 | } if (mp_init_u64(&b, bw) != MP_OKAY) { mp_clear(&dig); return NULL; } err = mp_mul_2d(&b, b2, &b); if (err == MP_OKAY) { err = mp_init_set(&S, 1); } if (err == MP_OKAY) { err = MulPow5(&S, s5, &S); if (err == MP_OKAY) { err = mp_mul_2d(&S, s2, &S); } } |
︙ | ︙ | |||
4804 4805 4806 4807 4808 4809 4810 | mp_zero(b); } else { Tcl_WideInt w = (Tcl_WideInt)ldexp(fract, mantBits); int shift = expt - mantBits; err = mp_init_i64(b, w); if (err != MP_OKAY) { | | | 4805 4806 4807 4808 4809 4810 4811 4812 4813 4814 4815 4816 4817 4818 4819 | mp_zero(b); } else { Tcl_WideInt w = (Tcl_WideInt)ldexp(fract, mantBits); int shift = expt - mantBits; err = mp_init_i64(b, w); if (err != MP_OKAY) { /* just skip */ } else if (shift < 0) { err = mp_div_2d(b, -shift, b, NULL); } else if (shift > 0) { err = mp_mul_2d(b, shift, b); } } if (err != MP_OKAY) { |
︙ | ︙ | |||
4834 4835 4836 4837 4838 4839 4840 | * too large to convert. * *---------------------------------------------------------------------- */ double TclBignumToDouble( | | | 4835 4836 4837 4838 4839 4840 4841 4842 4843 4844 4845 4846 4847 4848 4849 | * too large to convert. * *---------------------------------------------------------------------- */ double TclBignumToDouble( const void *big) /* Integer to convert. */ { mp_int b; int bits, shift, i, lsb; double r; mp_err err; const mp_int *a = (const mp_int *)big; |
︙ | ︙ | |||
4955 4956 4957 4958 4959 4960 4961 | * Returns the floating point number. * *---------------------------------------------------------------------- */ double TclCeil( | | | 4956 4957 4958 4959 4960 4961 4962 4963 4964 4965 4966 4967 4968 4969 4970 | * Returns the floating point number. * *---------------------------------------------------------------------- */ double TclCeil( const void *big) /* Integer to convert. */ { double r = 0.0; mp_int b; mp_err err; const mp_int *a = (const mp_int *)big; err = mp_init(&b); |
︙ | ︙ | |||
5021 5022 5023 5024 5025 5026 5027 | * Returns the floating point value. * *---------------------------------------------------------------------- */ double TclFloor( | | | 5022 5023 5024 5025 5026 5027 5028 5029 5030 5031 5032 5033 5034 5035 5036 | * Returns the floating point value. * *---------------------------------------------------------------------- */ double TclFloor( const void *big) /* Integer to convert. */ { double r = 0.0; mp_int b; mp_err err; const mp_int *a = (const mp_int *)big; err = mp_init(&b); |
︙ | ︙ |
Changes to generic/tclStringObj.c.
1 2 3 | /* * tclStringObj.c -- * | | | | | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 | /* * 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. * * 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). * * 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 * internal representation to keep track of how much space is used vs. * allocated. * * Copyright © 1995-1997 Sun Microsystems, Inc. |
︙ | ︙ | |||
120 121 122 123 124 125 126 | #ifndef TCL_MIN_UNICHAR_GROWTH #define TCL_MIN_UNICHAR_GROWTH TCL_MIN_GROWTH/sizeof(Tcl_UniChar) #endif static void GrowStringBuffer( Tcl_Obj *objPtr, | | | | 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 | #ifndef TCL_MIN_UNICHAR_GROWTH #define TCL_MIN_UNICHAR_GROWTH TCL_MIN_GROWTH/sizeof(Tcl_UniChar) #endif static void GrowStringBuffer( Tcl_Obj *objPtr, Tcl_Size needed, /* Not including terminating nul */ int flag) /* If 0, try to overallocate */ { /* * Preconditions: * TclHasInternalRep(objPtr, &tclStringType) * needed > stringPtr->allocated * flag || objPtr->bytes != NULL */ |
︙ | ︙ | |||
714 715 716 717 718 719 720 | * *---------------------------------------------------------------------- */ Tcl_Obj * Tcl_GetRange( Tcl_Obj *objPtr, /* The Tcl object to find the range of. */ | | | | 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 | * *---------------------------------------------------------------------- */ 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_Obj *newObjPtr; /* The Tcl object to find the range of. */ String *stringPtr; Tcl_Size length = 0; if (first < 0) { first = 0; |
︙ | ︙ | |||
1318 1319 1320 1321 1322 1323 1324 | void Tcl_AppendUnicodeToObj( Tcl_Obj *objPtr, /* Points to the object to append to. */ const Tcl_UniChar *unicode, /* The Unicode string to append to the * object. */ Tcl_Size length) /* Number of chars in Unicode. Negative | | | 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 | void Tcl_AppendUnicodeToObj( Tcl_Obj *objPtr, /* Points to the object to append to. */ 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 */ { String *stringPtr; if (Tcl_IsShared(objPtr)) { Tcl_Panic("%s called with shared object", "Tcl_AppendUnicodeToObj"); } |
︙ | ︙ | |||
2147 2148 2149 2150 2151 2152 2153 | char buf[4] = ""; int code, length; if (TclGetIntFromObj(interp, segment, &code) != TCL_OK) { goto error; } if ((unsigned)code > 0x10FFFF) { | | | 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 | char buf[4] = ""; int code, length; if (TclGetIntFromObj(interp, segment, &code) != TCL_OK) { goto error; } if ((unsigned)code > 0x10FFFF) { code = 0xFFFD; } length = Tcl_UniCharToUtf(code, buf); segment = Tcl_NewStringObj(buf, length); Tcl_IncrRefCount(segment); allocSegment = 1; break; } |
︙ | ︙ | |||
2967 2968 2969 2970 2971 2972 2973 | *--------------------------------------------------------------------------- * * TclStringRepeat -- * * Performs the [string repeat] function. * * Results: | | | | | 2967 2968 2969 2970 2971 2972 2973 2974 2975 2976 2977 2978 2979 2980 2981 2982 2983 2984 2985 | *--------------------------------------------------------------------------- * * TclStringRepeat -- * * Performs the [string repeat] function. * * Results: * 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. * *--------------------------------------------------------------------------- */ Tcl_Obj * TclStringRepeat( Tcl_Interp *interp, |
︙ | ︙ | |||
2994 2995 2996 2997 2998 2999 3000 | Tcl_Size done = 1; int binary = TclIsPureByteArray(objPtr); Tcl_Size maxCount; /* * Analyze to determine what representation result should be. * GOALS: Avoid shimmering & string rep generation. | | | | 2994 2995 2996 2997 2998 2999 3000 3001 3002 3003 3004 3005 3006 3007 3008 3009 | Tcl_Size done = 1; int binary = TclIsPureByteArray(objPtr); Tcl_Size maxCount; /* * Analyze to determine what representation result should be. * GOALS: Avoid shimmering & string rep generation. * Produce pure bytearray when possible. * Error on overflow. */ if (!binary) { if (TclHasInternalRep(objPtr, &tclStringType)) { String *stringPtr = GET_STRING(objPtr); if (stringPtr->hasUnicode) { unichar = 1; |
︙ | ︙ | |||
3029 3030 3031 3032 3033 3034 3035 | /* Any repeats of empty is empty. */ return objPtr; } /* maxCount includes space for null */ if (count > (maxCount-1)) { if (interp) { | | < | | < | 3029 3030 3031 3032 3033 3034 3035 3036 3037 3038 3039 3040 3041 3042 3043 3044 3045 | /* Any repeats of empty is empty. */ return objPtr; } /* 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_SetErrorCode(interp, "TCL", "MEMORY", (char *)NULL); } return NULL; } if (binary) { /* Efficiently produce a pure byte array result */ |
︙ | ︙ | |||
3124 3125 3126 3127 3128 3129 3130 | *--------------------------------------------------------------------------- * * TclStringCat -- * * Performs the [string cat] function. * * Results: | | | | | 3122 3123 3124 3125 3126 3127 3128 3129 3130 3131 3132 3133 3134 3135 3136 3137 3138 3139 3140 | *--------------------------------------------------------------------------- * * TclStringCat -- * * Performs the [string cat] function. * * Results: * 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. * *--------------------------------------------------------------------------- */ Tcl_Obj * TclStringCat( Tcl_Interp *interp, |
︙ | ︙ | |||
3162 3163 3164 3165 3166 3167 3168 | /* One object; return first */ return objv[0]; } /* * Analyze to determine what representation result should be. * GOALS: Avoid shimmering & string rep generation. | | | | | | | | 3160 3161 3162 3163 3164 3165 3166 3167 3168 3169 3170 3171 3172 3173 3174 3175 3176 3177 3178 3179 3180 3181 3182 3183 3184 3185 3186 3187 3188 3189 3190 3191 3192 3193 3194 3195 | /* One object; return first */ return objv[0]; } /* * Analyze to determine what representation result should be. * GOALS: Avoid shimmering & string rep generation. * Produce pure bytearray when possible. * Error on overflow. */ ov = objv, oc = objc; do { Tcl_Obj *objPtr = *ov++; if (TclIsPureByteArray(objPtr)) { allowUniChar = 0; } else if (objPtr->bytes) { /* Value has a string rep. */ if (objPtr->length) { /* * Non-empty string rep. Not a pure bytearray, so we won't * create a pure bytearray. */ 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; } } } else { binary = 0; if (TclHasInternalRep(objPtr, &tclStringType)) { |
︙ | ︙ | |||
3282 3283 3284 3285 3286 3287 3288 | pendingPtr = objPtr; } else { (void) TclGetStringFromObj(objPtr, &length); /* PANIC? */ } } while (--oc && (length == 0) && (pendingPtr == NULL)); /* | | | | | | 3280 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 3291 3292 3293 3294 3295 3296 3297 3298 | pendingPtr = objPtr; } else { (void) TclGetStringFromObj(objPtr, &length); /* PANIC? */ } } 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, * or (oc == 0) and all values are known empty, * so first = last = objc - 1 signals the right quick return. */ first = last = objc - oc - 1; if (oc && (length == 0)) { Tcl_Size numBytes; /* |
︙ | ︙ | |||
3397 3398 3399 3400 3401 3402 3403 | /* Ugly interface! Force resize of the unicode array. */ (void)Tcl_GetUnicodeFromObj(objResultPtr, &start); Tcl_InvalidateStringRep(objResultPtr); if (0 == Tcl_AttemptSetObjLength(objResultPtr, length)) { if (interp) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( | | | | 3395 3396 3397 3398 3399 3400 3401 3402 3403 3404 3405 3406 3407 3408 3409 3410 3411 3412 3413 3414 3415 3416 3417 3418 3419 3420 3421 3422 3423 3424 3425 3426 | /* Ugly interface! Force resize of the unicode array. */ (void)Tcl_GetUnicodeFromObj(objResultPtr, &start); Tcl_InvalidateStringRep(objResultPtr); if (0 == Tcl_AttemptSetObjLength(objResultPtr, length)) { if (interp) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "concatenation failed: unable to alloc %" TCL_Z_MODIFIER "u bytes", STRING_SIZE(length))); Tcl_SetErrorCode(interp, "TCL", "MEMORY", (char *)NULL); } return NULL; } dst = Tcl_GetUnicode(objResultPtr) + start; } else { Tcl_UniChar ch = 0; /* Ugly interface! No scheme to init array size. */ objResultPtr = Tcl_NewUnicodeObj(&ch, 0); /* PANIC? */ if (0 == Tcl_AttemptSetObjLength(objResultPtr, length)) { Tcl_DecrRefCount(objResultPtr); if (interp) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "concatenation failed: unable to alloc %" TCL_Z_MODIFIER "u bytes", STRING_SIZE(length))); Tcl_SetErrorCode(interp, "TCL", "MEMORY", (char *)NULL); } return NULL; } dst = Tcl_GetUnicode(objResultPtr); |
︙ | ︙ | |||
3446 3447 3448 3449 3450 3451 3452 | objResultPtr = *objv++; objc--; (void)TclGetStringFromObj(objResultPtr, &start); if (0 == Tcl_AttemptSetObjLength(objResultPtr, length)) { if (interp) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( | | | | 3444 3445 3446 3447 3448 3449 3450 3451 3452 3453 3454 3455 3456 3457 3458 3459 3460 3461 3462 3463 3464 3465 3466 3467 3468 3469 3470 3471 3472 3473 | objResultPtr = *objv++; objc--; (void)TclGetStringFromObj(objResultPtr, &start); if (0 == Tcl_AttemptSetObjLength(objResultPtr, length)) { if (interp) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "concatenation failed: unable to alloc %" TCL_SIZE_MODIFIER "d bytes", length)); Tcl_SetErrorCode(interp, "TCL", "MEMORY", (char *)NULL); } return NULL; } dst = TclGetString(objResultPtr) + start; TclFreeInternalRep(objResultPtr); } else { TclNewObj(objResultPtr); /* PANIC? */ if (0 == Tcl_AttemptSetObjLength(objResultPtr, length)) { Tcl_DecrRefCount(objResultPtr); if (interp) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "concatenation failed: unable to alloc %" TCL_SIZE_MODIFIER "d bytes", length)); Tcl_SetErrorCode(interp, "TCL", "MEMORY", (char *)NULL); } return NULL; } dst = TclGetString(objResultPtr); } |
︙ | ︙ | |||
3488 3489 3490 3491 3492 3493 3494 | *dst = '\0'; } return objResultPtr; overflow: if (interp) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( | | > | 3486 3487 3488 3489 3490 3491 3492 3493 3494 3495 3496 3497 3498 3499 3500 3501 | *dst = '\0'; } return objResultPtr; overflow: if (interp) { 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; } /* *--------------------------------------------------------------------------- |
︙ | ︙ | |||
3512 3513 3514 3515 3516 3517 3518 | * be changed. * *--------------------------------------------------------------------------- */ static int UniCharNcasememcmp( | | | | | | 3511 3512 3513 3514 3515 3516 3517 3518 3519 3520 3521 3522 3523 3524 3525 3526 3527 3528 3529 3530 3531 3532 3533 3534 3535 3536 3537 3538 3539 3540 3541 3542 3543 3544 3545 3546 3547 3548 | * be changed. * *--------------------------------------------------------------------------- */ 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 Tcl_UniChar *ucs = (const Tcl_UniChar *)ucsPtr; const Tcl_UniChar *uct = (const Tcl_UniChar *)uctPtr; for ( ; numChars != 0; numChars--, ucs++, uct++) { if (*ucs != *uct) { Tcl_UniChar lcs = Tcl_UniCharToLower(*ucs); Tcl_UniChar lct = Tcl_UniCharToLower(*uct); if (lcs != lct) { return (lcs - lct); } } } return 0; } 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. */ { Tcl_UniChar ch1 = 0, ch2 = 0; const char *cs = (const char *)csPtr; const char *ct = (const char *)ctPtr; /* * Cannot use 'memcmp(cs, ct, n);' as byte representation of \u0000 (the |
︙ | ︙ | |||
3567 3568 3569 3570 3571 3572 3573 | return 0; } static int UtfNcasememcmp( const void *csPtr, /* UTF string to compare to ct. */ const void *ctPtr, /* UTF string cs is compared to. */ | | | 3566 3567 3568 3569 3570 3571 3572 3573 3574 3575 3576 3577 3578 3579 3580 | return 0; } 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. */ { Tcl_UniChar ch1 = 0, ch2 = 0; const char *cs = (const char *)csPtr; const char *ct = (const char *)ctPtr; while (numChars-- > 0) { /* |
︙ | ︙ | |||
3594 3595 3596 3597 3598 3599 3600 | } } return 0; } static int UniCharNmemcmp( | | | | | 3593 3594 3595 3596 3597 3598 3599 3600 3601 3602 3603 3604 3605 3606 3607 3608 3609 | } } return 0; } 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 Tcl_UniChar *ucs = (const Tcl_UniChar *)ucsPtr; const Tcl_UniChar *uct = (const Tcl_UniChar *)uctPtr; #if defined(WORDS_BIGENDIAN) /* * We are definitely on a big-endian machine; memcmp() is safe */ |
︙ | ︙ | |||
3628 3629 3630 3631 3632 3633 3634 | int TclStringCmp( Tcl_Obj *value1Ptr, Tcl_Obj *value2Ptr, int checkEq, /* comparison is only for equality */ int nocase, /* comparison is not case sensitive */ Tcl_Size reqlength) /* requested length in characters; | | | 3627 3628 3629 3630 3631 3632 3633 3634 3635 3636 3637 3638 3639 3640 3641 | int TclStringCmp( Tcl_Obj *value1Ptr, Tcl_Obj *value2Ptr, 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 */ { const char *s1, *s2; int empty, match; Tcl_Size length, s1len = 0, s2len = 0; memCmpFn_t memCmpFn; if ((reqlength == 0) || (value1Ptr == value2Ptr)) { |
︙ | ︙ | |||
3674 3675 3676 3677 3678 3679 3680 | } else { s1len = Tcl_GetCharLength(value1Ptr); s2len = Tcl_GetCharLength(value2Ptr); if ((s1len == value1Ptr->length) && (value1Ptr->bytes != NULL) && (s2len == value2Ptr->length) && (value2Ptr->bytes != NULL)) { | | | < | 3673 3674 3675 3676 3677 3678 3679 3680 3681 3682 3683 3684 3685 3686 3687 3688 | } else { s1len = Tcl_GetCharLength(value1Ptr); s2len = Tcl_GetCharLength(value2Ptr); if ((s1len == value1Ptr->length) && (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 */ s1 = value1Ptr->bytes; s2 = value2Ptr->bytes; memCmpFn = memcmp; } else { s1 = (char *) Tcl_GetUnicode(value1Ptr); s2 = (char *) Tcl_GetUnicode(value2Ptr); if ( |
︙ | ︙ | |||
3937 3938 3939 3940 3941 3942 3943 | Tcl_Size lh = 0, ln = Tcl_GetCharLength(needle); Tcl_Size value = -1; Tcl_UniChar *checkStr, *uh, *un; Tcl_Obj *obj; if (ln == 0) { /* | | | | | 3935 3936 3937 3938 3939 3940 3941 3942 3943 3944 3945 3946 3947 3948 3949 3950 3951 3952 | Tcl_Size lh = 0, ln = Tcl_GetCharLength(needle); Tcl_Size value = -1; Tcl_UniChar *checkStr, *uh, *un; Tcl_Obj *obj; if (ln == 0) { /* * 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. */ goto lastEnd; } if (TclIsPureByteArray(needle) && TclIsPureByteArray(haystack)) { unsigned char *check, *bh = Tcl_GetBytesFromObj(NULL, haystack, &lh); unsigned char *bn = Tcl_GetBytesFromObj(NULL, needle, &ln); |
︙ | ︙ |
Changes to generic/tclTest.c.
︙ | ︙ | |||
2066 2067 2068 2069 2070 2071 2072 | * UtfTransformFn -- * * Implements a direct call into Tcl_UtfToExternal and Tcl_ExternalToUtf * as otherwise there is no script level command that directly exercises * these functions (i/o command cannot test all combinations) * The arguments at the script level are roughly those of the above * functions: | | | 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 | * UtfTransformFn -- * * Implements a direct call into Tcl_UtfToExternal and Tcl_ExternalToUtf * as otherwise there is no script level command that directly exercises * 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? * * Results: * TCL_OK or TCL_ERROR. This any errors running the test, NOT the * result of Tcl_UtfToExternal or Tcl_ExternalToUtf. * * Side effects: * |
︙ | ︙ | |||
3750 3751 3752 3753 3754 3755 3756 | if (arg[1] != 'r') { goto wrongArgs; } readonly = TCL_LINK_READ_ONLY; i++; } if (Tcl_GetIndexFromObj(interp, objv[i++], LinkType, "type", 0, | | | | 3750 3751 3752 3753 3754 3755 3756 3757 3758 3759 3760 3761 3762 3763 3764 3765 3766 3767 3768 3769 3770 3771 3772 3773 3774 3775 3776 3777 3778 3779 | if (arg[1] != 'r') { goto wrongArgs; } readonly = TCL_LINK_READ_ONLY; i++; } if (Tcl_GetIndexFromObj(interp, objv[i++], LinkType, "type", 0, &typeIndex) != TCL_OK) { return TCL_ERROR; } if (Tcl_GetIntFromObj(interp, objv[i++], &size) == TCL_ERROR) { Tcl_SetObjResult(interp, Tcl_NewStringObj("wrong size value", -1)); return TCL_ERROR; } name = Tcl_GetString(objv[i++]); /* * If no address is given request one in the underlying function */ if (i < objc) { if (Tcl_GetWideIntFromObj(interp, objv[i], &addr) == TCL_ERROR) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "wrong address value", -1)); return TCL_ERROR; } } else { addr = 0; } return Tcl_LinkArray(interp, name, INT2PTR(addr), |
︙ | ︙ | |||
8527 8528 8529 8530 8531 8532 8533 | TCL_UNUSED(Tcl_Interp *), const char *name, TCL_UNUSED(Tcl_Size) /* length */, TCL_UNUSED(Tcl_Namespace *), Tcl_ResolvedVarInfo **rPtr) { if (*name == 'T') { | | | | | | | | | | 8527 8528 8529 8530 8531 8532 8533 8534 8535 8536 8537 8538 8539 8540 8541 8542 8543 8544 8545 8546 8547 8548 8549 | TCL_UNUSED(Tcl_Interp *), const char *name, TCL_UNUSED(Tcl_Size) /* length */, TCL_UNUSED(Tcl_Namespace *), 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; } return TCL_CONTINUE; } static int TestInterpResolverCmd( TCL_UNUSED(void *), |
︙ | ︙ | |||
8652 8653 8654 8655 8656 8657 8658 | /* * The bug trigger. Repeating the command but: * - we are calling apply with a lambda that is a list (as BEFORE), * BUT * - The body of the lambda (lambdaObjs[1]) ALREADY has internal * representation of ByteCode and thus will not be compiled again */ | | < | 8652 8653 8654 8655 8656 8657 8658 8659 8660 8661 8662 8663 8664 8665 8666 | /* * The bug trigger. Repeating the command but: * - we are calling apply with a lambda that is a list (as BEFORE), * BUT * - 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 */ result = Tcl_EvalObjv(interp, 2, evalObjs, TCL_EVAL_GLOBAL); Tcl_DecrRefCount(evalObjs[0]); Tcl_DecrRefCount(lambdaObj); return result; } |
︙ | ︙ |
Changes to generic/tclThreadTest.c.
︙ | ︙ | |||
981 982 983 984 985 986 987 | * Since Tcl_CancelEval can be safely called from any thread, * we do it now. */ Tcl_MutexUnlock(&threadMutex); Tcl_ResetResult(interp); return Tcl_CancelEval(tsdPtr->interp, | | | 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 | * Since Tcl_CancelEval can be safely called from any thread, * we do it now. */ Tcl_MutexUnlock(&threadMutex); Tcl_ResetResult(interp); return Tcl_CancelEval(tsdPtr->interp, (result != NULL) ? Tcl_NewStringObj(result, -1) : NULL, 0, flags); } /* *------------------------------------------------------------------------ * * ThreadEventProc -- * |
︙ | ︙ |
Changes to generic/tclUtf.c.
︙ | ︙ | |||
202 203 204 205 206 207 208 | * None. * *--------------------------------------------------------------------------- */ Tcl_Size Tcl_UniCharToUtf( | | | < | | | < | 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 | * None. * *--------------------------------------------------------------------------- */ 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 flags = ch; if (ch >= TCL_COMBINE) { ch &= (TCL_COMBINE - 1); } if ((unsigned)(ch - 1) < (UNICODE_SELF - 1)) { |
︙ | ︙ | |||
305 306 307 308 309 310 311 | * None. * *--------------------------------------------------------------------------- */ char * Tcl_UniCharToUtfDString( | | | | 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 | * None. * *--------------------------------------------------------------------------- */ char * Tcl_UniCharToUtfDString( const int *uniStr, /* Unicode string to convert to UTF-8. */ Tcl_Size uniLength, /* Length of Unicode string. Negative for nul * terminated string */ Tcl_DString *dsPtr) /* UTF-8 representation of string is appended * to this previously initialized DString. */ { const int *w, *wEnd; char *p, *string; Tcl_Size oldLength; |
︙ | ︙ | |||
436 437 438 439 440 441 442 | 0x02C6, 0x2030, 0x0160, 0x2039, 0x0152, 0x8D, 0x017D, 0x8F, 0x90, 0x2018, 0x2019, 0x201C, 0x201D, 0x2022, 0x2013, 0x2014, 0x2DC, 0x2122, 0x0161, 0x203A, 0x0153, 0x9D, 0x017E, 0x0178 }; Tcl_Size Tcl_UtfToUniChar( | | | | | 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 | 0x02C6, 0x2030, 0x0160, 0x2039, 0x0152, 0x8D, 0x017D, 0x8F, 0x90, 0x2018, 0x2019, 0x201C, 0x201D, 0x2022, 0x2013, 0x2014, 0x2DC, 0x2122, 0x0161, 0x203A, 0x0153, 0x9D, 0x017E, 0x0178 }; Tcl_Size Tcl_UtfToUniChar( const char *src, /* The UTF-8 string. */ int *chPtr) /* Filled with the Unicode character * represented by the UTF-8 string. */ { int byte; /* * Unroll 1 to 4 byte UTF-8 sequences. */ |
︙ | ︙ |
Changes to generic/tclUtil.c.
︙ | ︙ | |||
154 155 156 157 158 159 160 | * The ASCII characters which can make up the whitespace between list elements * are: * * \u0009 \t TAB * \u000A \n NEWLINE * \u000B \v VERTICAL TAB * \u000C \f FORM FEED | | | 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 | * The ASCII characters which can make up the whitespace between list elements * are: * * \u0009 \t TAB * \u000A \n NEWLINE * \u000B \v VERTICAL TAB * \u000C \f FORM FEED * \u000D \r CARRIAGE RETURN * \u0020 SPACE * * NOTE: differences between this and other places where Tcl defines a role * for "whitespace". * * * Unlike command parsing, here NEWLINE is just another whitespace * character; its role as a command terminator in a script has no |
︙ | ︙ | |||
272 273 274 275 276 277 278 | * characters that have special meaning during script evaluation need * special treatment when canonical lists are produced: * * * Whitespace between elements may not include NEWLINE. * * The command terminating character, * \u003b ; SEMICOLON * must be BRACEd, QUOTEd, or escaped so that it does not terminate the | | | 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 | * characters that have special meaning during script evaluation need * special treatment when canonical lists are produced: * * * Whitespace between elements may not include NEWLINE. * * The command terminating character, * \u003b ; SEMICOLON * must be BRACEd, QUOTEd, or escaped so that it does not terminate the * command prematurely. * * Any of the characters that begin substitutions in scripts, * \u0024 $ DOLLAR * \u005b [ OPEN BRACKET * \u005c \ BACKSLASH * need to be BRACEd or escaped. * * In any list where the first character of the first element is * \u0023 # HASH |
︙ | ︙ | |||
1668 1669 1670 1671 1672 1673 1674 | do { const char *q = trim; Tcl_Size pInc = 0, bytesLeft = numTrim; pp = Tcl_UtfPrev(p, bytes); do { pp += pInc; | | | 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 | do { const char *q = trim; Tcl_Size pInc = 0, bytesLeft = numTrim; pp = Tcl_UtfPrev(p, bytes); do { pp += pInc; pInc = TclUtfToUniChar(pp, &ch1); } while (pp + pInc < p); /* * Inner loop: scan trim string for match to current character. */ do { |
︙ | ︙ | |||
1877 1878 1879 1880 1881 1882 1883 | /* * First allocate the result buffer at the size required. */ for (i = 0; i < argc; i++) { bytesNeeded += strlen(argv[i]); | | | 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 | /* * First allocate the result buffer at the size required. */ for (i = 0; i < argc; i++) { bytesNeeded += strlen(argv[i]); if (bytesNeeded < 0) { Tcl_Panic("Tcl_Concat: max size of Tcl value exceeded"); } } /* * All element bytes + (argc - 1) spaces + 1 terminating NULL. */ |
︙ | ︙ | |||
3409 3410 3411 3412 3413 3414 3415 | * TCL_SIZE_MAX. Negative values are returned as TCL_INDEX_NONE (-1). * * Callers should pass reasonable values for endValue - one in the * valid index range or TCL_INDEX_NONE (-1), for example for an empty * list. * * Results: | | | | | | | | | 3409 3410 3411 3412 3413 3414 3415 3416 3417 3418 3419 3420 3421 3422 3423 3424 3425 3426 3427 3428 3429 3430 3431 3432 3433 3434 3435 | * TCL_SIZE_MAX. Negative values are returned as TCL_INDEX_NONE (-1). * * Callers should pass reasonable values for endValue - one in the * valid index range or TCL_INDEX_NONE (-1), for example for an empty * list. * * Results: * TCL_OK * * The index is stored at the address given by by 'indexPtr'. * * 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. * * Side effects: * * The internal representation contained within objPtr may shimmer. * *---------------------------------------------------------------------- */ int Tcl_GetIntForIndex( Tcl_Interp *interp, /* Interpreter to use for error reporting. If |
︙ | ︙ | |||
3703 3704 3705 3706 3707 3708 3709 | * listLen-1 as endValue and and listLen is 0. The -1 will be * interpreted as FF...FF and adding 1 will result in 0 which * is what we want. Callers like lset which pass in listLen-1 == -1 * as endValue will have to adjust accordingly. */ *widePtr = (endValue == -1) ? WIDE_MAX : endValue + 1; } else if (offset == WIDE_MIN) { | < | | | < < < | 3703 3704 3705 3706 3707 3708 3709 3710 3711 3712 3713 3714 3715 3716 3717 3718 3719 3720 3721 3722 3723 | * listLen-1 as endValue and and listLen is 0. The -1 will be * interpreted as FF...FF and adding 1 will result in 0 which * is what we want. Callers like lset which pass in listLen-1 == -1 * as endValue will have to adjust accordingly. */ *widePtr = (endValue == -1) ? WIDE_MAX : endValue + 1; } else if (offset == WIDE_MIN) { *widePtr = (endValue == -1) ? WIDE_MIN : -1; } else if (offset < 0) { /* end-(n-1) - Different signs, sum cannot overflow */ *widePtr = endValue + offset + 1; } else { /* 0:WIDE_MAX - plain old index. */ *widePtr = offset; } return TCL_OK; /* Report a parse error. */ parseError: if (interp != NULL) { char * bytes = TclGetString(objPtr); |
︙ | ︙ |
Changes to generic/tclVar.c.
︙ | ︙ | |||
6568 6569 6570 6571 6572 6573 6574 | * Skip nameless (temporary) variables and undefined variables. */ if (*varNamePtr && !TclIsVarUndefined(varPtr) && (includeLinks || !TclIsVarLink(varPtr))) { varName = TclGetString(*varNamePtr); if ((pattern == NULL) || Tcl_StringMatch(varName, pattern)) { | | | 6568 6569 6570 6571 6572 6573 6574 6575 6576 6577 6578 6579 6580 6581 6582 | * Skip nameless (temporary) variables and undefined variables. */ if (*varNamePtr && !TclIsVarUndefined(varPtr) && (includeLinks || !TclIsVarLink(varPtr))) { varName = TclGetString(*varNamePtr); if ((pattern == NULL) || Tcl_StringMatch(varName, pattern)) { if (!justConstants || TclIsVarConstant(varPtr)) { Tcl_ListObjAppendElement(interp, listPtr, *varNamePtr); } if (includeLinks) { Tcl_CreateHashEntry(&addedTable, *varNamePtr, &added); } } } |
︙ | ︙ | |||
6622 6623 6624 6625 6626 6627 6628 | varPtr != NULL; varPtr = VarHashNextVar(&search)) { if (!TclIsVarUndefined(varPtr) && (includeLinks || !TclIsVarLink(varPtr))) { objNamePtr = VarHashGetKey(varPtr); varName = TclGetString(objNamePtr); if ((pattern == NULL) || Tcl_StringMatch(varName, pattern)) { | | | 6622 6623 6624 6625 6626 6627 6628 6629 6630 6631 6632 6633 6634 6635 6636 | varPtr != NULL; varPtr = VarHashNextVar(&search)) { if (!TclIsVarUndefined(varPtr) && (includeLinks || !TclIsVarLink(varPtr))) { objNamePtr = VarHashGetKey(varPtr); varName = TclGetString(objNamePtr); if ((pattern == NULL) || Tcl_StringMatch(varName, pattern)) { if (!justConstants || TclIsVarConstant(varPtr)) { Tcl_ListObjAppendElement(interp, listPtr, objNamePtr); } if (includeLinks) { Tcl_CreateHashEntry(&addedTable, objNamePtr, &added); } } } |
︙ | ︙ |
Changes to generic/tclZipfs.c.
︙ | ︙ | |||
213 214 215 216 217 218 219 | */ typedef struct ZipEntry { char *name; /* The full pathname of the virtual file */ 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. | | | | 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 | */ typedef struct ZipEntry { char *name; /* The full pathname of the virtual file */ 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 */ int numCompressedBytes; /* Compressed size of the virtual file. * -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. */ int crc32; /* CRC-32 as stored in ZIP */ int timestamp; /* Modification time */ int isEncrypted; /* True if data is encrypted */ int flags; |
︙ | ︙ | |||
254 255 256 257 258 259 260 | ZipFile *zipFilePtr; /* The ZIP file holding this channel */ ZipEntry *zipEntryPtr; /* Pointer back to virtual file */ Tcl_Size maxWrite; /* Maximum size for write */ Tcl_Size numBytes; /* Number of bytes of uncompressed data */ 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 | | | 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 | ZipFile *zipFilePtr; /* The ZIP file holding this channel */ ZipEntry *zipEntryPtr; /* Pointer back to virtual file */ Tcl_Size maxWrite; /* Maximum size for write */ Tcl_Size numBytes; /* Number of bytes of uncompressed data */ 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 may point *inside* the block) */ Tcl_Size ubufSize; /* Size of allocated ubufToFree */ int iscompr; /* True if data is compressed */ int isDirectory; /* Set to 1 if directory, or -1 if root */ int isEncrypted; /* True if data is encrypted */ int mode; /* O_WRITE, O_APPEND, O_TRUNC etc.*/ unsigned long keys[3]; /* Key for decryption */ |
︙ | ︙ | |||
429 430 431 432 433 434 435 | NULL, /* getCwdProc */ NULL, /* chdirProc */ }; /* * The channel type/driver definition used for ZIP archive members. */ | < | | | | | | | | | | | | < | | | | | | | 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 | NULL, /* getCwdProc */ NULL, /* chdirProc */ }; /* * The channel type/driver definition used for ZIP archive members. */ static const Tcl_ChannelType zipChannelType = { "zip", TCL_CHANNEL_VERSION_5, 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. */ }; /* *------------------------------------------------------------------------ * * TclIsZipfsPath -- * * Checks if the passed path has a zipfs volume prefix. * |
︙ | ︙ | |||
871 872 873 874 875 876 877 | *------------------------------------------------------------------------- */ static char * DecodeZipEntryText( const unsigned char *inputBytes, unsigned int inputLength, | | | 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 | *------------------------------------------------------------------------- */ static char * DecodeZipEntryText( const unsigned char *inputBytes, unsigned int inputLength, Tcl_DString *dstPtr) /* Must have been initialized by caller! */ { Tcl_Encoding encoding; const char *src; char *dst; int dstLen, srcLen = inputLength, flags; Tcl_EncodingState state; |
︙ | ︙ | |||
976 977 978 979 980 981 982 | * Results: * TCL_OK on success with normalized mount path in dsPtr * TCL_ERROR on fail with error message in interp if not NULL * *------------------------------------------------------------------------ */ static int | | > | | | 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 | * Results: * TCL_OK on success with normalized mount path in dsPtr * TCL_ERROR on fail with error message in interp if not NULL * *------------------------------------------------------------------------ */ static int NormalizeMountPoint( Tcl_Interp *interp, const char *mountPath, Tcl_DString *dsPtr) /* Must be initialized by caller! */ { const char *joiner[2]; char *joinedPath; Tcl_Obj *unnormalizedObj; Tcl_Obj *normalizedObj; const char *normalizedPath; Tcl_Size normalizedLen; |
︙ | ︙ | |||
2226 2227 2228 2229 2230 2231 2232 | * None. * * Side effects: * Memory associated with the mounted archive is deallocated. *------------------------------------------------------------------------ */ static void | | > | 2225 2226 2227 2228 2229 2230 2231 2232 2233 2234 2235 2236 2237 2238 2239 2240 | * None. * * Side effects: * Memory associated with the mounted archive is deallocated. *------------------------------------------------------------------------ */ static void CleanupMount( ZipFile *zf) /* Mount point */ { ZipEntry *z, *znext; Tcl_HashEntry *hPtr; for (z = zf->entries; z; z = znext) { znext = z->next; hPtr = Tcl_FindHashEntry(&ZipFS.fileHash, z->name); if (hPtr) { |
︙ | ︙ | |||
4897 4898 4899 4900 4901 4902 4903 | * Wrap the ZipChannel into a Tcl_Channel. */ snprintf(cname, sizeof(cname), "zipfs_%" TCL_Z_MODIFIER "x_%d", z->offset, ZipFS.idCount++); z->zipFilePtr->numOpen++; Unlock(); | | | 4897 4898 4899 4900 4901 4902 4903 4904 4905 4906 4907 4908 4909 4910 4911 | * Wrap the ZipChannel into a Tcl_Channel. */ snprintf(cname, sizeof(cname), "zipfs_%" TCL_Z_MODIFIER "x_%d", z->offset, ZipFS.idCount++); z->zipFilePtr->numOpen++; Unlock(); return Tcl_CreateChannel(&zipChannelType, cname, info, flags); error: Unlock(); return NULL; } /* |
︙ | ︙ |
Changes to generic/tclZlib.c.
︙ | ︙ | |||
204 205 206 207 208 209 210 | /* * Type of zlib-based compressing and decompressing channels. */ static const Tcl_ChannelType zlibChannelType = { "zlib", TCL_CHANNEL_VERSION_5, | | | | | | | | | 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 | /* * Type of zlib-based compressing and decompressing channels. */ static const Tcl_ChannelType zlibChannelType = { "zlib", TCL_CHANNEL_VERSION_5, NULL, /* Deprecated. */ ZlibTransformInput, ZlibTransformOutput, NULL, /* Deprecated. */ ZlibTransformSetOption, ZlibTransformGetOption, ZlibTransformWatch, ZlibTransformGetHandle, ZlibTransformClose, ZlibTransformBlockMode, NULL, /* Flush proc. */ ZlibTransformEventHandler, NULL, /* Seek proc. */ NULL, /* Thread action proc. */ NULL /* Truncate proc. */ }; /* *---------------------------------------------------------------------- * * Latin1 -- * Helper to definitely get the ISO 8859-1 encoding. It's internally |
︙ | ︙ | |||
3107 3108 3109 3110 3111 3112 3113 | return inProc(Tcl_GetChannelInstanceData(chanDataPtr->parent), buf, toRead, errorCodePtr); } gotBytes = 0; readBytes = chanDataPtr->inStream.avail_in; /* how many bytes in buffer now */ while (!HaveFlag(chanDataPtr, STREAM_DONE) && toRead > 0) { | | | 3107 3108 3109 3110 3111 3112 3113 3114 3115 3116 3117 3118 3119 3120 3121 | return inProc(Tcl_GetChannelInstanceData(chanDataPtr->parent), buf, toRead, errorCodePtr); } gotBytes = 0; readBytes = chanDataPtr->inStream.avail_in; /* how many bytes in buffer now */ while (!HaveFlag(chanDataPtr, STREAM_DONE) && toRead > 0) { unsigned int n; int decBytes; /* if starting from scratch or continuation after full decompression */ if (!chanDataPtr->inStream.avail_in) { /* buffer to start, we can read to whole available buffer */ chanDataPtr->inStream.next_in = (Bytef *) chanDataPtr->inBuffer; } |
︙ | ︙ |
Changes to library/auto.tcl.
︙ | ︙ | |||
41 42 43 44 45 46 47 | # tcl_findLibrary -- # # This is a utility for extensions that searches for a library directory # using a canonical searching algorithm. A side effect is to source the # initialization script and set a global library variable. # # Arguments: | | | 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 | # tcl_findLibrary -- # # This is a utility for extensions that searches for a library directory # using a canonical searching algorithm. A side effect is to source the # initialization script and set a global library variable. # # Arguments: # 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) # enVarName environment variable to honor (e.g., TK_LIBRARY) # varName Global variable to set when done (e.g., tk_library) proc tcl_findLibrary {basename version patch initScript enVarName varName} { |
︙ | ︙ | |||
126 127 128 129 130 131 132 | } elseif {[zipfs exists [file join $mountpoint $initScript]]} { lappend dirs [file join $mountpoint $initScript] set found 1 break } else { catch {zipfs unmount $mountpoint} } | | | 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 | } elseif {[zipfs exists [file join $mountpoint $initScript]]} { lappend dirs [file join $mountpoint $initScript] set found 1 break } else { catch {zipfs unmount $mountpoint} } } } } } # 2. In the package script directory registered within the # configuration of the package itself. |
︙ | ︙ | |||
476 477 478 479 480 481 482 | # # This procedure allows extensions to register their own commands with the # auto_mkindex facility. For example, a package like [incr Tcl] might # register a "class" command so that class definitions could be added to a # "tclIndex" file for auto-loading. # # Arguments: | | | | | | 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 | # # This procedure allows extensions to register their own commands with the # auto_mkindex facility. For example, a package like [incr Tcl] might # register a "class" command so that class definitions could be added to a # "tclIndex" file for auto-loading. # # Arguments: # name Name of command recognized in Tcl files. # arglist Argument list for command. # body Implementation of command to handle indexing. proc auto_mkindex_parser::command {name arglist body} { hook [list auto_mkindex_parser::commandInit $name $arglist $body] } # auto_mkindex_parser::commandInit -- # # This does the actual work set up by auto_mkindex_parser::command. This is # called when the interpreter used by the parser is created. # # Arguments: # name Name of command recognized in Tcl files. # arglist Argument list for command. # body Implementation of command to handle indexing. proc auto_mkindex_parser::commandInit {name arglist body} { variable parser set ns [namespace qualifiers $name] set tail [namespace tail $name] if {$ns eq ""} { |
︙ | ︙ |
Changes to library/clock.tcl.
︙ | ︙ | |||
136 137 138 139 140 141 142 | } LOCALE_TIME_FORMAT {%H:%M:%S} LOCALE_YEAR_FORMAT {%EC%Ey} MONTHS_ABBREV { Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec } MONTHS_FULL { | | | | | 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 | } LOCALE_TIME_FORMAT {%H:%M:%S} LOCALE_YEAR_FORMAT {%EC%Ey} MONTHS_ABBREV { Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec } MONTHS_FULL { January February March April May June July August September October November December } PM {pm} TIME_FORMAT {%H:%M:%S} TIME_FORMAT_12 {%I:%M:%S %P} TIME_FORMAT_24 {%H:%M} TIME_FORMAT_24_SECS {%H:%M:%S} |
︙ | ︙ | |||
288 289 290 291 292 293 294 | # Translation table to map Windows TZI onto cities, so that the Olson # rules can apply. In some cases the mapping is ambiguous, so it's wise # to specify $::env(TCL_TZ) rather than simply depending on the system # time zone. # The keys are long lists of values obtained from the time zone # information in the Registry. In order, the list elements are: | | | 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 | # Translation table to map Windows TZI onto cities, so that the Olson # rules can apply. In some cases the mapping is ambiguous, so it's wise # to specify $::env(TCL_TZ) rather than simply depending on the system # time zone. # 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 # StandardDate.wYear StandardDate.wMonth StandardDate.wDayOfWeek # StandardDate.wDay StandardDate.wHour StandardDate.wMinute # StandardDate.wSecond StandardDate.wMilliseconds # DaylightDate.wYear DaylightDate.wMonth DaylightDate.wDayOfWeek # DaylightDate.wDay DaylightDate.wHour DaylightDate.wMinute # DaylightDate.wSecond DaylightDate.wMilliseconds # The values are the names of time zones where those rules apply. There |
︙ | ︙ | |||
335 336 337 338 339 340 341 | {-3600 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Atlantic/Cape_Verde {0 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :UTC {0 0 3600 0 10 0 5 2 0 0 0 0 3 0 5 1 0 0 0} :Europe/London {3600 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Africa/Kinshasa {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} | | | 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 | {-3600 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Atlantic/Cape_Verde {0 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :UTC {0 0 3600 0 10 0 5 2 0 0 0 0 3 0 5 1 0 0 0} :Europe/London {3600 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Africa/Kinshasa {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 {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 {7200 0 3600 0 10 0 5 3 0 0 0 0 3 0 5 2 0 0 0} :Europe/Athens {7200 0 3600 0 9 5 5 1 0 0 0 0 3 4 5 0 0 0 0} :Asia/Amman {7200 0 3600 0 10 6 5 23 59 59 999 0 3 0 5 0 0 0 0} :Asia/Beirut |
︙ | ︙ | |||
476 477 478 479 480 481 482 | ] # Caches variable LocFmtMap [dict create]; # Dictionary with localized format maps variable TimeZoneBad [dict create]; # Dictionary whose keys are time zone | | | | 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 | ] # Caches 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 # the time zone is unknown and 0 # 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, # Daylight Saving Time indicator, and # time zone abbreviation. variable mcLocales [dict create]; # Dictionary with loaded locales |
︙ | ︙ | |||
514 515 516 517 518 519 520 | variable mcMergedCat switch -- $loc system { set loc [GetSystemLocale] } current { set loc [mclocale] } if {$loc ne {}} { | | | 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 | variable mcMergedCat switch -- $loc system { set loc [GetSystemLocale] } current { set loc [mclocale] } if {$loc ne {}} { set loc [string tolower $loc] } # try to retrieve now if already available: if {[dict exists $mcMergedCat $loc]} { return [dict get $mcMergedCat $loc] } |
︙ | ︙ | |||
647 648 649 650 651 652 653 | # Side effects: # Does [mclocale]. If necessary, loades the designated locale's files. # #---------------------------------------------------------------------- proc ::tcl::clock::EnterLocale { locale } { switch -- $locale system { | | | 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 | # Side effects: # Does [mclocale]. If necessary, loades the designated locale's files. # #---------------------------------------------------------------------- proc ::tcl::clock::EnterLocale { locale } { switch -- $locale system { set locale [GetSystemLocale] } current { set locale [mclocale] } # Select the locale, eventually load it mcpackagelocale set $locale return $locale } |
︙ | ︙ | |||
997 998 999 1000 1001 1002 1003 | if { [catch { LoadTimeZoneFile [string range $timezone 1 end] }] && [catch { LoadZoneinfoFile [string range $timezone 1 end] }] } then { | | | 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 | if { [catch { LoadTimeZoneFile [string range $timezone 1 end] }] && [catch { LoadZoneinfoFile [string range $timezone 1 end] }] } then { dict set TimeZoneBad $timezone 1 return -code error \ -errorcode [list CLOCK badTimeZone $timezone] \ "time zone \"$timezone\" not found" } } elseif { ![catch {ParsePosixTimeZone $timezone} tzfields] } { # This looks like a POSIX time zone - try to process it |
︙ | ︙ |
Changes to library/history.tcl.
︙ | ︙ | |||
85 86 87 88 89 90 91 | # Add an item to the history, and optionally eval it at the global scope # # Parameters: # event the command to add # exec (optional) a substring of "exec" causes the command to # be evaled. # Results: | | | 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 | # Add an item to the history, and optionally eval it at the global scope # # Parameters: # event the command to add # exec (optional) a substring of "exec" causes the command to # be evaled. # Results: # If executing, then the results of the command are returned # # Side Effects: # Adds to the history list proc ::tcl::HistAdd {event {exec {}}} { variable history |
︙ | ︙ | |||
193 194 195 196 197 198 199 | set result {} set newline "" for {set i [expr {$history(nextid) - $count + 1}]} \ {$i <= $history(nextid)} {incr i} { if {![info exists history($i)]} { continue } | | | 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 | set result {} set newline "" for {set i [expr {$history(nextid) - $count + 1}]} \ {$i <= $history(nextid)} {incr i} { if {![info exists history($i)]} { continue } set cmd [string map [list \n \n\t] [string trimright $history($i) \ \n]] append result $newline[format "%6d %s" $i $cmd] set newline \n } return $result } # tcl::HistRedo -- |
︙ | ︙ |
Changes to library/http/http.tcl.
︙ | ︙ | |||
153 154 155 156 157 158 159 | )? } variable TmpSockCounter 0 variable ThreadCounter 0 variable reasonDict [dict create {*}{ | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 | )? } variable TmpSockCounter 0 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} }] variable failedProxyValues { binary body charset coding |
︙ | ︙ | |||
295 296 297 298 299 300 301 | # list of port, command, variable name, (boolean) threadability, # and (boolean) endToEndProxy that was registered. proc http::register {proto port command {socketCmdVarName {}} {useSockThread 0} {endToEndProxy 0}} { variable urlTypes set lower [string tolower $proto] if {[info exists urlTypes($lower)]} { | | | 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 | # list of port, command, variable name, (boolean) threadability, # and (boolean) endToEndProxy that was registered. proc http::register {proto port command {socketCmdVarName {}} {useSockThread 0} {endToEndProxy 0}} { variable urlTypes set lower [string tolower $proto] if {[info exists urlTypes($lower)]} { unregister $lower } set urlTypes($lower) [list $port $command $socketCmdVarName $useSockThread $endToEndProxy] # If the external handler for protocol $proto has given $socketCmdVarName the expected # value "::socket", overwrite it with the new value. if {($socketCmdVarName ne {}) && ([set $socketCmdVarName] eq {::socket})} { set $socketCmdVarName ::http::socketAsCallback |
︙ | ︙ | |||
343 344 345 346 347 348 349 | # http::config -- # # See documentation for details. # # Arguments: # args Options parsed by the procedure. # Results: | | | 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 | # http::config -- # # See documentation for details. # # Arguments: # args Options parsed by the procedure. # Results: # TODO proc http::config {args} { variable http set options [lsort [array names http -*]] set usage [join $options ", "] if {[llength $args] == 0} { set result {} |
︙ | ︙ | |||
397 398 399 400 401 402 403 | # # Return Value: the reason phrase # ------------------------------------------------------------------------------ proc http::reasonPhrase {code} { variable reasonDict if {![regexp -- {^[1-5][0-9][0-9]$} $code]} { | | | | | | | 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 | # # Return Value: the reason phrase # ------------------------------------------------------------------------------ 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 } if {[dict exists $reasonDict $code]} { set reason [dict get $reasonDict $code] } else { set reason Unassigned } return $reason } # http::Finish -- # # Clean up the socket and eval close time callbacks # # Arguments: # token Connection token. # errormsg (optional) If set, forces status to error. # skipCB (optional) If set, don't call the -command callback. This # is useful when geturl wants to throw an exception instead # of calling the callback. That way, the same error isn't # reported to two places. # # Side Effects: # May close the socket. proc http::Finish {token {errormsg ""} {skipCB 0}} { variable socketMapping variable socketRdState variable socketWrState variable socketRdQueue variable socketWrQueue |
︙ | ︙ | |||
450 451 452 453 454 455 456 | if {[info commands ${token}--EventCoroutine] ne {}} { rename ${token}--EventCoroutine {} } if {[info commands ${token}--SocketCoroutine] ne {}} { rename ${token}--SocketCoroutine {} } if {[info exists state(socketcoro)]} { | | | | | 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 | if {[info commands ${token}--EventCoroutine] ne {}} { rename ${token}--EventCoroutine {} } if {[info commands ${token}--SocketCoroutine] ne {}} { rename ${token}--SocketCoroutine {} } if {[info exists state(socketcoro)]} { Log $token Cancel socket after-idle event (Finish) after cancel $state(socketcoro) unset state(socketcoro) } # Is this an upgrade request/response? set upgradeResponse \ [expr { [info exists state(upgradeRequest)] && $state(upgradeRequest) && [info exists state(http)] |
︙ | ︙ | |||
477 478 479 480 481 482 483 | } { set closeQueue 1 set connId $state(socketinfo) if {[info exists state(sock)]} { set sock $state(sock) CloseSocket $state(sock) $token } else { | | | | | | | < | | | | | | 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 | } { set closeQueue 1 set connId $state(socketinfo) if {[info exists state(sock)]} { 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. } 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. thread::release $state(tid) set state(tid) {} } else { } } elseif {$upgradeResponse} { # Special handling for an upgrade request/response. # - geturl ensures that this is not a "persistent" socket used for # multiple HTTP requests, so a call to KeepSocket is not needed. # - Leave socket open, so a call to CloseSocket is not needed either. # - Remove fileevent bindings. The caller will set its own bindings. # - THE CALLER MUST PROCESS THE UPGRADED SOCKET IN THE CALLBACK COMMAND # 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))) } { set closeQueue 1 set connId $state(socketinfo) if {[info exists state(sock)]} { 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. } } elseif { ([info exists state(-keepalive)] && $state(-keepalive)) && ([info exists state(connection)] && ("close" ni $state(connection))) } { KeepSocket $token } |
︙ | ︙ | |||
917 918 919 920 921 922 923 | # See documentation for details. # # Arguments: # token Connection token. # why Status info. # # Side Effects: | | | 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 | # See documentation for details. # # Arguments: # token Connection token. # why Status info. # # Side Effects: # See Finish proc http::reset {token {why reset}} { variable $token upvar 0 $token state set state(status) $why catch {fileevent $state(sock) readable {}} catch {fileevent $state(sock) writable {}} |
︙ | ︙ | |||
1116 1117 1118 1119 1120 1121 1122 | set usage [join [lsort $options] ", "] set options [string map {- ""} $options] set pat ^-(?:[join $options |])$ foreach {flag value} $args { if {[regexp -- $pat $flag]} { # Validate numbers if { [info exists type($flag)] | | | 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 | set usage [join [lsort $options] ", "] set options [string map {- ""} $options] set pat ^-(?:[join $options |])$ foreach {flag value} $args { if {[regexp -- $pat $flag]} { # Validate numbers if { [info exists type($flag)] && (![string is $type($flag) -strict $value]) } { unset $token return -code error \ "Bad value for $flag ($value), must be $type($flag)" } if {($flag eq "-headers") && ([llength $value] % 2 != 0)} { unset $token |
︙ | ︙ | |||
1400 1401 1402 1403 1404 1405 1406 | # Pass -myaddr directly to the socket command if {[info exists state(-myaddr)]} { lappend sockopts -myaddr $state(-myaddr) } if {$useSockThread} { | | | | 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 | # Pass -myaddr directly to the socket command if {[info exists state(-myaddr)]} { lappend sockopts -myaddr $state(-myaddr) } if {$useSockThread} { set targs [list -type $token] } else { set targs {} } set state(connArgs) [list $proto $phost $srvurl] set state(openCmd) [list {*}$defcmd {*}$sockopts {*}$targs {*}$targetAddr] # See if we are supposed to use a previously opened channel. # - In principle, ANY call to http::geturl could use a previously opened # channel if it is available - the "Connection: keep-alive" header is a |
︙ | ︙ | |||
1503 1504 1505 1506 1507 1508 1509 | } } set state(reusing) $reusing unset reusing if {![info exists sock]} { | | | | 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 | } } set state(reusing) $reusing 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. # Give the socket a placeholder name. set sock HTTP_PLACEHOLDER_[incr TmpSockCounter] } set state(sock) $sock if {$state(reusing)} { # Define these for use (only) by http::ReplayIfDead if the persistent |
︙ | ︙ | |||
1601 1602 1603 1604 1605 1606 1607 | if { $state(-keepalive) && (![info exists socketMapping($state(socketinfo))]) } { # This code is executed only for the first -keepalive request on a # socket. It makes the socket persistent. ##Log " PreparePersistentConnection" $token -- $sock -- DO | | | | | | | | | | | | | | | | | | | | | | | | 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 | if { $state(-keepalive) && (![info exists socketMapping($state(socketinfo))]) } { # 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] } else { ##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 } 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 } 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 } return } # ------------------------------------------------------------------------------ |
︙ | ︙ | |||
1673 1674 1675 1676 1677 1678 1679 | set socketProxyId($state(socketinfo)) $state(proxyUsed) # - The value of state(proxyUsed) was set in http::CreateToken to either # "none" or "HttpProxy". # - $token is the first transaction to use this placeholder, so there are # no other tokens whose (proxyUsed) must be modified. if {![info exists socketRdState($state(socketinfo))]} { | | | | | | | | | | | | | | | | | | | | | | 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 | set socketProxyId($state(socketinfo)) $state(proxyUsed) # - The value of state(proxyUsed) was set in http::CreateToken to either # "none" or "HttpProxy". # - $token is the first transaction to use this placeholder, so there are # 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 } 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 } 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 } 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 } # Value of socketPhQueue() may have already been set by ReplayCore. if {![info exists socketPhQueue($state(sock))]} { set socketPhQueue($state(sock)) {} } set socketRdQueue($state(socketinfo)) {} set socketWrQueue($state(socketinfo)) {} set socketClosing($state(socketinfo)) 0 set socketPlayCmd($state(socketinfo)) {ReplayIfClose Wready {} {}} set socketCoEvent($state(socketinfo)) {} set socketProxyId($state(socketinfo)) {} |
︙ | ︙ | |||
1747 1748 1749 1750 1751 1752 1753 | variable socketPlayCmd variable socketCoEvent variable socketProxyId Log >K$tk Start OpenSocket coroutine if {![info exists state(-keepalive)]} { | | | | | | | 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 | variable socketPlayCmd variable socketCoEvent variable socketProxyId Log >K$tk Start OpenSocket coroutine if {![info exists state(-keepalive)]} { # The request has already been cancelled by the calling script. return } set sockOld $state(sock) dict unset socketCoEvent($state(socketinfo)) $token unset -nocomplain state(socketcoro) if {[catch { 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 in the [catch] below. set pre [clock milliseconds] ##Log pre socket opened, - token $token ##Log $state(openCmd) - token $token set sock [namespace eval :: $state(openCmd)] set state(sock) $sock # Normal return from $state(openCmd) always returns a valid socket. |
︙ | ︙ | |||
1785 1786 1787 1788 1789 1790 1791 | } fconfigure $sock -translation {auto crlf} \ -buffersize $state(-blocksize) if {[package vsatisfies [package provide Tcl] 9.0-]} { fconfigure $sock -profile replace } ##Log socket opened, DONE fconfigure - token $token | | | | | | | | 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 | } fconfigure $sock -translation {auto crlf} \ -buffersize $state(-blocksize) if {[package vsatisfies [package provide Tcl] 9.0-]} { fconfigure $sock -profile replace } ##Log socket opened, DONE fconfigure - 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 } result errdict]} { ##Log OpenSocket failed $result - token $token # There may be other requests in the socketPhQueue. # Prepare socketPlayCmd so that Finish will replay them. if { ($state(-keepalive)) && (!$state(reusing)) && [info exists socketPhQueue($sockOld)] && ($socketPhQueue($sockOld) ne {}) } { if {$socketMapping($state(socketinfo)) ne $sockOld} { Log "WARNING: this code should not be reached.\ {$socketMapping($state(socketinfo)) ne $sockOld}" } set socketPlayCmd($state(socketinfo)) [list ReplayIfClose Wready {} $socketPhQueue($sockOld)] set socketPhQueue($sockOld) {} } 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 # request, and http::SecureProxyConnect copied this to $token, # and also set ${token}(connection) set to "close". # - Remove the error message $result so that Finish delivers this # HTTP response to the caller. |
︙ | ︙ | |||
1883 1884 1885 1886 1887 1888 1889 | set reusing $state(reusing) set sock $state(sock) set proxyUsed $state(proxyUsed) ##Log " ConfigureNewSocket" $token $sockOld ... -- $reusing $sock $proxyUsed if {(!$reusing) && ($sock ne $sockOld)} { | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 | set reusing $state(reusing) set sock $state(sock) set proxyUsed $state(proxyUsed) ##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]} { set varName ::http::socketRdState($state(socketinfo)) trace add variable $varName unset ::http::CancelReadPipeline } if {[dict get $DoLater -tracewrite]} { set varName ::http::socketWrState($state(socketinfo)) trace add variable $varName unset ::http::CancelWritePipeline } } # Do this in all cases. ScheduleRequest $token # Now look at all other tokens that use the placeholder $sockOld. if { (!$reusing) && ($sock ne $sockOld) && [info exists 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 set ${tok}(proxyUsed) $proxyUsed # 2. Schedule the token's HTTP request. # Every token in socketPhQueue(*) has reusing 1 alreadyQueued 0. |
︙ | ︙ | |||
2081 2082 2083 2084 2085 2086 2087 | # pipelined request jumping the queue. ##Log "HTTP request for token $token is queued for nonpipeline use" #Log re-use nonpipeline, GRANT delayed write access to $token in geturl set socketWrState($state(socketinfo)) peNding lappend socketWrQueue($state(socketinfo)) $token } else { | | | | | | | | | | | 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 2118 2119 2120 2121 2122 2123 2124 | # pipelined request jumping the queue. ##Log "HTTP request for token $token is queued for nonpipeline use" #Log re-use nonpipeline, GRANT delayed write access to $token in geturl set socketWrState($state(socketinfo)) peNding lappend socketWrQueue($state(socketinfo)) $token } else { 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} { # 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 { } # Process the request now. # - Command is not called unless $state(sock) is a real socket handle # and not a placeholder. # - All (!$reusing) cases come here. # - Some $reusing cases come here too if the connection is # marked as ready. Those $reusing cases are: # $reusing && ($socketWrState($state(socketinfo)) eq "Wready") && # EITHER !$pipeline && ($socketRdState($state(socketinfo)) eq "Rready") # OR $pipeline # #Log ---- $state(socketinfo) << conn to $token for HTTP request (a) ##Log " ScheduleRequest" $token -- fileevent $state(sock) writable for $token # Connect does its own fconfigure. lassign $state(connArgs) proto phost srvurl if {[catch { fileevent $state(sock) writable \ [list http::Connect $token $proto $phost $srvurl] } res opts]} { # The socket no longer exists. ##Log bug -- socket gone -- $res -- $opts |
︙ | ︙ | |||
2280 2281 2282 2283 2284 2285 2286 | # Some server implementations of HTTP/1.0 have a faulty # implementation of RFC 2068 Keep-Alive. # Don't leave this to chance. # For HTTP/1.0 we have already "set state(connection) close" # and "state(-keepalive) 0". set ConnVal close } | | | | | | 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 | # Some server implementations of HTTP/1.0 have a faulty # implementation of RFC 2068 Keep-Alive. # Don't leave this to chance. # For HTTP/1.0 we have already "set state(connection) close" # and "state(-keepalive) 0". set ConnVal close } # 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 set content_type_seen 0 set connection_seen 0 foreach {key value} $state(-headers) { set value [string map [list \n "" \r ""] $value] |
︙ | ︙ | |||
2310 2311 2312 2313 2314 2315 2316 | set content_type_seen 1 } if {[string equal -nocase $key "content-length"]} { set contDone 1 set state(querylength) $value } if { [string equal -nocase $key "connection"] | | | 2309 2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 | set content_type_seen 1 } if {[string equal -nocase $key "content-length"]} { set contDone 1 set state(querylength) $value } if { [string equal -nocase $key "connection"] && [info exists state(bypass)] } { # Value supplied in -headers overrides $ConnVal. set connection_seen 1 } elseif {[string equal -nocase $key "connection"]} { # Remove "close" or "keep-alive" and use our own value. # In an upgrade request, the upgrade is not guaranteed. # Value "close" or "keep-alive" tells the server what to do |
︙ | ︙ | |||
2445 2446 2447 2448 2449 2450 2451 | # later, OR https handshake error, which may be discovered as late as # the "flush" command above... Log "WARNING - if testing, pay special attention to this\ case (GI) which is seldom executed - token $token" if {[info exists state(reusing)] && $state(reusing)} { # The socket was closed at the server end, and closed at # this end by http::CheckEof. | | | 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 | # later, OR https handshake error, which may be discovered as late as # the "flush" command above... Log "WARNING - if testing, pay special attention to this\ case (GI) which is seldom executed - token $token" 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]} { return } else { Finish $token {failed to re-use socket} } # else: # This is NOT a persistent socket that has been closed since its |
︙ | ︙ | |||
2602 2603 2604 2605 2606 2607 2608 | if {[package vsatisfies [package provide Tcl] 9.0-]} { fconfigure $sock -profile replace } Log ^D$tk begin receiving response - token $token coroutine ${token}--EventCoroutine http::Event $sock $token if {[info exists state(-handler)] || [info exists state(-progress)]} { | | | | 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 | if {[package vsatisfies [package provide Tcl] 9.0-]} { fconfigure $sock -profile replace } Log ^D$tk begin receiving response - token $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] } else { fileevent $sock readable ${token}--EventCoroutine } return } # http::EventGateway # |
︙ | ︙ | |||
2630 2631 2632 2633 2634 2635 2636 | proc http::EventGateway {sock token} { variable $token upvar 0 $token state fileevent $sock readable {} catch {${token}--EventCoroutine} res opts if {[info commands ${token}--EventCoroutine] ne {}} { | | | | | | | | | | | 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 | proc http::EventGateway {sock token} { variable $token upvar 0 $token state fileevent $sock readable {} catch {${token}--EventCoroutine} res opts if {[info commands ${token}--EventCoroutine] ne {}} { # The coroutine can be deleted by completion (a non-yield return), by # http::Finish (when there is a premature end to the transaction), by # http::reset or http::cleanup, or if the caller set option -channel # but not option -handler: in the last case reading from the socket is # now managed by commands ::http::Copy*, http::ReceiveChunked, and # http::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. return -options $opts $res } |
︙ | ︙ | |||
3044 3045 3046 3047 3048 3049 3050 | } if {[info exists state(after)]} { after cancel $state(after) unset state(after) } if {[info exists state(socketcoro)]} { | | | | | 3043 3044 3045 3046 3047 3048 3049 3050 3051 3052 3053 3054 3055 3056 3057 3058 3059 | } if {[info exists state(after)]} { after cancel $state(after) unset state(after) } if {[info exists 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. set tmpState $state(tmpState) set tmpOpenCmd $state(tmpOpenCmd) set tmpConnArgs $state(tmpConnArgs) foreach name [array names state] { |
︙ | ︙ | |||
3206 3207 3208 3209 3210 3211 3212 | variable $token upvar 0 $token state return $state(currentsize) } proc http::requestHeaders {token args} { set lenny [llength $args] if {$lenny > 1} { | | | | | | | | | | | | | | | | | | | | | | | | 3205 3206 3207 3208 3209 3210 3211 3212 3213 3214 3215 3216 3217 3218 3219 3220 3221 3222 3223 3224 3225 3226 3227 3228 3229 3230 3231 3232 3233 3234 3235 3236 3237 3238 3239 3240 3241 3242 3243 3244 3245 3246 3247 3248 3249 3250 3251 3252 3253 3254 3255 3256 3257 3258 3259 3260 3261 3262 3263 3264 3265 3266 3267 3268 3269 3270 | variable $token upvar 0 $token state return $state(currentsize) } proc http::requestHeaders {token args} { set lenny [llength $args] if {$lenny > 1} { return -code error {usage: ::http::requestHeaders token ?headerName?} } else { 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?} } else { return [Meta $token response {*}$args] } } proc http::requestHeaderValue {token header} { Meta $token request $header VALUE } proc http::responseHeaderValue {token header} { Meta $token response $header VALUE } proc http::Meta {token who args} { variable $token upvar 0 $token state if {$who eq {request}} { set whom requestHeaders } elseif {$who eq {response}} { set whom meta } else { 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) } elseif {($lenny > 2) || (($lenny == 2) && ($how ne {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] } } } # ------------------------------------------------------------------------------ # Proc http::responseInfo # ------------------------------------------------------------------------------ |
︙ | ︙ | |||
3279 3280 3281 3282 3283 3284 3285 | # ------------------------------------------------------------------------------ proc http::responseInfo {token} { variable $token upvar 0 $token state set result {} foreach {key origin name} { | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 3278 3279 3280 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 3291 3292 3293 3294 3295 3296 3297 3298 3299 3300 3301 3302 3303 3304 3305 3306 3307 3308 3309 3310 3311 3312 3313 3314 3315 3316 3317 3318 3319 3320 3321 3322 3323 3324 3325 3326 3327 3328 3329 3330 3331 3332 3333 3334 3335 3336 3337 3338 3339 3340 3341 | # ------------------------------------------------------------------------------ proc http::responseInfo {token} { variable $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 } { 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 } proc http::error {token} { variable $token upvar 0 $token state if {[info exists state(error)]} { |
︙ | ︙ | |||
3373 3374 3375 3376 3377 3378 3379 | rename ${token}--SocketCoroutine {} } if {[info exists state(after)]} { after cancel $state(after) unset state(after) } if {[info exists state(socketcoro)]} { | | | | | | | | | 3372 3373 3374 3375 3376 3377 3378 3379 3380 3381 3382 3383 3384 3385 3386 3387 3388 3389 3390 3391 3392 3393 3394 3395 3396 3397 3398 3399 3400 3401 3402 3403 3404 3405 3406 3407 3408 3409 3410 3411 3412 3413 3414 3415 3416 3417 | rename ${token}--SocketCoroutine {} } if {[info exists state(after)]} { after cancel $state(after) unset state(after) } if {[info exists state(socketcoro)]} { Log $token Cancel socket after-idle event (cleanup) after cancel $state(socketcoro) unset state(socketcoro) } if {[info exists state]} { unset state } return } # http::Connect # # This callback is made when an asynchronous connection completes. # # Arguments # token The token returned from http::geturl # # Side Effects # Sets the status of the connection, which unblocks # the waiting geturl call proc http::Connect {token proto phost srvurl} { variable $token upvar 0 $token state set tk [namespace tail $token] if {[catch {eof $state(sock)} tmp] || $tmp} { set err "due to unexpected EOF" } elseif {[set err [fconfigure $state(sock) -error]] ne ""} { # set err is done in test } else { # All OK set state(state) connecting fileevent $state(sock) writable {} ::http::Connected $token $proto $phost $srvurl return } # Error cases. |
︙ | ︙ | |||
3817 3818 3819 3820 3821 3822 3823 | if {[info commands ${token}--EventCoroutine] ne {}} { rename ${token}--EventCoroutine {} } if {[info commands ${token}--SocketCoroutine] ne {}} { rename ${token}--SocketCoroutine {} } if {[info exists state(socketcoro)]} { | | | | | 3816 3817 3818 3819 3820 3821 3822 3823 3824 3825 3826 3827 3828 3829 3830 3831 3832 | if {[info commands ${token}--EventCoroutine] ne {}} { rename ${token}--EventCoroutine {} } if {[info commands ${token}--SocketCoroutine] ne {}} { rename ${token}--SocketCoroutine {} } if {[info exists 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) unset state(after) } if { [info exists state(-command)] && (![info exists state(done-command-cb)]) |
︙ | ︙ | |||
4643 4644 4645 4646 4647 4648 4649 | # ------------------------------------------------------------------------------ proc http::GuessType {token} { variable $token upvar 0 $token state if {$state(type) ne {application/octet-stream}} { | | | | | | | | | | 4642 4643 4644 4645 4646 4647 4648 4649 4650 4651 4652 4653 4654 4655 4656 4657 4658 4659 4660 4661 4662 4663 4664 4665 4666 4667 4668 4669 4670 4671 4672 4673 4674 4675 4676 4677 4678 4679 4680 4681 4682 4683 4684 4685 4686 4687 | # ------------------------------------------------------------------------------ proc http::GuessType {token} { variable $token upvar 0 $token state if {$state(type) ne {application/octet-stream}} { return 0 } set body $state(body) # e.g. {<?xml version="1.0" encoding="utf-8"?> ...} if {![regexp -nocase -- {^<[?]xml[[:space:]][^>?]*[?]>} $body match]} { return 0 } # e.g. {<?xml version="1.0" encoding="utf-8"?>} set contents [regsub -- {[[:space:]]+} $match { }] set contents [string range [string tolower $contents] 6 end-2] # e.g. {version="1.0" encoding="utf-8"} # without excess whitespace or upper-case letters if {![regexp -- {^([^=" ]+="[^"]+" )+$} "$contents "]} { 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 } } set enc [CharsetToEncoding $res] if {$enc eq "binary"} { return 0 } if {[package vsatisfies [package provide Tcl] 9.0-]} { set state(body) [encoding convertfrom -profile replace $enc $state(body)] } else { set state(body) [encoding convertfrom $enc $state(body)] } set state(body) [string map {\r\n \n \r \n} $state(body)] |
︙ | ︙ | |||
4725 4726 4727 4728 4729 4730 4731 | # args A list of name-value pairs. # # Results: # TODO proc http::formatQuery {args} { if {[llength $args] % 2} { | | | | | | 4724 4725 4726 4727 4728 4729 4730 4731 4732 4733 4734 4735 4736 4737 4738 4739 4740 4741 | # args A list of name-value pairs. # # Results: # TODO 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.} } set result "" set sep "" foreach i $args { append result $sep [quoteString $i] if {$sep eq "="} { set sep & |
︙ | ︙ | |||
4781 4782 4783 4784 4785 4786 4787 | # # Results: # The current proxy settings proc http::ProxyRequired {host} { variable http if {(![info exists http(-proxyhost)]) || ($http(-proxyhost) eq {})} { | | | | | | 4780 4781 4782 4783 4784 4785 4786 4787 4788 4789 4790 4791 4792 4793 4794 4795 4796 4797 4798 4799 4800 4801 4802 4803 4804 4805 4806 4807 | # # Results: # The current proxy settings proc http::ProxyRequired {host} { variable http if {(![info exists http(-proxyhost)]) || ($http(-proxyhost) eq {})} { return } if {![info exists http(-proxyport)] || ($http(-proxyport) eq {})} { set port 8080 } else { set port $http(-proxyport) } # 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 {} } } return [list $http(-proxyhost) $port] } # http::CharsetToEncoding -- # # Tries to map a given IANA charset to a tcl encoding. If no encoding |
︙ | ︙ | |||
4921 4922 4923 4924 4925 4926 4927 | catch {chan event $chan readable {}} return } } } # http::SplitCommaSeparatedFieldValue -- | | | | 4920 4921 4922 4923 4924 4925 4926 4927 4928 4929 4930 4931 4932 4933 4934 4935 4936 4937 4938 4939 4940 4941 4942 4943 4944 4945 4946 4947 4948 4949 4950 4951 | catch {chan event $chan readable {}} return } } } # http::SplitCommaSeparatedFieldValue -- # Return the individual values of a comma-separated field value. # # Arguments: # fieldValue Comma-separated header field value. # # Results: # List of values. proc http::SplitCommaSeparatedFieldValue {fieldValue} { set r {} foreach el [split $fieldValue ,] { lappend r [string trim $el] } return $r } # http::GetFieldValue -- # Return the value of a header field. # # Arguments: # headers Headers key-value list # fieldName Name of header field whose value to return. # # Results: # The value of the fieldName header field |
︙ | ︙ | |||
5007 5008 5009 5010 5011 5012 5013 | # ------------------------------------------------------------------------------ proc http::socketAsCallback {args} { variable http set targ [lsearch -exact $args -type] if {$targ != -1} { | | | | | | | | | | | | | | 5006 5007 5008 5009 5010 5011 5012 5013 5014 5015 5016 5017 5018 5019 5020 5021 5022 5023 5024 5025 5026 5027 5028 5029 5030 5031 5032 5033 5034 5035 5036 5037 5038 5039 5040 5041 5042 | # ------------------------------------------------------------------------------ proc http::socketAsCallback {args} { variable http set targ [lsearch -exact $args -type] if {$targ != -1} { set token [lindex $args $targ+1] upvar 0 ${token} state set protoProxyConn $state(protoProxyConn) } else { set protoProxyConn 0 } set host [lindex $args end-1] set port [lindex $args end] if { ($http(-proxyfilter) ne {}) && (![catch {$http(-proxyfilter) $host} proxy]) && $protoProxyConn } { set phost [lindex $proxy 0] set pport [lindex $proxy 1] } else { set phost {} set pport {} } if {$phost eq ""} { set sock [::http::AltSocket {*}$args] } else { set sock [::http::SecureProxyConnect {*}$args $phost $pport] } return $sock } # ------------------------------------------------------------------------------ # Proc http::SecureProxyConnect |
︙ | ︙ | |||
5075 5076 5077 5078 5079 5080 5081 | set args [lreplace $args end-3 end-2] # Proxy server URL for connection. # This determines where the socket is opened. set phost [lindex $args end-1] set pport [lindex $args end] if {[string first : $phost] != -1} { | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 5074 5075 5076 5077 5078 5079 5080 5081 5082 5083 5084 5085 5086 5087 5088 5089 5090 5091 5092 5093 5094 5095 5096 5097 5098 5099 5100 5101 5102 5103 5104 5105 5106 5107 5108 5109 5110 5111 5112 5113 5114 5115 5116 5117 5118 5119 5120 5121 5122 5123 5124 5125 5126 5127 5128 5129 5130 5131 5132 5133 5134 5135 5136 5137 5138 5139 5140 5141 5142 5143 5144 5145 5146 5147 5148 5149 5150 5151 5152 5153 5154 5155 5156 5157 5158 5159 5160 5161 5162 5163 5164 5165 5166 5167 5168 5169 5170 5171 5172 5173 5174 5175 5176 5177 5178 5179 5180 5181 5182 5183 5184 5185 5186 5187 5188 5189 5190 5191 5192 5193 5194 | set args [lreplace $args end-3 end-2] # Proxy server URL for connection. # This determines where the socket is opened. 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}\]" } set url http://${phost}:${pport} # Elements of args other than host and port are not used when # AsyncTransaction opens a socket. Those elements are -async and the # -type $tokenName for the https transaction. Option -async is used by # AsyncTransaction anyway, and -type $tokenName should not be # propagated: the proxy request adds its own -type value. 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. } else { set tim 0 } if {$tim == 0} { # Do not use infinite timeout for the proxy. set tim 30000 } # Prepare and send a CONNECT request to the proxy, using # code similar to http::geturl. set requestHeaders [list Host $host] lappend requestHeaders Connection keep-alive if {$http(-proxyauth) != {}} { lappend requestHeaders Proxy-Authorization $http(-proxyauth) } set token2 [CreateToken $url -keepalive 0 -timeout $tim \ -headers $requestHeaders -command [list http::AllDone $varName]] variable $token2 upvar 0 $token2 state2 # Kludges: # Setting this variable overrides the HTTP request line and also allows # -headers to override the Connection: header set by -keepalive. # The arguments "-keepalive 0" ensure that when Finish is called for an # unsuccessful request, the socket is always closed. set state2(bypass) "CONNECT $host:$port HTTP/1.1" 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 } else { 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)]) } { 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. # 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" # - 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) # as the response of the proxy. # - The cases where this would mislead the caller of http::geturl are # given a different value of msg (below) so that http::OpenSocket will # treat them as errors, but will preserve the $token array for |
︙ | ︙ | |||
5268 5269 5270 5271 5272 5273 5274 | variable ThreadCounter variable http LoadThreadIfNeeded set targ [lsearch -exact $args -type] if {$targ != -1} { | | | | | | | | | | | | | | | | | | | | | | | | | | 5267 5268 5269 5270 5271 5272 5273 5274 5275 5276 5277 5278 5279 5280 5281 5282 5283 5284 5285 5286 5287 5288 5289 5290 5291 5292 5293 5294 5295 5296 5297 5298 5299 5300 5301 5302 5303 5304 5305 5306 5307 5308 5309 5310 5311 5312 5313 5314 5315 5316 5317 5318 5319 5320 5321 5322 5323 5324 5325 5326 5327 5328 5329 5330 5331 5332 5333 5334 5335 5336 5337 | variable ThreadCounter variable http LoadThreadIfNeeded 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 } if {$http(usingThread) && [info exists state] && $state(protoSockThread)} { } else { # 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 state(tid) [thread::create] set varName ::http::ThreadVar([incr ThreadCounter]) 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 } else { 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) set state(tid) {} 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" } lassign $result threadCode threadDict threadResult if {($threadCode != 0)} { # 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.\ Check that this script is not running in a child interpreter.} } return -options $errdict -code $catchCode $sock } # The commands below are dependencies of http::AltSocket and # http::SecureProxyConnect and are not used elsewhere. |
︙ | ︙ | |||
5352 5353 5354 5355 5356 5357 5358 | # Arguments: none # Return Value: none # ------------------------------------------------------------------------------ proc http::LoadThreadIfNeeded {} { variable http if {$http(-threadlevel) == 0} { | | | | | | | | | | | 5351 5352 5353 5354 5355 5356 5357 5358 5359 5360 5361 5362 5363 5364 5365 5366 5367 5368 5369 5370 5371 5372 5373 5374 5375 | # Arguments: none # Return Value: none # ------------------------------------------------------------------------------ proc http::LoadThreadIfNeeded {} { variable http if {$http(-threadlevel) == 0} { 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 } set http(usingThread) 1 return } # ------------------------------------------------------------------------------ |
︙ | ︙ | |||
5389 5390 5391 5392 5393 5394 5395 | # ------------------------------------------------------------------------------ proc http::SockInThread {caller defcmd sockargs} { package require Thread set catchCode [catch {eval $defcmd $sockargs} sock errdict] if {$catchCode == 0} { | | | 5388 5389 5390 5391 5392 5393 5394 5395 5396 5397 5398 5399 5400 5401 5402 | # ------------------------------------------------------------------------------ proc http::SockInThread {caller defcmd sockargs} { package require Thread set catchCode [catch {eval $defcmd $sockargs} sock errdict] if {$catchCode == 0} { set catchCode [catch {thread::transfer $caller $sock; set sock} sock errdict] } return [list $catchCode $errdict $sock] } # ------------------------------------------------------------------------------ # Proc http::cwaiter::cwait |
︙ | ︙ | |||
5426 5427 5428 5429 5430 5431 5432 | } proc http::cwaiter::cwait { varName {coroName {}} {timeout {}} {timeoutValue {}} } { set thisCoro [info coroutine] if {$thisCoro eq {}} { | | | | | | | | 5425 5426 5427 5428 5429 5430 5431 5432 5433 5434 5435 5436 5437 5438 5439 5440 5441 5442 5443 5444 5445 5446 5447 5448 5449 5450 5451 5452 | } proc http::cwaiter::cwait { varName {coroName {}} {timeout {}} {timeoutValue {}} } { set thisCoro [info coroutine] if {$thisCoro eq {}} { return -code error {cwait cannot be called outside a coroutine} } if {$coroName eq {}} { set coroName $thisCoro } if {[string range $varName 0 1] ne {::}} { return -code error {argument varName must be fully qualified} } if {$timeout eq {}} { set toe {} } elseif {[string is integer -strict $timeout] && ($timeout > 0)} { set toe [after $timeout [list set $varName $timeoutValue]] } else { return -code error {if timeout is supplied it must be a positive integer} } set cmd [list ::http::cwaiter::CwaitHelper $varName $coroName $toe] trace add variable $varName write $cmd CoLog "Yield $varName $coroName" yield CoLog "Resume $varName $coroName" |
︙ | ︙ | |||
5497 5498 5499 5500 5501 5502 5503 | return $log } proc http::cwaiter::CoLog {msg} { variable log variable logOn if {$logOn} { | | | 5496 5497 5498 5499 5500 5501 5502 5503 5504 5505 5506 5507 5508 5509 5510 5511 5512 5513 5514 | return $log } proc http::cwaiter::CoLog {msg} { variable log variable logOn if {$logOn} { append log $msg \n } return } namespace eval http { namespace import ::http::cwaiter::* } # Local variables: # indent-tabs-mode: t # End: |
Changes to library/init.tcl.
︙ | ︙ | |||
550 551 552 553 554 555 556 | set ns [uplevel 1 [list ::namespace current]] set patternList [auto_qualify $pattern $ns] auto_load_index foreach pattern $patternList { | | | | | | | 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 | set ns [uplevel 1 [list ::namespace current]] set patternList [auto_qualify $pattern $ns] auto_load_index foreach pattern $patternList { 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) } } } } # auto_execok -- # # Returns string that indicates name of program to execute if # name corresponds to a shell builtin or an executable in the |
︙ | ︙ |
Changes to library/msgcat/msgcat.tcl.
︙ | ︙ | |||
16 17 18 19 20 21 22 | # When the version number changes, be sure to update the pkgIndex.tcl file, # and the installation directory in the Makefiles. package provide msgcat 1.7.1 namespace eval msgcat { namespace export mc mcn mcexists mcload mclocale mcmax\ mcmset mcpreferences mcset\ | | | 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 | # When the version number changes, be sure to update the pkgIndex.tcl file, # and the installation directory in the Makefiles. 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\ mcpackagenamespaceget mcpackageconfig mcpackagelocale mcutil # Records the list of locales to search variable Loclist {} # List of currently loaded locales variable LoadedLocales {} |
︙ | ︙ | |||
734 735 736 737 738 739 740 | if {[llength [info level 0]] == 4 } { # value provided if {$subcommand in {"get" "isset" "unset"}} { return -code error "wrong # args: should be\ \"[lrange [info level 0] 0 2] value\"" } } elseif {$subcommand eq "set"} { | | | 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 | if {[llength [info level 0]] == 4 } { # value provided if {$subcommand in {"get" "isset" "unset"}} { return -code error "wrong # args: should be\ \"[lrange [info level 0] 0 2] value\"" } } elseif {$subcommand eq "set"} { return -code error\ "wrong # args: should be \"[lrange [info level 0] 0 2]\"" } # Execute subcommands switch -exact -- $subcommand { get { # Operation get return current value if {![dict exists $PackageConfig $option $ns]} { |
︙ | ︙ |
Changes to library/opt/optparse.tcl.
︙ | ︙ | |||
13 14 15 16 17 18 19 | # and the install directory in the Makefiles. package provide opt 0.4.9 namespace eval ::tcl { # Exported APIs namespace export OptKeyRegister OptKeyDelete OptKeyError OptKeyParse \ | | | | | | | | | | | | | | | | | | | | | | | | | 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 | # and the install directory in the Makefiles. package provide opt 0.4.9 namespace eval ::tcl { # Exported APIs namespace export OptKeyRegister OptKeyDelete OptKeyError OptKeyParse \ OptProc OptProcArgGiven OptParse \ Lempty Lget \ Lassign Lvarpop Lvarpop1 Lvarset Lvarincr \ SetMax SetMin ################# Example of use / 'user documentation' ################### proc OptCreateTestProc {} { # Defines ::tcl::OptParseTest as a test proc with parsed arguments # (can't be defined before the code below is loaded (before "OptProc")) # Every OptProc give usage information on "procname -help". # Try "tcl::OptParseTest -help" and "tcl::OptParseTest -a" and # then other arguments. # # example of 'valid' call: # ::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"} {arg2 -boolean "a boolean"} {arg3 -choice "ch1 ch2"} {?optarg? -list {} "optional argument"} } { foreach v [info locals] { puts stderr [format "%14s : %s" $v [set $v]] } } } ################### No User serviceable part below ! ############### |
︙ | ︙ | |||
142 143 144 145 146 147 148 | # Parse a given description and saves it here under the given key # generate a unused keyid if not given # proc ::tcl::OptKeyRegister {desc {key ""}} { variable OptDesc variable OptDescN if {[string equal $key ""]} { | | | | | | | | | | | | | | | | | | | | | | | | | | | | 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 | # Parse a given description and saves it here under the given key # generate a unused keyid if not given # 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 } # program counter set program [list [list "P" 1]] # are we processing flags (which makes a single program step) set inflags 0 set state {} # flag used to detect that we just have a single (flags set) subprogram. set empty 1 foreach item $desc { if {$state == "args"} { # 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"} { # 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 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 } } } if {$inflags} { if {$empty} { # We just have the subprogram, optimize and remove # unneeded level: set program $flagsprg |
︙ | ︙ | |||
215 216 217 218 219 220 221 | proc ::tcl::OptKeyDelete {key} { variable OptDesc unset OptDesc($key) } # Get the parsed description stored under the given key. proc OptKeyGetDesc {descKey} { | | | | | | | 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 | proc ::tcl::OptKeyDelete {key} { variable OptDesc unset OptDesc($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) } # Parse entry point for people who don't want to register with a key, # for instance because the description changes dynamically. # (otherwise one should really use OptKeyRegister once + OptKeyParse # as it is way faster or simply OptProc which does it all) # Assign a temporary key, call OptKeyParse and then free the storage |
︙ | ︙ | |||
244 245 246 247 248 249 250 | # and add a first line to the code to call the OptKeyParse proc # Stores the list of variables that have been actually given by the user # (the other will be sets to their default value) # into local variable named "Args". proc ::tcl::OptProc {name desc body} { set namespace [uplevel 1 [list ::namespace current]] if {[string match "::*" $name] || [string equal $namespace "::"]} { | | | | | | 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 | # and add a first line to the code to call the OptKeyParse proc # Stores the list of variables that have been actually given by the user # (the other will be sets to their default value) # into local variable named "Args". 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 } else { # 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"] return $key } # Check that a argument has been given # assumes that "OptProc" has been used as it will check in "Args" list |
︙ | ︙ | |||
296 297 298 299 300 301 302 | lappend res [Lget $lst $idx] } return $res } # Advance to next description proc OptNextDesc {descName} { | | | | | | | | | | | | | | | | | | | 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 | lappend res [Lget $lst $idx] } return $res } # Advance to next description proc OptNextDesc {descName} { uplevel 1 [list Lvarincr $descName {0 1}] } # Get the current description, eventually descend proc OptCurDesc {descriptions} { lindex $descriptions [OptGetPrgCounter $descriptions] } # get the current description, eventually descend # through sub programs as needed. proc OptCurDescFinal {descriptions} { set item [OptCurDesc $descriptions] # Descend untill we get the actual item and not a sub program while {[OptIsPrg $item]} { set item [OptCurDesc $item] } return $item } # Current final instruction adress proc OptCurAddr {descriptions {start {}}} { set adress [OptGetPrgCounter $descriptions] lappend start $adress set item [lindex $descriptions $adress] if {[OptIsPrg $item]} { return [OptCurAddr $item $start] } else { return $start } } # Set the value field of the current instruction. proc OptCurSetValue {descriptionsName value} { upvar $descriptionsName descriptions # Get the current item full address. set adress [OptCurAddr $descriptions] # Use the 3rd field of the item (see OptValue / OptNewInst). lappend adress 2 Lvarset descriptions $adress [list 1 $value] # ^hasBeenSet flag } # Empty state means done/paste the end of the program. proc OptState {item} { lindex $item 0 } # current state proc OptCurState {descriptions} { OptState [OptCurDesc $descriptions] } ####### # Arguments manipulation # Returns the argument that has to be processed now. proc OptCurrentArg {lst} { lindex $lst 0 } # Advance to next argument. proc OptNextArg {argsName} { uplevel 1 [list Lvarpop1 $argsName] } ####### # Loop over all descriptions, calling OptDoOne which will # eventually eat all the arguments. proc OptDoAll {descriptionsName argumentsName} { upvar $descriptionsName descriptions upvar $argumentsName arguments # puts "entered DoAll" # Nb: the places where "state" can be set are tricky to figure # because DoOne sets the state to flagsValue and return -continue # when needed... set state [OptCurState $descriptions] # We'll exit the loop in "OptDoOne" or when state is empty. while 1 { set curitem [OptCurDesc $descriptions] # Do subprograms if needed, call ourselves on the sub branch while {[OptIsPrg $curitem]} { OptDoAll curitem arguments # puts "done DoAll sub" # Insert back the results in current tree Lvarset1nc descriptions [OptGetPrgCounter $descriptions]\ $curitem OptNextDesc descriptions set curitem [OptCurDesc $descriptions] set state [OptCurState $descriptions] } # puts "state = \"$state\" - arguments=($arguments)" if {[Lempty $state]} { # Nothing left to do, we are done in this branch: break } # The following statement can make us terminate/continue # as it use return -code {break, continue, return and error} # codes 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 $stateName state # the special state/instruction "args" eats all # the remaining args (if any) if {($state == "args")} { if {![Lempty $arguments]} { # If there is no additional arguments, leave the default value |
︙ | ︙ | |||
439 440 441 442 443 444 445 | } else { return -code error [OptMissingValue $descriptions] } } else { set arg [OptCurrentArg $arguments] } | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 | } else { return -code error [OptMissingValue $descriptions] } } else { 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] } set item [OptCurDesc $descriptions] if {[OptNeedValue $item]} { # we need a value, next state is set state flagValue } else { OptCurSetValue descriptions 1 } # continue return -code continue } flagValue - value { set item [OptCurDesc $descriptions] # 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 # set the value OptCurSetValue descriptions $val # go to next state if {$state == "flagValue"} { set state flags return -code continue } else { set state next; # not used, for debug only return ; # will go on next step } } optValue { set item [OptCurDesc $descriptions] # Test the values against their required type if {![catch {OptCheckType $arg\ [OptType $item] [OptTypeArgs $item]} val]} { # right type, so : # consume the value OptNextArg arguments # set the value OptCurSetValue descriptions $val } # go to next state 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\"\ (prg counter [OptGetPrgCounter $descriptions]:\ [OptCurDesc $descriptions])" } |
︙ | ︙ | |||
572 573 574 575 576 577 578 | # otherwise returns the canonical value of that arg (ie 0/1 for booleans) proc ::tcl::OptCheckType {arg type {typeArgs ""}} { # puts "checking '$arg' against '$type' ($typeArgs)" # only types "any", "choice", and numbers can have leading "-" switch -exact -- $type { | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 | # otherwise returns the canonical value of that arg (ie 0/1 for booleans) proc ::tcl::OptCheckType {arg type {typeArgs ""}} { # puts "checking '$arg' against '$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" } return $arg } float { return [expr {double($arg)}] } script - list { # if llength fail : malformed list if {[llength $arg]==0 && [OptIsFlag $arg]} { error "no values with leading -" } return $arg } 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" } return $arg } any { return $arg } string - default { if {[OptIsFlag $arg]} { error "no values with leading -" } return $arg } } return neverReached } # internal utilities # 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 {} 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] # lets try to match case insensitively # (string length ought to be cheap) set lflag [string tolower $flag] if {$len == [string length $lflag]} { if {[string equal $larg $lflag]} { # Exact match case OptSetPrgCounter desc $i return 1 } } elseif {[string equal $larg [string range $lflag 0 $last]]} { lappend hitems $i incr hits } incr i } if {$hits} { OptSetPrgCounter desc $hitems } return $hits } # Extract fields from the list structure: proc OptName {item} { lindex $item 1 } proc OptHasBeenSet {item} { Lget $item {2 0} } proc OptValue {item} { Lget $item {2 1} } proc OptIsFlag {name} { string match "-*" $name } proc OptIsOpt {name} { string match {\?*} $name } proc OptVarName {item} { set name [OptName $item] if {[OptIsFlag $name]} { return [string range $name 1 end] } elseif {[OptIsOpt $name]} { return [string trim $name "?"] } else { return $name } } proc OptType {item} { lindex $item 3 } proc OptTypeArgs {item} { lindex $item 4 } proc OptHelp {item} { lindex $item 5 } proc OptNeedValue {item} { expr {![string equal [OptType $item] boolflag]} } proc OptDefaultValue {item} { 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 # is broken.. if {$val} { return 1 } else { return 0 } } } 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?}" } # Generate a canonical form single instruction proc OptNewInst {state varname type typeArgs help} { list $state $varname [list 0 {}] $type $typeArgs $help # ^ ^ # | | # hasBeenSet=+ +=currentValue } # Translate one item to canonical form proc OptNormalizeOne {item} { set lg [Lassign $item varname arg1 arg2 arg3] # puts "called optnormalizeone '$item' v=($varname), lg=$lg" set isflag [OptIsFlag $varname] set isopt [OptIsOpt $varname] if {$isflag} { set state "flags" } elseif {$isopt} { set state "optValue" } elseif {![string equal $varname "args"]} { set state "value" } else { set state "args" } # apply 'smart' 'fuzzy' logic to try to make # 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} { set type boolflag set def false } else { set type any 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]} { # flags/optValue as they are optional, need a "value", # on the contrary, for a variable (non optional), # 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\ [OptGuessType $arg1] $arg1 $arg2] } } 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] } } } # 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 } # Error messages front ends proc OptAmbigous {desc arg} { OptError "ambigous option \"$arg\", choose from:" [OptSelection $desc] } proc OptFlagUsage {desc arg} { OptError "bad flag \"$arg\", must be one of" $desc } proc OptTooManyArgs {desc arguments} { OptError "too many arguments (unexpected argument(s): $arguments),\ usage:"\ $desc 1 } proc OptParamType {item} { if {[OptIsFlag $item]} { return "flag" } else { return "parameter" } } proc OptBadValue {item arg {err {}}} { # puts "bad val err = \"$err\"" 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]\"\ (use -help for full usage) :"\ [list $item] } proc ::tcl::OptKeyError {prefix descKey {header 0}} { OptError $prefix [OptKeyGetDesc $descKey] $header } |
︙ | ︙ | |||
939 940 941 942 943 944 945 | proc ::tcl::Lempty {list} { expr {[llength $list]==0} } # Gets the value of one leaf of a lists tree proc ::tcl::Lget {list indexLst} { if {[llength $indexLst] <= 1} { | | | | | | | | | | | | | | | | | | | | | | | | | | 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 | proc ::tcl::Lempty {list} { expr {[llength $list]==0} } # Gets the value of one leaf of a lists tree proc ::tcl::Lget {list indexLst} { if {[llength $indexLst] <= 1} { return [lindex $list $indexLst] } Lget [lindex $list [lindex $indexLst 0]] [lrange $indexLst 1 end] } # Sets the value of one leaf of a lists tree # (we use the version that does not create the elements because # it would be even slower... needs to be written in C !) # (nb: there is a non trivial recursive problem with indexes 0, # which appear because there is no difference between a list # of 1 element and 1 element alone : [list "a"] == "a" while # it should be {a} and [listp a] should be 0 while [listp {a b}] would be 1 # and [listp "a b"] maybe 0. listp does not exist either...) proc ::tcl::Lvarset {listName indexLst newValue} { upvar $listName list if {[llength $indexLst] <= 1} { Lvarset1nc list $indexLst $newValue } else { 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 } } # Set one cell to a value, eventually create all the needed elements # (on level-1 of lists) variable emptyList {} proc ::tcl::Lvarset1 {listName index newValue} { upvar $listName list 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 } else { set list [lreplace $list $index $index $newValue] } } # same as Lvarset1 but no bound checking / creation proc ::tcl::Lvarset1nc {listName index newValue} { upvar $listName list set list [lreplace $list $index $index $newValue] } # Increments the value of one leaf of a lists tree # (which must exists) proc ::tcl::Lvarincr {listName indexLst {howMuch 1}} { upvar $listName list if {[llength $indexLst] <= 1} { 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 } } # Increments the value of one cell of a list proc ::tcl::Lvarincr1 {listName index {howMuch 1}} { upvar $listName list set newValue [expr {[lindex $list $index]+$howMuch}] set list [lreplace $list $index $index $newValue] |
︙ | ︙ | |||
1033 1034 1035 1036 1037 1038 1039 | } # Assign list elements to variables and return the length of the list proc ::tcl::Lassign {list args} { # faster than direct blown foreach (which does not byte compile) set i 0 set lg [llength $list] foreach vname $args { | | | | | | | 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 | } # Assign list elements to variables and return the length of the list proc ::tcl::Lassign {list args} { # faster than direct blown foreach (which does not byte compile) set i 0 set lg [llength $list] foreach vname $args { if {$i>=$lg} break uplevel 1 [list ::set $vname [lindex $list $i]] incr i } return $lg } # Misc utilities # Set the varname to value if value is greater than varname's current value # or if varname is undefined proc ::tcl::SetMax {varname value} { upvar 1 $varname var if {![info exists var] || $value > $var} { set var $value } } # Set the varname to value if value is smaller than varname's current value # or if varname is undefined proc ::tcl::SetMin {varname value} { upvar 1 $varname var if {![info exists var] || $value < $var} { set var $value } } # everything loaded fine, lets create the test proc: # OptCreateTestProc # Don't need the create temp proc anymore: # rename OptCreateTestProc {} } |
Changes to library/package.tcl.
︙ | ︙ | |||
27 28 29 30 31 32 33 | # Results: # Returns 1 if the extension matches, 0 otherwise proc tcl::Pkg::CompareExtension {fileName {ext {}}} { global tcl_platform if {$ext eq ""} {set ext [info sharedlibextension]} if {$tcl_platform(platform) eq "windows"} { | | | | | | | | | | | | 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 | # Results: # Returns 1 if the extension matches, 0 otherwise 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] } 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 } # The current extension does not match; if it is not a numeric # value, quit, as we are only looking to ignore version number # extensions. Otherwise we might return 1 in this case: # tcl::Pkg::CompareExtension foo.so.bar .so # which should not match. if {![string is integer -strict [string range $currExt 1 end]]} { return 0 } set root [file rootname $root] } } } # pkg_mkIndex -- # This procedure creates a package index in a given directory. The package # index consists of a "pkgIndex.tcl" file whose contents are a Tcl script that |
︙ | ︙ | |||
500 501 502 503 504 505 506 | # $file was not readable; silently ignore continue } on error msg { if {[regexp {version conflict for package} $msg]} { # In case of version conflict, silently ignore continue } | | | 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 | # $file was not readable; silently ignore continue } on error msg { if {[regexp {version conflict for package} $msg]} { # In case of version conflict, silently ignore continue } tclLog "error reading package index file $file: $msg" } on ok {} { set procdDirs($dir) 1 } } } } set dir [lindex $use_path end] |
︙ | ︙ | |||
608 609 610 611 612 613 614 | try { ::tcl::Pkg::source $file } trap {POSIX EACCES} {} { # $file was not readable; silently ignore continue } on error msg { if {[regexp {version conflict for package} $msg]} { | | | 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 | try { ::tcl::Pkg::source $file } trap {POSIX EACCES} {} { # $file was not readable; silently ignore continue } on error msg { if {[regexp {version conflict for package} $msg]} { # In case of version conflict, silently ignore continue } tclLog "error reading package index file $file: $msg" } on ok {} { set procdDirs($dir) 1 } } |
︙ | ︙ |
Changes to library/platform/shell.tcl.
︙ | ︙ | |||
127 128 129 130 131 132 133 | set cc [open $c w] puts $cc $code close $cc set e [TEMP] set code [catch { | | | 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 | set cc [open $c w] puts $cc $code close $cc set e [TEMP] set code [catch { exec $shell $c 2> $e } res] file delete $c if {$code} { append res \n[read [set chan [open $e r]]][close $chan] file delete $e |
︙ | ︙ | |||
159 160 161 162 163 164 165 | set maxtries 10 set access [list RDWR CREAT EXCL TRUNC] set permission 0600 set channel "" set checked_dir_writable 0 set mypid [pid] for {set i 0} {$i < $maxtries} {incr i} { | | | | | | | | | | | | | | | | | | | | | | | | 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 | set maxtries 10 set access [list RDWR CREAT EXCL TRUNC] set permission 0600 set channel "" 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 \ [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 close $channel return [file normalize $newname] } } } if {$channel ne ""} { return -code error "Failed to open a temporary file: $channel" } else { return -code error "Failed to find an unused temporary file name" } } proc ::platform::shell::DIR {} { # This code is copied out of Tcllib's fileutil package. # (TempDir/tempdir) |
︙ | ︙ |
Changes to library/safe.tcl.
︙ | ︙ | |||
76 77 78 79 80 81 82 | # #### # Interface/entry point function and front end for "Create" proc ::safe::interpCreate {args} { variable AutoPathSync if {$AutoPathSync} { | | | | 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 | # #### # Interface/entry point function and front end for "Create" proc ::safe::interpCreate {args} { variable AutoPathSync if {$AutoPathSync} { set autoPath {} } set Args [::tcl::OptKeyParse ::safe::interpCreate $args] RejectExcessColons $child set withAutoPath [::tcl::OptProcArgGiven -autoPath] InterpCreate $child $accessPath \ [InterpStatics] [InterpNested] $deleteHook $autoPath $withAutoPath } proc ::safe::interpInit {args} { variable AutoPathSync if {$AutoPathSync} { set autoPath {} } set Args [::tcl::OptKeyParse ::safe::interpIC $args] if {![::interp exists $child]} { return -code error "\"$child\" is not an interpreter" } RejectExcessColons $child |
︙ | ︙ | |||
140 141 142 143 144 145 146 | CheckInterp $child namespace upvar ::safe [VarName $child] state set TMP [list \ [list -accessPath $state(access_path)] \ [list -statics $state(staticsok)] \ [list -nested $state(nestedok)] \ | | | | 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 | CheckInterp $child namespace upvar ::safe [VarName $child] state set TMP [list \ [list -accessPath $state(access_path)] \ [list -statics $state(staticsok)] \ [list -nested $state(nestedok)] \ [list -deleteHook $state(cleanupHook)] \ ] if {!$AutoPathSync} { lappend TMP [list -autoPath $state(auto_path)] } return [join $TMP] } 2 { # If we have exactly 2 arguments the semantic is a "configure # get" lassign $args child arg |
︙ | ︙ | |||
172 173 174 175 176 177 178 | set name [::tcl::OptName $item] switch -exact -- $name { -accessPath { return [list -accessPath $state(access_path)] } -autoPath { if {$AutoPathSync} { | | | | 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 | set name [::tcl::OptName $item] switch -exact -- $name { -accessPath { return [list -accessPath $state(access_path)] } -autoPath { if {$AutoPathSync} { return -code error "unknown flag $name (bug)" } else { return [list -autoPath $state(auto_path)] } } -statics { return [list -statics $state(staticsok)] } -nested { return [list -nested $state(nestedok)] |
︙ | ︙ | |||
376 377 378 379 380 381 382 | set raw_auto_path $access_path # Add 1st level subdirs (will searched by auto loading from tcl # code in the child using glob and thus fail, so we add them here # so by default it works the same). set access_path [AddSubDirs $access_path] } else { | | | | | 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 | set raw_auto_path $access_path # Add 1st level subdirs (will searched by auto loading from tcl # code in the child using glob and thus fail, so we add them here # so by default it works the same). set access_path [AddSubDirs $access_path] } else { set raw_auto_path $autoPath } if {$withAutoPath} { 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 } namespace upvar ::safe [VarName $child] state # clear old autopath if it existed # build new one # Extend the access list with the paths used to look for Tcl Modules. |
︙ | ︙ | |||
437 438 439 440 441 442 443 | set addpaths $morepaths set morepaths {} foreach dir $addpaths { # Prevent the addition of dirs on the tm list to the # result if they are already known. if {[dict exists $remap_access_path $dir]} { | | | 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 | set addpaths $morepaths set morepaths {} foreach dir $addpaths { # Prevent the addition of dirs on the tm list to the # result if they are already known. if {[dict exists $remap_access_path $dir]} { if {$firstpass} { # $dir is in [::tcl::tm::list] and belongs in the child_tm_path. # Later passes handle subdirectories, which belong in the # access path but not in the module path. lappend child_tm_path [dict get $remap_access_path $dir] } continue } |
︙ | ︙ | |||
482 483 484 485 486 487 488 | set state(access_path,child) $child_access_path set state(tm_path_child) $child_tm_path set state(staticsok) $staticsok set state(nestedok) $nestedok set state(cleanupHook) $deletehook if {!$AutoPathSync} { | | | 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 | set state(access_path,child) $child_access_path set state(tm_path_child) $child_tm_path set state(staticsok) $staticsok set state(nestedok) $nestedok set state(cleanupHook) $deletehook if {!$AutoPathSync} { set state(auto_path) $raw_auto_path } SyncAccessPath $child return } |
︙ | ︙ | |||
683 684 685 686 687 688 689 | # When an interpreter is deleted with [interp delete], any sub-interpreters # are deleted automatically, but this leaves behind their data in the Safe # Base. To clean up properly, we call safe::interpDelete recursively on each # Safe Base sub-interpreter, so each one is deleted cleanly and not by # the automatic mechanism built into [interp delete]. foreach sub [interp children $child] { | | | | | 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 | # When an interpreter is deleted with [interp delete], any sub-interpreters # are deleted automatically, but this leaves behind their data in the Safe # Base. To clean up properly, we call safe::interpDelete recursively on each # Safe Base sub-interpreter, so each one is deleted cleanly and not by # the automatic mechanism built into [interp delete]. foreach sub [interp children $child] { 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 # existence because we might be called to delete an interp which has # not been registered with us at all if {[info exists state(cleanupHook)]} { |
︙ | ︙ | |||
1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 | set f [open $realfile] fconfigure $f -encoding $encoding -eofchar \x1A set contents [read $f] close $f ::interp eval $child [list info script $file] } msg opt] if {$code == 0} { set code [catch {::interp eval $child $contents} msg opt] set replacementMsg $msg } catch {interp eval $child [list info script $old]} # Note that all non-errors are fine result codes from [source], so we must # take a little care to do it properly. [Bug 2923613] if {$code == 1} { | > > > > | 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 | set f [open $realfile] fconfigure $f -encoding $encoding -eofchar \x1A set contents [read $f] close $f ::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 } catch {interp eval $child [list info script $old]} # Note that all non-errors are fine result codes from [source], so we must # take a little care to do it properly. [Bug 2923613] if {$code == 1} { |
︙ | ︙ | |||
1276 1277 1278 1279 1280 1281 1282 | # becomes # namespace upvar ::safe [VarName $child] state # ------------------------------------------------------------------------------ proc ::safe::RejectExcessColons {child} { set stripped [regsub -all -- {:::*} $child ::] if {[string range $stripped end-1 end] eq {::}} { | | | | | | 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 | # becomes # namespace upvar ::safe [VarName $child] state # ------------------------------------------------------------------------------ proc ::safe::RejectExcessColons {child} { set stripped [regsub -all -- {:::*} $child ::] if {[string range $stripped end-1 end] eq {::}} { return -code error {interpreter name must not end in "::"} } if {$stripped ne $child} { set msg {interpreter name has excess colons in namespace separators} return -code error $msg } if {[string range $stripped 0 1] eq {::}} { return -code error {interpreter name must not begin "::"} } return } proc ::safe::VarName {child} { # return S$child return S[string map {:: @N @ @A} $child] |
︙ | ︙ | |||
1311 1312 1313 1314 1315 1316 1317 | {-noStatics "prevent loading of statically linked pkgs"} {-statics true "loading of statically linked pkgs"} {-nestedLoadOk "allow nested loading"} {-nested false "nested loading"} {-deleteHook -script {} "delete hook"} } if {!$AutoPathSync} { | | | 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 | {-noStatics "prevent loading of statically linked pkgs"} {-statics true "loading of statically linked pkgs"} {-nestedLoadOk "allow nested loading"} {-nested false "nested loading"} {-deleteHook -script {} "delete hook"} } if {!$AutoPathSync} { lappend OptList {-autoPath -list {} "::auto_path for the child"} } set temp [::tcl::OptKeyRegister $OptList] # create case (child is optional) ::tcl::OptKeyRegister { {?child? -name {} "name of the child (optional)"} } ::safe::interpCreate |
︙ | ︙ | |||
1369 1370 1371 1372 1373 1374 1375 | # because Setup has not yet been called.) proc ::safe::setSyncMode {args} { variable AutoPathSync if {[llength $args] == 0} { } elseif {[llength $args] == 1} { | | | | | | | | | | | | | | | | | | | | | 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 | # because Setup has not yet been called.) proc ::safe::setSyncMode {args} { variable AutoPathSync 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 } } else { set msg {wrong # args: should be "safe::setSyncMode ?newValue?"} return -code error $msg } return $AutoPathSync } namespace eval ::safe { # internal variables (must not begin with "S") |
︙ | ︙ |
Changes to library/tcltest/tcltest.tcl.
︙ | ︙ | |||
511 512 513 514 515 516 517 | return -code error $msg } else { set Option($option) $msg } unset $varName } namespace eval [namespace current] \ | | | 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 | return -code error $msg } else { set Option($option) $msg } unset $varName } namespace eval [namespace current] \ [list upvar 0 Option($option) $varName] # Workaround for Bug (now Feature Request) 572889. Grrrr.... # Track all the variables tied to options lappend OptionControlledVariables $varName # Later, set auto-configure read traces on all # of them, since a single trace on Option does not work. proc $varName {{value {}}} [subst -nocommands { if {[llength [info level 0]] == 2} { |
︙ | ︙ | |||
1154 1155 1156 1157 1158 1159 1160 | # # Side effects: # None. proc tcltest::Asciify {s} { set print "" foreach c [split $s ""] { | | | | | | | | | | | 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 | # # Side effects: # None. 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]] } } return $print } # tcltest::ConstraintInitializer -- # # Get or set a script that when evaluated in the tcltest namespace |
︙ | ︙ | |||
1343 1344 1345 1346 1347 1348 1349 | ConstraintInitializer eformat {string equal [format %g 5e-5] 5e-05} # Test to see if execed commands such as cat, echo, rm and so forth # are present on this machine. ConstraintInitializer unixExecs { set code 1 | | | | | | | | | | | | | | | | | | | | | | 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 | ConstraintInitializer eformat {string equal [format %g 5e-5] 5e-05} # Test to see if execed commands such as cat, echo, rm and so forth # are present on this machine. ConstraintInitializer unixExecs { set code 1 if {$::tcl_platform(platform) eq "macintosh"} { set code 0 } if {$::tcl_platform(platform) eq "windows"} { if {[catch { set file _tcl_test_remove_me.txt makeFile {hello} $file }]} { 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 } { set code 0 } removeFile $file } set code } ConstraintInitializer stdio { variable fullutf set code 0 |
︙ | ︙ | |||
1544 1545 1546 1547 1548 1549 1550 | "missing value for option [lindex $args 0]" exit 1 } } # Call the hook catch { | | | | 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 | "missing value for option [lindex $args 0]" exit 1 } } # Call the hook catch { array set flag $flagArray processCmdLineArgsHook [array get flag] } return } # tcltest::ProcessCmdLineArgs -- # # This procedure must be run after constraint initialization is |
︙ | ︙ | |||
1728 1729 1730 1731 1732 1733 1734 | # # Side effects: # None. proc tcltest::CompareStrings {actual expected mode} { variable CustomMatch if {![info exists CustomMatch($mode)]} { | | | 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 | # # Side effects: # None. proc tcltest::CompareStrings {actual expected mode} { variable CustomMatch if {![info exists CustomMatch($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]} { return -code error "Invalid result from `-match $mode' command: $result" } return $match } |
︙ | ︙ | |||
1806 1807 1808 1809 1810 1811 1812 | # separated strings as it throws away the whitespace which maybe # important so we have to do it all by hand. set result {} set token "" while {[string length $argList]} { | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 | # separated strings as it throws away the whitespace which maybe # important so we have to do it all by hand. set result {} set token "" while {[string length $argList]} { # 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 # this word, from the argList. 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 {} } } # If the last token has not been added to the list then there # is a problem. if { [string length $token] } { error "incomplete token \"$token\"" } return $result } # tcltest::test -- |
︙ | ︙ | |||
1910 1911 1912 1913 1914 1915 1916 | # previously registered by a call to [customMatch]. # The strings exact, glob, and regexp are preregistered # by the tcltest package. Default value is exact. # # Arguments: # name - Name of test, in the form foo-1.2. # description - Short textual description of the test, to | | | 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 | # previously registered by a call to [customMatch]. # The strings exact, glob, and regexp are preregistered # by the tcltest package. Default value is exact. # # 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. # # Results: # None. # # Side effects: # Just about anything is possible depending on the test. # |
︙ | ︙ | |||
2005 2006 2007 2008 2009 2010 2011 | must be $values" } # Replace symbolic valies supplied for -returnCodes foreach {strcode numcode} {ok 0 normal 0 error 1 return 2 break 3 continue 4} { set returnCodes [string map -nocase [list $strcode $numcode] $returnCodes] } | | | | | | 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 | must be $values" } # Replace symbolic valies supplied for -returnCodes 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 } } else { # This is parsing for the old test command format; it is here # for backward compatibility. set result [lindex $args end] if {[llength $args] == 2} { set body [lindex $args 0] } elseif {[llength $args] == 3} { |
︙ | ︙ | |||
2091 2092 2093 2094 2095 2096 2097 | # check if the return code matched the expected return code set codeFailure 0 if {$processTest && !$setupFailure && ($returnCode ni $returnCodes)} { set codeFailure 1 } set errorCodeFailure 0 if {$processTest && !$setupFailure && !$codeFailure && $returnCode == 1 && \ | | | 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 | # check if the return code matched the expected return code set codeFailure 0 if {$processTest && !$setupFailure && ($returnCode ni $returnCodes)} { set codeFailure 1 } set errorCodeFailure 0 if {$processTest && !$setupFailure && !$codeFailure && $returnCode == 1 && \ ![string match $errorCode $errorCodeRes(body)]} { set errorCodeFailure 1 } # If expected output/error strings exist, we have to compare # them. If the comparison fails, then so did the test. set outputFailure 0 variable outData |
︙ | ︙ | |||
2124 2125 2126 2127 2128 2129 2130 | set errorFailure 1 } } # check if the answer matched the expected answer # Only check if we ran the body of the test (no setup failure) if {!$processTest} { | | | 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 | set errorFailure 1 } } # 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 } elseif {$setupFailure || $codeFailure} { set scriptFailure 0 } elseif {[set scriptCompare [catch { CompareStrings $actualAnswer $result $match } scriptMatch]] == 0} { set scriptFailure [expr {!$scriptMatch}] } else { |
︙ | ︙ | |||
2410 2411 2412 2413 2414 2415 2416 | return 1 } } else { # "constraints" argument exists; # make sure that the constraints are satisfied. set doTest 0 | | | 2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 | return 1 } } else { # "constraints" argument exists; # make sure that the constraints are satisfied. set doTest 0 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]]} } elseif {[regexp {[^.:_a-zA-Z0-9 \n\r\t]+} $constraints] != 0} { # something like {a || b} should be turned into # $testConstraints(a) || $testConstraints(b). regsub -all {[.\w]+} $constraints {$testConstraints(&)} c |
︙ | ︙ |
Changes to macosx/tclMacOSXNotify.c.
︙ | ︙ | |||
1679 1680 1681 1682 1683 1684 1685 | if (tsdPtr->runLoop) { CFTimeInterval waitTime; CFRunLoopTimerRef runLoopTimer = tsdPtr->runLoopTimer; CFAbsoluteTime nextTimerFire = 0, waitEnd, now; SInt32 runLoopStatus; waitTime = vdelay.sec + 1.0e-6 * vdelay.usec; | | | 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 | if (tsdPtr->runLoop) { CFTimeInterval waitTime; CFRunLoopTimerRef runLoopTimer = tsdPtr->runLoopTimer; CFAbsoluteTime nextTimerFire = 0, waitEnd, now; SInt32 runLoopStatus; waitTime = vdelay.sec + 1.0e-6 * vdelay.usec; now = CFAbsoluteTimeGetCurrent(); waitEnd = now + waitTime; if (runLoopTimer) { nextTimerFire = CFRunLoopTimerGetNextFireDate(runLoopTimer); if (nextTimerFire < waitEnd) { CFRunLoopTimerSetNextFireDate(runLoopTimer, now + CF_TIMEINTERVAL_FOREVER); |
︙ | ︙ | |||
1709 1710 1711 1712 1713 1714 1715 | break; case kCFRunLoopRunTimedOut: waitTime = 0; break; } } while (waitTime > 0); tsdPtr->sleeping = 0; | | | 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 | break; case kCFRunLoopRunTimedOut: waitTime = 0; break; } } while (waitTime > 0); tsdPtr->sleeping = 0; if (runLoopTimer) { CFRunLoopTimerSetNextFireDate(runLoopTimer, nextTimerFire); } } else { struct timespec waitTime; waitTime.tv_sec = vdelay.sec; waitTime.tv_nsec = vdelay.usec * 1000; |
︙ | ︙ |
Changes to tests-perf/list.perf.tcl.
︙ | ︙ | |||
90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 | { lsearch -glob $l $sNF } { lsearch -nocase $l $sNF } { lsearch -nocase -glob $l $sNF } } } 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 puts \n**OK** } }; # end of ::tclTestPerf-List # ------------------------------------------------------------------------ | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 | { lsearch -glob $l $sNF } { lsearch -nocase $l $sNF } { lsearch -nocase -glob $l $sNF } } } 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** } }; # end of ::tclTestPerf-List # ------------------------------------------------------------------------ |
︙ | ︙ |
Changes to tests/indexObj.test.
︙ | ︙ | |||
16 17 18 19 20 21 22 | ::tcltest::loadTestedCommands catch [list package require -exact tcl::test [info patchlevel]] 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}] | < | 16 17 18 19 20 21 22 23 24 25 26 27 28 29 | ::tcltest::loadTestedCommands catch [list package require -exact tcl::test [info patchlevel]] 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}] test indexObj-1.1 {exact match} testindexobj { testindexobj 1 1 xyz abc def xyz alm } {2} test indexObj-1.2 {exact match} testindexobj { testindexobj 1 1 abc abc def xyz alm } {0} |
︙ | ︙ | |||
224 225 226 227 228 229 230 | } -3 test indexObj-8.12 {Tcl_GetIntForIndex end} testgetintforindex { testgetintforindex end -1 } -1 test indexObj-8.13 {Tcl_GetIntForIndex end} testgetintforindex { testgetintforindex end -2 } -2 | | | > > > | > | | | | < > > | | | | | 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 | } -3 test indexObj-8.12 {Tcl_GetIntForIndex end} testgetintforindex { testgetintforindex end -1 } -1 test indexObj-8.13 {Tcl_GetIntForIndex end} testgetintforindex { testgetintforindex end -2 } -2 test indexObj-8.14 {Tcl_GetIntForIndex end+1} testgetintforindex { testgetintforindex end+1 -1 } [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 return # Local Variables: # mode: tcl # End: |
Changes to tests/interp.test.
︙ | ︙ | |||
16 17 18 19 20 21 22 | } ::tcltest::loadTestedCommands catch [list package require -exact tcl::test [info patchlevel]] testConstraint testinterpdelete [llength [info commands testinterpdelete]] | | | 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 | } ::tcltest::loadTestedCommands 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: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] } incr t0 $ms list -seconds [expr {$t0 / 1000}] -milliseconds [expr {$t0 % 1000}] } |
︙ | ︙ |
Changes to tests/lseq.test.
︙ | ︙ | |||
105 106 107 108 109 110 111 | test lseq-1.15 {count with decreasing step} { -body { lseq 5 count 5 by -2 } -result {5 3 1 -1 -3} } | | > > > > | 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 | test lseq-1.15 {count with decreasing step} { -body { lseq 5 count 5 by -2 } -result {5 3 1 -1 -3} } 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??"} test lseq-1.18 {too many arguments extra valid keyword} -body { lseq 12 to 24 by 2 count |
︙ | ︙ | |||
135 136 137 138 139 140 141 142 143 144 145 146 147 148 | test lseq-1.21 {n n by n} { lseq 66 84 by 3 } {66 69 72 75 78 81 84} test lseq-1.22 {n n by -n} { lseq 84 66 by -3 } {84 81 78 75 72 69 66} # # Short-hand use cases # test lseq-2.2 {step magnitude} { lseq 10 1 2 ;# this is an empty case since step has wrong sign } {} | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 | test lseq-1.21 {n n by n} { lseq 66 84 by 3 } {66 69 72 75 78 81 84} 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 # test lseq-2.2 {step magnitude} { lseq 10 1 2 ;# this is an empty case since step has wrong sign } {} |
︙ | ︙ | |||
217 218 219 220 221 222 223 224 225 226 227 228 229 230 | [lseq -10 1 -3] \ [lseq 10 -1 -4] \ [lseq -10 -1 3] \ [lseq 10 1 -5] } {{-10 -8 -6 -4 -2} {} {} {10 6 2} {-10 -7 -4 -1} {10 5}} test lseq-3.1 {experiement} -body { set ans {} foreach factor [lseq 2.0 10.0] { set start 1 set end 10 for {set step 1} {$step < 1e8} {} { set l [lseq $start to $end by $step] | > > > > > > > > > > > > > > > > > | 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 | [lseq -10 1 -3] \ [lseq 10 -1 -4] \ [lseq -10 -1 3] \ [lseq 10 1 -5] } {{-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] { set start 1 set end 10 for {set step 1} {$step < 1e8} {} { set l [lseq $start to $end by $step] |
︙ | ︙ | |||
241 242 243 244 245 246 247 | set ans } -cleanup { unset ans step end start factor l } -result {OK} test lseq-3.2 {error case} -body { lseq foo | | | | > > > | 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 | set ans } -cleanup { unset ans step end start factor l } -result {OK} test lseq-3.2 {error case} -body { lseq foo } -returnCodes 1 -match glob -result {invalid bareword "foo"*} test lseq-3.3 {error case} -body { lseq 10 foo } -returnCodes 1 -match glob -result {invalid bareword "foo"*} test lseq-3.4 {error case} -body { lseq 25 or 6 } -returnCodes 1 -match glob -result {invalid bareword "or"*} test lseq-3.5 {simple count and step arguments} -body { set s [lseq 25 by 6] list $s length=[llength $s] } -cleanup { unset s } -result {{0 6 12 18 24 30 36 42 48 54 60 66 72 78 84 90 96 102 108 114 120 126 132 138 144} length=25} 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} } } -cleanup {unset x} -result {0 1 4 9 16} test lseq-3.8 {lrange lseq} -body { |
︙ | ︙ |
Changes to tests/remote.tcl.
︙ | ︙ | |||
36 37 38 39 40 41 42 | } proc __readAndExecute__ {s} { global command VERBOSE set l [gets $s] if {[string compare $l "--Marker--Marker--Marker--"] == 0} { | | | | | | 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 | } proc __readAndExecute__ {s} { global command VERBOSE set l [gets $s] if {[string compare $l "--Marker--Marker--Marker--"] == 0} { puts $s [__doCommands__ $command($s) $s] puts $s "--Marker--Marker--Marker--" set command($s) "" return } if {[string compare $l ""] == 0} { if {[eof $s]} { if {$VERBOSE} { puts "Server closing $s, eof from client" } close $s } return } if {[eof $s]} { if {$VERBOSE} { puts "Server closing $s, eof from client" } close $s unset command($s) return } append command($s) $l "\n" } proc __accept__ {s a p} { global command VERBOSE |
︙ | ︙ |
Changes to tools/index.tcl.
︙ | ︙ | |||
10 11 12 13 14 15 16 | # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # Global variables used by these scripts: # # state - state variable that controls action of text proc. # # topics - array indexed by (package,section,topic) with value | | | | | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 | # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # Global variables used by these scripts: # # state - state variable that controls action of text proc. # # topics - array indexed by (package,section,topic) with value # of topic ID. # # 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. # # curPkg - current package name (e.g. Tcl). # # curSect - current section title (e.g. "Tcl Built-In Commands"). # # getPackages -- |
︙ | ︙ |
Changes to tools/makeTestCases.tcl.
︙ | ︙ | |||
211 212 213 214 215 216 217 | proc testcases2 { f2 } { listYears startOfYear # Define the roman numerals set roman { | | | | 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 | proc testcases2 { f2 } { listYears startOfYear # Define the roman numerals set roman { ? i ii iii iv v vi vii viii ix x xi xii xiii xiv xv xvi xvii xviii xix xx xxi xxii xxiii xxiv xxv xxvi xxvii xxviii xxix xxx xxxi xxxii xxxiii xxxiv xxxv xxxvi xxxvii xxxviii xxxix xl xli xlii xliii xliv xlv xlvi xlvii xlviii xlix l li lii liii liv lv lvi lvii lviii lix lx lxi lxii lxiii lxiv lxv lxvi lxvii lxviii lxix lxx lxxi lxxii lxxiii lxxiv lxxv lxxvi lxxvii lxxviii lxxix lxxx lxxxi lxxxii lxxxiii lxxxiv lxxxv lxxxvi lxxxvii lxxxviii lxxxix xc xci xcii xciii xciv xcv xcvi xcvii xcviii xcix c } set romanc { ? 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 } # Names of the months |
︙ | ︙ |
Changes to tools/tclOOScript.tcl.
1 2 | # tclOOScript.h -- # | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 | # 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. # # Copyright © 2012-2019 Donal K. Fellows # Copyright © 2013 Andreas Kupries # Copyright © 2017 Gerald Lester # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. |
︙ | ︙ |
Changes to tools/tcltk-man2html.tcl.
︙ | ︙ | |||
606 607 608 609 610 611 612 | wide() mathfunc packagens pkg::create pkgMkIndex pkg_mkIndex pkg_mkIndex pkg_mkIndex Tcl_Obj Tcl_NewObj Tcl_ObjType Tcl_RegisterObjType Tcl_OpenFileChannelProc Tcl_FSOpenFileChannel | | | | 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 | wide() mathfunc packagens pkg::create pkgMkIndex pkg_mkIndex pkg_mkIndex pkg_mkIndex Tcl_Obj Tcl_NewObj Tcl_ObjType Tcl_RegisterObjType Tcl_OpenFileChannelProc Tcl_FSOpenFileChannel errorinfo env errorcode env tcl_pkgpath env Tcl_Command Tcl_CreateObjCommand Tcl_CmdProc Tcl_CreateObjCommand Tcl_CmdDeleteProc Tcl_CreateObjCommand Tcl_ObjCmdProc Tcl_CreateObjCommand Tcl_Channel Tcl_OpenFileChannel Tcl_WideInt Tcl_NewIntObj |
︙ | ︙ |
Changes to unix/Makefile.in.
1 2 3 4 5 6 | # # This file is a Makefile for Tcl. If it has the name "Makefile.in" then it is # a template for a Makefile; to generate the actual Makefile, run # "./configure", which is a configuration script generated by the "autoconf" # program (constructs like "@foo@" will get replaced in the actual Makefile. | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | # # This file is a Makefile for Tcl. If it has the name "Makefile.in" then it is # a template for a Makefile; to generate the actual Makefile, run # "./configure", which is a configuration script generated by the "autoconf" # program (constructs like "@foo@" will get replaced in the actual Makefile. VERSION = @TCL_VERSION@ MAJOR_VERSION = @TCL_MAJOR_VERSION@ MINOR_VERSION = @TCL_MINOR_VERSION@ PATCH_LEVEL = @TCL_PATCH_LEVEL@ #-------------------------------------------------------------------------- # Things you can change to personalize the Makefile for your own site (you can # make these changes in either Makefile.in or Makefile, but changes to |
︙ | ︙ | |||
1097 1098 1099 1100 1101 1102 1103 | @echo "Installing encoding files to $(SCRIPT_INSTALL_DIR)/encoding/" @for i in $(TOP_DIR)/library/encoding/*.enc; do \ $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)/encoding"; \ done @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)] }" >> \ | | | 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 | @echo "Installing encoding files to $(SCRIPT_INSTALL_DIR)/encoding/" @for i in $(TOP_DIR)/library/encoding/*.enc; do \ $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)/encoding"; \ done @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"; \ fi install-tzdata: @for i in tzdata; do \ if [ ! -d "$(SCRIPT_INSTALL_DIR)/$$i" ] ; then \ echo "Making directory $(SCRIPT_INSTALL_DIR)/$$i"; \ $(INSTALL_DATA_DIR) "$(SCRIPT_INSTALL_DIR)/$$i"; \ |
︙ | ︙ |
Changes to unix/configure.
︙ | ︙ | |||
5792 5793 5794 5795 5796 5797 5798 | # AIX requires the _r compiler when gcc isn't being used case "${CC}" in *_r|*_r\ *) # ok ... ;; *) # Make sure only first arg gets _r | | | 5792 5793 5794 5795 5796 5797 5798 5799 5800 5801 5802 5803 5804 5805 5806 | # AIX requires the _r compiler when gcc isn't being used case "${CC}" in *_r|*_r\ *) # ok ... ;; *) # Make sure only first arg gets _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 printf "%s\n" "Using $CC for compiling with threads" >&6; } fi LIBS="$LIBS -lc" |
︙ | ︙ | |||
10012 10013 10014 10015 10016 10017 10018 | #include <sys/types.h> #include <sys/socket.h> int main (void) { | | | 10012 10013 10014 10015 10016 10017 10018 10019 10020 10021 10022 10023 10024 10025 10026 | #include <sys/types.h> #include <sys/socket.h> int main (void) { socklen_t foo; ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO" then : |
︙ | ︙ |
Changes to unix/configure.ac.
︙ | ︙ | |||
400 401 402 403 404 405 406 | AC_TYPE_UID_T AC_CACHE_CHECK([for socklen_t], tcl_cv_type_socklen_t, [ AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[ #include <sys/types.h> #include <sys/socket.h> ]], [[ | | | 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 | AC_TYPE_UID_T AC_CACHE_CHECK([for socklen_t], tcl_cv_type_socklen_t, [ AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[ #include <sys/types.h> #include <sys/socket.h> ]], [[ 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]) fi AC_CHECK_TYPES([intptr_t, uintptr_t],,,[[ #include <stdint.h> |
︙ | ︙ |
Changes to unix/dltest/embtest.c.
︙ | ︙ | |||
30 31 32 33 34 35 36 | printf("Tcl_FindExecutable gives version %s\n", version); } if (tclStubsPtr == NULL) { printf("ERROR: Tcl_FindExecutable does not initialize the stub table\n"); exitcode = 1; } if (!exitcode) { | | | 30 31 32 33 34 35 36 37 38 39 40 | printf("Tcl_FindExecutable gives version %s\n", version); } if (tclStubsPtr == NULL) { printf("ERROR: Tcl_FindExecutable does not initialize the stub table\n"); exitcode = 1; } if (!exitcode) { printf("All OK!\n"); } return exitcode; } |
Changes to unix/installManPage.
︙ | ︙ | |||
8 9 10 11 12 13 14 | Sym="" Loc="" Gz="" Suffix="" while true; do case $1 in | | | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 | Sym="" Loc="" Gz="" Suffix="" while true; do case $1 in -s | --symlinks ) Sym="-s " ;; -z | --compress ) Gzip=$2; shift ;; -e | --extension ) Gz=$2; shift ;; -x | --suffix ) Suffix=$2; shift ;; -*) cat <<EOF Unknown option "$1". Supported options: -s Use symbolic links for manpages with multiple names. -z PROG Use PROG to compress manual pages. -e EXT Defines the extension added by -z PROG when compressing. |
︙ | ︙ |
Changes to unix/tcl.m4.
︙ | ︙ | |||
986 987 988 989 990 991 992 | # AIX requires the _r compiler when gcc isn't being used case "${CC}" in *_r|*_r\ *) # ok ... ;; *) # Make sure only first arg gets _r | | | 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 | # AIX requires the _r compiler when gcc isn't being used case "${CC}" in *_r|*_r\ *) # ok ... ;; *) # Make sure only first arg gets _r CC=`echo "$CC" | sed -e 's/^\([[^ ]]*\)/\1_r/'` ;; esac AC_MSG_RESULT([Using $CC for compiling with threads]) ]) LIBS="$LIBS -lc" SHLIB_CFLAGS="" SHLIB_SUFFIX=".so" |
︙ | ︙ |
Changes to unix/tclEpollNotfy.c.
︙ | ︙ | |||
203 204 205 206 207 208 209 | if (filePtr->mask & (TCL_READABLE | TCL_EXCEPTION)) { newEvent.events |= EPOLLIN; } if (filePtr->mask & TCL_WRITABLE) { newEvent.events |= EPOLLOUT; } if (isNew) { | | | | | 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 | if (filePtr->mask & (TCL_READABLE | TCL_EXCEPTION)) { newEvent.events |= EPOLLIN; } if (filePtr->mask & TCL_WRITABLE) { newEvent.events |= EPOLLOUT; } if (isNew) { newPedPtr = (struct PlatformEventData *) Tcl_Alloc(sizeof(struct PlatformEventData)); newPedPtr->filePtr = filePtr; newPedPtr->tsdPtr = tsdPtr; filePtr->pedPtr = newPedPtr; } newEvent.data.ptr = filePtr->pedPtr; /* * N.B. As discussed in Tcl_WaitForEvent(), epoll(7) does not support * regular files (S_IFREG). Therefore, filePtr is in these cases simply |
︙ | ︙ | |||
259 260 261 262 263 264 265 | * above operations are protected by tsdPtr->notifierMutex, which is * destroyed thereafter. * * Results: * None. * * Side effects: | | | 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 | * above operations are protected by tsdPtr->notifierMutex, which is * destroyed thereafter. * * Results: * None. * * Side effects: * 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. * * tsdPtr->notifierMutex is destroyed. * *---------------------------------------------------------------------- |
︙ | ︙ | |||
363 364 365 366 367 368 369 | tsdPtr->triggerFilePtr = filePtr; if ((tsdPtr->eventsFd = epoll_create1(EPOLL_CLOEXEC)) == -1) { Tcl_Panic("epoll_create1: %s", strerror(errno)); } filePtr->mask = TCL_READABLE; PlatformEventsControl(filePtr, tsdPtr, EPOLL_CTL_ADD, 1); if (!tsdPtr->readyEvents) { | | | 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 | tsdPtr->triggerFilePtr = filePtr; if ((tsdPtr->eventsFd = epoll_create1(EPOLL_CLOEXEC)) == -1) { Tcl_Panic("epoll_create1: %s", strerror(errno)); } filePtr->mask = TCL_READABLE; PlatformEventsControl(filePtr, tsdPtr, EPOLL_CTL_ADD, 1); if (!tsdPtr->readyEvents) { tsdPtr->maxReadyEvents = 512; tsdPtr->readyEvents = (struct epoll_event *) Tcl_Alloc( tsdPtr->maxReadyEvents * sizeof(tsdPtr->readyEvents[0])); } LIST_INIT(&tsdPtr->firstReadyFileHandlerPtr); } /* |
︙ | ︙ |
Changes to unix/tclKqueueNotfy.c.
︙ | ︙ | |||
257 258 259 260 261 262 263 | * operations are protected by tsdPtr->notifierMutex, which is destroyed * thereafter. * * Results: * None. * * Side effects: | | | 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 | * operations are protected by tsdPtr->notifierMutex, which is destroyed * thereafter. * * Results: * None. * * Side effects: * 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. * * tsdPtr->notifierMutex is destroyed. * *---------------------------------------------------------------------- |
︙ | ︙ |
Changes to unix/tclLoadDl.c.
︙ | ︙ | |||
84 85 86 87 88 89 90 | */ native = (const char *)Tcl_FSGetNativePath(pathPtr); /* * Use (RTLD_NOW|RTLD_LOCAL) as default, see [Bug #3216070] */ if (flags & TCL_LOAD_GLOBAL) { | | | | | | 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 | */ native = (const char *)Tcl_FSGetNativePath(pathPtr); /* * Use (RTLD_NOW|RTLD_LOCAL) as default, see [Bug #3216070] */ if (flags & TCL_LOAD_GLOBAL) { dlopenflags |= RTLD_GLOBAL; } else { dlopenflags |= RTLD_LOCAL; } if (flags & TCL_LOAD_LAZY) { dlopenflags |= RTLD_LAZY; } else { dlopenflags |= RTLD_NOW; } handle = dlopen(native, dlopenflags); if (handle == NULL) { /* * Let the OS loader examine the binary search path for whatever * string the user gave us which hopefully refers to a file on the * binary path. |
︙ | ︙ |
Changes to unix/tclLoadDyld.c.
︙ | ︙ | |||
193 194 195 196 197 198 199 | #if TCL_DYLD_USE_DLFCN /* * Use (RTLD_NOW|RTLD_LOCAL) as default, see [Bug #3216070] */ if (flags & TCL_LOAD_GLOBAL) { | | | | | | 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 | #if TCL_DYLD_USE_DLFCN /* * Use (RTLD_NOW|RTLD_LOCAL) as default, see [Bug #3216070] */ if (flags & TCL_LOAD_GLOBAL) { dlopenflags |= RTLD_GLOBAL; } else { dlopenflags |= RTLD_LOCAL; } if (flags & TCL_LOAD_LAZY) { dlopenflags |= RTLD_LAZY; } else { dlopenflags |= RTLD_NOW; } dlHandle = dlopen(nativePath, dlopenflags); if (!dlHandle) { /* * Let the OS loader examine the binary search path for whatever string * the user gave us which hopefully refers to a file on the binary * path. |
︙ | ︙ |
Changes to unix/tclLoadOSF.c.
︙ | ︙ | |||
124 125 126 127 128 129 130 | * impossible to get a package name given a module. * * I build loadable modules with a makefile rule like * ld ... -export $@: -o $@ $(OBJS) */ if ((pkg = strrchr(fileName, '/')) == NULL) { | | | 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 | * impossible to get a package name given a module. * * I build loadable modules with a makefile rule like * ld ... -export $@: -o $@ $(OBJS) */ if ((pkg = strrchr(fileName, '/')) == NULL) { pkg = fileName; } else { pkg++; } newHandle = (Tcl_LoadHandle)Tcl_Alloc(sizeof(*newHandle)); newHandle->clientData = pkg; newHandle->findSymbolProcPtr = &FindSymbol; newHandle->unloadFileProcPtr = &UnloadFile; |
︙ | ︙ |
Changes to unix/tclUnixChan.c.
︙ | ︙ | |||
157 158 159 160 161 162 163 | /* * This structure describes the channel type structure for file based IO: */ static const Tcl_ChannelType fileChannelType = { "file", /* Type name. */ | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 | /* * This structure describes the channel type structure for file based IO: */ static const Tcl_ChannelType fileChannelType = { "file", /* Type name. */ TCL_CHANNEL_VERSION_5, NULL, /* Deprecated. */ FileInputProc, FileOutputProc, NULL, /* Deprecated. */ NULL, /* Set option proc. */ FileGetOptionProc, FileWatchProc, FileGetHandleProc, FileCloseProc, FileBlockModeProc, NULL, /* Flush proc. */ NULL, /* Bubbled event handler proc. */ FileWideSeekProc, NULL, /* Thread action proc. */ FileTruncateProc }; #ifdef SUPPORTS_TTY /* * This structure describes the channel type structure for serial IO. * Note that this type is a subclass of the "file" type. */ static const Tcl_ChannelType ttyChannelType = { "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. */ NULL, /* Thread action proc. */ NULL /* Truncate proc. */ }; #endif /* SUPPORTS_TTY */ /* *---------------------------------------------------------------------- * * FileBlockModeProc -- |
︙ | ︙ | |||
221 222 223 224 225 226 227 | * Sets the device into blocking or non-blocking mode. * *---------------------------------------------------------------------- */ static int FileBlockModeProc( | | | 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 | * Sets the device into blocking or non-blocking mode. * *---------------------------------------------------------------------- */ static int FileBlockModeProc( void *instanceData, /* File state. */ int mode) /* The mode to set. Can be TCL_MODE_BLOCKING * or TCL_MODE_NONBLOCKING. */ { FileState *fsPtr = (FileState *)instanceData; if (TclUnixSetBlockingMode(fsPtr->fd, mode) < 0) { return errno; |
︙ | ︙ | |||
254 255 256 257 258 259 260 | * Reads input from the input device of the channel. * *---------------------------------------------------------------------- */ static int FileInputProc( | | | 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 | * Reads input from the input device of the channel. * *---------------------------------------------------------------------- */ static int FileInputProc( void *instanceData, /* File state. */ char *buf, /* Where to store data read. */ int toRead, /* How much space is available in the * buffer? */ int *errorCodePtr) /* Where to store error code. */ { FileState *fsPtr = (FileState *)instanceData; int bytesRead; /* How many bytes were actually read from the |
︙ | ︙ | |||
304 305 306 307 308 309 310 | * Writes output on the output device of the channel. * *---------------------------------------------------------------------- */ static int FileOutputProc( | | | 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 | * Writes output on the output device of the channel. * *---------------------------------------------------------------------- */ static int FileOutputProc( void *instanceData, /* File state. */ const char *buf, /* The data buffer. */ int toWrite, /* How many bytes to write? */ int *errorCodePtr) /* Where to store error code. */ { FileState *fsPtr = (FileState *)instanceData; int written; |
︙ | ︙ | |||
351 352 353 354 355 356 357 | * Closes the device of the channel. * *---------------------------------------------------------------------- */ static int FileCloseProc( | | | 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 | * Closes the device of the channel. * *---------------------------------------------------------------------- */ static int FileCloseProc( void *instanceData, /* File state. */ TCL_UNUSED(Tcl_Interp *), int flags) { FileState *fsPtr = (FileState *)instanceData; int errorCode = 0; if ((flags & (TCL_CLOSE_READ | TCL_CLOSE_WRITE)) != 0) { |
︙ | ︙ | |||
444 445 446 447 448 449 450 | * operations. * *---------------------------------------------------------------------- */ static long long FileWideSeekProc( | | | 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 | * operations. * *---------------------------------------------------------------------- */ static long long FileWideSeekProc( 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. */ int *errorCodePtr) /* To store error code. */ { FileState *fsPtr = (FileState *)instanceData; long long newLoc; |
︙ | ︙ | |||
492 493 494 495 496 497 498 | { Tcl_Channel channel = (Tcl_Channel)clientData; Tcl_NotifyChannel(channel, mask); } static void FileWatchProc( | | | 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 | { Tcl_Channel channel = (Tcl_Channel)clientData; Tcl_NotifyChannel(channel, mask); } static void FileWatchProc( void *instanceData, /* The file state. */ int mask) /* Events of interest; an OR-ed combination of * TCL_READABLE, TCL_WRITABLE and * TCL_EXCEPTION. */ { FileState *fsPtr = (FileState *)instanceData; /* |
︙ | ︙ | |||
532 533 534 535 536 537 538 | * None. * *---------------------------------------------------------------------- */ static int FileGetHandleProc( | | | | 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 | * None. * *---------------------------------------------------------------------- */ static int FileGetHandleProc( void *instanceData, /* The file state. */ int direction, /* TCL_READABLE or TCL_WRITABLE */ void **handlePtr) /* Where to store the handle. */ { FileState *fsPtr = (FileState *)instanceData; if (direction & fsPtr->validMask) { *handlePtr = INT2PTR(fsPtr->fd); return TCL_OK; } |
︙ | ︙ | |||
754 755 756 757 758 759 760 | * calling Tcl_BadChannelOption). * *---------------------------------------------------------------------- */ static int TtySetOptionProc( | | | 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 | * calling Tcl_BadChannelOption). * *---------------------------------------------------------------------- */ static int TtySetOptionProc( 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. */ { TtyState *fsPtr = (TtyState *)instanceData; size_t len, vlen; TtyAttrs tty; |
︙ | ︙ | |||
1094 1095 1096 1097 1098 1099 1100 | * (by calling Tcl_BadChannelOption). * *---------------------------------------------------------------------- */ static int TtyGetOptionProc( | | | 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 | * (by calling Tcl_BadChannelOption). * *---------------------------------------------------------------------- */ static int TtyGetOptionProc( 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). */ { TtyState *fsPtr = (TtyState *)instanceData; size_t len; char buf[3*TCL_INTEGER_SPACE + 16]; |
︙ | ︙ | |||
1633 1634 1635 1636 1637 1638 1639 | * sure to allow for the case where strchr is a macro. [Bug: 5089] * * We cannot if/else/endif the strchr arguments, it has to be the whole * function. On AIX this function is apparently a macro, and macros do * not allow preprocessor directives in their arguments. */ | < | | > | > > | | < < < < < < | 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 | * sure to allow for the case where strchr is a macro. [Bug: 5089] * * We cannot if/else/endif the strchr arguments, it has to be the whole * function. On AIX this function is apparently a macro, and macros do * not allow preprocessor directives in their arguments. */ #ifdef PAREXT #define PARITY_CHARS "noems" #define PARITY_MSG "n, o, e, m, or s" #else #define PARITY_CHARS "noe" #define PARITY_MSG "n, o, or e" #endif /* PAREXT */ if (strchr(PARITY_CHARS, parity) == NULL) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "%s parity: should be %s", bad, PARITY_MSG)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "SERIALMODE", (char *)NULL); } return TCL_ERROR; } ttyPtr->parity = parity; if ((ttyPtr->data < 5) || (ttyPtr->data > 8)) { if (interp != NULL) { |
︙ | ︙ | |||
2050 2051 2052 2053 2054 2055 2056 | const char *chanID, /* String that identifies file. */ int forWriting, /* 1 means the file is going to be used for * writing, 0 means for reading. */ TCL_UNUSED(int), /* Obsolete argument. * Ignored, we always check that * the channel is open for the requested * mode. */ | | | 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 | const char *chanID, /* String that identifies file. */ int forWriting, /* 1 means the file is going to be used for * writing, 0 means for reading. */ TCL_UNUSED(int), /* Obsolete argument. * Ignored, we always check that * the channel is open for the requested * mode. */ void **filePtr) /* Store pointer to FILE structure here. */ { Tcl_Channel chan; int chanMode, fd; const Tcl_ChannelType *chanTypePtr; void *data; FILE *f; |
︙ | ︙ |
Changes to unix/tclUnixCompat.c.
︙ | ︙ | |||
990 991 992 993 994 995 996 | int *regsPtr) /* Registers after the CPUID. */ { int status = TCL_ERROR; /* 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 */ | | | | | | | | | | 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 | int *regsPtr) /* Registers after the CPUID. */ { int status = TCL_ERROR; /* 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)); 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)); status = TCL_OK; #else (void)index; (void)regsPtr; #endif return status; } |
︙ | ︙ |
Changes to unix/tclUnixFCmd.c.
︙ | ︙ | |||
805 806 807 808 809 810 811 | * the pathname of the file that caused the error is stored in errorPtr. * Some possible values for errno are: * * EACCES: path directory can't be read and/or written. * EEXIST: path is a non-empty directory. * EINVAL: path is a root directory. * ENOENT: path doesn't exist or is "". | | | 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 | * the pathname of the file that caused the error is stored in errorPtr. * Some possible values for errno are: * * EACCES: path directory can't be read and/or written. * 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. * * Side effects: * Directory removed. If an error occurs, the error will be returned * immediately, and remaining files will not be deleted. * *--------------------------------------------------------------------------- */ |
︙ | ︙ | |||
949 950 951 952 953 954 955 | * traversed (native). */ Tcl_DString *targetPtr, /* Pathname of directory to traverse in * parallel with source directory (native). */ Tcl_DString *errorPtr, /* If non-NULL, uninitialized or free DString * filled with UTF-8 name of file causing * error. */ int doRewind) /* Flag indicating that to ensure complete | | | | | | | | 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 | * traversed (native). */ Tcl_DString *targetPtr, /* Pathname of directory to traverse in * parallel with source directory (native). */ Tcl_DString *errorPtr, /* If non-NULL, uninitialized or free DString * 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. */ { Tcl_StatBuf statBuf; const char *source, *errfile; int result; size_t targetLen, sourceLen; #ifndef HAVE_FTS int numProcessed = 0; |
︙ | ︙ |
Changes to unix/tclUnixFile.c.
︙ | ︙ | |||
9 10 11 12 13 14 15 | * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" #include "tclFileSystem.h" | | > | | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 | * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" #include "tclFileSystem.h" static int NativeMatchType(Tcl_Interp *interp, const char* nativeEntry, const char* nativeName, Tcl_GlobTypeData *types); /* *--------------------------------------------------------------------------- * * TclpFindExecutable -- * * This function computes the absolute path name of the current |
︙ | ︙ |
Changes to unix/tclUnixInit.c.
︙ | ︙ | |||
50 51 52 53 54 55 56 | static const char *const processors[NUMPROCESSORS] = { "i686", "mips", "alpha", "ppc", "shx", "arm", "ia64", "alpha64", "msil", "x86_64", "ia32_on_win64", "neutral", "arm64", "arm32_on_win64", "ia32_on_arm64" }; typedef struct { union { | | | | | | | 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 | static const char *const processors[NUMPROCESSORS] = { "i686", "mips", "alpha", "ppc", "shx", "arm", "ia64", "alpha64", "msil", "x86_64", "ia32_on_win64", "neutral", "arm64", "arm32_on_win64", "ia32_on_arm64" }; typedef struct { union { unsigned int dwOemId; struct { int wProcessorArchitecture; int wReserved; }; }; unsigned int dwPageSize; void *lpMinimumApplicationAddress; void *lpMaximumApplicationAddress; void *dwActiveProcessorMask; unsigned int dwNumberOfProcessors; unsigned int dwProcessorType; |
︙ | ︙ | |||
856 857 858 859 860 861 862 | p = q+1; } if (*p) { Tcl_ListObjAppendElement(NULL, pkgListObj, Tcl_NewStringObj(p, -1)); } Tcl_ObjSetVar2(interp, Tcl_NewStringObj("tcl_pkgPath", -1), NULL, pkgListObj, TCL_GLOBAL_ONLY); { | | | | | | | | | | 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 | p = q+1; } if (*p) { Tcl_ListObjAppendElement(NULL, pkgListObj, Tcl_NewStringObj(p, -1)); } 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); } } #ifdef DJGPP Tcl_SetVar2(interp, "tcl_platform", "platform", "dos", TCL_GLOBAL_ONLY); #else Tcl_SetVar2(interp, "tcl_platform", "platform", "unix", TCL_GLOBAL_ONLY); #endif |
︙ | ︙ |
Changes to unix/tclUnixNotfy.c.
︙ | ︙ | |||
356 357 358 359 360 361 362 | * Remove the ThreadSpecificData structure of this thread from the * waiting list. This prevents us from continuously spinning on * epoll_wait until the other threads runs and services the file * event. */ if (tsdPtr->prevPtr) { | | | | | 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 | * Remove the ThreadSpecificData structure of this thread from the * waiting list. This prevents us from continuously spinning on * epoll_wait until the other threads runs and services the file * event. */ if (tsdPtr->prevPtr) { tsdPtr->prevPtr->nextPtr = tsdPtr->nextPtr; } else { waitingListPtr = tsdPtr->nextPtr; } if (tsdPtr->nextPtr) { tsdPtr->nextPtr->prevPtr = tsdPtr->prevPtr; } tsdPtr->nextPtr = tsdPtr->prevPtr = NULL; tsdPtr->onList = 0; tsdPtr->pollState = 0; } #ifdef __CYGWIN__ PostMessageW(tsdPtr->hwnd, 1024, 0, 0); |
︙ | ︙ |
Changes to unix/tclUnixPipe.c.
︙ | ︙ | |||
74 75 76 77 78 79 80 | /* * This structure describes the channel type structure for command pipe based * I/O: */ static const Tcl_ChannelType pipeChannelType = { | | | | | | | | | | | | | | | | | 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 | /* * This structure describes the channel type structure for command pipe based * I/O: */ static const Tcl_ChannelType pipeChannelType = { "pipe", TCL_CHANNEL_VERSION_5, NULL, /* Deprecated. */ PipeInputProc, PipeOutputProc, NULL, /* Deprecated. */ NULL, /* Set option proc. */ NULL, /* Get option proc. */ PipeWatchProc, PipeGetHandleProc, PipeClose2Proc, PipeBlockModeProc, NULL, /* Flush proc. */ NULL, /* Bubbled event handler proc. */ NULL, /* Seek proc. */ NULL, /* Thread action proc. */ NULL /* Truncation proc. */ }; /* *---------------------------------------------------------------------- * * TclpMakeFile -- * |
︙ | ︙ | |||
840 841 842 843 844 845 846 | size_t numPids, /* The number of pids in the pid array. */ Tcl_Pid *pidPtr) /* An array of process identifiers. Allocated * by the caller, freed when the channel is * closed or the processes are detached (in a * background exec). */ { char channelName[16 + TCL_INTEGER_SPACE]; | | | 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 | size_t numPids, /* The number of pids in the pid array. */ Tcl_Pid *pidPtr) /* An array of process identifiers. Allocated * by the caller, freed when the channel is * closed or the processes are detached (in a * background exec). */ { char channelName[16 + TCL_INTEGER_SPACE]; int fd; PipeState *statePtr = (PipeState *)Tcl_Alloc(sizeof(PipeState)); int mode; statePtr->inFile = readFile; statePtr->outFile = writeFile; statePtr->errorFile = errorFile; statePtr->numPids = numPids; |
︙ | ︙ | |||
864 865 866 867 868 869 870 | } /* * Use one of the fds associated with the channel as the channel id. */ if (readFile) { | | | | | | | 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 | } /* * Use one of the fds associated with the channel as the channel id. */ if (readFile) { fd = GetFd(readFile); } else if (writeFile) { fd = GetFd(writeFile); } else if (errorFile) { fd = GetFd(errorFile); } else { fd = 0; } /* * For backward compatibility with previous versions of Tcl, we use * "file%d" as the base name for pipes even though it would be more * natural to use "pipe%d". */ snprintf(channelName, sizeof(channelName), "file%d", fd); statePtr->channel = Tcl_CreateChannel(&pipeChannelType, channelName, statePtr, mode); return statePtr->channel; } /* *---------------------------------------------------------------------- |
︙ | ︙ |
Changes to unix/tclUnixSock.c.
︙ | ︙ | |||
59 60 61 62 63 64 65 | TcpFdList fds; /* The file descriptors of the sockets. */ int interest; /* Event types of interest */ /* * Only needed for server sockets */ | | < | 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 | TcpFdList fds; /* The file descriptors of the sockets. */ int interest; /* Event types of interest */ /* * Only needed for server sockets */ Tcl_TcpAcceptProc *acceptProc; /* Proc to call on accept. */ void *acceptProcData; /* The data for the accept proc. */ /* * Only needed for client sockets */ struct addrinfo *addrlist; /* Addresses to connect to. */ |
︙ | ︙ | |||
150 151 152 153 154 155 156 | /* * This structure describes the channel type structure for TCP socket * based IO: */ static const Tcl_ChannelType tcpChannelType = { | | | | | | | | | | | | | | | | | | | 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 | /* * This structure describes the channel type structure for TCP socket * based IO: */ static const Tcl_ChannelType tcpChannelType = { "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. */ TcpThreadActionProc, NULL /* Truncate proc. */ }; /* * The following variable holds the network name of this host. */ static TclInitProcessGlobalValueProc InitializeHostName; |
︙ | ︙ | |||
200 201 202 203 204 205 206 | } #endif /* * ---------------------------------------------------------------------- * * InitializeHostName -- * | | | | 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 | } #endif /* * ---------------------------------------------------------------------- * * InitializeHostName -- * * This routine sets the process global value of the name of the local * host on which the process is running. * * Results: * None. * * ---------------------------------------------------------------------- */ |
︙ | ︙ | |||
223 224 225 226 227 228 229 | #ifndef NO_UNAME struct utsname u; struct hostent *hp; memset(&u, (int) 0, sizeof(struct utsname)); if (uname(&u) >= 0) { /* INTL: Native. */ | | | | | | 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 | #ifndef NO_UNAME struct utsname u; struct hostent *hp; memset(&u, (int) 0, sizeof(struct utsname)); if (uname(&u) >= 0) { /* INTL: Native. */ hp = TclpGetHostByName(u.nodename); /* INTL: Native. */ if (hp == NULL) { /* * Sometimes the nodename is fully qualified, but gets truncated * as it exceeds SYS_NMLN. See if we can just get the immediate * nodename and get a proper answer that way. */ char *dot = strchr(u.nodename, '.'); if (dot != NULL) { char *node = (char *)Tcl_Alloc(dot - u.nodename + 1); memcpy(node, u.nodename, dot - u.nodename); node[dot - u.nodename] = '\0'; hp = TclpGetHostByName(node); Tcl_Free(node); } } if (hp != NULL) { native = hp->h_name; } else { native = u.nodename; } } #else /* !NO_UNAME */ /* * Uname doesn't exist; try gethostname instead. * * There is no portable macro for the maximum length of host names * returned by gethostbyname(). We should only trust SYS_NMLN if it is at |
︙ | ︙ | |||
366 367 368 369 370 371 372 | if (mode == TCL_MODE_BLOCKING) { CLEAR_BITS(statePtr->flags, TCP_NONBLOCKING); } else { SET_BITS(statePtr->flags, TCP_NONBLOCKING); } if (GOT_BITS(statePtr->flags, TCP_ASYNC_CONNECT)) { | | | | 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 | if (mode == TCL_MODE_BLOCKING) { CLEAR_BITS(statePtr->flags, TCP_NONBLOCKING); } else { SET_BITS(statePtr->flags, TCP_NONBLOCKING); } if (GOT_BITS(statePtr->flags, TCP_ASYNC_CONNECT)) { statePtr->cachedBlocking = mode; return 0; } if (TclUnixSetBlockingMode(statePtr->fds.fd, mode) < 0) { return errno; } return 0; } |
︙ | ︙ | |||
396 397 398 399 400 401 402 | * * EWOULDBLOCK: if connect is still in progress * * ENOTCONN: if connect failed. This would be the error message * of a recv or sendto syscall so this is emulated here. * * NULL: Called by a background operation. Do not block and do not * return any error code. * * Results: | | | | 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 | * * EWOULDBLOCK: if connect is still in progress * * ENOTCONN: if connect failed. This would be the error message * of a recv or sendto syscall so this is emulated here. * * NULL: Called by a background operation. Do not block and do not * return any error code. * * Results: * 0 if the connection has completed, -1 if still in progress or there is * an error. * * Side effects: * Processes socket events off the system queue. May process * asynchronous connects. * *---------------------------------------------------------------------- */ |
︙ | ︙ | |||
439 440 441 442 443 444 445 | * In socket test mode do not continue with the connect. * Exceptions are: * - Call by recv/send and blocking socket * (errorCodePtr != NULL && !GOT_BITS(flags, TCP_NONBLOCKING)) */ if (GOT_BITS(statePtr->flags, TCP_ASYNC_TEST_MODE) | | | | | | | | | | | | | | | | | | | | | 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 | * In socket test mode do not continue with the connect. * Exceptions are: * - Call by recv/send and blocking socket * (errorCodePtr != NULL && !GOT_BITS(flags, TCP_NONBLOCKING)) */ if (GOT_BITS(statePtr->flags, TCP_ASYNC_TEST_MODE) && !(errorCodePtr != NULL && !GOT_BITS(statePtr->flags, TCP_NONBLOCKING))) { *errorCodePtr = EWOULDBLOCK; return -1; } if (errorCodePtr == NULL || GOT_BITS(statePtr->flags, TCP_NONBLOCKING)) { timeout = 0; } else { timeout = -1; } do { if (TclUnixWaitForFile(statePtr->fds.fd, TCL_WRITABLE | TCL_EXCEPTION, timeout) != 0) { TcpConnect(NULL, statePtr); } /* * Do this only once in the nonblocking case and repeat it until the * socket is final when blocking. */ } while (timeout == -1 && 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; } } return 0; } /* *---------------------------------------------------------------------- * |
︙ | ︙ | |||
623 624 625 626 627 628 629 | while (fds != NULL) { TcpFdList *next = fds->next; Tcl_Free(fds); fds = next; } if (statePtr->addrlist != NULL) { | | | | 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 | while (fds != NULL) { TcpFdList *next = fds->next; Tcl_Free(fds); fds = next; } if (statePtr->addrlist != NULL) { freeaddrinfo(statePtr->addrlist); } if (statePtr->myaddrlist != NULL) { freeaddrinfo(statePtr->myaddrlist); } Tcl_Free(statePtr); return errorCode; } /* *---------------------------------------------------------------------- |
︙ | ︙ | |||
702 703 704 705 706 707 708 | #pragma GCC diagnostic ignored "-Wstrict-aliasing" #endif static inline int IPv6AddressNeedsNumericRendering( struct in6_addr addr) { if (IN6_ARE_ADDR_EQUAL(&addr, &in6addr_any)) { | | | | | | | | | | | | | | | | | | | | | | | 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 | #pragma GCC diagnostic ignored "-Wstrict-aliasing" #endif static inline int IPv6AddressNeedsNumericRendering( struct in6_addr addr) { if (IN6_ARE_ADDR_EQUAL(&addr, &in6addr_any)) { return 1; } /* * The IN6_IS_ADDR_V4MAPPED macro has a problem with aliasing warnings on * at least some versions of OSX. */ if (!IN6_IS_ADDR_V4MAPPED(&addr)) { return 0; } return (addr.s6_addr[12] == 0 && addr.s6_addr[13] == 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 #endif #endif /* NEED_FAKE_RFC2553 */ static void TcpHostPortList( Tcl_Interp *interp, Tcl_DString *dsPtr, address addr, socklen_t salen) { #define SUPPRESS_RDNS_VAR "::tcl::unsupported::noReverseDNS" char host[NI_MAXHOST], nhost[NI_MAXHOST], nport[NI_MAXSERV]; int flags = 0; getnameinfo(&addr.sa, salen, nhost, sizeof(nhost), nport, sizeof(nport), NI_NUMERICHOST | NI_NUMERICSERV); Tcl_DStringAppendElement(dsPtr, nhost); /* * We don't want to resolve INADDR_ANY and sin6addr_any; they can * sometimes cause problems (and never have a name). */ if (addr.sa.sa_family == AF_INET) { 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; } #endif /* NEED_FAKE_RFC2553 */ } /* * Check if reverse DNS has been switched off globally. */ if (interp != NULL && 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. */ Tcl_DStringAppendElement(dsPtr, host); } else { /* * Reverse mapping failed - use the numeric rep once more. */ Tcl_DStringAppendElement(dsPtr, nhost); } Tcl_DStringAppendElement(dsPtr, nport); } /* *---------------------------------------------------------------------- * |
︙ | ︙ | |||
903 904 905 906 907 908 909 | } if ((len > 1) && (optionName[1] == 'e') && (strncmp(optionName, "-error", len) == 0)) { socklen_t optlen = sizeof(int); WaitForConnect(statePtr, NULL); | | | | | | | | | | | | | | | | | | | | | 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 | } if ((len > 1) && (optionName[1] == 'e') && (strncmp(optionName, "-error", len) == 0)) { 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) { Tcl_DStringAppend(dsPtr, Tcl_ErrnoMsg(errno), TCL_INDEX_NONE); } return TCL_OK; } if ((len > 1) && (optionName[1] == 'c') && (strncmp(optionName, "-connecting", len) == 0)) { WaitForConnect(statePtr, NULL); Tcl_DStringAppend(dsPtr, GOT_BITS(statePtr->flags, TCP_ASYNC_CONNECT) ? "1" : "0", TCL_INDEX_NONE); return TCL_OK; } if ((len == 0) || ((len > 1) && (optionName[1] == 'p') && (strncmp(optionName, "-peername", len) == 0))) { address peername; socklen_t size = sizeof(peername); WaitForConnect(statePtr, NULL); if (GOT_BITS(statePtr->flags, TCP_ASYNC_CONNECT)) { /* * In async connect output an empty string */ |
︙ | ︙ | |||
959 960 961 962 963 964 965 | * Peername fetch succeeded - output list */ if (len == 0) { Tcl_DStringAppendElement(dsPtr, "-peername"); Tcl_DStringStartSublist(dsPtr); } | | | | | | | 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 | * Peername fetch succeeded - output list */ if (len == 0) { Tcl_DStringAppendElement(dsPtr, "-peername"); Tcl_DStringStartSublist(dsPtr); } TcpHostPortList(interp, dsPtr, peername, size); if (len) { return TCL_OK; } Tcl_DStringEndSublist(dsPtr); } else { /* * getpeername failed - but if we were asked for all the options * (len==0), don't flag an error at that point because it could be * an fconfigure request on a server socket (which have no peer). * Same must be done on win&mac. */ if (len) { if (interp) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't get peername: %s", Tcl_PosixError(interp))); } return TCL_ERROR; } } } |
︙ | ︙ | |||
1000 1001 1002 1003 1004 1005 1006 | Tcl_DStringStartSublist(dsPtr); } if (GOT_BITS(statePtr->flags, TCP_ASYNC_CONNECT)) { /* * In async connect output an empty string */ | | | | | | | | | | | | | 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 | Tcl_DStringStartSublist(dsPtr); } if (GOT_BITS(statePtr->flags, TCP_ASYNC_CONNECT)) { /* * In async connect output an empty string */ found = 1; } else { for (fds = &statePtr->fds; fds != NULL; fds = fds->next) { size = sizeof(sockname); if (getsockname(fds->fd, &(sockname.sa), &size) >= 0) { found = 1; TcpHostPortList(interp, dsPtr, sockname, size); } } } 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; } } if ((len == 0) || ((len > 1) && (optionName[1] == 'k') && (strncmp(optionName, "-keepalive", len) == 0))) { int opt = 0; |
︙ | ︙ | |||
1066 1067 1068 1069 1070 1071 1072 | if (len > 0) { return TCL_OK; } } if (len > 0) { return Tcl_BadChannelOption(interp, optionName, | | | 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 | if (len > 0) { return TCL_OK; } } if (len > 0) { return Tcl_BadChannelOption(interp, optionName, "connecting keepalive nodelay peername sockname"); } return TCL_OK; } /* * ---------------------------------------------------------------------- |
︙ | ︙ | |||
1173 1174 1175 1176 1177 1178 1179 | int mask) /* Events of interest; an OR-ed combination of * TCL_READABLE, TCL_WRITABLE and * TCL_EXCEPTION. */ { TcpState *statePtr = (TcpState *)instanceData; if (statePtr->acceptProc != NULL) { | | | | | | | | | | | | | 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 | int mask) /* Events of interest; an OR-ed combination of * TCL_READABLE, TCL_WRITABLE and * TCL_EXCEPTION. */ { 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). */ 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. */ statePtr->filehandlers = mask; } else if (mask) { /* * Whether it is a bug or feature or otherwise, it is a fact of life * that on at least some Linux kernels select() fails to report that a * socket file descriptor is writable when the other end of the socket * is closed. This is in contrast to the guarantees Tcl makes that |
︙ | ︙ | |||
1310 1311 1312 1313 1314 1315 1316 | socklen_t optlen; int async_callback = GOT_BITS(statePtr->flags, TCP_ASYNC_PENDING); int ret = -1, error = EHOSTUNREACH; int async = GOT_BITS(statePtr->flags, TCP_ASYNC_CONNECT); static const int reuseaddr = 1; if (async_callback) { | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 | socklen_t optlen; int async_callback = GOT_BITS(statePtr->flags, TCP_ASYNC_PENDING); int ret = -1, error = EHOSTUNREACH; int async = GOT_BITS(statePtr->flags, TCP_ASYNC_CONNECT); static const int reuseaddr = 1; if (async_callback) { goto reenter; } for (statePtr->addr = statePtr->addrlist; statePtr->addr != NULL; statePtr->addr = statePtr->addr->ai_next) { for (statePtr->myaddr = statePtr->myaddrlist; statePtr->myaddr != NULL; statePtr->myaddr = statePtr->myaddr->ai_next) { /* * No need to try combinations of local and remote addresses of * different families. */ if (statePtr->myaddr->ai_family != statePtr->addr->ai_family) { continue; } /* * Close the socket if it is still open from the last unsuccessful * iteration. */ if (statePtr->fds.fd >= 0) { close(statePtr->fds.fd); statePtr->fds.fd = -1; errno = 0; } statePtr->fds.fd = socket(statePtr->addr->ai_family, SOCK_STREAM, 0); if (statePtr->fds.fd < 0) { continue; } /* * Set the close-on-exec flag so that the socket will not get * inherited by child processes. */ fcntl(statePtr->fds.fd, F_SETFD, FD_CLOEXEC); /* * Set kernel space buffering */ 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; } /* * Attempt to connect. The connect may fail at present with an * EINPROGRESS but at a later time it will complete. The caller * will set up a file handler on the socket if she is interested * in being informed when the connect completes. */ ret = connect(statePtr->fds.fd, statePtr->addr->ai_addr, statePtr->addr->ai_addrlen); if (ret < 0) { error = errno; } if (ret < 0 && errno == EINPROGRESS) { Tcl_CreateFileHandler(statePtr->fds.fd, TCL_WRITABLE | TCL_EXCEPTION, TcpAsyncCallback, statePtr); errno = EWOULDBLOCK; SET_BITS(statePtr->flags, TCP_ASYNC_PENDING); return TCL_OK; reenter: 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; } } } out: 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(). */ 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; } return TCL_OK; } /* *---------------------------------------------------------------------- * |
︙ | ︙ | |||
1507 1508 1509 1510 1511 1512 1513 | char channelName[SOCK_CHAN_LENGTH]; /* * Do the name lookups for the local and remote addresses. */ if (!TclCreateSocketAddress(interp, &addrlist, host, port, 0, &errorMsg) | | | | | | | | | | | | | | | 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 | char channelName[SOCK_CHAN_LENGTH]; /* * Do the name lookups for the local and remote addresses. */ if (!TclCreateSocketAddress(interp, &addrlist, host, port, 0, &errorMsg) || !TclCreateSocketAddress(interp, &myaddrlist, myaddr, myport, 1, &errorMsg)) { if (addrlist != NULL) { freeaddrinfo(addrlist); } if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't open socket: %s", errorMsg)); } return NULL; } /* * Allocate a new TcpState for this socket. */ statePtr = (TcpState *)Tcl_Alloc(sizeof(TcpState)); memset(statePtr, 0, sizeof(TcpState)); statePtr->flags = async ? TCP_ASYNC_CONNECT : 0; statePtr->cachedBlocking = TCL_MODE_BLOCKING; statePtr->addrlist = addrlist; statePtr->myaddrlist = myaddrlist; statePtr->fds.fd = -1; /* * Create a new client socket and wrap it in a channel. */ if (TcpConnect(interp, statePtr) != TCL_OK) { TcpCloseProc(statePtr, NULL); return NULL; } snprintf(channelName, sizeof(channelName), SOCK_TEMPLATE, PTR2INT(statePtr)); statePtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName, statePtr, TCL_READABLE | TCL_WRITABLE); if (Tcl_SetChannelOption(interp, statePtr->channel, "-translation", "auto crlf") == TCL_ERROR) { Tcl_CloseEx(NULL, statePtr->channel, 0); return NULL; } return statePtr->channel; } |
︙ | ︙ | |||
1573 1574 1575 1576 1577 1578 1579 | */ Tcl_Channel Tcl_MakeTcpClientChannel( void *sock) /* The socket to wrap up into a channel. */ { return (Tcl_Channel) TclpMakeTcpClientChannelMode(sock, | | | 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 | */ Tcl_Channel Tcl_MakeTcpClientChannel( void *sock) /* The socket to wrap up into a channel. */ { return (Tcl_Channel) TclpMakeTcpClientChannelMode(sock, TCL_READABLE | TCL_WRITABLE); } /* *---------------------------------------------------------------------- * * TclpMakeTcpClientChannelMode -- * |
︙ | ︙ | |||
1680 1681 1682 1683 1684 1685 1686 | */ int retry = 0; #define MAXRETRY 10 repeat: if (retry > 0) { | | | | | | | | | | | | | | | 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 | */ int retry = 0; #define MAXRETRY 10 repeat: if (retry > 0) { if (statePtr != NULL) { TcpCloseProc(statePtr, NULL); statePtr = NULL; } if (addrlist != NULL) { freeaddrinfo(addrlist); addrlist = NULL; } if (retry >= MAXRETRY) { goto error; } } retry++; chosenport = 0; if (TclSockGetPort(interp, service, "tcp", &port) != TCL_OK) { errorMsg = "invalid port number"; goto error; } if (!TclCreateSocketAddress(interp, &addrlist, myHost, port, 1, &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); if (sock == -1) { if (howfar < SOCKET) { howfar = SOCKET; my_errno = errno; } continue; } |
︙ | ︙ | |||
1756 1757 1758 1759 1760 1761 1762 | #else optvalue = 1; (void) setsockopt(sock, SOL_SOCKET, SO_REUSEPORT, (char *) &optvalue, sizeof(optvalue)); #endif } | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 | #else optvalue = 1; (void) setsockopt(sock, SOL_SOCKET, SO_REUSEPORT, (char *) &optvalue, sizeof(optvalue)); #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. */ if (port == 0 && chosenport != 0) { ((struct sockaddr_in *) addrPtr->ai_addr)->sin_port = htons(chosenport); } #ifdef IPV6_V6ONLY /* * Missing on: Solaris 2.8 */ if (addrPtr->ai_family == AF_INET6) { int v6only = 1; (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 (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) { 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); } error: if (addrlist != NULL) { freeaddrinfo(addrlist); } if (statePtr != NULL) { statePtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName, statePtr, 0); return statePtr->channel; } if (interp != NULL) { 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 { Tcl_AppendToObj(errorObj, errorMsg, TCL_INDEX_NONE); } Tcl_SetObjResult(interp, errorObj); } if (sock != -1) { close(sock); } return NULL; } |
︙ | ︙ | |||
1934 1935 1936 1937 1938 1939 1940 | newSockState, TCL_READABLE | TCL_WRITABLE); Tcl_SetChannelOption(NULL, newSockState->channel, "-translation", "auto crlf"); if (fds->statePtr->acceptProc != NULL) { getnameinfo(&addr.sa, len, host, sizeof(host), port, sizeof(port), | | | | 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 | newSockState, TCL_READABLE | TCL_WRITABLE); Tcl_SetChannelOption(NULL, newSockState->channel, "-translation", "auto crlf"); if (fds->statePtr->acceptProc != NULL) { getnameinfo(&addr.sa, len, host, sizeof(host), port, sizeof(port), NI_NUMERICHOST|NI_NUMERICSERV); fds->statePtr->acceptProc(fds->statePtr->acceptProcData, newSockState->channel, host, atoi(port)); } } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * tab-width: 8 * indent-tabs-mode: nil * End: */ |
Changes to unix/tclUnixTest.c.
︙ | ︙ | |||
545 546 547 548 549 550 551 | * * Signal handler for the alarm command. * * Results: * None. * * Side effects: | | | | 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 | * * Signal handler for the alarm command. * * Results: * None. * * Side effects: * Calls the Tcl Async handler. * *---------------------------------------------------------------------- */ static void AlarmHandler( TCL_UNUSED(int) /*signum*/) { gotsig = "1"; } /* *---------------------------------------------------------------------- * * TestgotsigCmd -- * * Verify the signal was handled after the testalarm command. * * Results: * None. * * Side Effects: * Resets the value of gotsig back to '0'. * |
︙ | ︙ |
Changes to unix/tclUnixTime.c.
︙ | ︙ | |||
242 243 244 245 246 247 248 | * TclpWideClickInMicrosec -- * * This procedure return scale to convert click values from the * TclpGetWideClicks native resolution to microsecond resolution * and back. * * Results: | | | 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 | * TclpWideClickInMicrosec -- * * This procedure return scale to convert click values from the * TclpGetWideClicks native resolution to microsecond resolution * and back. * * Results: * 1 click in microseconds as double. * * Side effects: * None. * *---------------------------------------------------------------------- */ |
︙ | ︙ |
Changes to win/Makefile.in.
︙ | ︙ | |||
75 76 77 78 79 80 81 | # The default switches for optimization or debugging CFLAGS_DEBUG = @CFLAGS_DEBUG@ CFLAGS_OPTIMIZE = @CFLAGS_OPTIMIZE@ # To change the compiler switches, for example to change from optimization to # debugging symbols, change the following line: | | | | | | 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 | # The default switches for optimization or debugging CFLAGS_DEBUG = @CFLAGS_DEBUG@ 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 # To compile without backward compatibility and deprecated code uncomment the # following NO_DEPRECATED_FLAGS = #NO_DEPRECATED_FLAGS = -DTCL_NO_DEPRECATED # To enable compilation debugging reverse the comment characters on one of the |
︙ | ︙ | |||
158 159 160 161 162 163 164 | package ifneeded dde 1.4.5 [list load ${DDE_DLL_FILE}];\ package ifneeded registry 1.3.7 [list load ${REG_DLL_FILE}] TEST_LOAD_FACILITIES = package ifneeded tcl::test ${VERSION}@TCL_PATCH_LEVEL@ [list load ${TEST_DLL_FILE} Tcltest];\ $(TEST_LOAD_PRMS) ZLIB_DLL_FILE = zlib1.dll TOMMATH_DLL_FILE = libtommath.dll | | | 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 | package ifneeded dde 1.4.5 [list load ${DDE_DLL_FILE}];\ package ifneeded registry 1.3.7 [list load ${REG_DLL_FILE}] TEST_LOAD_FACILITIES = package ifneeded tcl::test ${VERSION}@TCL_PATCH_LEVEL@ [list load ${TEST_DLL_FILE} Tcltest];\ $(TEST_LOAD_PRMS) ZLIB_DLL_FILE = zlib1.dll TOMMATH_DLL_FILE = libtommath.dll SHARED_LIBRARIES = $(TCL_DLL_FILE) @ZLIB_DLL_FILE@ @TOMMATH_DLL_FILE@ STATIC_LIBRARIES = $(TCL_LIB_FILE) TCLSH = tclsh$(VER)${EXESUFFIX} WINE = @WINE@ CAT32 = cat32$(EXEEXT) # For cross-compiled builds, TCL_EXE is the name of a tclsh executable that is |
︙ | ︙ | |||
613 614 615 616 617 618 619 | @$(RM) ${TEST_DLL_FILE} ${TEST_LIB_FILE} @MAKE_DLL@ ${TCLTEST_OBJS} $(TCL_STUB_LIB_FILE) $(SHLIB_LD_LIBS) $(COPY) tclsh.exe.manifest ${TEST_DLL_FILE}.manifest ${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) \ | | | 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 | @$(RM) ${TEST_DLL_FILE} ${TEST_LIB_FILE} @MAKE_DLL@ ${TCLTEST_OBJS} $(TCL_STUB_LIB_FILE) $(SHLIB_LD_LIBS) $(COPY) tclsh.exe.manifest ${TEST_DLL_FILE}.manifest ${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) $(COPY) tclsh.exe.manifest ${TEST_EXE_FILE}.manifest # use prebuilt zlib1.dll ${ZLIB_DLL_FILE}: ${TCL_STUB_LIB_FILE} @if test "@ZLIB_LIBS@set" = "${ZLIB_DIR_NATIVE}/win64-arm/zdll.libset" ; then \ $(COPY) $(ZLIB_DIR)/win64-arm/${ZLIB_DLL_FILE} ${ZLIB_DLL_FILE}; \ elif test "@ZLIB_LIBS@set" = "${ZLIB_DIR_NATIVE}/win64-arm/libz.dll.aset" ; then \ |
︙ | ︙ |
Changes to win/makefile.vc.
︙ | ︙ | |||
53 54 55 56 57 58 59 | # # Basic macros and options usable on the commandline (see rules.vc for more info): # OPTS=nomsvcrt,noembed,nothreads,pdbs,profile,static,symbols,thrdalloc,unchecked,none # Sets special options for the core. The default is for none. # Any combination of the above may be used (comma separated). # 'none' will over-ride everything to nothing. # | | | 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 | # # Basic macros and options usable on the commandline (see rules.vc for more info): # OPTS=nomsvcrt,noembed,nothreads,pdbs,profile,static,symbols,thrdalloc,unchecked,none # Sets special options for the core. The default is for none. # 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 # 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 # but copied to the installation target (as in 8.6). # nomsvcrt = Affects the static option only to switch it from # using msvcrt(d) as the C runtime [by default] to # libcmt(d). This is useful for static embedding |
︙ | ︙ |
Changes to win/nmakehlp.c.
︙ | ︙ | |||
86 87 88 89 90 91 92 | SetEnvironmentVariable("LINK", ""); if (argc > 1 && *argv[1] == '-') { switch (*(argv[1]+1)) { case 'c': if (argc != 3) { chars = snprintf(msg, sizeof(msg) - 1, | | | 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 | SetEnvironmentVariable("LINK", ""); if (argc > 1 && *argv[1] == '-') { switch (*(argv[1]+1)) { case 'c': if (argc != 3) { chars = snprintf(msg, sizeof(msg) - 1, "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, &dwWritten, NULL); return 2; } return CheckForCompilerFeature(argv[2]); |
︙ | ︙ | |||
267 268 269 270 271 272 273 | NULL, /* Use parent's starting directory. */ &si, /* Pointer to STARTUPINFO structure. */ &pi); /* Pointer to PROCESS_INFORMATION structure. */ if (!ok) { DWORD err = GetLastError(); int chars = snprintf(msg, sizeof(msg) - 1, | | | 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 | NULL, /* Use parent's starting directory. */ &si, /* Pointer to STARTUPINFO structure. */ &pi); /* Pointer to PROCESS_INFORMATION structure. */ if (!ok) { DWORD err = GetLastError(); int chars = snprintf(msg, sizeof(msg) - 1, "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], (300-chars), 0); WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, lstrlen(msg), &err,NULL); return 2; } |
︙ | ︙ | |||
314 315 316 317 318 319 320 | /* * Look for the commandline warning code in both streams. * - in MSVC 6 & 7 we get D4002, in MSVC 8 we get D9002. */ return !(strstr(Out.buffer, "D4002") != NULL | | | | | | | 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 | /* * Look for the commandline warning code in both streams. * - in MSVC 6 & 7 we get D4002, in MSVC 8 we get D9002. */ 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); } static int CheckForLinkerFeature( char **options, int count) { |
︙ | ︙ | |||
401 402 403 404 405 406 407 | NULL, /* Use parent's starting directory. */ &si, /* Pointer to STARTUPINFO structure. */ &pi); /* Pointer to PROCESS_INFORMATION structure. */ if (!ok) { DWORD err = GetLastError(); int chars = snprintf(msg, sizeof(msg) - 1, | | | 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 | NULL, /* Use parent's starting directory. */ &si, /* Pointer to STARTUPINFO structure. */ &pi); /* Pointer to PROCESS_INFORMATION structure. */ if (!ok) { DWORD err = GetLastError(); int chars = snprintf(msg, sizeof(msg) - 1, "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], (300-chars), 0); WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, lstrlen(msg), &err,NULL); return 2; } |
︙ | ︙ | |||
596 597 598 599 600 601 602 | * option here to handle autoconf style substitutions. * The substitution file is whitespace and line delimited. The file should * consist of lines matching the regular expression: * \s*\S+\s+\S*$ * * Usage is something like: * nmakehlp -S << $** > $@ | | | | | 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 | * option here to handle autoconf style substitutions. * The substitution file is whitespace and line delimited. The file should * consist of lines matching the regular expression: * \s*\S+\s+\S*$ * * Usage is something like: * nmakehlp -S << $** > $@ * @PACKAGE_NAME@ $(PACKAGE_NAME) * @PACKAGE_VERSION@ $(PACKAGE_VERSION) * << */ static int SubstituteFile( const char *substitutions, const char *filename) { |
︙ | ︙ | |||
726 727 728 729 730 731 732 | int keylen, ret; WIN32_FIND_DATA finfo; if (dir == NULL || keypath == NULL) { return 2; /* Have no real error reporting mechanism into nmake */ } dirlen = strlen(dir); | | | > | > | > | | | | | | | 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 | int keylen, ret; WIN32_FIND_DATA finfo; if (dir == NULL || keypath == NULL) { return 2; /* Have no real error reporting mechanism into nmake */ } dirlen = strlen(dir); if ((dirlen + 3) > sizeof(path)) { return 2; } strncpy(path, dir, dirlen); strncpy(path+dirlen, "\\*", 3); /* Including terminating \0 */ keylen = strlen(keypath); #if 0 /* This function is not available in Visual C++ 6 */ /* * Use numerics 0 -> FindExInfoStandard, * 1 -> FindExSearchLimitToDirectories, * as these are not defined in Visual C++ 6 */ hSearch = FindFirstFileEx(path, 0, &finfo, 1, NULL, 0); #else hSearch = FindFirstFile(path, &finfo); #endif if (hSearch == INVALID_HANDLE_VALUE) { return 1; /* Not found */ } /* Loop through all subdirs checking if the keypath is under there */ ret = 1; /* Assume not found */ do { int sublen; /* * We need to check it is a directory despite the * FindExSearchLimitToDirectories in the above call. See SDK docs */ if ((finfo.dwFileAttributes & FILE_ATTRIBUTE_DIRECTORY) == 0) { continue; } sublen = strlen(finfo.cFileName); if ((dirlen+1+sublen+1+keylen+1) > sizeof(path)) { continue; /* Path does not fit, assume not matched */ } strncpy(path+dirlen+1, finfo.cFileName, sublen); path[dirlen+1+sublen] = '\\'; strncpy(path+dirlen+1+sublen+1, keypath, keylen+1); if (FileExists(path)) { /* Found a match, print to stdout */ path[dirlen+1+sublen] = '\0'; QualifyPath(path); ret = 0; break; } } while (FindNextFile(hSearch, &finfo)); FindClose(hSearch); return ret; } /* * LocateDependency -- * * Locates a dependency for a package. * keypath - a relative path within the package directory * that is used to confirm it is the correct directory. * The search path for the package directory is currently only * the parent and grandparent of the current working directory. * If found, the command prints * name_DIRPATH=<full path of located directory> * and returns 0. If not found, does not print anything and returns 1. */ static int LocateDependency(const char *keypath) { size_t i; int ret; static const char *paths[] = {"..", "..\\..", "..\\..\\.."}; |
︙ | ︙ |
Changes to win/rules.vc.
︙ | ︙ | |||
1244 1245 1246 1247 1248 1249 1250 | !if $(TK_MAJOR_VERSION) == 8 TKSTUBLIBNAME = tkstub$(TK_VERSION).lib !else TKSTUBLIBNAME = tkstub.lib !endif !if $(DOING_TK) | | | 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 | !if $(TK_MAJOR_VERSION) == 8 TKSTUBLIBNAME = tkstub$(TK_VERSION).lib !else TKSTUBLIBNAME = tkstub.lib !endif !if $(DOING_TK) WISH = $(OUT_DIR)\$(WISHNAME) TKSTUBLIB = $(OUT_DIR)\$(TKSTUBLIBNAME) TKIMPLIB = $(OUT_DIR)\$(TKIMPLIBNAME) TKLIB = $(OUT_DIR)\$(TKLIBNAME) TK_INCLUDES = -I"$(WIN_DIR)" -I"$(GENERICDIR)" TKSCRIPTZIP = $(OUT_DIR)\$(TKSCRIPTZIPNAME) !else # effectively NEED_TK |
︙ | ︙ |
Changes to win/tcl.rc.
︙ | ︙ | |||
15 16 17 18 19 20 21 | #define SUFFIX SUFFIX_DEBUG LANGUAGE 0x9, 0x1 /* LANG_ENGLISH, SUBLANG_DEFAULT */ VS_VERSION_INFO VERSIONINFO | | | | | | | | | 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 | #define SUFFIX SUFFIX_DEBUG LANGUAGE 0x9, 0x1 /* LANG_ENGLISH, SUBLANG_DEFAULT */ VS_VERSION_INFO VERSIONINFO 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 #ifdef DEBUG FILEFLAGS VS_FF_DEBUG #else FILEFLAGS 0x0L #endif FILEOS VOS__WINDOWS32 FILETYPE VFT_DLL FILESUBTYPE 0x0L BEGIN BLOCK "StringFileInfo" BEGIN BLOCK "040904b0" /* LANG_ENGLISH/SUBLANG_ENGLISH_US, Unicode CP */ BEGIN VALUE "FileDescription", "Tcl DLL\0" VALUE "OriginalFilename", "tcl" STRINGIFY(TCL_MAJOR_VERSION) STRINGIFY(TCL_MINOR_VERSION) SUFFIX ".dll\0" |
︙ | ︙ |
Changes to win/tclWinChan.c.
︙ | ︙ | |||
102 103 104 105 106 107 108 | int permissions, int appendMode); /* * This structure describes the channel type structure for file based IO. */ static const Tcl_ChannelType fileChannelType = { | | | | | | | | | | | | | | | | | | 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 | int permissions, int appendMode); /* * This structure describes the channel type structure for file based IO. */ static const Tcl_ChannelType fileChannelType = { "file", TCL_CHANNEL_VERSION_5, NULL, /* Deprecated. */ FileInputProc, FileOutputProc, NULL, /* Deprecated. */ NULL, /* Set option proc. */ FileGetOptionProc, FileWatchProc, FileGetHandleProc, FileCloseProc, FileBlockProc, NULL, /* Flush proc. */ NULL, /* Bubbled event handler proc. */ FileWideSeekProc, FileThreadActionProc, FileTruncateProc }; /* * General useful clarification macros. */ #define SET_FLAG(var, flag) ((var) |= (flag)) |
︙ | ︙ |
Changes to win/tclWinConsole.c.
︙ | ︙ | |||
172 173 174 175 176 177 178 | * opening and dropped on channel close. This also covers the reference * from gWatchingChannelList since queueing / dequeuing from that list * happens in conjunction with channel operations. * - the Tcl event queue entries. This reference is added when the event * is queued and dropped on receipt. */ typedef struct ConsoleChannelInfo { | | | 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 | * opening and dropped on channel close. This also covers the reference * from gWatchingChannelList since queueing / dequeuing from that list * happens in conjunction with channel operations. * - the Tcl event queue entries. This reference is added when the event * is queued and dropped on receipt. */ typedef struct ConsoleChannelInfo { HANDLE handle; /* Console handle */ Tcl_ThreadId threadId; /* Id of owning thread */ struct ConsoleChannelInfo *nextWatchingChannelPtr; /* Pointer to next channel watching events. */ Tcl_Channel channel; /* Pointer to channel structure. */ DWORD initMode; /* Initial console mode. */ int numRefs; /* See comments above */ int permissions; /* OR'ed combination of TCL_READABLE, |
︙ | ︙ | |||
294 295 296 297 298 299 300 | /* * This structure describes the channel type structure for command console * based IO. */ static const Tcl_ChannelType consoleChannelType = { | | | | | | | | | | | | | | | | | | | 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 | /* * This structure describes the channel type structure for command console * based IO. */ static const Tcl_ChannelType consoleChannelType = { "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. */ }; /* *------------------------------------------------------------------------ * * RingBufferInit -- * |
︙ | ︙ | |||
2063 2064 2065 2066 2067 2068 2069 | * * Side effects: * None. * *------------------------------------------------------------------------ */ static ConsoleHandleInfo * | > | | 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 | * * Side effects: * None. * *------------------------------------------------------------------------ */ static ConsoleHandleInfo * FindConsoleInfo( const ConsoleChannelInfo *chanInfoPtr) { ConsoleHandleInfo *handleInfoPtr; for (handleInfoPtr = gConsoleHandleInfoList; handleInfoPtr; handleInfoPtr = handleInfoPtr->nextPtr) { if (handleInfoPtr->console == chanInfoPtr->handle) { return handleInfoPtr; } } |
︙ | ︙ |
Changes to win/tclWinPipe.c.
︙ | ︙ | |||
197 198 199 200 201 202 203 | /* * This structure describes the channel type structure for command pipe based * I/O. */ static const Tcl_ChannelType pipeChannelType = { | | | | | | | | | | | | | | | | | 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 | /* * This structure describes the channel type structure for command pipe based * I/O. */ static const Tcl_ChannelType pipeChannelType = { "pipe", TCL_CHANNEL_VERSION_5, NULL, /* Deprecated. */ PipeInputProc, PipeOutputProc, NULL, /* Deprecated. */ NULL, /* Set option proc. */ NULL, /* Get option proc. */ PipeWatchProc, PipeGetHandleProc, PipeClose2Proc, PipeBlockModeProc, NULL, /* Flush proc. */ NULL, /* Bubbled event handler proc. */ NULL, /* Seek proc. */ PipeThreadActionProc, NULL /* Truncate proc. */ }; /* *---------------------------------------------------------------------- * * PipeInit -- * |
︙ | ︙ | |||
1458 1459 1460 1461 1462 1463 1464 | const char *bspos) { if (!bspos) { if (current > start) { /* part before current (special) */ Tcl_DStringAppend(dsPtr, start, (int) (current - start)); } } else { | | | 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 | const char *bspos) { if (!bspos) { if (current > start) { /* part before current (special) */ Tcl_DStringAppend(dsPtr, start, (int) (current - start)); } } else { if (bspos > start) { /* part before first backslash */ Tcl_DStringAppend(dsPtr, start, (int) (bspos - start)); } while (bspos++ < current) { /* each backslash twice */ TclDStringAppendLiteral(dsPtr, "\\\\"); } } } |
︙ | ︙ | |||
1501 1502 1503 1504 1505 1506 1507 | * main quotes, so `\` remains `\`, but important - not at end of part, * because results as before the quote, so `%\%\` should be escaped as * `"%\%"\\`). */ TclDStringAppendLiteral(dsPtr, "\""); /* opening escape quote-char */ do { | | | 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 | * main quotes, so `\` remains `\`, but important - not at end of part, * because results as before the quote, so `%\%\` should be escaped as * `"%\%"\\`). */ TclDStringAppendLiteral(dsPtr, "\""); /* opening escape quote-char */ do { *bspos = NULL; special++; if (*special == '\\') { /* * Bypass backslashes (and mark first backslash position). */ special = BuildCmdLineBypassBS(special, bspos); |
︙ | ︙ | |||
1806 1807 1808 1809 1810 1811 1812 | infoPtr->readable = CreateEventW(NULL, TRUE, TRUE, NULL); infoPtr->readThread = CreateThread(NULL, 256, PipeReaderThread, TclPipeThreadCreateTI(&infoPtr->readTI, infoPtr, infoPtr->readable), 0, NULL); SetThreadPriority(infoPtr->readThread, THREAD_PRIORITY_HIGHEST); infoPtr->validMask |= TCL_READABLE; } else { | | | | | 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 | infoPtr->readable = CreateEventW(NULL, TRUE, TRUE, NULL); infoPtr->readThread = CreateThread(NULL, 256, PipeReaderThread, TclPipeThreadCreateTI(&infoPtr->readTI, infoPtr, infoPtr->readable), 0, NULL); SetThreadPriority(infoPtr->readThread, THREAD_PRIORITY_HIGHEST); infoPtr->validMask |= TCL_READABLE; } else { infoPtr->readTI = NULL; infoPtr->readThread = 0; } if (writeFile != NULL) { /* * Start the background writer thread. */ infoPtr->writable = CreateEventW(NULL, TRUE, TRUE, NULL); infoPtr->writeThread = CreateThread(NULL, 256, PipeWriterThread, TclPipeThreadCreateTI(&infoPtr->writeTI, infoPtr, infoPtr->writable), 0, NULL); SetThreadPriority(infoPtr->writeThread, THREAD_PRIORITY_HIGHEST); infoPtr->validMask |= TCL_WRITABLE; } else { infoPtr->writeTI = NULL; infoPtr->writeThread = 0; } /* * For backward compatibility with previous versions of Tcl, we use * "file%d" as the base name for pipes even though it would be more * natural to use "pipe%d". Use the pointer to keep the channel names * unique, in case channels share handles (stdin/stdout). |
︙ | ︙ | |||
3393 3394 3395 3396 3397 3398 3399 | /* * End of work, check the owner of the TI structure. */ if (state != PTI_STATE_STOP) { *pipeTIPtr = NULL; } else { | | | | 3393 3394 3395 3396 3397 3398 3399 3400 3401 3402 3403 3404 3405 3406 3407 3408 3409 3410 | /* * End of work, check the owner of the TI structure. */ if (state != PTI_STATE_STOP) { *pipeTIPtr = NULL; } else { pipeTI->evWakeUp = NULL; } if (wakeEvent) { SetEvent(wakeEvent); } return 0; } /* *---------------------------------------------------------------------- * |
︙ | ︙ |
Changes to win/tclWinPort.h.
︙ | ︙ | |||
110 111 112 113 114 115 116 | /* * The following defines redefine the Windows Socket errors as * BSD errors so Tcl_PosixError can do the right thing. */ #ifndef ENOTEMPTY | | | 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 | /* * The following defines redefine the Windows Socket errors as * BSD errors so Tcl_PosixError can do the right thing. */ #ifndef ENOTEMPTY # define ENOTEMPTY 41 /* Directory not empty */ #endif #ifndef EREMOTE # define EREMOTE 66 /* The object is remote */ #endif #ifndef EPFNOSUPPORT # define EPFNOSUPPORT 96 /* Protocol family not supported */ #endif |
︙ | ︙ |
Changes to win/tclWinSerial.c.
︙ | ︙ | |||
198 199 200 201 202 203 204 | /* * This structure describes the channel type structure for command serial * based IO. */ static const Tcl_ChannelType serialChannelType = { | | | | | | | | | | | | | | | | | | | 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 | /* * This structure describes the channel type structure for command serial * based IO. */ static const Tcl_ChannelType serialChannelType = { "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. */ SerialThreadActionProc, NULL /* Truncate proc. */ }; /* *---------------------------------------------------------------------- * * SerialInit -- * |
︙ | ︙ | |||
616 617 618 619 620 621 622 | if (serialPtr->validMask & TCL_READABLE) { PurgeComm(serialPtr->handle, PURGE_RXABORT | PURGE_RXCLEAR); CloseHandle(serialPtr->osRead.hEvent); } serialPtr->validMask &= ~TCL_READABLE; if (serialPtr->writeThread) { | | | 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 | if (serialPtr->validMask & TCL_READABLE) { PurgeComm(serialPtr->handle, PURGE_RXABORT | PURGE_RXCLEAR); CloseHandle(serialPtr->osRead.hEvent); } serialPtr->validMask &= ~TCL_READABLE; if (serialPtr->writeThread) { TclPipeThreadStop(&serialPtr->writeTI, serialPtr->writeThread); CloseHandle(serialPtr->osWrite.hEvent); CloseHandle(serialPtr->evWritable); CloseHandle(serialPtr->writeThread); serialPtr->writeThread = NULL; PurgeComm(serialPtr->handle, PURGE_TXABORT | PURGE_TXCLEAR); |
︙ | ︙ |
Changes to win/tclWinSock.c.
︙ | ︙ | |||
266 267 268 269 270 271 272 | /* * This structure describes the channel type structure for TCP socket * based IO: */ static const Tcl_ChannelType tcpChannelType = { | | | | | | | | | | | | | | | | | | | 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 | /* * This structure describes the channel type structure for TCP socket * based IO: */ static const Tcl_ChannelType tcpChannelType = { "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. */ TcpThreadActionProc, NULL /* Truncate proc. */ }; /* * The following variable holds the network name of this host. */ static TclInitProcessGlobalValueProc InitializeHostName; |
︙ | ︙ | |||
614 615 616 617 618 619 620 | * * EWOULDBLOCK: if connect is still in progress * * ENOTCONN: if connect failed. This would be the error message * of a recv or sendto syscall so this is emulated here. * * Null: Called by a background operation. Do not block and don't * return any error code. * * Results: | | | | 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 | * * EWOULDBLOCK: if connect is still in progress * * ENOTCONN: if connect failed. This would be the error message * of a recv or sendto syscall so this is emulated here. * * Null: Called by a background operation. Do not block and don't * return any error code. * * Results: * 0 if the connection has completed, -1 if still in progress or there is * an error. * * Side effects: * Processes socket events off the system queue. May process * asynchronous connect. * *---------------------------------------------------------------------- */ |
︙ | ︙ |
Changes to win/tclWinTime.c.
︙ | ︙ | |||
31 32 33 34 35 36 37 | DWORD calibrationInterv; /* Calibration interval in seconds (start 1 * sec) */ HANDLE calibrationThread; /* Handle to the thread that keeps the virtual * clock calibrated. */ HANDLE readyEvent; /* System event used to trigger the requesting * thread when the clock calibration procedure * is initialized for the first time. */ | | | 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 | DWORD calibrationInterv; /* Calibration interval in seconds (start 1 * sec) */ HANDLE calibrationThread; /* Handle to the thread that keeps the virtual * clock calibrated. */ 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 * tell the calibration loop to terminate. */ LARGE_INTEGER nominalFreq; /* Nominal frequency of the system performance * counter, that is, the value returned from * QueryPerformanceFrequency. */ /* * The following values are used for calculating virtual time. Virtual * time is always equal to: |
︙ | ︙ | |||
105 106 107 108 109 110 111 | /* * Declarations for functions defined later in this file. */ static void StopCalibration(void *clientData); static DWORD WINAPI CalibrationThread(LPVOID arg); | | | 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 | /* * Declarations for functions defined later in this file. */ static void StopCalibration(void *clientData); static DWORD WINAPI CalibrationThread(LPVOID arg); static void UpdateTimeEachSecond(void); static void ResetCounterSamples(unsigned long long fileTime, long long perfCounter, long long perfFreq); static long long AccumulateSample(long long perfCounter, unsigned long long fileTime); static void NativeScaleTime(Tcl_Time* timebuf, void *clientData); static long long NativeGetMicroseconds(void); |
︙ | ︙ | |||
274 275 276 277 278 279 280 | return (long long)curCounter.QuadPart; } /* fallback using microseconds */ wideClick.perfCounter = 0; wideClick.microsecsScale = 1; return TclpGetMicroseconds(); } else { | | | | | 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 | return (long long)curCounter.QuadPart; } /* fallback using microseconds */ wideClick.perfCounter = 0; wideClick.microsecsScale = 1; return TclpGetMicroseconds(); } else { return TclpGetMicroseconds(); } } /* *---------------------------------------------------------------------- * * TclpWideClickInMicrosec -- * * This procedure return scale to convert wide click values from the * TclpGetWideClicks native resolution to microsecond resolution * and back. * * Results: * 1 click in microseconds as double. * * Side effects: * None. * *---------------------------------------------------------------------- */ double TclpWideClickInMicrosec(void) { if (!wideClick.initialized) { (void) TclpGetWideClicks(); /* initialize */ } return wideClick.microsecsScale; } /* *---------------------------------------------------------------------- * |
︙ | ︙ | |||
866 867 868 869 870 871 872 | /* * If calibration still not needed (check for possible time switch) */ if (curFileTime.QuadPart > lastFileTime.QuadPart && curFileTime.QuadPart < lastFileTime.QuadPart + (timeInfo.calibrationInterv * 10000000)) { | | | 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 | /* * If calibration still not needed (check for possible time switch) */ if (curFileTime.QuadPart > lastFileTime.QuadPart && curFileTime.QuadPart < lastFileTime.QuadPart + (timeInfo.calibrationInterv * 10000000)) { /* * Look again in next one second. */ return; } QueryPerformanceCounter(&curPerfCounter); |
︙ | ︙ | |||
936 937 938 939 940 941 942 | * If we've gotten more than a second away from system time, then drifting * the clock is going to be pretty hopeless. Just let it jump. Otherwise, * compute the drift frequency and fill in everything. */ tdiff = vt0 - curFileTime.QuadPart; if (tdiff > 10000000 || tdiff < -10000000) { | | | | | 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 | * If we've gotten more than a second away from system time, then drifting * the clock is going to be pretty hopeless. Just let it jump. Otherwise, * compute the drift frequency and fill in everything. */ tdiff = vt0 - curFileTime.QuadPart; if (tdiff > 10000000 || tdiff < -10000000) { /* * Jump to current system time, use curent estimated frequency. */ vt0 = curFileTime.QuadPart; } else { /* * Calculate new frequency and estimate drift to the next second. */ vt1 = 20000000 + curFileTime.QuadPart; driftFreq = (estFreq * 20000000 / (vt1 - vt0)); /* |
︙ | ︙ | |||
1011 1012 1013 1014 1015 1016 1017 | /* * If drift unavoidable (e. g. we had a time switch), then reset * it. */ vt1 = vt0 - curFileTime.QuadPart; if (vt1 > 10000000 || vt1 < -10000000) { | | | | 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 | /* * If drift unavoidable (e. g. we had a time switch), then reset * it. */ vt1 = vt0 - curFileTime.QuadPart; if (vt1 > 10000000 || vt1 < -10000000) { /* * Larger jump resp. shift relative new file-time. */ vt0 = curFileTime.QuadPart; } } } /* * In lock commit new values to timeInfo (hold lock as short as possible) */ |
︙ | ︙ |
Changes to win/tclsh.rc.
︙ | ︙ | |||
22 23 24 25 26 27 28 | #define SUFFIX SUFFIX_STATIC SUFFIX_DEBUG LANGUAGE 0x9, 0x1 /* LANG_ENGLISH, SUBLANG_DEFAULT */ VS_VERSION_INFO VERSIONINFO | | | | | | | | | 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 | #define SUFFIX SUFFIX_STATIC SUFFIX_DEBUG LANGUAGE 0x9, 0x1 /* LANG_ENGLISH, SUBLANG_DEFAULT */ VS_VERSION_INFO VERSIONINFO 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 #ifdef DEBUG FILEFLAGS VS_FF_DEBUG #else FILEFLAGS 0x0L #endif FILEOS VOS__WINDOWS32 FILETYPE VFT_APP FILESUBTYPE 0x0L BEGIN BLOCK "StringFileInfo" BEGIN BLOCK "040904b0" BEGIN VALUE "FileDescription", "Tclsh Application\0" VALUE "OriginalFilename", "tclsh" STRINGIFY(TCL_MAJOR_VERSION) STRINGIFY(TCL_MINOR_VERSION) SUFFIX ".exe\0" |
︙ | ︙ |
Changes to win/tcltest.rc.
︙ | ︙ | |||
22 23 24 25 26 27 28 | #define SUFFIX SUFFIX_STATIC SUFFIX_DEBUG LANGUAGE 0x9, 0x1 /* LANG_ENGLISH, SUBLANG_DEFAULT */ VS_VERSION_INFO VERSIONINFO | | | | | | | | | 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 | #define SUFFIX SUFFIX_STATIC SUFFIX_DEBUG LANGUAGE 0x9, 0x1 /* LANG_ENGLISH, SUBLANG_DEFAULT */ VS_VERSION_INFO VERSIONINFO 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 #ifdef DEBUG FILEFLAGS VS_FF_DEBUG #else FILEFLAGS 0x0L #endif FILEOS VOS__WINDOWS32 FILETYPE VFT_APP FILESUBTYPE 0x0L BEGIN BLOCK "StringFileInfo" BEGIN BLOCK "040904b0" BEGIN VALUE "FileDescription", "Tcltest Application\0" VALUE "OriginalFilename", "tcltest" STRINGIFY(TCL_MAJOR_VERSION) STRINGIFY(TCL_MINOR_VERSION) SUFFIX ".exe\0" |
︙ | ︙ |