Many hyperlinks are disabled.
Use anonymous login
to enable hyperlinks.
Comment: | Merge 9.0 |
---|---|
Downloads: | Tarball | ZIP archive | SQL archive |
Timelines: | family | ancestors | tip-626 |
Files: | files | file ages | folders |
SHA3-256: |
29d29484d05da0d69e43de4675f1e160 |
User & Date: | jan.nijtmans 2024-06-20 18:22:43 |
Original Comment: | Merge 8.7 |
2024-06-20
| ||
18:22 | Merge 9.0 Leaf check-in: 29d29484d0 user: jan.nijtmans tags: tip-626 | |
2024-06-19
| ||
16:39 | Fix [7be97a6859]: Reviewing chan.n changes check-in: 9453353b55 user: jan.nijtmans tags: trunk, main | |
2024-06-11
| ||
07:52 | Merge 9.0 check-in: 121c2ead8c user: jan.nijtmans tags: tip-626 | |
Changes to doc/CrtCommand.3.
︙ | ︙ | |||
98 99 100 101 102 103 104 | point to constant strings or may be shared with other parts of the interpreter. Note also that the argument strings are encoded in normalized UTF-8 since version 8.1 of Tcl. .PP \fIProc\fR must return an integer code that is expected to be one of \fBTCL_OK\fR, \fBTCL_ERROR\fR, \fBTCL_RETURN\fR, \fBTCL_BREAK\fR, or | | > | > > | | 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 | point to constant strings or may be shared with other parts of the interpreter. Note also that the argument strings are encoded in normalized UTF-8 since version 8.1 of Tcl. .PP \fIProc\fR must return an integer code that is expected to be one of \fBTCL_OK\fR, \fBTCL_ERROR\fR, \fBTCL_RETURN\fR, \fBTCL_BREAK\fR, or \fBTCL_CONTINUE\fR. See the \fBreturn\fR man page for details on what these codes mean and the use of extended values for an extension's private use. Most normal commands will only return \fBTCL_OK\fR or \fBTCL_ERROR\fR. .PP In addition, \fIproc\fR must set the interpreter result; in the case of a \fBTCL_OK\fR return code this gives the result of the command, and in the case of \fBTCL_ERROR\fR it gives an error message. The \fBTcl_SetResult\fR procedure provides an easy interface for setting the return value; for complete details on how the interpreter result field is managed, see the \fBTcl_Interp\fR man page. Before invoking a command procedure, |
︙ | ︙ |
Changes to doc/CrtObjCmd.3.
︙ | ︙ | |||
128 129 130 131 132 133 134 | \fBTcl_GetIntFromObj\fR on \fIobjv\fR[\fB2\fR] to obtain the integer representation of that value; that call may change the type of the value that \fIobjv\fR[\fB2\fR] points at, but will not change where \fIobjv\fR[\fB2\fR] points. .PP \fIproc\fR must return an integer code that is either \fBTCL_OK\fR, \fBTCL_ERROR\fR, \fBTCL_RETURN\fR, \fBTCL_BREAK\fR, or \fBTCL_CONTINUE\fR. | < | > | > | 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 | \fBTcl_GetIntFromObj\fR on \fIobjv\fR[\fB2\fR] to obtain the integer representation of that value; that call may change the type of the value that \fIobjv\fR[\fB2\fR] points at, but will not change where \fIobjv\fR[\fB2\fR] points. .PP \fIproc\fR must return an integer code that is either \fBTCL_OK\fR, \fBTCL_ERROR\fR, \fBTCL_RETURN\fR, \fBTCL_BREAK\fR, or \fBTCL_CONTINUE\fR. See the \fBreturn\fR man page for details on what these codes mean and the use of extended values for an extension's private use. Most normal commands will only return \fBTCL_OK\fR or \fBTCL_ERROR\fR. .PP In addition, if \fIproc\fR needs to return a non-empty result, it can call \fBTcl_SetObjResult\fR to set the interpreter's result. In the case of a \fBTCL_OK\fR return code this gives the result of the command, and in the case of \fBTCL_ERROR\fR this gives an error message. Before invoking a command procedure, \fBTcl_EvalObjEx\fR sets interpreter's result to |
︙ | ︙ |
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/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.
︙ | ︙ | |||
230 231 232 233 234 235 236 | .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 | | | 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 | .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 |
︙ | ︙ |
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 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 | .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 \fBTcl_AppendStringsToObj\fR(\fIobjPtr, string, string, ... \fB(char *)NULL\fR) .sp \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 \fBTcl_AppendPrintfToObj\fR(\fIobjPtr, format, ...\fR) .sp \fBTcl_SetObjLength\fR(\fIobjPtr, newLength\fR) .sp int \fBTcl_AttemptSetObjLength\fR(\fIobjPtr, newLength\fR) .sp Tcl_Obj * \fBTcl_ConcatObj\fR(\fIobjc, objv\fR) | > > > > > > > | 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) |
︙ | ︙ |
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/catch.n.
︙ | ︙ | |||
26 27 28 29 30 31 32 | value corresponding to the exceptional return code returned by evaluation of \fIscript\fR. Tcl defines the normal return code from script evaluation to be zero (0), or \fBTCL_OK\fR. Tcl also defines four exceptional return codes: 1 (\fBTCL_ERROR\fR), 2 (\fBTCL_RETURN\fR), 3 (\fBTCL_BREAK\fR), and 4 (\fBTCL_CONTINUE\fR). Errors during evaluation of a script are indicated by a return code of \fBTCL_ERROR\fR. The other exceptional return codes are returned by the \fBreturn\fR, \fBbreak\fR, and \fBcontinue\fR commands | | | | > > | | 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 | value corresponding to the exceptional return code returned by evaluation of \fIscript\fR. Tcl defines the normal return code from script evaluation to be zero (0), or \fBTCL_OK\fR. Tcl also defines four exceptional return codes: 1 (\fBTCL_ERROR\fR), 2 (\fBTCL_RETURN\fR), 3 (\fBTCL_BREAK\fR), and 4 (\fBTCL_CONTINUE\fR). Errors during evaluation of a script are indicated by a return code of \fBTCL_ERROR\fR. The other exceptional return codes are returned by the \fBreturn\fR, \fBbreak\fR, and \fBcontinue\fR commands and in other special situations as documented. New commands defined by Tcl packages as well as scripts that make use of the \fBreturn \-code\fR command can return other integer values as the return code. These must however lie outside the range reserved for Tcl as documented for the \fBreturn\fR command. .PP If the \fIresultVarName\fR argument is given, then the variable it names is set to the result of the script evaluation. When the return code from the script is 1 (\fBTCL_ERROR\fR), the value stored in \fIresultVarName\fR is an error message. When the return code from the script is 0 (\fBTCL_OK\fR), the value stored in \fIresultVarName\fR is the value returned from \fIscript\fR. .PP |
︙ | ︙ |
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 \fIchannel\fR . This tests whether the last input operation on the channel called \fIchannel\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 \fIchannel\fR ?\fIdirection\fR? . Close and destroy the channel called \fIchannel\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 \fIchannel\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 \fIchannel\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 \fIchannel\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 \fIchannel\fR ?\fIoptionName\fR? ?\fIvalue\fR? ?\fIoptionName value\fR?... . Query or set the configuration options of the channel named \fIchannel\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 \fIchannel\fR . Test whether the last input operation on the channel called \fIchannel\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 \fIchannel 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 \fIchannel\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 \fIchannel\fR . Ensures that all pending output for the channel called \fIchannel\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 \fIchannel\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 channel\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 \fIchannel\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 \fIchannel\fR . Removes the topmost transformation from the channel \fIchannel\fR, if there is any. If there are no transformations added to \fIchannel\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 \fIchannel eventSpec\fR . This subcommand is used by command handlers specified with \fBchan create\fR. It notifies the channel represented by the handle \fIchannel\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 \fIchannel cmdPrefix\fR . Adds a new transformation on top of the channel \fIchannel\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? ?\fIchannel\fR? \fIstring\fR . Writes \fIstring\fR to the channel named \fIchannel\fR followed by a newline character. A trailing newline character is written unless the optional flag \fB\-nonewline\fR is given. If \fIchannel\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 \fIchannel\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 \fIchannel\fR ?\fInumChars\fR? .TP \fBchan read \fR?\fB\-nonewline\fR? \fIchannel\fR . In the first form, the result will be the next \fInumChars\fR characters read from the channel named \fIchannel\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 \fIchannel\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 \fIchannel \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 \fIchannel numChars\fR . In this form \fBchan read\fR blocks until \fInumChars\fR have been received from the serial port. .TP \fBchan read \fIchannel\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 \fIchannel offset\fR ?\fIorigin\fR? . Sets the current access position within the underlying data stream for the channel named \fIchannel\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 \fIchannel\fR . Returns a number giving the current access position within the underlying data stream for the channel named \fIchannel\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 \fIchannel\fR ?\fIlength\fR? . Sets the byte length of the underlying data stream for the channel named \fIchannel\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/close.n.
︙ | ︙ | |||
8 9 10 11 12 13 14 | .TH close n 7.5 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME close \- Close an open channel .SH SYNOPSIS | | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | .TH close n 7.5 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME close \- Close an open channel .SH SYNOPSIS \fBclose \fIchannel\fR ?\fBr\fR(\fBead\fR)|\fBw\fR(\fBrite\fR)? .BE .SH DESCRIPTION .PP The \fBclose\fR command has been superceded by the \fBchan close\fR command which supports the same syntax and options. .SH "SEE ALSO" chan(n) |
︙ | ︙ |
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/eof.n.
︙ | ︙ | |||
8 9 10 11 12 13 14 | .TH eof n 7.5 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME eof \- Check for end of file condition on channel .SH SYNOPSIS | | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | .TH eof n 7.5 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME eof \- Check for end of file condition on channel .SH SYNOPSIS \fBeof \fIchannel\fR .BE .SH DESCRIPTION .PP The \fBeof\fR command has been superceded by the \fBchan eof\fR command which supports the same syntax and options. .SH "SEE ALSO" chan(n) |
︙ | ︙ |
Changes to doc/fblocked.n.
1 2 3 4 5 6 7 8 9 10 11 12 | '\" '\" Copyright (c) 1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH fblocked n 7.5 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME fblocked \- Test whether the last input operation exhausted all available input .SH SYNOPSIS | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | '\" '\" Copyright (c) 1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH fblocked n 7.5 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME fblocked \- Test whether the last input operation exhausted all available input .SH SYNOPSIS \fBfblocked \fIchannel\fR .BE .SH DESCRIPTION .PP The \fBfblocked\fR command has been superceded by the \fBchan blocked\fR command which supports the same syntax and options. .SH "SEE ALSO" chan(n) |
︙ | ︙ |
Changes to doc/fconfigure.n.
︙ | ︙ | |||
8 9 10 11 12 13 14 | .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME fconfigure \- Set and get options on a channel .SH SYNOPSIS .nf | | | | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 | .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME fconfigure \- Set and get options on a channel .SH SYNOPSIS .nf \fBfconfigure \fIchannel\fR \fBfconfigure \fIchannel name\fR \fBfconfigure \fIchannel name value \fR?\fIname value ...\fR? .fi .BE .SH DESCRIPTION .PP The \fBfconfigure\fR command has been superceded by the \fBchan configure\fR command which supports the same syntax and options. .SH "SEE ALSO" |
︙ | ︙ |
Changes to doc/fileevent.n.
︙ | ︙ | |||
9 10 11 12 13 14 15 | .TH fileevent n 7.5 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME fileevent \- Execute a script when a channel becomes readable or writable .SH SYNOPSIS | | | | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 | .TH fileevent n 7.5 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME fileevent \- Execute a script when a channel becomes readable or writable .SH SYNOPSIS \fBfileevent \fIchannel \fBreadable \fR?\fIscript\fR? .sp \fBfileevent \fIchannel \fBwritable \fR?\fIscript\fR? .BE .SH DESCRIPTION .PP The \fBfileevent\fR command has been superceded by the \fBchan event\fR command which supports the same syntax and options. .SH "SEE ALSO" chan(n) |
︙ | ︙ |
Changes to doc/flush.n.
︙ | ︙ | |||
8 9 10 11 12 13 14 | .TH flush n 7.5 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME flush \- Flush buffered output for a channel .SH SYNOPSIS | | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | .TH flush n 7.5 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME flush \- Flush buffered output for a channel .SH SYNOPSIS \fBflush \fIchannel\fR .BE .SH DESCRIPTION .PP The \fBflush\fR command has been superceded by the \fBchan flush\fR command which supports the same syntax and options. .SH "SEE ALSO" chan(n) |
︙ | ︙ |
Changes to doc/format.n.
︙ | ︙ | |||
137 138 139 140 141 142 143 | function of the \fBexpr\fR command (at least a 64-bit range). If it is \fBz\fR or \fBt\fR it specifies that the integer value is truncated to the range determined by the value of the \fBpointerSize\fR element of the \fBtcl_platform\fR array. If it is \fBL\fR it specifies that an integer or double value is taken without truncation for conversion to a formatted substring. If neither of those are present, the integer value is | | < | 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 | function of the \fBexpr\fR command (at least a 64-bit range). If it is \fBz\fR or \fBt\fR it specifies that the integer value is truncated to the range determined by the value of the \fBpointerSize\fR element of the \fBtcl_platform\fR array. If it is \fBL\fR it specifies that an integer or double value is taken without truncation for conversion to a formatted substring. If neither of those are present, the integer value is truncated to a 32-bit range. .SS "MANDATORY CONVERSION TYPE" .PP The last thing in a conversion specifier is an alphabetic character that determines what kind of conversion to perform. The following conversion characters are currently supported: .IP \fBd\fR 10 Convert integer to signed decimal string. |
︙ | ︙ |
Changes to doc/gets.n.
︙ | ︙ | |||
8 9 10 11 12 13 14 | .TH gets n 7.5 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME gets \- Read a line from a channel .SH SYNOPSIS | | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | .TH gets n 7.5 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME gets \- Read a line from a channel .SH SYNOPSIS \fBgets \fIchannel\fR ?\fIvarName\fR? .BE .SH DESCRIPTION .PP The \fBgets\fR command has been superceded by the \fBchan gets\fR command which supports the same syntax and options. .SH "SEE ALSO" chan(n) |
︙ | ︙ |
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/interp.n.
︙ | ︙ | |||
388 389 390 391 392 393 394 | application. If your machine has a limit on the size of the C stack, you may get stack overflows before reaching the limit set by the command. If this happens, see if there is a mechanism in your system for increasing the maximum size of the C stack. .RE .\" METHOD: share .TP | | | | | | 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 | application. If your machine has a limit on the size of the C stack, you may get stack overflows before reaching the limit set by the command. If this happens, see if there is a mechanism in your system for increasing the maximum size of the C stack. .RE .\" METHOD: share .TP \fBinterp share\fI srcPath channel destPath\fR . Causes the IO channel identified by \fIchannel\fR to become shared between the interpreter identified by \fIsrcPath\fR and the interpreter identified by \fIdestPath\fR. Both interpreters have the same permissions on the IO channel. Both interpreters must close it to close the underlying IO channel; IO channels accessible in an interpreter are automatically closed when an interpreter is destroyed. .\" METHOD: target .TP \fBinterp target\fI path alias\fR . Returns a Tcl list describing the target interpreter for an alias. The alias is specified with an interpreter path and source command name, just as in \fBinterp alias\fR above. The name of the target interpreter is returned as an interpreter path, relative to the invoking interpreter. If the target interpreter for the alias is the invoking interpreter then an empty list is returned. If the target interpreter for the alias is not the invoking interpreter or one of its descendants then an error is generated. The target command does not have to be defined at the time of this invocation. .\" METHOD: transfer .TP \fBinterp transfer\fI srcPath channel destPath\fR . Causes the IO channel identified by \fIchannel\fR to become available in the interpreter identified by \fIdestPath\fR and unavailable in the interpreter identified by \fIsrcPath\fR. .SH "CHILD COMMAND" .PP For each child interpreter created with the \fBinterp\fR command, a new Tcl command is created in the parent interpreter with the same name as the new interpreter. This command may be used to invoke |
︙ | ︙ |
Changes to doc/namespace.n.
︙ | ︙ | |||
491 492 493 494 495 496 497 | If you provide a fully-qualified name that starts with a \fB::\fR, there is no question about what command, variable, or namespace you mean. However, if the name does not start with a \fB::\fR (i.e., is \fIrelative\fR), Tcl follows basic rules for looking it up: .IP \(bu | | | > > | < | | < < | | | | | | | | | 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 | If you provide a fully-qualified name that starts with a \fB::\fR, there is no question about what command, variable, or namespace you mean. However, if the name does not start with a \fB::\fR (i.e., is \fIrelative\fR), Tcl follows basic rules for looking it up: .IP \(bu \fBVariable names\fR are always resolved starting in the current namespace. In the absence of special resolvers, foo::bar::baz refers to a variable named "baz" in a namespace named "bar" that is a child of a namespace named "foo" that is a child of the current namespace of the interpreter. .IP \(bu \fBCommand names\fR are always resolved by looking in the current namespace first. If not found there, they are searched for in every namespace on the current namespace's command path (which is empty by default). If not found there, command names are looked up in the global namespace (or, failing that, are processed by the appropriate \fBnamespace unknown\fR handler.) .IP \(bu \fBNamespace names\fR are always resolved by looking in only the current namespace. .PP In the following example, .PP .CS set traceLevel 0 \fBnamespace eval\fR Debug { printTrace $traceLevel } .CE .PP Tcl looks for \fBtraceLevel\fR in the namespace \fBDebug\fR. It looks up the command \fBprintTrace\fR in the same way. If a variable or command name is not found, the name is undefined. To make this point absolutely clear, consider the following example: .PP .CS set traceLevel 0 \fBnamespace eval\fR Foo { variable traceLevel 3 \fBnamespace eval\fR Debug { printTrace $traceLevel } } .CE .PP Here Tcl looks for \fBtraceLevel\fR in the namespace \fBFoo::Debug\fR. The variables \fBFoo::traceLevel\fR and \fBFoo::Debug::traceLevel\fR are completely ignored during the name resolution process. .PP You can use the \fBnamespace which\fR command to clear up any question about name resolution. For example, the command: .PP .CS \fBnamespace eval\fR Foo::Debug {\fBnamespace which\fR -variable traceLevel} .CE .PP returns the empty string. The command, .PP .CS \fBnamespace eval\fR Foo {\fBnamespace which\fR -variable traceLevel} .CE .PP returns the empty string as well. .PP As mentioned above, namespace names and variables are looked up differently than the names of commands. Namespace names and variables are always resolved in the current namespace. This means, for example, that a \fBnamespace eval\fR command that creates a new namespace always creates a child of the current namespace unless the new namespace name begins with \fB::\fR. .PP Tcl has no access control to limit what variables, commands, or namespaces you can reference. |
︙ | ︙ |
Changes to doc/puts.n.
︙ | ︙ | |||
8 9 10 11 12 13 14 | .TH puts n 7.5 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME puts \- Write to a channel .SH SYNOPSIS | | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | .TH puts n 7.5 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME puts \- Write to a channel .SH SYNOPSIS \fBputs \fR?\fB\-nonewline\fR? ?\fIchannel\fR? \fIstring\fR .BE .SH DESCRIPTION .PP The \fBputs\fR command has been superceded by the \fBchan puts\fR command which supports the same syntax and options. .SH "SEE ALSO" chan(n) |
︙ | ︙ |
Changes to doc/read.n.
︙ | ︙ | |||
8 9 10 11 12 13 14 | .TH read n 8.1 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME read \- Read from a channel .SH SYNOPSIS | | | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 | .TH read n 8.1 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME read \- Read from a channel .SH SYNOPSIS \fBread \fR?\fB\-nonewline\fR? \fIchannel\fR .sp \fBread \fIchannel numChars\fR .BE .SH DESCRIPTION .PP The \fBread\fR command has been superceded by the \fBchan read\fR command which supports the same syntax and options. .SH "SEE ALSO" chan(n) |
︙ | ︙ |
Changes to doc/refchan.n.
︙ | ︙ | |||
10 11 12 13 14 15 16 | .\" Note: do not modify the .SH NAME line immediately below! .SH NAME refchan \- command handler API of reflected channels .SH SYNOPSIS .nf \fBchan create \fImode cmdPrefix\fR | | | | | | | | | | | | | | 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 | .\" Note: do not modify the .SH NAME line immediately below! .SH NAME refchan \- command handler API of reflected channels .SH SYNOPSIS .nf \fBchan create \fImode cmdPrefix\fR \fIcmdPrefix \fBblocking\fI channel mode\fR \fIcmdPrefix \fBcget\fI channel option\fR \fIcmdPrefix \fBcgetall\fI channel\fR \fIcmdPrefix \fBconfigure\fI channel option value\fR \fIcmdPrefix \fBfinalize\fI channel\fR \fIcmdPrefix \fBinitialize\fI channel mode\fR \fIcmdPrefix \fBread\fI channel count\fR \fIcmdPrefix \fBseek\fI channel offset base\fR \fIcmdPrefix \fBwatch\fI channel eventspec\fR \fIcmdPrefix \fBwrite\fI channel data\fR .fi .BE .SH DESCRIPTION .PP The Tcl-level handler for a reflected channel has to be a command with subcommands (termed an \fIensemble\fR, as it is a command such as that created by \fBnamespace ensemble\fR \fBcreate\fR, though the implementation of handlers for reflected channel \fIis not\fR tied to \fBnamespace ensemble\fRs in any way; see \fBEXAMPLE\fR below for how to build an \fBoo::class\fR that supports the API). Note that \fIcmdPrefix\fR is whatever was specified in the call to \fBchan create\fR, and may consist of multiple arguments; this will be expanded to multiple words in place of the prefix. .PP Of all the possible subcommands, the handler \fImust\fR support \fBinitialize\fR, \fBfinalize\fR, and \fBwatch\fR. Support for the other subcommands is optional. .SS "MANDATORY SUBCOMMANDS" .\" METHOD: initialize .TP \fIcmdPrefix \fBinitialize \fIchannel mode\fR . An invocation of this subcommand will be the first call the \fIcmdPrefix\fR will receive for the specified new \fIchannel\fR. It is the responsibility of this subcommand to set up any internal data structures required to keep track of the channel and its state. .RS .PP The return value of the method has to be a list containing the names of all subcommands supported by the \fIcmdPrefix\fR. This also tells the Tcl core which version of the API for reflected channels is used by |
︙ | ︙ | |||
71 72 73 74 75 76 77 | will usually contain at least one element. .PP The subcommand must throw an error if the chosen mode is not supported by the \fIcmdPrefix\fR. .RE .\" METHOD: finalize .TP | | | | | | | | | 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 | will usually contain at least one element. .PP The subcommand must throw an error if the chosen mode is not supported by the \fIcmdPrefix\fR. .RE .\" METHOD: finalize .TP \fIcmdPrefix \fBfinalize \fIchannel\fR . An invocation of this subcommand will be the last call the \fIcmdPrefix\fR will receive for the specified \fIchannel\fR. It will be generated just before the destruction of the data structures of the channel held by the Tcl core. The command handler \fImust not\fR access the \fIchannel\fR anymore in no way. Upon this subcommand being called, any internal resources allocated to this channel must be cleaned up. .RS .PP The return value of this subcommand is ignored. .PP If the subcommand throws an error the command which caused its invocation (usually \fBchan close\fR) will appear to have thrown this error. Any exception beyond \fBerror\fR (e.g.,\ \fBbreak\fR, etc.) is treated as (and converted to) an error. .PP This subcommand is not invoked if the creation of the channel was aborted during \fBinitialize\fR (See above). .RE .\" METHOD: watch .TP \fIcmdPrefix \fBwatch \fIchannel eventspec\fR . This subcommand notifies the \fIcmdPrefix\fR that the specified \fIchannel\fR is interested in the events listed in the \fIeventspec\fR. This argument is a list containing any of \fBread\fR and \fBwrite\fR. The list may be empty, which signals that the channel does not wish to be notified of any events. In that situation, the handler should disable event generation completely. .RS .PP \fBWarning:\fR Any return value of the subcommand is ignored. This includes all errors thrown by the subcommand, \fBbreak\fR, \fBcontinue\fR, and custom return codes. .PP This subcommand interacts with \fBchan postevent\fR. Trying to post an event which was not listed in the last call to \fBwatch\fR will cause \fBchan postevent\fR to throw an error. .RE .SS "OPTIONAL SUBCOMMANDS" .\" METHOD: read .TP \fIcmdPrefix \fBread \fIchannel count\fR . This \fIoptional\fR subcommand is called when the user requests data from the channel \fIchannel\fR. \fIcount\fR specifies how many \fIbytes\fR have been requested. If the subcommand is not supported then it is not possible to read from the channel handled by the command. .RS .PP The return value of this subcommand is taken as the requested data \fIbytes\fR. If the returned data contains more bytes than requested, an error will be signaled and later thrown by the command which |
︙ | ︙ | |||
172 173 174 175 176 177 178 | If the subcommand throws any other error, the command which caused its invocation (usually \fBgets\fR, or \fBread\fR) will appear to have thrown this error. Any exception beyond \fBerror\fR, (e.g.,\ \fBbreak\fR, etc.) is treated as and converted to an error. .RE .\" METHOD: write .TP | | | | 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 | If the subcommand throws any other error, the command which caused its invocation (usually \fBgets\fR, or \fBread\fR) will appear to have thrown this error. Any exception beyond \fBerror\fR, (e.g.,\ \fBbreak\fR, etc.) is treated as and converted to an error. .RE .\" METHOD: write .TP \fIcmdPrefix \fBwrite \fIchannel data\fR . This \fIoptional\fR subcommand is called when the user writes data to the channel \fIchannel\fR. The \fIdata\fR argument contains \fIbytes\fR, not characters. Any type of transformation (EOL, encoding) configured for the channel has already been applied at this point. If this subcommand is not supported then it is not possible to write to the channel handled by the command. .RS .PP The return value of the subcommand is taken as the number of bytes |
︙ | ︙ | |||
230 231 232 233 234 235 236 | If the subcommand throws any other error the command which caused its invocation (usually \fBputs\fR) will appear to have thrown this error. Any exception beyond \fBerror\fR (e.g.,\ \fBbreak\fR, etc.) is treated as and converted to an error. .RE .\" METHOD: seek .TP | | | | 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 | If the subcommand throws any other error the command which caused its invocation (usually \fBputs\fR) will appear to have thrown this error. Any exception beyond \fBerror\fR (e.g.,\ \fBbreak\fR, etc.) is treated as and converted to an error. .RE .\" METHOD: seek .TP \fIcmdPrefix \fBseek \fIchannel offset base\fR . This \fIoptional\fR subcommand is responsible for the handling of \fBchan seek\fR and \fBchan tell\fR requests on the channel \fIchannel\fR. If it is not supported then seeking will not be possible for the channel. .RS .PP The \fIbase\fR argument is the same as the equivalent argument of the builtin \fBchan seek\fR, namely: .IP \fBstart\fR 10 Seeking is relative to the beginning of the channel. |
︙ | ︙ | |||
267 268 269 270 271 272 273 | .PP The offset/base combination of 0/\fBcurrent\fR signals a \fBchan tell\fR request, i.e.,\ seek nothing relative to the current location, making the new location identical to the current one, which is then returned. .RE .\" METHOD: configure .TP | | | | | | | | | | | | 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 | .PP The offset/base combination of 0/\fBcurrent\fR signals a \fBchan tell\fR request, i.e.,\ seek nothing relative to the current location, making the new location identical to the current one, which is then returned. .RE .\" METHOD: configure .TP \fIcmdPrefix \fBconfigure \fIchannel option value\fR . This \fIoptional\fR subcommand is for setting the type-specific options of channel \fIchannel\fR. The \fIoption\fR argument indicates the option to be written, and the \fIvalue\fR argument indicates the value to set the option to. .RS .PP This subcommand will never try to update more than one option at a time; that is behavior implemented in the Tcl channel core. .PP The return value of the subcommand is ignored. .PP If the subcommand throws an error the command which performed the (re)configuration or query (usually \fBfconfigure\fR or \fBchan configure\fR) will appear to have thrown this error. Any exception beyond \fBerror\fR (e.g.,\ \fBbreak\fR, etc.) is treated as and converted to an error. .RE .\" METHOD: cget .TP \fIcmdPrefix \fBcget \fIchannel option\fR . This \fIoptional\fR subcommand is used when reading a single type-specific option of channel \fIchannel\fR. If this subcommand is supported then the subcommand \fBcgetall\fR must be supported as well. .RS .PP The subcommand should return the value of the specified \fIoption\fR. .PP If the subcommand throws an error, the command which performed the (re)configuration or query (usually \fBfconfigure\fR or \fBchan configure\fR) will appear to have thrown this error. Any exception beyond \fIerror\fR (e.g.,\ \fBbreak\fR, etc.) is treated as and converted to an error. .RE .\" METHOD: cgetall .TP \fIcmdPrefix \fBcgetall \fIchannel\fR . This \fIoptional\fR subcommand is used for reading all type-specific options of channel \fIchannel\fR. If this subcommand is supported then the subcommand \fBcget\fR has to be supported as well. .RS .PP The subcommand should return a list of all options and their values. This list must have an even number of elements. .PP If the subcommand throws an error the command which performed the (re)configuration or query (usually \fBfconfigure\fR or \fBchan configure\fR) will appear to have thrown this error. Any exception beyond \fBerror\fR (e.g.,\ \fBbreak\fR, etc.) is treated as and converted to an error. .RE .\" METHOD: blocking .TP \fIcmdPrefix \fBblocking \fIchannel mode\fR . This \fIoptional\fR subcommand handles changes to the blocking mode of the channel \fIchannel\fR. The \fImode\fR is a boolean flag. A true value means that the channel has to be set to blocking, and a false value means that the channel should be non-blocking. .RS .PP The return value of the subcommand is ignored. .PP If the subcommand throws an error the command which caused its invocation (usually \fBfconfigure\fR or \fBchan configure\fR) will appear to have thrown this error. Any exception beyond \fBerror\fR (e.g.,\ \fBbreak\fR, etc.) is treated as and converted to an error. .RE .\" METHOD: truncate .TP \fIcmdPrefix \fBtruncate\fI channel length\fR . This \fIoptional\fR subcommand handles changing the length of the underlying data stream for the channel \fIchannel\fR. Its length gets set to \fIlength\fR. .RS .PP If the subcommand throws an error the command which caused its invocation (usually \fBchan truncate\fR) will appear to have thrown this error. Any exception beyond \fBerror\fR (e.g.,\ \fBbreak\fR, etc.) is treated as and converted to an error. |
︙ | ︙ |
Changes to doc/return.n.
︙ | ︙ | |||
74 75 76 77 78 79 80 | The return code of the procedure is 4 (\fBTCL_CONTINUE\fR). The procedure command behaves in its calling context as if it were the command \fBcontinue\fR. .TP 13 \fIvalue\fR . \fIValue\fR must be an integer; it will be returned as the | | > > > | 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 | The return code of the procedure is 4 (\fBTCL_CONTINUE\fR). The procedure command behaves in its calling context as if it were the command \fBcontinue\fR. .TP 13 \fIvalue\fR . \fIValue\fR must be an integer; it will be returned as the return code for the current procedure. Applications and packages should use values in the range 5 to 1073741823 (0x3fffffff) for their own purposes. Values outside this range are reserved for use by Tcl. .LP When a procedure wants to signal that it has received invalid arguments from its caller, it may use \fBreturn -code error\fR with \fIresult\fR set to a suitable error message. Otherwise usage of the \fBreturn -code\fR option is mostly limited to procedures that implement a new control structure. .PP |
︙ | ︙ |
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. |
︙ | ︙ | |||
243 244 245 246 247 248 249 | puts "X=$x, Y=$y" .CE .PP An interactive session demonstrating the truncation of integer values determined by size modifiers: .PP .CS | < < | 245 246 247 248 249 250 251 252 253 254 255 256 257 258 | puts "X=$x, Y=$y" .CE .PP An interactive session demonstrating the truncation of integer values determined by size modifiers: .PP .CS \fI%\fR scan 20000000000000000000 %d 2147483647 \fI%\fR scan 20000000000000000000 %ld 9223372036854775807 \fI%\fR scan 20000000000000000000 %lld 20000000000000000000 .CE |
︙ | ︙ |
Changes to doc/seek.n.
︙ | ︙ | |||
8 9 10 11 12 13 14 | .TH seek n 8.1 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME seek \- Change the access position for an open channel .SH SYNOPSIS | | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | .TH seek n 8.1 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME seek \- Change the access position for an open channel .SH SYNOPSIS \fBseek \fIchannel offset \fR?\fIorigin\fR? .BE .SH DESCRIPTION .PP The \fBseek\fR command has been superceded by the \fBchan seek\fR command which supports the same syntax and options. .SH "SEE ALSO" chan(n) |
︙ | ︙ |
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/tell.n.
︙ | ︙ | |||
8 9 10 11 12 13 14 | .TH tell n 8.1 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME tell \- Return current access position for an open channel .SH SYNOPSIS | | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | .TH tell n 8.1 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME tell \- Return current access position for an open channel .SH SYNOPSIS \fBtell \fIchannel\fR .BE .SH DESCRIPTION .PP The \fBtell\fR command has been superceded by the \fBchan tell\fR command which supports the same syntax and options. .SH "SEE ALSO" chan(n) |
︙ | ︙ |
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 \fIchannel 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/tcl.h.
︙ | ︙ | |||
490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 | * TCL_RETURN The command requests that the current function return; * the interpreter's result contains the function's * return value. * TCL_BREAK The command requests that the innermost loop be * exited; the interpreter's result is meaningless. * TCL_CONTINUE Go on to the next iteration of the current loop; the * interpreter's result is meaningless. */ #define TCL_OK 0 #define TCL_ERROR 1 #define TCL_RETURN 2 #define TCL_BREAK 3 #define TCL_CONTINUE 4 /* *---------------------------------------------------------------------------- * Flags to control what substitutions are performed by Tcl_SubstObj(): */ #define TCL_SUBST_COMMANDS 001 | > > > > | 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 | * TCL_RETURN The command requests that the current function return; * the interpreter's result contains the function's * return value. * TCL_BREAK The command requests that the innermost loop be * exited; the interpreter's result is meaningless. * TCL_CONTINUE Go on to the next iteration of the current loop; the * interpreter's result is meaningless. * Integer return codes in the range TCL_CODE_USER_MIN to TCL_CODE_USER_MAX are * reserved for the use of packages. */ #define TCL_OK 0 #define TCL_ERROR 1 #define TCL_RETURN 2 #define TCL_BREAK 3 #define TCL_CONTINUE 4 #define TCL_CODE_USER_MIN 5 #define TCL_CODE_USER_MAX 0x3fffffff /* 1073741823 */ /* *---------------------------------------------------------------------------- * Flags to control what substitutions are performed by Tcl_SubstObj(): */ #define TCL_SUBST_COMMANDS 001 |
︙ | ︙ |
Changes to generic/tclArithSeries.c.
︙ | ︙ | |||
497 498 499 500 501 502 503 | * Results: * A Tcl_Obj pointer. No assignment on error. * * Side Effects: * None. *---------------------------------------------------------------------- */ | | > > | > > | > > > | > | < > < > | > > | > > | | | > > | | 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 | * 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; |
︙ | ︙ | |||
625 626 627 628 629 630 631 | } } 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 | } } 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 -- * |
︙ | ︙ | |||
828 829 830 831 832 833 834 | 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. */ /* |
︙ | ︙ | |||
1039 1040 1041 1042 1043 1044 1045 | 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); |
︙ | ︙ | |||
1073 1074 1075 1076 1077 1078 1079 | 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 -- * |
︙ | ︙ |
Changes to generic/tclBasic.c.
︙ | ︙ | |||
233 234 235 236 237 238 239 | static Tcl_NRPostProc TEOV_Exception; static Tcl_NRPostProc TEOV_NotFoundCallback; static Tcl_NRPostProc TEOV_RestoreVarFrame; static Tcl_NRPostProc TEOV_RunLeaveTraces; static Tcl_NRPostProc EvalObjvCore; static Tcl_NRPostProc Dispatch; | < | 233 234 235 236 237 238 239 240 241 242 243 244 245 246 | static Tcl_NRPostProc TEOV_Exception; static Tcl_NRPostProc TEOV_NotFoundCallback; static Tcl_NRPostProc TEOV_RestoreVarFrame; static Tcl_NRPostProc TEOV_RunLeaveTraces; static Tcl_NRPostProc EvalObjvCore; static Tcl_NRPostProc Dispatch; static Tcl_NRPostProc NRPostInvoke; static Tcl_ObjCmdProc2 CoroTypeObjCmd; static Tcl_ObjCmdProc2 TclNRCoroInjectObjCmd; static Tcl_ObjCmdProc2 TclNRCoroProbeObjCmd; static Tcl_NRPostProc InjectHandler; static Tcl_NRPostProc InjectHandlerPostCall; |
︙ | ︙ | |||
1183 1184 1185 1186 1187 1188 1189 | /* Adding the bytecode assembler command */ cmdPtr = (Command *) Tcl_NRCreateCommand2(interp, "::tcl::unsupported::assemble", Tcl_AssembleObjCmd, TclNRAssembleObjCmd, NULL, NULL); cmdPtr->compileProc = &TclCompileAssembleCmd; /* Coroutine monkeybusiness */ | < < | 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 | /* Adding the bytecode assembler command */ cmdPtr = (Command *) Tcl_NRCreateCommand2(interp, "::tcl::unsupported::assemble", Tcl_AssembleObjCmd, TclNRAssembleObjCmd, NULL, NULL); cmdPtr->compileProc = &TclCompileAssembleCmd; /* Coroutine monkeybusiness */ Tcl_CreateObjCommand2(interp, "::tcl::unsupported::corotype", CoroTypeObjCmd, NULL, NULL); /* Export unsupported commands */ nsPtr = Tcl_FindNamespace(interp, "::tcl::unsupported", NULL, 0); if (nsPtr) { Tcl_Export(interp, nsPtr, "*", 1); |
︙ | ︙ | |||
9306 9307 9308 9309 9310 9311 9312 | return TCL_OK; } /* *---------------------------------------------------------------------- * | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 9303 9304 9305 9306 9307 9308 9309 9310 9311 9312 9313 9314 9315 9316 | return TCL_OK; } /* *---------------------------------------------------------------------- * * CoroTypeObjCmd -- * * Implementation of [::tcl::unsupported::corotype] command. * *---------------------------------------------------------------------- */ |
︙ | ︙ | |||
9657 9658 9659 9660 9661 9662 9663 | Tcl_Size numLevels = iPtr->numLevels; iPtr->numLevels = corPtr->auxNumLevels; corPtr->auxNumLevels = numLevels - corPtr->auxNumLevels; iPtr->execEnvPtr = corPtr->callerEEPtr; } return result; } | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 9625 9626 9627 9628 9629 9630 9631 9632 9633 9634 9635 9636 9637 9638 | Tcl_Size numLevels = iPtr->numLevels; iPtr->numLevels = corPtr->auxNumLevels; corPtr->auxNumLevels = numLevels - corPtr->auxNumLevels; iPtr->execEnvPtr = corPtr->callerEEPtr; } return result; } int TclNRInterpCoroutine( void *clientData, Tcl_Interp *interp, /* Current interpreter. */ Tcl_Size objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ |
︙ | ︙ |
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 4212 | 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; Tcl_Size i; int 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; |
︙ | ︙ | |||
4343 4344 4345 4346 4347 4348 4349 | break; default: goto done; break; } break; | < < < < < < < < < < < < < < < < < < < < < < < < < < > > > > > > > > > > > > > > > > > > > > > > | > > | > > > > > | > | | | | 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 4391 | 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/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) { |
︙ | ︙ | |||
4304 4305 4306 4307 4308 4309 4310 | } 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( | | > | > | > | 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 | } 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 | 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; } /* *------------------------------------------------------------------------ * |
︙ | ︙ | |||
4377 4378 4379 4380 4381 4382 4383 | 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) { | | | | | 4403 4404 4405 4406 4407 4408 4409 4410 4411 4412 4413 4414 4415 4416 4417 4418 4419 4420 4421 4422 | 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, Tcl_Size objc, Tcl_Obj *const objv[], Tcl_Obj **prefixObjPtr); static int NsEnsembleImplementationCmdNR(void *clientData, Tcl_Interp *interp,Tcl_Size 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, Tcl_Size objc, Tcl_Obj *const objv[], Tcl_Obj **prefixObjPtr); static int NsEnsembleImplementationCmdNR(void *clientData, Tcl_Interp *interp,Tcl_Size 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, Tcl_Size 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, Tcl_Size 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->objProc2 != 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->objClientData2; } /* *---------------------------------------------------------------------- * * 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)->objProc2 != TclEnsembleImplementationCmd) { /* * Reuse existing infrastructure for following import link chains * rather than duplicating it. */ token = TclGetOriginalCommand(token); if (token == NULL || ((Command *) token)->objProc2 != 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->objProc2 == 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 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 | 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].proc2 || map[i].nreProc2) { /* * 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_NRCreateCommand2(interp, "___tmp", map[i].proc2, map[i].nreProc2, 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)); } /* don't compile unsafe subcommands in safe interp */ cmdPtr->compileProc = NULL; } else { /* * Not hidden, so just create it. Yay! */ cmdPtr = (Command *) Tcl_NRCreateCommand2(interp, TclGetString(toObj), map[i].proc2, map[i].nreProc2, map[i].clientData, NULL); cmdPtr->compileProc = map[i].compileProc; } } } Tcl_SetEnsembleMappingDict(interp, ensemble, mapDict); } Tcl_DStringFree(&buf); Tcl_DStringFree(&hiddenBuf); |
︙ | ︙ | |||
1697 1698 1699 1700 1701 1702 1703 | { return Tcl_NRCallObjProc2(interp, NsEnsembleImplementationCmdNR, clientData, objc, objv); } static int NsEnsembleImplementationCmdNR( | | | | 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 | { return Tcl_NRCallObjProc2(interp, NsEnsembleImplementationCmdNR, clientData, objc, objv); } static int NsEnsembleImplementationCmdNR( void *clientData, /* The ensemble this is the impl. of. */ Tcl_Interp *interp, Tcl_Size 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) { | < | | > | 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 | * 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 && | | | < | 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 | * 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. */ | | | | 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 | 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); | | | 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 | /* * 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) { | | > | > | 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 | 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 { | | | | 2245 2246 2247 2248 2249 2250 2251 2252 2253 2254 2255 2256 2257 2258 2259 2260 2261 | } } 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) { | > > > > > > > > > > > | < | | 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 2336 2337 | } 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, | | | | | > > | 2359 2360 2361 2362 2363 2364 2365 2366 2367 2368 2369 2370 2371 2372 2373 2374 2375 2376 2377 2378 | * * ---------------------------------------------------------------------- */ static inline int EnsembleUnknownCallback( Tcl_Interp *interp, EnsembleConfig *ensemblePtr,/* The ensemble structure. */ Tcl_Size 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( | | > | 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 2407 2408 2409 2410 2411 2412 | 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( | | > | > | > | > | 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 2472 2473 | * 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( | | | | | > | | 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 2531 2532 | * 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( | | | | | | | | | | | | | 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 2592 2593 | * 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( | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 2796 2797 | * 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. */ | | | | 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 | * 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) { | | > | > > | | | | 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 2906 2907 | * 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; | | > | 2955 2956 2957 2958 2959 2960 2961 2962 2963 2964 2965 2966 2967 2968 2969 2970 | 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++; |
︙ | ︙ | |||
3133 3134 3135 3136 3137 3138 3139 | } targetCmdObj = elems[0]; oldCmdPtr = cmdPtr; Tcl_IncrRefCount(targetCmdObj); newCmdPtr = (Command *) Tcl_GetCommandFromObj(interp, targetCmdObj); TclDecrRefCount(targetCmdObj); | | | < | 3220 3221 3222 3223 3224 3225 3226 3227 3228 3229 3230 3231 3232 3233 3234 3235 3236 3237 3238 3239 3240 3241 | } targetCmdObj = elems[0]; oldCmdPtr = cmdPtr; Tcl_IncrRefCount(targetCmdObj); newCmdPtr = (Command *) Tcl_GetCommandFromObj(interp, targetCmdObj); TclDecrRefCount(targetCmdObj); if (newCmdPtr == NULL || (Tcl_IsSafe(interp) && !cmdPtr->compileProc) || 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; } cmdPtr = newCmdPtr; depth++; /* * See whether we have a nested ensemble. If we do, we can go round the |
︙ | ︙ | |||
3188 3189 3190 3191 3192 3193 3194 | } /* * Throw out any line information generated by the failed compile attempt. */ while (mapPtr->nuloc > eclIndex + 1) { | | | | | 3274 3275 3276 3277 3278 3279 3280 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 | } /* * 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) { | | | 3490 3491 3492 3493 3494 3495 3496 3497 3498 3499 3500 3501 3502 3503 3504 | * 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. */ | | > | 3532 3533 3534 3535 3536 3537 3538 3539 3540 3541 3542 3543 3544 3545 3546 3547 | 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); } /* *---------------------------------------------------------------------- |
︙ | ︙ |
Changes to generic/tclIO.c.
︙ | ︙ | |||
9191 9192 9193 9194 9195 9196 9197 | const char *chanName; int modeIndex; /* Index of mode argument. */ int mask; static const char *const modeOptions[] = {"readable", "writable", NULL}; static const int maskArray[] = {TCL_READABLE, TCL_WRITABLE}; if ((objc != 3) && (objc != 4)) { | | | 9191 9192 9193 9194 9195 9196 9197 9198 9199 9200 9201 9202 9203 9204 9205 | const char *chanName; int modeIndex; /* Index of mode argument. */ int mask; static const char *const modeOptions[] = {"readable", "writable", NULL}; static const int maskArray[] = {TCL_READABLE, TCL_WRITABLE}; if ((objc != 3) && (objc != 4)) { Tcl_WrongNumArgs(interp, 1, objv, "channel event ?script?"); return TCL_ERROR; } if (Tcl_GetIndexFromObj(interp, objv[2], modeOptions, "event name", 0, &modeIndex) != TCL_OK) { return TCL_ERROR; } mask = maskArray[modeIndex]; |
︙ | ︙ |
Changes to generic/tclIOCmd.c.
︙ | ︙ | |||
134 135 136 137 138 139 140 | chanObjPtr = objv[2]; string = objv[3]; break; } /* Fall through */ default: /* [puts] or * [puts some bad number of arguments...] */ | | | 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 | chanObjPtr = objv[2]; string = objv[3]; break; } /* Fall through */ default: /* [puts] or * [puts some bad number of arguments...] */ Tcl_WrongNumArgs(interp, 1, objv, "?-nonewline? ?channel? string"); return TCL_ERROR; } if (chanObjPtr == NULL) { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); if (!tsdPtr->initialized) { |
︙ | ︙ | |||
218 219 220 221 222 223 224 | Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Obj *chanObjPtr; Tcl_Channel chan; /* The channel to flush on. */ int mode; if (objc != 2) { | | | 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 | Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Obj *chanObjPtr; Tcl_Channel chan; /* The channel to flush on. */ int mode; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "channel"); return TCL_ERROR; } chanObjPtr = objv[1]; if (TclGetChannelFromObj(interp, chanObjPtr, &chan, &mode, 0) != TCL_OK) { return TCL_ERROR; } if (!(mode & TCL_WRITABLE)) { |
︙ | ︙ | |||
284 285 286 287 288 289 290 | Tcl_Channel chan; /* The channel to read from. */ Tcl_Size lineLen; /* Length of line just read. */ int mode; /* Mode in which channel is opened. */ Tcl_Obj *linePtr, *chanObjPtr; int code = TCL_OK; if ((objc != 2) && (objc != 3)) { | | | 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 | Tcl_Channel chan; /* The channel to read from. */ Tcl_Size lineLen; /* Length of line just read. */ int mode; /* Mode in which channel is opened. */ Tcl_Obj *linePtr, *chanObjPtr; int code = TCL_OK; if ((objc != 2) && (objc != 3)) { Tcl_WrongNumArgs(interp, 1, objv, "channel ?varName?"); return TCL_ERROR; } chanObjPtr = objv[1]; if (TclGetChannelFromObj(interp, chanObjPtr, &chan, &mode, 0) != TCL_OK) { return TCL_ERROR; } if (!(mode & TCL_READABLE)) { |
︙ | ︙ | |||
376 377 378 379 380 381 382 | Tcl_Obj *resultPtr, *chanObjPtr; if ((objc != 2) && (objc != 3)) { Interp *iPtr; argerror: iPtr = (Interp *) interp; | | | | 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 | Tcl_Obj *resultPtr, *chanObjPtr; if ((objc != 2) && (objc != 3)) { Interp *iPtr; argerror: iPtr = (Interp *) interp; Tcl_WrongNumArgs(interp, 1, objv, "channel ?numChars?"); /* * Do not append directly; that makes ensembles using this command as * a subcommand produce the wrong message. */ iPtr->flags |= INTERP_ALTERNATE_WRONG_ARGS; Tcl_WrongNumArgs(interp, 1, objv, "?-nonewline? channel"); return TCL_ERROR; } i = 1; newline = 0; if (strcmp(TclGetString(objv[1]), "-nonewline") == 0) { newline = 1; |
︙ | ︙ | |||
512 513 514 515 516 517 518 | int optionIndex; static const char *const originOptions[] = { "start", "current", "end", NULL }; static const int modeArray[] = {SEEK_SET, SEEK_CUR, SEEK_END}; if ((objc != 3) && (objc != 4)) { | | | 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 | int optionIndex; static const char *const originOptions[] = { "start", "current", "end", NULL }; static const int modeArray[] = {SEEK_SET, SEEK_CUR, SEEK_END}; if ((objc != 3) && (objc != 4)) { Tcl_WrongNumArgs(interp, 1, objv, "channel offset ?origin?"); return TCL_ERROR; } if (TclGetChannelFromObj(interp, objv[1], &chan, NULL, 0) != TCL_OK) { return TCL_ERROR; } if (TclGetWideIntFromObj(interp, objv[2], &offset) != TCL_OK) { return TCL_ERROR; |
︙ | ︙ | |||
581 582 583 584 585 586 587 | Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Channel chan; /* The channel to tell on. */ Tcl_WideInt newLoc; int code; if (objc != 2) { | | | 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 | Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Channel chan; /* The channel to tell on. */ Tcl_WideInt newLoc; int code; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "channel"); return TCL_ERROR; } /* * Try to find a channel with the right name and permissions in the IO * channel table of this interpreter. */ |
︙ | ︙ | |||
644 645 646 647 648 649 650 | Tcl_Channel chan; /* The channel to close. */ static const char *const dirOptions[] = { "read", "write", NULL }; static const int dirArray[] = {TCL_CLOSE_READ, TCL_CLOSE_WRITE}; if ((objc != 2) && (objc != 3)) { | | | 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 | Tcl_Channel chan; /* The channel to close. */ static const char *const dirOptions[] = { "read", "write", NULL }; static const int dirArray[] = {TCL_CLOSE_READ, TCL_CLOSE_WRITE}; if ((objc != 2) && (objc != 3)) { Tcl_WrongNumArgs(interp, 1, objv, "channel ?direction?"); return TCL_ERROR; } if (TclGetChannelFromObj(interp, objv[1], &chan, NULL, 0) != TCL_OK) { return TCL_ERROR; } |
︙ | ︙ | |||
750 751 752 753 754 755 756 | Tcl_Obj *const objv[]) /* Argument objects. */ { const char *optionName, *valueName; Tcl_Channel chan; /* The channel to set a mode on. */ Tcl_Size i; /* Iterate over arg-value pairs. */ if ((objc < 2) || (((objc % 2) == 1) && (objc != 3))) { | | | 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 | Tcl_Obj *const objv[]) /* Argument objects. */ { const char *optionName, *valueName; Tcl_Channel chan; /* The channel to set a mode on. */ Tcl_Size i; /* Iterate over arg-value pairs. */ if ((objc < 2) || (((objc % 2) == 1) && (objc != 3))) { Tcl_WrongNumArgs(interp, 1, objv, "channel ?-option value ...?"); return TCL_ERROR; } if (TclGetChannelFromObj(interp, objv[1], &chan, NULL, 0) != TCL_OK) { return TCL_ERROR; } |
︙ | ︙ | |||
823 824 825 826 827 828 829 | Tcl_Interp *interp, /* Current interpreter. */ Tcl_Size objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Channel chan; if (objc != 2) { | | | 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 | Tcl_Interp *interp, /* Current interpreter. */ Tcl_Size objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Channel chan; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "channel"); return TCL_ERROR; } if (TclGetChannelFromObj(interp, objv[1], &chan, NULL, 0) != TCL_OK) { return TCL_ERROR; } |
︙ | ︙ | |||
1035 1036 1037 1038 1039 1040 1041 | Tcl_Size objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Channel chan; int mode; if (objc != 2) { | | | 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 | Tcl_Size objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Channel chan; int mode; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "channel"); return TCL_ERROR; } if (TclGetChannelFromObj(interp, objv[1], &chan, &mode, 0) != TCL_OK) { return TCL_ERROR; } if (!(mode & TCL_READABLE)) { |
︙ | ︙ | |||
1806 1807 1808 1809 1810 1811 1812 | { Tcl_Channel chan; static const char *const options[] = {"input", "output", NULL}; enum pendingOptionsEnum {PENDING_INPUT, PENDING_OUTPUT} index; int mode; if (objc != 3) { | | | 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 | { Tcl_Channel chan; static const char *const options[] = {"input", "output", NULL}; enum pendingOptionsEnum {PENDING_INPUT, PENDING_OUTPUT} index; int mode; if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "mode channel"); return TCL_ERROR; } if (Tcl_GetIndexFromObj(interp, objv[1], options, "mode", 0, &index) != TCL_OK) { return TCL_ERROR; } |
︙ | ︙ | |||
1866 1867 1868 1869 1870 1871 1872 | Tcl_Size objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Channel chan; Tcl_WideInt length; if ((objc < 2) || (objc > 3)) { | | | 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 | Tcl_Size objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Channel chan; Tcl_WideInt length; if ((objc < 2) || (objc > 3)) { Tcl_WrongNumArgs(interp, 1, objv, "channel ?length?"); return TCL_ERROR; } if (TclGetChannelFromObj(interp, objv[1], &chan, NULL, 0) != TCL_OK) { return TCL_ERROR; } if (objc == 3) { |
︙ | ︙ |
Changes to generic/tclInt.h.
︙ | ︙ | |||
2123 2124 2125 2126 2127 2128 2129 | 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. */ | | > | 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 | 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. */ |
︙ | ︙ | |||
3057 3058 3059 3060 3061 3062 3063 3064 3065 3066 3067 3068 3069 3070 | * 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; | > | 3058 3059 3060 3061 3062 3063 3064 3065 3066 3067 3068 3069 3070 3071 3072 | * 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; |
︙ | ︙ | |||
3446 3447 3448 3449 3450 3451 3452 | 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); | | < | 3448 3449 3450 3451 3452 3453 3454 3455 3456 3457 3458 3459 3460 3461 3462 | 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/tclInterp.c.
︙ | ︙ | |||
1060 1061 1062 1063 1064 1065 1066 | } case OPT_TRANSFER: case OPT_SHARE: { Tcl_Interp *parentInterp; /* The parent of the child. */ Tcl_Channel chan; if (objc != 5) { | | | 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 | } case OPT_TRANSFER: case OPT_SHARE: { Tcl_Interp *parentInterp; /* The parent of the child. */ Tcl_Channel chan; if (objc != 5) { Tcl_WrongNumArgs(interp, 2, objv, "srcPath channel destPath"); return TCL_ERROR; } parentInterp = GetInterp(interp, objv[2]); if (parentInterp == NULL) { return TCL_ERROR; } chan = Tcl_GetChannel(parentInterp, TclGetString(objv[3]), NULL); |
︙ | ︙ |
Changes to generic/tclListObj.c.
︙ | ︙ | |||
494 495 496 497 498 499 500 | *------------------------------------------------------------------------ */ static int ListLimitExceededError( Tcl_Interp *interp) { if (interp != NULL) { | | < | | 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 | *------------------------------------------------------------------------ */ 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; } /* *------------------------------------------------------------------------ |
︙ | ︙ |
Changes to generic/tclScan.c.
︙ | ︙ | |||
354 355 356 357 358 359 360 | * 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 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 | * 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); } /* * Handle any size specifier. */ switch (ch) { case 'z': case 't': if (sizeof(void *) > sizeof(int)) { flags |= SCAN_LONGER; } format += TclUtfToUniChar(format, &ch); break; case 'L': flags |= SCAN_BIG; format += TclUtfToUniChar(format, &ch); break; case 'l': if (*format == 'l') { flags |= SCAN_BIG; format += 1; format += TclUtfToUniChar(format, &ch); break; } /* FALLTHRU */ case 'j': case 'q': flags |= SCAN_LONGER; /* FALLTHRU */ case 'h': format += TclUtfToUniChar(format, &ch); } if (!(flags & SCAN_SUPPRESS) && numVars && (objIndex >= numVars)) { |
︙ | ︙ | |||
590 591 592 593 594 595 596 | Tcl_Interp *interp, /* Current interpreter. */ Tcl_Size objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { const char *format; int numVars, nconversions, totalVars = -1; int objIndex, offset, i, result, code; | | | 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 | Tcl_Interp *interp, /* Current interpreter. */ Tcl_Size objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { const char *format; int numVars, nconversions, totalVars = -1; int objIndex, offset, i, result, code; int value; const char *string, *end, *baseString; char op = 0; int underflow = 0; Tcl_Size width; Tcl_WideInt wideValue; Tcl_UniChar ch = 0, sch = 0; Tcl_Obj **objs = NULL, *objPtr = NULL; |
︙ | ︙ | |||
983 984 985 986 987 988 989 | "unsigned bignum scans are invalid", -1)); Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADUNSIGNED", (char *)NULL); return TCL_ERROR; } } } else { | | | | | 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 | "unsigned bignum scans are invalid", -1)); Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADUNSIGNED", (char *)NULL); return TCL_ERROR; } } } else { if (TclGetIntFromObj(NULL, objPtr, &value) != TCL_OK) { 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( |
︙ | ︙ | |||
1093 1094 1095 1096 1097 1098 1099 | } } 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/tclStringObj.c.
︙ | ︙ | |||
1871 1872 1873 1874 1875 1876 1877 | */ while (*format != '\0') { char *end; int gotMinus = 0, gotHash = 0, gotZero = 0, gotSpace = 0, gotPlus = 0; int gotPrecision, sawFlag, useShort = 0, useBig = 0; Tcl_WideInt width, precision; | < < | 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 | */ while (*format != '\0') { char *end; int gotMinus = 0, gotHash = 0, gotZero = 0, gotSpace = 0, gotPlus = 0; int gotPrecision, sawFlag, useShort = 0, useBig = 0; Tcl_WideInt width, precision; int useWide = 0; int newXpg, allocSegment = 0; Tcl_Size numChars, segmentLimit, segmentNumBytes; Tcl_Obj *segment; int step = TclUtfToUniChar(format, &ch); format += step; if (ch != '%') { |
︙ | ︙ | |||
2078 2079 2080 2081 2082 2083 2084 | } else if (ch == 'l') { format += step; step = TclUtfToUniChar(format, &ch); if (ch == 'l') { useBig = 1; format += step; step = TclUtfToUniChar(format, &ch); | < < < < < < < < | 2076 2077 2078 2079 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 | } else if (ch == 'l') { format += step; step = TclUtfToUniChar(format, &ch); if (ch == 'l') { useBig = 1; format += step; step = TclUtfToUniChar(format, &ch); } else { useWide = 1; } } else if (ch == 'I') { if ((format[1] == '6') && (format[2] == '4')) { format += (step + 2); step = TclUtfToUniChar(format, &ch); useWide = 1; } else if ((format[1] == '3') && (format[2] == '2')) { format += (step + 2); step = TclUtfToUniChar(format, &ch); } else { format += step; step = TclUtfToUniChar(format, &ch); } } else if ((ch == 'q') || (ch == 'j')) { format += step; step = TclUtfToUniChar(format, &ch); useWide = 1; } else if ((ch == 't') || (ch == 'z')) { format += step; step = TclUtfToUniChar(format, &ch); if (sizeof(void *) > sizeof(int)) { useWide = 1; } } else if (ch == 'L') { format += step; step = TclUtfToUniChar(format, &ch); useBig = 1; } format += step; |
︙ | ︙ | |||
2176 2177 2178 2179 2180 2181 2182 | case 'o': case 'p': case 'x': case 'X': case 'b': { short s = 0; /* Silence compiler warning; only defined and * used when useShort is true. */ | | < < < < | | | | | | | 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 2192 2193 2194 2195 2196 2197 2198 2199 2200 2201 2202 2203 2204 2205 2206 2207 2208 2209 2210 2211 2212 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 2228 2229 2230 2231 2232 2233 2234 2235 2236 2237 2238 2239 2240 2241 2242 2243 | case 'o': case 'p': case 'x': case 'X': case 'b': { short s = 0; /* Silence compiler warning; only defined and * used when useShort is true. */ int l; Tcl_WideInt w; mp_int big; int isNegative = 0; Tcl_Size toAppend; if ((ch == 'p') && (sizeof(void *) > sizeof(int))) { useWide = 1; } if (useBig) { int cmpResult; if (Tcl_GetBignumFromObj(interp, segment, &big) != TCL_OK) { goto error; } cmpResult = mp_cmp_d(&big, 0); isNegative = (cmpResult == MP_LT); if (cmpResult == MP_EQ) { gotHash = 0; } if (ch == 'u') { if (isNegative) { mp_clear(&big); msg = "unsigned bignum format is invalid"; errCode = "BADUNSIGNED"; goto errorMsg; } else { ch = 'd'; } } } else if (useWide) { if (TclGetWideBitsFromObj(interp, segment, &w) != TCL_OK) { goto error; } isNegative = (w < (Tcl_WideInt) 0); if (w == (Tcl_WideInt) 0) { gotHash = 0; } } else if (TclGetIntFromObj(NULL, segment, &l) != TCL_OK) { if (TclGetWideBitsFromObj(interp, segment, &w) != TCL_OK) { goto error; } else { l = (int) w; } if (useShort) { s = (short) l; isNegative = (s < (short) 0); if (s == (short) 0) { gotHash = 0; } } else { isNegative = (l < (int) 0); if (l == (int) 0) { gotHash = 0; } } } else if (useShort) { s = (short) l; isNegative = (s < (short) 0); if (s == (short) 0) { gotHash = 0; } } else { isNegative = (l < (int) 0); if (l == (int) 0) { gotHash = 0; } } TclNewObj(segment); allocSegment = 1; segmentLimit = TCL_SIZE_MAX; |
︙ | ︙ | |||
2290 2291 2292 2293 2294 2295 2296 | case 'd': { Tcl_Size length; Tcl_Obj *pure; const char *bytes; if (useShort) { TclNewIntObj(pure, s); | < < | 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 | case 'd': { Tcl_Size length; Tcl_Obj *pure; const char *bytes; if (useShort) { TclNewIntObj(pure, s); } else if (useWide) { TclNewIntObj(pure, w); } else if (useBig) { pure = Tcl_NewBignumObj(&big); } else { TclNewIntObj(pure, l); } Tcl_IncrRefCount(pure); bytes = TclGetStringFromObj(pure, &length); |
︙ | ︙ | |||
2378 2379 2380 2381 2382 2383 2384 | unsigned short us = (unsigned short) s; bits = (Tcl_WideUInt) us; while (us) { numDigits++; us /= base; } | < < | | 2362 2363 2364 2365 2366 2367 2368 2369 2370 2371 2372 2373 2374 2375 2376 2377 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 2396 2397 2398 2399 2400 | unsigned short us = (unsigned short) s; bits = (Tcl_WideUInt) us; while (us) { numDigits++; us /= base; } } else if (useWide) { Tcl_WideUInt uw = (Tcl_WideUInt) w; bits = uw; while (uw) { numDigits++; uw /= base; } } else if (useBig && !mp_iszero(&big)) { int leftover = (big.used * MP_DIGIT_BIT) % numBits; mp_digit mask = (~(mp_digit)0) << (MP_DIGIT_BIT-leftover); numDigits = 1 + (((Tcl_WideInt) big.used * MP_DIGIT_BIT) / numBits); while ((mask & big.dp[big.used-1]) == 0) { numDigits--; mask >>= numBits; } if (numDigits > INT_MAX) { msg = overflow; errCode = "OVERFLOW"; goto errorMsg; } } else if (!useBig) { unsigned ul = (unsigned) l; bits = (Tcl_WideUInt) ul; while (ul) { numDigits++; ul /= base; } } |
︙ | ︙ |
Changes to generic/tclTest.c.
︙ | ︙ | |||
6392 6393 6394 6395 6396 6397 6398 | if ((cmdName[0] == 't') && (strncmp(cmdName, "transform", len) == 0)) { /* * Syntax: transform channel -command command */ if (argc != 5) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], | | | 6392 6393 6394 6395 6396 6397 6398 6399 6400 6401 6402 6403 6404 6405 6406 | if ((cmdName[0] == 't') && (strncmp(cmdName, "transform", len) == 0)) { /* * Syntax: transform channel -command command */ if (argc != 5) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " transform channel -command cmd\"", (char *)NULL); return TCL_ERROR; } if (strcmp(argv[3], "-command") != 0) { Tcl_AppendResult(interp, "bad argument \"", argv[3], "\": should be \"-command\"", (char *)NULL); return TCL_ERROR; } |
︙ | ︙ |
Changes to library/history.tcl.
︙ | ︙ | |||
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 |
︙ | ︙ | |||
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 | 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 } |
︙ | ︙ | |||
3400 3401 3402 3403 3404 3405 3406 | 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} { | | | | | 3399 3400 3401 3402 3403 3404 3405 3406 3407 3408 3409 3410 3411 3412 3413 3414 3415 3416 3417 | 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 |
︙ | ︙ | |||
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 |
︙ | ︙ |
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 |
︙ | ︙ |
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.
︙ | ︙ | |||
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 |
︙ | ︙ | |||
1635 1636 1637 1638 1639 1640 1641 | 1 { # Only the string to be printed is specified append outData [lindex $args 0]\n return # return [Puts [lindex $args 0]] } 2 { | | | | 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 | 1 { # Only the string to be printed is specified append outData [lindex $args 0]\n return # return [Puts [lindex $args 0]] } 2 { # Either -nonewline or channel has been specified if {[lindex $args 0] eq "-nonewline"} { append outData [lindex $args end] return # return [Puts -nonewline [lindex $args end]] } else { set channel [lindex $args 0] set newline \n } } 3 { if {[lindex $args 0] eq "-nonewline"} { # Both -nonewline and channel are specified, unless # it's an error. -nonewline is supposed to be argv[0]. set channel [lindex $args 1] set newline "" } } } |
︙ | ︙ | |||
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 -- |
︙ | ︙ | |||
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 |
︙ | ︙ | |||
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 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/chan.test.
︙ | ︙ | |||
25 26 27 28 29 30 31 | } -returnCodes error -result "wrong # args: should be \"chan subcommand ?arg ...?\"" test chan-1.2 {chan command general syntax} -body { chan FOOBAR } -returnCodes error -match glob -result "unknown or ambiguous subcommand \"FOOBAR\": must be *" test chan-2.1 {chan command: blocked subcommand} -body { chan blocked foo bar | | | | | 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 | } -returnCodes error -result "wrong # args: should be \"chan subcommand ?arg ...?\"" test chan-1.2 {chan command general syntax} -body { chan FOOBAR } -returnCodes error -match glob -result "unknown or ambiguous subcommand \"FOOBAR\": must be *" test chan-2.1 {chan command: blocked subcommand} -body { chan blocked foo bar } -returnCodes error -result "wrong # args: should be \"chan blocked channel\"" test chan-3.1 {chan command: close subcommand} -body { chan close foo bar zet } -returnCodes error -result "wrong # args: should be \"chan close channel ?direction?\"" test chan-3.2 {chan command: close subcommand} -setup { set chan [open [info script] r] } -body { chan close $chan bar } -cleanup { close $chan } -returnCodes error -result "bad direction \"bar\": must be read or write" test chan-3.3 {chan command: close subcommand} -setup { set chan [open [info script] r] } -body { chan close $chan write } -cleanup { close $chan } -returnCodes error -result "Half-close of write-side not possible, side not opened or already closed" test chan-4.1 {chan command: configure subcommand} -body { chan configure } -returnCodes error -result "wrong # args: should be \"chan configure channel ?-option value ...?\"" test chan-4.2 {chan command: [Bug 800753]} -body { chan configure stdout -eofchar Ā } -returnCodes error -result {bad value for -eofchar: must be non-NUL ASCII character} test chan-4.3 {chan command: [Bug 800753]} -body { chan configure stdout -eofchar \x00 } -returnCodes error -result {bad value for -eofchar: must be non-NUL ASCII character} test chan-4.4 {chan command: check valid inValue, no outValue} -constraints deprecated -body { |
︙ | ︙ | |||
68 69 70 71 72 73 74 | test chan-5.1 {chan command: copy subcommand} -body { chan copy foo } -returnCodes error -result "wrong # args: should be \"chan copy input output ?-size size? ?-command callback?\"" test chan-6.1 {chan command: eof subcommand} -body { chan eof foo bar | | | | | | | | | | | | | | 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 | test chan-5.1 {chan command: copy subcommand} -body { chan copy foo } -returnCodes error -result "wrong # args: should be \"chan copy input output ?-size size? ?-command callback?\"" test chan-6.1 {chan command: eof subcommand} -body { chan eof foo bar } -returnCodes error -result "wrong # args: should be \"chan eof channel\"" test chan-7.1 {chan command: event subcommand} -body { chan event foo } -returnCodes error -result "wrong # args: should be \"chan event channel event ?script?\"" test chan-8.1 {chan command: flush subcommand} -body { chan flush foo bar } -returnCodes error -result "wrong # args: should be \"chan flush channel\"" test chan-9.1 {chan command: gets subcommand} -body { chan gets } -returnCodes error -result "wrong # args: should be \"chan gets channel ?varName?\"" test chan-10.1 {chan command: names subcommand} -body { chan names foo bar } -returnCodes error -result "wrong # args: should be \"chan names ?pattern?\"" test chan-11.1 {chan command: puts subcommand} -body { chan puts foo bar foo bar } -returnCodes error -result "wrong # args: should be \"chan puts ?-nonewline? ?channel? string\"" test chan-12.1 {chan command: read subcommand} -body { chan read } -returnCodes error -result "wrong # args: should be \"chan read channel ?numChars?\" or \"chan read ?-nonewline? channel\"" test chan-13.1 {chan command: seek subcommand} -body { chan seek foo bar foo bar } -returnCodes error -result "wrong # args: should be \"chan seek channel offset ?origin?\"" test chan-14.1 {chan command: tell subcommand} -body { chan tell foo bar } -returnCodes error -result "wrong # args: should be \"chan tell channel\"" test chan-15.1 {chan command: truncate subcommand} -body { chan truncate foo bar foo bar } -returnCodes error -result "wrong \# args: should be \"chan truncate channel ?length?\"" test chan-15.2 {chan command: truncate subcommand} -setup { set file [makeFile {} testTruncate] set f [open $file w+] fconfigure $f -translation binary } -body { seek $f 0 puts -nonewline $f 12345 seek $f 0 chan truncate $f 2 read $f } -result 12 -cleanup { catch {close $f} catch {removeFile $file} } # TIP 287: chan pending test chan-16.1 {chan command: pending subcommand} -body { chan pending } -returnCodes error -result "wrong # args: should be \"chan pending mode channel\"" test chan-16.2 {chan command: pending subcommand} -body { chan pending stdin } -returnCodes error -result "wrong # args: should be \"chan pending mode channel\"" test chan-16.3 {chan command: pending subcommand} -body { chan pending stdin stdout stderr } -returnCodes error -result "wrong # args: should be \"chan pending mode channel\"" test chan-16.4 {chan command: pending subcommand} -body { chan pending {input output} stdout } -returnCodes error -result "bad mode \"input output\": must be input or output" test chan-16.5 {chan command: pending input subcommand} -body { chan pending input stdout } -result -1 test chan-16.6 {chan command: pending input subcommand} -body { |
︙ | ︙ |
Changes to tests/chanio.test.
︙ | ︙ | |||
5501 5502 5503 5504 5505 5506 5507 | } -cleanup { file delete ./~ ;# ./ because don't want to delete home in case of bugs! cd $curdir } -result 1 test chan-io-41.1 {Tcl_FileeventCmd: errors} -constraints fileevent -body { chan event foo | | | | 5501 5502 5503 5504 5505 5506 5507 5508 5509 5510 5511 5512 5513 5514 5515 5516 5517 5518 | } -cleanup { file delete ./~ ;# ./ because don't want to delete home in case of bugs! cd $curdir } -result 1 test chan-io-41.1 {Tcl_FileeventCmd: errors} -constraints fileevent -body { chan event foo } -returnCodes error -result {wrong # args: should be "chan event channel event ?script?"} test chan-io-41.2 {Tcl_FileeventCmd: errors} -constraints fileevent -body { chan event foo bar baz q } -returnCodes error -result {wrong # args: should be "chan event channel event ?script?"} test chan-io-41.3 {Tcl_FileeventCmd: errors} -constraints fileevent -body { chan event gorp readable } -returnCodes error -result {can not find channel named "gorp"} test chan-io-41.4 {Tcl_FileeventCmd: errors} -constraints fileevent -body { chan event gorp writable } -returnCodes error -result {can not find channel named "gorp"} test chan-io-41.5 {Tcl_FileeventCmd: errors} -constraints fileevent -body { |
︙ | ︙ |
Changes to tests/coroutine.test.
︙ | ︙ | |||
821 822 823 824 825 826 827 | # c1. After the fix, that doesn't happen, so if c1 still exists call it # one final time to allow it to finish and clean up rename c1 {} } return [list $done0 $done1] } -result {failure failure} | < < < < < < < < < < < < < < < < | | | > | 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 | # c1. After the fix, that doesn't happen, so if c1 still exists call it # one final time to allow it to finish and clean up rename c1 {} } return [list $done0 $done1] } -result {failure failure} test coroutine-8.1.1 {coro inject, ticket 42202ba1e5ff566e} -body { interp create child child eval { coroutine demo apply {{} { while {1} yield }} demo coroinject demo set ::result inject-executed } interp delete child } -result {} test coroutine-8.1.2 {coro inject with result, ticket 42202ba1e5ff566e} -body { interp create child child eval { coroutine demo apply {{} { while {1} yield }} demo coroinject demo lappend ::result inject-executed } child eval demo set result [child eval {set ::result}] interp delete child set result } -result {inject-executed yield {}} test coroutine-9.1 {coroprobe with yield} -body { coroutine demo apply {{} { foreach i {1 2} yield }} list [coroprobe demo set i] [demo] [coroprobe demo set i] [demo] } -cleanup { catch {rename demo {}} } -result {1 {} 2 {}} |
︙ | ︙ | |||
1033 1034 1035 1036 1037 1038 1039 | test coroutine-12.1 {coroutine general introspection} -setup { set i [interp create] } -body { $i eval { # Make the introspection code namespace path tcl::unsupported | | | | 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 | test coroutine-12.1 {coroutine general introspection} -setup { set i [interp create] } -body { $i eval { # Make the introspection code namespace path tcl::unsupported proc probe {var type args} { upvar 1 $var v set f [info frame] incr f -1 set result [list $v [dict get [info frame $f] proc]] if {$type eq "yield"} { tailcall yield $result } else { tailcall yieldto string cat $result } } proc pokecoro {c var} { coroinject $c probe $var $c } # Coroutine implementations proc cbody1 {} { set val [info coroutine] set accum {} |
︙ | ︙ |
Changes to tests/expr.test.
︙ | ︙ | |||
5838 5839 5840 5841 5842 5843 5844 | [expr {$max_long_str + 0}] \ [expr {$max_long + 0}] \ [expr {2147483647 + 0}] \ [expr {$max_long == $max_long_hex}] \ [expr {int(2147483647 + 1) > 0}] \ } {2147483647 2147483647 2147483647 2147483647 1 1} | | | 5838 5839 5840 5841 5842 5843 5844 5845 5846 5847 5848 5849 5850 5851 5852 | [expr {$max_long_str + 0}] \ [expr {$max_long + 0}] \ [expr {2147483647 + 0}] \ [expr {$max_long == $max_long_hex}] \ [expr {int(2147483647 + 1) > 0}] \ } {2147483647 2147483647 2147483647 2147483647 1 1} test expr-33.2 {parse smallest long value} { set min_long_str -2147483648 set min_long_hex "-0x80000000 " set min_long -2147483648 # This will convert to integer (not wide) internal rep string is integer $min_long |
︙ | ︙ |
Changes to tests/format.test.
︙ | ︙ | |||
11 12 13 14 15 16 17 | # of this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { package require tcltest 2.5 namespace import -force ::tcltest::* } | | < < < | < < < | < < < | < < < | < < < | < < < | < < < | 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 | # of this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { package require tcltest 2.5 namespace import -force ::tcltest::* } # %z/%t/%p output depends on pointerSize, so some tests are not portable. testConstraint pointerIs64bit [expr {$tcl_platform(pointerSize) >= 8}] # MSVC uses a broken libc that gets sprintf("%g") wrong. This is a pain # particularly in Continuous Integration, and there isn't anything much we can # do about it. testConstraint knownMsvcBug [expr {![string match msvc-* [tcl::build-info compiler]]}] test format-1.1 {integer formatting} { format "%*d %d %d %d" 6 34 16923 -12 -1 } { 34 16923 -12 -1} test format-1.2 {integer formatting} { format "%4d %4d %4d %4d %d %#x %#X" 6 34 16923 -12 -1 14 12 } { 6 34 16923 -12 -1 0xe 0xC} test format-1.3 {integer formatting} { format "%4u %4u %4u %4u %d %#o" 6 34 16923 -12 -1 0 } { 6 34 16923 4294967284 -1 0} test format-1.4 {integer formatting} { format "%-4d %-4i %-4d %-4ld" 6 34 16923 -12 -1 } {6 34 16923 -12 } test format-1.5 {integer formatting} { format "%04d %04d %04d %04i" 6 34 16923 -12 -1 } {0006 0034 16923 -012} test format-1.6 {integer formatting} { format "%00*d" 6 34 } {000034} # Printing negative numbers in hex or octal format depends on word # length, so these tests are not portable. test format-1.7 {integer formatting} { format "%4x %4x %4x %4x" 6 34 16923 -12 -1 } { 6 22 421b fffffff4} test format-1.8 {integer formatting} { format "%#x %#x %#X %#X %#x" 0 6 34 16923 -12 -1 } {0 0x6 0x22 0x421B 0xfffffff4} test format-1.9 {integer formatting} { format "%#5x %#20x %#20x %#20x %#20x" 0 6 34 16923 -12 -1 } { 0 0x6 0x22 0x421b 0xfffffff4} test format-1.10 {integer formatting} { format "%-#5x %-#20x %-#20x %-#20x %-#20x" 0 6 34 16923 -12 -1 } {0 0x6 0x22 0x421b 0xfffffff4 } test format-1.11 {integer formatting} { format "%-#5o %-#20o %#-20o %#-20o %#-20o" 0 6 34 16923 -12 -1 } {0 0o6 0o42 0o41033 0o37777777764 } test format-1.12 {integer formatting} { format "%b %#b %#b %llb" 5 0 5 [expr {2**100}] } {101 0 0b101 10000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000} test format-1.13 {integer formatting} { format "%#0d %#0d %#0d %#0d %#0d" 0 6 34 16923 -12 -1 } {0 0d6 0d34 0d16923 -0d12} test format-1.14 {integer formatting} { |
︙ | ︙ | |||
552 553 554 555 556 557 558 | for {set i 290} {$i < 400} {incr i} { test format-16.[expr {$i -289}] {testing MAX_FLOAT_SIZE} { format {%s} $b } $b append b "x" } | | | | | 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 | for {set i 290} {$i < 400} {incr i} { test format-16.[expr {$i -289}] {testing MAX_FLOAT_SIZE} { format {%s} $b } $b append b "x" } test format-17.1 {testing %d with wide} { format %d 7810179016327718216 } 1819043144 test format-17.2 {testing %ld with wide} { format %ld 7810179016327718216 } 7810179016327718216 test format-17.3 {testing %ld with non-wide} { format %ld 42 } 42 test format-17.4 {testing %l with non-integer} { format %lf 1 } 1.000000 test format-17.5 {testing %llu with positive bignum} -body { format %llu 0xabcdef0123456789abcdef |
︙ | ︙ | |||
585 586 587 588 589 590 591 | lappend result [expr {$a == $b}] set b 0xaaaa append b aaaa lappend result [expr {$a == $b}] format %08x $b lappend result [expr {$a == $b}] } {1 1 1 1} | | | < | 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 | lappend result [expr {$a == $b}] set b 0xaaaa append b aaaa lappend result [expr {$a == $b}] format %08x $b lappend result [expr {$a == $b}] } {1 1 1 1} test format-18.2 {do not demote existing numeric values} { set a [expr {0xaaaaaaaaaa + 1}] set b 0xaaaaaaaaab list [format %08x $a] [expr {$a == $b}] } {aaaaaaab 1} test format-19.1 {regression test - tcl-core message by Brian Griffin on 26 0ctober 2004} -body { set x 0x8fedc654 list [expr { ~ $x }] [format %08x [expr { ~$x }]] } -match regexp -result {-2414724693 f*701239ab} test format-19.2 {Bug 1867855} { format %llx 0 } 0 test format-19.3 {Bug 2830354} { string length [format %340f 0] } 340 test format-19.4.1 {Bug d498578df4: width overflow should cause limit exceeded} -body { # in case of overflow into negative, it produces width -2 (and limit exceeded), # in case of width will be unsigned, it will be outside limit (2GB for 32bit)... # and it don't throw an error in case the bug is not fixed (and probably no segfault). format %[expr {0xffffffff - 1}]g 0 } -returnCodes error -result "max size for a Tcl value exceeded" test format-19.4.2 {Bug d498578df4: width overflow should cause limit exceeded} -body { |
︙ | ︙ |
Changes to tests/io.test.
︙ | ︙ | |||
6070 6071 6072 6073 6074 6075 6076 | set x [list [catch {open ~/foo} msg] $msg] set ::env(HOME) $home set x } {1 {couldn't open "~/foo": no such file or directory}} test io-41.1 {Tcl_FileeventCmd: errors} {fileevent} { list [catch {fileevent foo} msg] $msg | | | | 6070 6071 6072 6073 6074 6075 6076 6077 6078 6079 6080 6081 6082 6083 6084 6085 6086 6087 | set x [list [catch {open ~/foo} msg] $msg] set ::env(HOME) $home set x } {1 {couldn't open "~/foo": no such file or directory}} test io-41.1 {Tcl_FileeventCmd: errors} {fileevent} { list [catch {fileevent foo} msg] $msg } {1 {wrong # args: should be "fileevent channel event ?script?"}} test io-41.2 {Tcl_FileeventCmd: errors} {fileevent} { list [catch {fileevent foo bar baz q} msg] $msg } {1 {wrong # args: should be "fileevent channel event ?script?"}} test io-41.3 {Tcl_FileeventCmd: errors} {fileevent} { list [catch {fileevent gorp readable} msg] $msg } {1 {can not find channel named "gorp"}} test io-41.4 {Tcl_FileeventCmd: errors} {fileevent} { list [catch {fileevent gorp writable} msg] $msg } {1 {can not find channel named "gorp"}} test io-41.5 {Tcl_FileeventCmd: errors} {fileevent} { |
︙ | ︙ |
Changes to tests/ioCmd.test.
︙ | ︙ | |||
26 27 28 29 30 31 32 | # Custom constraints used in this file testConstraint testchannel [llength [info commands testchannel]] #---------------------------------------------------------------------- test iocmd-1.1 {puts command} { list [catch {puts} msg] $msg | | | | | 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 | # Custom constraints used in this file testConstraint testchannel [llength [info commands testchannel]] #---------------------------------------------------------------------- test iocmd-1.1 {puts command} { list [catch {puts} msg] $msg } {1 {wrong # args: should be "puts ?-nonewline? ?channel? string"}} test iocmd-1.2 {puts command} { list [catch {puts a b c d e f g} msg] $msg } {1 {wrong # args: should be "puts ?-nonewline? ?channel? string"}} test iocmd-1.3 {puts command} { list [catch {puts froboz -nonewline kablooie} msg] $msg } {1 {wrong # args: should be "puts ?-nonewline? ?channel? string"}} test iocmd-1.4 {puts command} { list [catch {puts froboz hello} msg] $msg } {1 {can not find channel named "froboz"}} test iocmd-1.5 {puts command} { list [catch {puts stdin hello} msg] $msg } {1 {channel "stdin" wasn't opened for writing}} |
︙ | ︙ | |||
66 67 68 69 70 71 72 | puts -nonewline $f [binary format a4a5 foo bar] close $f file size $path(test1) } 9 test iocmd-2.1 {flush command} { list [catch {flush} msg] $msg | | | | | | | | | | 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 | puts -nonewline $f [binary format a4a5 foo bar] close $f file size $path(test1) } 9 test iocmd-2.1 {flush command} { list [catch {flush} msg] $msg } {1 {wrong # args: should be "flush channel"}} test iocmd-2.2 {flush command} { list [catch {flush a b c d e} msg] $msg } {1 {wrong # args: should be "flush channel"}} test iocmd-2.3 {flush command} { list [catch {flush foo} msg] $msg } {1 {can not find channel named "foo"}} test iocmd-2.4 {flush command} { list [catch {flush stdin} msg] $msg } {1 {channel "stdin" wasn't opened for writing}} test iocmd-3.1 {gets command} { list [catch {gets} msg] $msg } {1 {wrong # args: should be "gets channel ?varName?"}} test iocmd-3.2 {gets command} { list [catch {gets a b c d e f g} msg] $msg } {1 {wrong # args: should be "gets channel ?varName?"}} test iocmd-3.3 {gets command} { list [catch {gets aaa} msg] $msg } {1 {can not find channel named "aaa"}} test iocmd-3.4 {gets command} { list [catch {gets stdout} msg] $msg } {1 {channel "stdout" wasn't opened for reading}} test iocmd-3.5 {gets command} { set f [open $path(test1) w] puts $f [binary format a4a5 foo bar] close $f set f [open $path(test1) r] set result [gets $f] close $f set x foo\x00 set x "${x}bar\x00\x00" string compare $x $result } 0 test iocmd-4.1 {read command} { list [catch {read} msg] $msg } {1 {wrong # args: should be "read channel ?numChars?" or "read ?-nonewline? channel"}} test iocmd-4.2 {read command} { list [catch {read a b c d e f g h} msg] $msg } {1 {wrong # args: should be "read channel ?numChars?" or "read ?-nonewline? channel"}} test iocmd-4.3 {read command} { list [catch {read aaa} msg] $msg } {1 {can not find channel named "aaa"}} test iocmd-4.4 {read command} { list [catch {read -nonewline} msg] $msg } {1 {wrong # args: should be "read channel ?numChars?" or "read ?-nonewline? channel"}} test iocmd-4.5 {read command} { list [catch {read -nonew file4} msg] $msg $::errorCode } {1 {can not find channel named "-nonew"} {TCL LOOKUP CHANNEL -nonew}} test iocmd-4.6 {read command} { list [catch {read stdout} msg] $msg } {1 {channel "stdout" wasn't opened for reading}} test iocmd-4.7 {read command} { list [catch {read -nonewline stdout} msg] $msg } {1 {channel "stdout" wasn't opened for reading}} test iocmd-4.8 {read command with incorrect combination of arguments} { file delete $path(test1) set f [open $path(test1) w] puts $f "Two lines: this one" puts $f "and this one" close $f set f [open $path(test1)] set x [list [catch {read -nonewline $f 20 z} msg] $msg $::errorCode] close $f set x } {1 {wrong # args: should be "read channel ?numChars?" or "read ?-nonewline? channel"} {TCL WRONGARGS}} test iocmd-4.9 {read command} { list [catch {read stdin foo} msg] $msg $::errorCode } {1 {expected non-negative integer but got "foo"} {TCL VALUE NUMBER}} test iocmd-4.10 {read command} { list [catch {read file107} msg] $msg $::errorCode } {1 {can not find channel named "file107"} {TCL LOOKUP CHANNEL file107}} set path(test3) [makeFile {} test3] |
︙ | ︙ | |||
157 158 159 160 161 162 163 | read $f 12z } -cleanup { close $f } -result {expected non-negative integer but got "12z"} -errorCode {TCL VALUE NUMBER} test iocmd-5.1 {seek command} -returnCodes error -body { seek | | | | | | | | 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 | read $f 12z } -cleanup { close $f } -result {expected non-negative integer but got "12z"} -errorCode {TCL VALUE NUMBER} test iocmd-5.1 {seek command} -returnCodes error -body { seek } -result {wrong # args: should be "seek channel offset ?origin?"} test iocmd-5.2 {seek command} -returnCodes error -body { seek a b c d e f g } -result {wrong # args: should be "seek channel offset ?origin?"} test iocmd-5.3 {seek command} -returnCodes error -body { seek stdin gugu } -result {expected integer but got "gugu"} test iocmd-5.4 {seek command} -returnCodes error -body { seek stdin 100 gugu } -result {bad origin "gugu": must be start, current, or end} test iocmd-6.1 {tell command} { list [catch {tell} msg] $msg } {1 {wrong # args: should be "tell channel"}} test iocmd-6.2 {tell command} { list [catch {tell a b c d e} msg] $msg } {1 {wrong # args: should be "tell channel"}} test iocmd-6.3 {tell command} { list [catch {tell aaa} msg] $msg } {1 {can not find channel named "aaa"}} test iocmd-7.1 {close command} { list [catch {close} msg] $msg } {1 {wrong # args: should be "close channel ?direction?"}} test iocmd-7.2 {close command} { list [catch {close a b c d e} msg] $msg } {1 {wrong # args: should be "close channel ?direction?"}} test iocmd-7.3 {close command} { list [catch {close aaa} msg] $msg } {1 {can not find channel named "aaa"}} test iocmd-7.4 {close command} -setup { set chan [open [info script] r] } -body { chan close $chan bar |
︙ | ︙ | |||
212 213 214 215 216 217 218 | } set opts [list {*}$basicOpts {*}$extra] lset opts end [string cat "or " [lindex $opts end]] return [format {bad option "%s": should be one of %s} $got [join $opts ", "]] } test iocmd-8.1 {fconfigure command} -returnCodes error -body { fconfigure | | | | 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 | } set opts [list {*}$basicOpts {*}$extra] lset opts end [string cat "or " [lindex $opts end]] return [format {bad option "%s": should be one of %s} $got [join $opts ", "]] } test iocmd-8.1 {fconfigure command} -returnCodes error -body { fconfigure } -result {wrong # args: should be "fconfigure channel ?-option value ...?"} test iocmd-8.2 {fconfigure command} -returnCodes error -body { fconfigure a b c d e f } -result {wrong # args: should be "fconfigure channel ?-option value ...?"} test iocmd-8.3 {fconfigure command} -returnCodes error -body { fconfigure a b } -result {can not find channel named "a"} test iocmd-8.4 {fconfigure command} -setup { file delete $path(test1) set f1 [open $path(test1) w] } -body { |
︙ | ︙ | |||
372 373 374 375 376 377 378 | test iocmd-8.23 {fconfigure -profile badprofile} -body { fconfigure stdin -profile froboz } -returnCodes error -result {bad profile name "froboz": must be replace, strict, or tcl8} test iocmd-9.1 {eof command} { list [catch {eof} msg] $msg $::errorCode | | | | | | 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 | test iocmd-8.23 {fconfigure -profile badprofile} -body { fconfigure stdin -profile froboz } -returnCodes error -result {bad profile name "froboz": must be replace, strict, or tcl8} test iocmd-9.1 {eof command} { list [catch {eof} msg] $msg $::errorCode } {1 {wrong # args: should be "eof channel"} {TCL WRONGARGS}} test iocmd-9.2 {eof command} { list [catch {eof a b} msg] $msg $::errorCode } {1 {wrong # args: should be "eof channel"} {TCL WRONGARGS}} test iocmd-9.3 {eof command} { catch {close file100} list [catch {eof file100} msg] $msg $::errorCode } {1 {can not find channel named "file100"} {TCL LOOKUP CHANNEL file100}} # The tests for Tcl_ExecObjCmd are in exec.test test iocmd-10.1 {fblocked command} { list [catch {fblocked} msg] $msg } {1 {wrong # args: should be "fblocked channel"}} test iocmd-10.2 {fblocked command} { list [catch {fblocked a b c d e f g} msg] $msg } {1 {wrong # args: should be "fblocked channel"}} test iocmd-10.3 {fblocked command} { list [catch {fblocked file1000} msg] $msg } {1 {can not find channel named "file1000"}} test iocmd-10.4 {fblocked command} { list [catch {fblocked stdout} msg] $msg } {1 {channel "stdout" wasn't opened for reading}} test iocmd-10.5 {fblocked command} { |
︙ | ︙ |
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/namespace.test.
︙ | ︙ | |||
3366 3367 3368 3369 3370 3371 3372 3373 3374 3375 3376 3377 3378 3379 | rename getbytes {} unset i ns start end } -result 0 test namespace-55.1 {compiled ensembles inside compiled ensembles: Bug 6d2f249a01} { info class [format %s constructor] oo::object } "" test namespace-56.1 {bug f97d4ee020: mutually-entangled deletion} { namespace eval ::testing { proc abc {} {} proc def {} {} trace add command abc delete "rename ::testing::def {}; #" trace add command def delete "rename ::testing::abc {}; #" | > > > > > > > > > > > > > > > > | 3366 3367 3368 3369 3370 3371 3372 3373 3374 3375 3376 3377 3378 3379 3380 3381 3382 3383 3384 3385 3386 3387 3388 3389 3390 3391 3392 3393 3394 3395 | rename getbytes {} unset i ns start end } -result 0 test namespace-55.1 {compiled ensembles inside compiled ensembles: Bug 6d2f249a01} { info class [format %s constructor] oo::object } "" test namespace-55.2 {compiled ensembles inside safe interpreters (for safe sub-commands), bug [1095bf7f756f9aed]} -setup { interp create -safe si set code { proc test_comp_dict d { dict for {k v} $d {expr $v} } regexp -inline {Command 1:(?:[^\n]*\n){1,5}} [::tcl::unsupported::disassemble proc test_comp_dict] } } -body { set a [ eval $code] set b [si eval $code] list [expr {$a eq $b}] [regexp { dictFirst } $a] [regexp { dictFirst } $b] $a $b } -cleanup { rename test_comp_dict {} unset -nocomplain code a b interp delete si } -match glob -result {1 1 1 *} test namespace-56.1 {bug f97d4ee020: mutually-entangled deletion} { namespace eval ::testing { proc abc {} {} proc def {} {} trace add command abc delete "rename ::testing::def {}; #" trace add command def delete "rename ::testing::abc {}; #" |
︙ | ︙ |
Changes to tests/obj.test.
︙ | ︙ | |||
16 17 18 19 20 21 22 | namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands catch [list package require -exact tcl::test [info patchlevel]] testConstraint testobj [llength [info commands testobj]] | < | 16 17 18 19 20 21 22 23 24 25 26 27 28 29 | namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands catch [list package require -exact tcl::test [info patchlevel]] testConstraint testobj [llength [info commands testobj]] testConstraint wideIs64bit [expr {wide(0x8000000000000000) < 0}] test obj-1.1 {Tcl_AppendAllObjTypes, and InitTypeTable, Tcl_RegisterObjType} testobj { set r 1 foreach {t} { bytecode cmdName |
︙ | ︙ | |||
543 544 545 546 547 548 549 | set x {} for {set i 0} {$i<100000} {incr i} { set x [list $x {}] } unset x } {} | | | | | | | 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 | set x {} for {set i 0} {$i<100000} {incr i} { set x [list $x {}] } unset x } {} test obj-33.1 {integer overflow on input} {wideIs64bit} { set x 0x8000; append x 0000 list [string is integer $x] [expr { wide($x) }] } {1 2147483648} test obj-33.2 {integer overflow on input} {wideIs64bit} { set x 0xffff; append x ffff list [string is integer $x] [expr { wide($x) }] } {1 4294967295} test obj-33.3 {integer overflow on input} { set x 0x10000; append x 0000 list [string is integer $x] [expr { wide($x) }] } {1 4294967296} test obj-33.4 {integer overflow on input} {wideIs64bit} { set x -0x8000; append x 0000 list [string is integer $x] [expr { wide($x) }] } {1 -2147483648} test obj-33.5 {integer overflow on input} {wideIs64bit} { set x -0x8000; append x 0001 list [string is integer $x] [expr { wide($x) }] } {1 -2147483649} test obj-33.6 {integer overflow on input} {wideIs64bit} { set x -0xffff; append x ffff list [string is integer $x] [expr { wide($x) }] } {1 -4294967295} test obj-33.7 {integer overflow on input} { set x -0x10000; append x 0000 list [string is integer $x] [expr { wide($x) }] } {1 -4294967296} |
︙ | ︙ |
Changes to tests/pid.test.
︙ | ︙ | |||
43 44 45 46 47 48 49 | close $f set pids } -cleanup { removeFile test1 } -result {} test pid-1.4 {pid command} pidDefined { list [catch {pid a b} msg] $msg | | | 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 | close $f set pids } -cleanup { removeFile test1 } -result {} test pid-1.4 {pid command} pidDefined { list [catch {pid a b} msg] $msg } {1 {wrong # args: should be "pid ?channel?"}} test pid-1.5 {pid command} pidDefined { list [catch {pid gorp} msg] $msg } {1 {can not find channel named "gorp"}} # cleanup ::tcltest::cleanupTests return |
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 tests/scan.test.
︙ | ︙ | |||
78 79 80 81 82 83 84 | default { return 0 } } } testConstraint ieeeFloatingPoint [testIEEE] | < | 78 79 80 81 82 83 84 85 86 87 88 89 90 91 | default { return 0 } } } testConstraint ieeeFloatingPoint [testIEEE] test scan-1.1 {BuildCharSet, CharInSet} { list [scan foo {%[^o]} x] $x } {1 f} test scan-1.2 {BuildCharSet, CharInSet} { list [scan \]foo {%[]f]} x] $x } {1 \]f} |
︙ | ︙ | |||
513 514 515 516 517 518 519 | # test scan-5.11 {integer scanning} -constraints {nonPortable} -setup { set a {}; set b {} } -body { list [scan "4294967280 4294967280" "%u %d" a b] $a \ [expr {$b == -16 || $b == 0x7fffffff}] } -result {2 4294967280 1} | | | 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 | # test scan-5.11 {integer scanning} -constraints {nonPortable} -setup { set a {}; set b {} } -body { list [scan "4294967280 4294967280" "%u %d" a b] $a \ [expr {$b == -16 || $b == 0x7fffffff}] } -result {2 4294967280 1} test scan-5.12 {integer scanning} -setup { set a {}; set b {}; set c {} } -body { list [scan "7810179016327718216,6c63546f6c6c6548,661432506755433062510" \ %ld,%lx,%lo a b c] $a $b $c } -result {3 7810179016327718216 7810179016327718216 7810179016327718216} test scan-5.13 {integer scanning and overflow} { # This test used to fail on some 64-bit systems. [Bug 1011860] |
︙ | ︙ |
Changes to tests/trace.test.
︙ | ︙ | |||
1691 1692 1693 1694 1695 1696 1697 | set {*}$args } test trace-21.12 {bug 2438181} -setup { trace add execution set2 leave {puts one two three #;} } -body { set2 a hello | | | 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 | set {*}$args } test trace-21.12 {bug 2438181} -setup { trace add execution set2 leave {puts one two three #;} } -body { set2 a hello } -returnCodes 1 -result {wrong # args: should be "puts ?-nonewline? ?channel? string"} proc factorial {n} { if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] } return 1 } test trace-22.1 {recursive(1) trace execution: enter} { |
︙ | ︙ |
Changes to unix/Makefile.in.
︙ | ︙ | |||
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/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/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 |
︙ | ︙ | |||
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/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/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/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/tclUnixPipe.c.
︙ | ︙ | |||
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; } /* *---------------------------------------------------------------------- |
︙ | ︙ | |||
1376 1377 1378 1379 1380 1381 1382 | { Tcl_Channel chan; PipeState *pipePtr; size_t i; Tcl_Obj *resultPtr; if (objc > 2) { | | | 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 | { Tcl_Channel chan; PipeState *pipePtr; size_t i; Tcl_Obj *resultPtr; if (objc > 2) { Tcl_WrongNumArgs(interp, 1, objv, "?channel?"); return TCL_ERROR; } if (objc == 1) { Tcl_SetObjResult(interp, Tcl_NewWideIntObj(getpid())); } else { /* |
︙ | ︙ |
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. */ |
︙ | ︙ | |||
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; } |
︙ | ︙ | |||
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 win/Makefile.in.
︙ | ︙ | |||
603 604 605 606 607 608 609 | @$(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) \ | | | 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 | @$(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/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/tclWinDde.c.
︙ | ︙ | |||
1320 1321 1322 1323 1324 1325 1326 | enum DdeSrvOptions { DDE_SERVERNAME_EXACT, DDE_SERVERNAME_HANDLER, DDE_SERVERNAME_LAST, }; static const char *const ddeExecOptions[] = { "-async", "-binary", NULL }; enum DdeExecOptions { | | | 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 | enum DdeSrvOptions { DDE_SERVERNAME_EXACT, DDE_SERVERNAME_HANDLER, DDE_SERVERNAME_LAST, }; static const char *const ddeExecOptions[] = { "-async", "-binary", NULL }; enum DdeExecOptions { DDE_EXEC_ASYNC, DDE_EXEC_BINARY }; static const char *const ddeEvalOptions[] = { "-async", NULL }; static const char *const ddeReqOptions[] = { "-binary", NULL }; |
︙ | ︙ |
Changes to win/tclWinFCmd.c.
︙ | ︙ | |||
1707 1708 1709 1710 1711 1712 1713 | * fprintf(stderr, "%d\n", ((WCHAR *) nativeName)[0]); */ Tcl_DStringInit(&dsTemp); Tcl_WCharToUtfDString(nativeName, TCL_INDEX_NONE, &dsTemp); Tcl_DStringFree(&ds); | | | | 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 | * fprintf(stderr, "%d\n", ((WCHAR *) nativeName)[0]); */ Tcl_DStringInit(&dsTemp); Tcl_WCharToUtfDString(nativeName, TCL_INDEX_NONE, &dsTemp); Tcl_DStringFree(&ds); tempPath = Tcl_DStringToObj(&dsTemp); Tcl_ListObjReplace(NULL, splitPath, i, 1, 1, &tempPath); FindClose(handle); } } *attributePtrPtr = Tcl_FSJoinPath(splitPath, TCL_INDEX_NONE); if (splitPath != NULL) { |
︙ | ︙ |
Changes to win/tclWinFile.c.
︙ | ︙ | |||
1434 1435 1436 1437 1438 1439 1440 | Tcl_DStringInit(bufferPtr); wDomain = NULL; domain = Tcl_UtfFindFirst(name, '@'); if (domain == NULL) { const char *ptr; | | | | | | | | | | | | | | | | | | | 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 | Tcl_DStringInit(bufferPtr); wDomain = NULL; domain = Tcl_UtfFindFirst(name, '@'); if (domain == NULL) { const char *ptr; /* * Treat the current user as a special case because the general case * below does not properly retrieve the path. The NetUserGetInfo * call returns an empty path and the code defaults to the user's * name in the profiles directory. On modern Windows systems, this * is generally wrong as when the account is a Microsoft account, * for example [email protected], the directory name is * abcde and not abcdefghi. * * Note we could have just used env(USERPROFILE) here but * the intent is to retrieve (as on Unix) the system's view * of the home irrespective of environment settings of HOME * and USERPROFILE. * * Fixing this for the general user needs more investigating but * at least for the current user we can use a direct call. */ ptr = TclpGetUserName(&ds); if (ptr != NULL && strcasecmp(name, ptr) == 0) { HANDLE hProcess; WCHAR buf[MAX_PATH]; DWORD nChars = sizeof(buf) / sizeof(buf[0]); /* Sadly GetCurrentProcessToken not in Win 7 so slightly longer */ hProcess = GetCurrentProcess(); /* Need not be closed */ |
︙ | ︙ | |||
2050 2051 2052 2053 2054 2055 2056 | NULL, OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS | FILE_FLAG_OPEN_REPARSE_POINT, NULL); if (fileHandle != INVALID_HANDLE_VALUE) { BY_HANDLE_FILE_INFORMATION data; if (GetFileInformationByHandle(fileHandle,&data) != TRUE) { | | | | | | | | | | | | | | | | | | | 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 | NULL, OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS | FILE_FLAG_OPEN_REPARSE_POINT, NULL); if (fileHandle != INVALID_HANDLE_VALUE) { BY_HANDLE_FILE_INFORMATION data; if (GetFileInformationByHandle(fileHandle,&data) != TRUE) { fileType = GetFileType(fileHandle); CloseHandle(fileHandle); if (fileType != FILE_TYPE_CHAR && fileType != FILE_TYPE_DISK) { Tcl_SetErrno(ENOENT); return -1; } /* * Mock up the expected structure */ memset(&data, 0, sizeof(data)); statPtr->st_atime = 0; statPtr->st_mtime = 0; statPtr->st_ctime = 0; } else { CloseHandle(fileHandle); statPtr->st_atime = ToCTime(data.ftLastAccessTime); statPtr->st_mtime = ToCTime(data.ftLastWriteTime); statPtr->st_ctime = ToCTime(data.ftCreationTime); } attr = data.dwFileAttributes; statPtr->st_size = ((long long) data.nFileSizeLow) | (((long long) data.nFileSizeHigh) << 32); /* * On Unix, for directories, nlink apparently depends on the number of * files in the directory. We could calculate that, but it would be a |
︙ | ︙ | |||
2130 2131 2132 2133 2134 2135 2136 | statPtr->st_mtime = ToCTime(data.ftLastWriteTime); statPtr->st_ctime = ToCTime(data.ftCreationTime); } dev = NativeDev(nativePath); mode = NativeStatMode(attr, checkLinks, NativeIsExec(nativePath)); if (fileType == FILE_TYPE_CHAR) { | | | | | | 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 | statPtr->st_mtime = ToCTime(data.ftLastWriteTime); statPtr->st_ctime = ToCTime(data.ftCreationTime); } dev = NativeDev(nativePath); mode = NativeStatMode(attr, checkLinks, NativeIsExec(nativePath)); if (fileType == FILE_TYPE_CHAR) { mode &= ~S_IFMT; mode |= S_IFCHR; } else if (fileType == FILE_TYPE_DISK) { mode &= ~S_IFMT; mode |= S_IFBLK; } statPtr->st_dev = (dev_t) dev; statPtr->st_ino = inode; statPtr->st_mode = mode; statPtr->st_nlink = nlink; statPtr->st_uid = 0; |
︙ | ︙ | |||
3276 3277 3278 3279 3280 3281 3282 | int owned = 0; native = (const WCHAR *)Tcl_FSGetNativePath(pathPtr); if (GetNamedSecurityInfoW((LPWSTR) native, SE_FILE_OBJECT, OWNER_SECURITY_INFORMATION, &ownerSid, NULL, NULL, NULL, &secd) != ERROR_SUCCESS) { | | | | | | | | | | | | | | | | 3276 3277 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 | int owned = 0; native = (const WCHAR *)Tcl_FSGetNativePath(pathPtr); if (GetNamedSecurityInfoW((LPWSTR) native, SE_FILE_OBJECT, OWNER_SECURITY_INFORMATION, &ownerSid, NULL, NULL, NULL, &secd) != ERROR_SUCCESS) { /* * Either not a file, or we do not have access to it in which case we * are in all likelihood not the owner. */ return 0; } /* * Getting the current process SID is a multi-step process. We make the * assumption that if a call fails, this process is so underprivileged it * could not possibly own anything. Normally a process can *always* look * up its own token. */ if (OpenProcessToken(GetCurrentProcess(), TOKEN_QUERY, &token)) { /* * Find out how big the buffer needs to be. */ bufsz = 0; GetTokenInformation(token, TokenUser, NULL, 0, &bufsz); if (bufsz) { buf = (LPBYTE)Tcl_Alloc(bufsz); if (GetTokenInformation(token, TokenUser, buf, bufsz, &bufsz)) { owned = EqualSid(ownerSid, ((PTOKEN_USER) buf)->User.Sid); } } CloseHandle(token); } /* * Free allocations and be done. */ if (secd) { LocalFree(secd); /* Also frees ownerSid */ } if (buf) { Tcl_Free(buf); } return (owned != 0); /* Convert non-0 to 1 */ } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
Changes to win/tclWinInit.c.
︙ | ︙ | |||
512 513 514 515 516 517 518 | if (ptr != NULL) { Tcl_DStringAppend(&ds, ptr, TCL_INDEX_NONE); } if (Tcl_DStringLength(&ds) > 0) { Tcl_SetVar2(interp, "env", "HOME", Tcl_DStringValue(&ds), TCL_GLOBAL_ONLY); } else { | | | | | | | | | | 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 | if (ptr != NULL) { Tcl_DStringAppend(&ds, ptr, TCL_INDEX_NONE); } if (Tcl_DStringLength(&ds) > 0) { Tcl_SetVar2(interp, "env", "HOME", Tcl_DStringValue(&ds), TCL_GLOBAL_ONLY); } else { /* None of HOME, HOMEDRIVE, HOMEPATH exists. Try USERPROFILE */ ptr = Tcl_GetVar2(interp, "env", "USERPROFILE", TCL_GLOBAL_ONLY); if (ptr != NULL && ptr[0]) { Tcl_SetVar2(interp, "env", "HOME", ptr, TCL_GLOBAL_ONLY); } else { /* Last resort */ Tcl_SetVar2(interp, "env", "HOME", "c:\\", TCL_GLOBAL_ONLY); } } } /* * Initialize the user name from the environment first, since this is much * faster than asking the system. * Note: cchUserNameLen is number of characters including nul terminator. |
︙ | ︙ |
Changes to win/tclWinLoad.c.
︙ | ︙ | |||
86 87 88 89 90 91 92 | * 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. */ Tcl_DString ds; | | | | | | | | | | | | | | | | | | 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 | * 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. */ Tcl_DString ds; /* * Remember the first error on load attempt to be used if the * second load attempt below also fails. */ firstError = (nativeName == NULL) ? ERROR_MOD_NOT_FOUND : GetLastError(); Tcl_DStringInit(&ds); nativeName = Tcl_UtfToWCharDString(TclGetString(pathPtr), TCL_INDEX_NONE, &ds); hInstance = LoadLibraryExW(nativeName, NULL, LOAD_WITH_ALTERED_SEARCH_PATH); Tcl_DStringFree(&ds); } if (hInstance == NULL) { DWORD lastError; Tcl_Obj *errMsg; /* * We choose to only use the error from the second call if the first * call failed due to the file not being found. Else stick to the * first error for reporting purposes. */ if (firstError == ERROR_MOD_NOT_FOUND || firstError == ERROR_DLL_NOT_FOUND) { lastError = GetLastError(); } else { lastError = firstError; } errMsg = Tcl_ObjPrintf("couldn't load library \"%s\": ", TclGetString(pathPtr)); /* * Check for possible DLL errors. This doesn't work quite right, * because Windows seems to only return ERROR_MOD_NOT_FOUND for just |
︙ | ︙ | |||
153 154 155 156 157 158 159 | " is damaged", TCL_INDEX_NONE); break; case ERROR_DLL_INIT_FAILED: Tcl_SetErrorCode(interp, "WIN_LOAD", "DLL_INIT_FAILED", (char *)NULL); Tcl_AppendToObj(errMsg, "the library initialization" " routine failed", TCL_INDEX_NONE); break; | | | | | 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 | " is damaged", TCL_INDEX_NONE); break; case ERROR_DLL_INIT_FAILED: Tcl_SetErrorCode(interp, "WIN_LOAD", "DLL_INIT_FAILED", (char *)NULL); Tcl_AppendToObj(errMsg, "the library initialization" " routine failed", TCL_INDEX_NONE); break; case ERROR_BAD_EXE_FORMAT: Tcl_SetErrorCode(interp, "WIN_LOAD", "BAD_EXE_FORMAT", (char *)NULL); Tcl_AppendToObj(errMsg, "Bad exe format. Possibly a 32/64-bit mismatch.", TCL_INDEX_NONE); break; default: Tcl_WinConvertError(lastError); Tcl_AppendToObj(errMsg, Tcl_PosixError(interp), TCL_INDEX_NONE); } Tcl_SetObjResult(interp, errMsg); } return TCL_ERROR; } |
︙ | ︙ |
Changes to win/tclWinPipe.c.
︙ | ︙ | |||
2758 2759 2760 2761 2762 2763 2764 | Tcl_Channel chan; const Tcl_ChannelType *chanTypePtr; PipeInfo *pipePtr; size_t i; Tcl_Obj *resultPtr; if (objc > 2) { | | | 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 2771 2772 | Tcl_Channel chan; const Tcl_ChannelType *chanTypePtr; PipeInfo *pipePtr; size_t i; Tcl_Obj *resultPtr; if (objc > 2) { Tcl_WrongNumArgs(interp, 1, objv, "?channel?"); return TCL_ERROR; } if (objc == 1) { Tcl_SetObjResult(interp, Tcl_NewWideIntObj(getpid())); } else { chan = Tcl_GetChannel(interp, TclGetString(objv[1]), NULL); |
︙ | ︙ |