Many hyperlinks are disabled.
Use anonymous login
to enable hyperlinks.
Overview
| Comment: | Merge trunk |
|---|---|
| Timelines: | family | ancestors | descendants | both | regexp-api-64bit |
| Files: | files | file ages | folders |
| SHA3-256: |
f0009090a2224d6682c67f2823fa333a |
| User & Date: | jan.nijtmans 2019-05-10 07:50:31.334 |
Context
|
2019-05-31
| ||
| 12:50 | TIP 537 implementation: Enable 64-bit indexes in regexp matching check-in: 6e8aae14c1 user: jan.nijtmans tags: trunk | |
|
2019-05-10
| ||
| 07:50 | Merge trunk Closed-Leaf check-in: f0009090a2 user: jan.nijtmans tags: regexp-api-64bit | |
|
2019-05-09
| ||
| 20:42 | Merge 8.7. Define Tcl_GetStringResult() as macro. check-in: 02588757a0 user: jan.nijtmans tags: trunk | |
|
2019-04-02
| ||
| 20:09 | Merge trunk check-in: 85c116565b user: jan.nijtmans tags: regexp-api-64bit | |
Changes
Changes to .travis.yml.
| ︙ | ︙ | |||
154 155 156 157 158 159 160 161 162 163 164 165 166 167 |
packages:
- gcc-mingw-w64-base
- binutils-mingw-w64-i686
- gcc-mingw-w64-i686
- gcc-mingw-w64
- gcc-multilib
- wine
env:
- BUILD_DIR=win
- CFGOPT="--host=i686-w64-mingw32 CFLAGS=-DTCL_UTF_MAX=6"
- NO_DIRECT_TEST=1
- os: linux
dist: xenial
compiler: i686-w64-mingw32-gcc
| > > > > > > > > > > > > > > > > | 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 |
packages:
- gcc-mingw-w64-base
- binutils-mingw-w64-i686
- gcc-mingw-w64-i686
- gcc-mingw-w64
- gcc-multilib
- wine
env:
- BUILD_DIR=win
- CFGOPT="--host=i686-w64-mingw32 --disable-shared"
- NO_DIRECT_TEST=1
- os: linux
dist: xenial
compiler: i686-w64-mingw32-gcc
addons:
apt:
packages:
- gcc-mingw-w64-base
- binutils-mingw-w64-i686
- gcc-mingw-w64-i686
- gcc-mingw-w64
- gcc-multilib
- wine
env:
- BUILD_DIR=win
- CFGOPT="--host=i686-w64-mingw32 CFLAGS=-DTCL_UTF_MAX=6"
- NO_DIRECT_TEST=1
- os: linux
dist: xenial
compiler: i686-w64-mingw32-gcc
|
| ︙ | ︙ | |||
207 208 209 210 211 212 213 214 215 216 217 218 219 220 |
- gcc-mingw-w64
- wine
env:
- BUILD_DIR=win
- CFGOPT="--host=x86_64-w64-mingw32 --enable-64bit"
- NO_DIRECT_TEST=1
- os: linux
dist: xenial
compiler: x86_64-w64-mingw32-gcc
addons:
apt:
packages:
- gcc-mingw-w64-base
- binutils-mingw-w64-x86-64
| > > > > > > > > > > > > > > > | 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 |
- gcc-mingw-w64
- wine
env:
- BUILD_DIR=win
- CFGOPT="--host=x86_64-w64-mingw32 --enable-64bit"
- NO_DIRECT_TEST=1
- os: linux
dist: xenial
compiler: x86_64-w64-mingw32-gcc
addons:
apt:
packages:
- gcc-mingw-w64-base
- binutils-mingw-w64-x86-64
- gcc-mingw-w64-x86-64
- gcc-mingw-w64
- wine
env:
- BUILD_DIR=win
- CFGOPT="--host=x86_64-w64-mingw32 --enable-64bit --disable-shared"
- NO_DIRECT_TEST=1
- os: linux
dist: xenial
compiler: x86_64-w64-mingw32-gcc
addons:
apt:
packages:
- gcc-mingw-w64-base
- binutils-mingw-w64-x86-64
|
| ︙ | ︙ |
Changes to doc/LinkVar.3.
1 2 3 4 5 6 7 8 9 10 11 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-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 Tcl_LinkVar 3 7.5 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME | | > > > > > | | > > > > > > | | | > > > > > > > > > > | | > > > > > > > > > > > > > | > | > | > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > | > | > | > | > | > | > > | > | | | > | > > | 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 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-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 Tcl_LinkVar 3 7.5 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME Tcl_LinkArray, Tcl_LinkVar, Tcl_UnlinkVar, Tcl_UpdateLinkedVar \- link Tcl variable to C variable .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp int \fBTcl_LinkVar\fR(\fIinterp, varName, addr, type\fR) .sp .VS "TIP 312" int \fBTcl_LinkArray\fR(\fIinterp, varName, addr, type, size\fR) .VE "TIP 312" .sp \fBTcl_UnlinkVar\fR(\fIinterp, varName\fR) .sp \fBTcl_UpdateLinkedVar\fR(\fIinterp, varName\fR) .SH ARGUMENTS .AS Tcl_Interp varName in .AP Tcl_Interp *interp in Interpreter that contains \fIvarName\fR. Also used by \fBTcl_LinkVar\fR to return error messages. .AP "const char" *varName in Name of global variable. .AP void *addr in Address of C variable that is to be linked to \fIvarName\fR. .sp .VS "TIP 312" In \fBTcl_LinkArray\fR, may be NULL to tell Tcl to create the storage for the array in the variable. .VE "TIP 312" .AP int type in Type of C variable for \fBTcl_LinkVar\fR or type of array element for \fBTcl_LinkArray\fR. Must be one of \fBTCL_LINK_INT\fR, \fBTCL_LINK_UINT\fR, \fBTCL_LINK_CHAR\fR, \fBTCL_LINK_UCHAR\fR, \fBTCL_LINK_SHORT\fR, \fBTCL_LINK_USHORT\fR, \fBTCL_LINK_LONG\fR, \fBTCL_LINK_ULONG\fR, \fBTCL_LINK_WIDE_INT\fR, \fBTCL_LINK_WIDE_UINT\fR, \fBTCL_LINK_FLOAT\fR, \fBTCL_LINK_DOUBLE\fR, \fBTCL_LINK_BOOLEAN\fR, or one of the extra ones listed below. .sp In \fBTcl_LinkVar\fR, the additional linked type \fBTCL_LINK_STRING\fR may be used. .sp .VS "TIP 312" In \fBTcl_LinkArray\fR, the additional linked types \fBTCL_LINK_CHARS\fR and \fBTCL_LINK_BYTES\fR may be used. .VE "TIP 312" .sp All the above for both functions may be optionally OR'ed with \fBTCL_LINK_READ_ONLY\fR to make the Tcl variable read-only. .AP int size in .VS "TIP 312" The number of elements in the C array. Must be greater than zero. .VE "TIP 312" .BE .SH DESCRIPTION .PP \fBTcl_LinkVar\fR uses variable traces to keep the Tcl variable named by \fIvarName\fR in sync with the C variable at the address given by \fIaddr\fR. Whenever the Tcl variable is read the value of the C variable will be returned, and whenever the Tcl variable is written the C variable will be updated to have the same value. \fBTcl_LinkVar\fR normally returns \fBTCL_OK\fR; if an error occurs while setting up the link (e.g. because \fIvarName\fR is the name of array) then \fBTCL_ERROR\fR is returned and the interpreter's result contains an error message. .PP .VS "TIP 312" \fBTcl_LinkArray\fR is similar, but for arrays of fixed size (given by the \fIsize\fR argument). When asked to allocate the backing C array storage (via the \fIaddr\fR argument being NULL), it writes the address that it allocated to the Tcl interpreter result. .VE "TIP 312" .PP The \fItype\fR argument specifies the type of the C variable, or the type of the elements of the C array, and must have one of the following values, optionally OR'ed with \fBTCL_LINK_READ_ONLY\fR: .TP \fBTCL_LINK_INT\fR . The C variable, or each element of the C array, is of type \fBint\fR. Any value written into the Tcl variable must have a proper integer form acceptable to \fBTcl_GetIntFromObj\fR; attempts to write non-integer values into \fIvarName\fR will be rejected with Tcl errors. Incomplete integer representations (like the empty string, '+', '-' or the hex/octal/binary prefix) are accepted as if they are valid too. .TP \fBTCL_LINK_UINT\fR . The C variable, or each element of the C array, is of type \fBunsigned int\fR. Any value written into the Tcl variable must have a proper unsigned integer form acceptable to \fBTcl_GetWideIntFromObj\fR and in the platform's defined range for the \fBunsigned int\fR type; attempts to write non-integer values (or values outside the range) into \fIvarName\fR will be rejected with Tcl errors. Incomplete integer representations (like the empty string, '+', '-' or the hex/octal/binary prefix) are accepted as if they are valid too. .TP \fBTCL_LINK_CHAR\fR . The C variable, or each element of the C array, is of type \fBchar\fR. Any value written into the Tcl variable must have a proper integer form acceptable to \fBTcl_GetIntFromObj\fR and be in the range of the \fBchar\fR datatype; attempts to write non-integer or out-of-range values into \fIvarName\fR will be rejected with Tcl errors. Incomplete integer representations (like the empty string, '+', '-' or the hex/octal/binary prefix) are accepted as if they are valid too. .RS .PP .VS "TIP 312" If using an array of these, consider using \fBTCL_LINK_CHARS\fR instead. .VE "TIP 312" .RE .TP \fBTCL_LINK_CHARS\fR .VS "TIP 312" The C array is of type \fBchar *\fR and is mapped into Tcl as a string. Any value written into the Tcl variable must have the same length as the underlying storage. Only supported with \fBTcl_LinkArray\fR. .VE "TIP 312" .TP \fBTCL_LINK_UCHAR\fR . The C variable, or each element of the C array, is of type \fBunsigned char\fR. Any value written into the Tcl variable must have a proper unsigned integer form acceptable to \fBTcl_GetIntFromObj\fR and in the platform's defined range for the \fBunsigned char\fR type; attempts to write non-integer values (or values outside the range) into \fIvarName\fR will be rejected with Tcl errors. Incomplete integer representations (like the empty string, '+', '-' or the hex/octal/binary prefix) are accepted as if they are valid too. .RS .PP .VS "TIP 312" If using an array of these, consider using \fBTCL_LINK_BYTES\fR instead. .VE "TIP 312" .RE .TP \fBTCL_LINK_BYTES\fR .VS "TIP 312" The C array is of type \fBunsigned char *\fR and is mapped into Tcl as a bytearray. Any value written into the Tcl variable must have the same length as the underlying storage. Only supported with \fBTcl_LinkArray\fR. .VE "TIP 312" .TP \fBTCL_LINK_SHORT\fR . The C variable, or each element of the C array, is of type \fBshort\fR. Any value written into the Tcl variable must have a proper integer form acceptable to \fBTcl_GetIntFromObj\fR and be in the range of the \fBshort\fR datatype; attempts to write non-integer or out-of-range values into \fIvarName\fR will be rejected with Tcl errors. Incomplete integer representations (like the empty string, '+', '-' or the hex/octal/binary prefix) are accepted as if they are valid too. .TP \fBTCL_LINK_USHORT\fR . The C variable, or each element of the C array, is of type \fBunsigned short\fR. Any value written into the Tcl variable must have a proper unsigned integer form acceptable to \fBTcl_GetIntFromObj\fR and in the platform's defined range for the \fBunsigned short\fR type; attempts to write non-integer values (or values outside the range) into \fIvarName\fR will be rejected with Tcl errors. Incomplete integer representations (like the empty string, '+', '-' or the hex/octal/binary prefix) are accepted as if they are valid too. .TP \fBTCL_LINK_LONG\fR . The C variable, or each element of the C array, is of type \fBlong\fR. Any value written into the Tcl variable must have a proper integer form acceptable to \fBTcl_GetLongFromObj\fR; attempts to write non-integer or out-of-range values into \fIvarName\fR will be rejected with Tcl errors. Incomplete integer representations (like the empty string, '+', '-' or the hex/octal/binary prefix) are accepted as if they are valid too. .TP \fBTCL_LINK_ULONG\fR . The C variable, or each element of the C array, is of type \fBunsigned long\fR. Any value written into the Tcl variable must have a proper unsigned integer form acceptable to \fBTcl_GetWideIntFromObj\fR and in the platform's defined range for the \fBunsigned long\fR type; attempts to write non-integer values (or values outside the range) into \fIvarName\fR will be rejected with Tcl errors. Incomplete integer representations (like the empty string, '+', '-' or the hex/octal/binary prefix) are accepted as if they are valid too. .TP \fBTCL_LINK_DOUBLE\fR . The C variable, or each element of the C array, is of type \fBdouble\fR. Any value written into the Tcl variable must have a proper real form acceptable to \fBTcl_GetDoubleFromObj\fR; attempts to write non-real values into \fIvarName\fR will be rejected with Tcl errors. Incomplete integer or real representations (like the empty string, '.', '+', '-' or the hex/octal/binary prefix) are accepted as if they are valid too. .TP \fBTCL_LINK_FLOAT\fR . The C variable, or each element of the C array, is of type \fBfloat\fR. Any value written into the Tcl variable must have a proper real form acceptable to \fBTcl_GetDoubleFromObj\fR and must be within the range acceptable for a \fBfloat\fR; attempts to write non-real values (or values outside the range) into \fIvarName\fR will be rejected with Tcl errors. Incomplete integer or real representations (like the empty string, '.', '+', '-' or the hex/octal/binary prefix) are accepted as if they are valid too. .TP \fBTCL_LINK_WIDE_INT\fR . The C variable, or each element of the C array, is of type \fBTcl_WideInt\fR (which is an integer type at least 64-bits wide on all platforms that can support it.) Any value written into the Tcl variable must have a proper integer form acceptable to \fBTcl_GetWideIntFromObj\fR; attempts to write non-integer values into \fIvarName\fR will be rejected with Tcl errors. Incomplete integer representations (like the empty string, '+', '-' or the hex/octal/binary prefix) are accepted as if they are valid too. .TP \fBTCL_LINK_WIDE_UINT\fR . The C variable, or each element of the C array, is of type \fBTcl_WideUInt\fR (which is an unsigned integer type at least 64-bits wide on all platforms that can support it.) Any value written into the Tcl variable must have a proper unsigned integer form acceptable to \fBTcl_GetWideIntFromObj\fR (it will be cast to unsigned); .\" FIXME! Use bignums instead. attempts to write non-integer values into \fIvarName\fR will be rejected with Tcl errors. Incomplete integer representations (like the empty string, '+', '-' or the hex/octal/binary prefix) are accepted as if they are valid too. .TP \fBTCL_LINK_BOOLEAN\fR . The C variable, or each element of the C array, is of type \fBint\fR. If its value is zero then it will read from Tcl as .QW 0 ; otherwise it will read from Tcl as .QW 1 . Whenever \fIvarName\fR is modified, the C variable will be set to a 0 or 1 value. Any value written into the Tcl variable must have a proper boolean form acceptable to \fBTcl_GetBooleanFromObj\fR; attempts to write non-boolean values into \fIvarName\fR will be rejected with Tcl errors. .TP \fBTCL_LINK_STRING\fR . The C variable is of type \fBchar *\fR. If its value is not NULL then it must be a pointer to a string allocated with \fBTcl_Alloc\fR. Whenever the Tcl variable is modified the current C string will be freed and new memory will be allocated to hold a copy of the variable's new value. If the C variable contains a NULL pointer then the Tcl variable will read as .QW NULL . This is only supported by \fBTcl_LinkVar\fR. .PP If the \fBTCL_LINK_READ_ONLY\fR flag is present in \fItype\fR then the variable will be read-only from Tcl, so that its value can only be changed by modifying the C variable. Attempts to write the variable from Tcl will be rejected with errors. .PP \fBTcl_UnlinkVar\fR removes the link previously set up for the |
| ︙ | ︙ |
Changes to doc/define.n.
| ︙ | ︙ | |||
280 281 282 283 284 285 286 | .VE TIP524 .TP \fBdeletemethod\fI name\fR ?\fIname ...\fR? . This deletes each of the methods called \fIname\fR from a class. The methods must have previously existed in that class. Does not affect the superclasses of the class, nor does it affect the subclasses or instances of the class | | > | 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 | .VE TIP524 .TP \fBdeletemethod\fI name\fR ?\fIname ...\fR? . This deletes each of the methods called \fIname\fR from a class. The methods must have previously existed in that class. Does not affect the superclasses of the class, nor does it affect the subclasses or instances of the class (except when they have a call chain through the class being modified) or the class object itself. .TP \fBfilter\fR ?\fI\-slotOperation\fR? ?\fImethodName ...\fR? . This slot (see \fBSLOTTED DEFINITIONS\fR below) sets or updates the list of method names that are used to guard whether method call to instances of the class may be called and what the method's results are. Each \fImethodName\fR names a single filtering method (which may |
| ︙ | ︙ | |||
306 307 308 309 310 311 312 | .TP \fBrenamemethod\fI fromName toName\fR . This renames the method called \fIfromName\fR in a class to \fItoName\fR. The method must have previously existed in the class, and \fItoName\fR must not previously refer to a method in that class. Does not affect the superclasses of the class, nor does it affect the subclasses or instances of the class | | > | 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 | .TP \fBrenamemethod\fI fromName toName\fR . This renames the method called \fIfromName\fR in a class to \fItoName\fR. The method must have previously existed in the class, and \fItoName\fR must not previously refer to a method in that class. Does not affect the superclasses of the class, nor does it affect the subclasses or instances of the class (except when they have a call chain through the class being modified), or the class object itself. Does not change the export status of the method; if it was exported before, it will be afterwards. .SH "CONFIGURING OBJECTS" .PP The following commands are supported in the \fIdefScript\fR for \fBoo::objdefine\fR, each of which may also be used in the \fIsubcommand\fR form: |
| ︙ | ︙ | |||
432 433 434 435 436 437 438 | This allows the class of an object to be changed after creation. Note that the class's constructors are not called when this is done, and so the object may well be in an inconsistent state unless additional configuration work is done. .TP \fBdeletemethod\fI name\fR ?\fIname ...\fR . This deletes each of the methods called \fIname\fR from an object. The methods | | > | > | > > | | 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 | This allows the class of an object to be changed after creation. Note that the class's constructors are not called when this is done, and so the object may well be in an inconsistent state unless additional configuration work is done. .TP \fBdeletemethod\fI name\fR ?\fIname ...\fR . This deletes each of the methods called \fIname\fR from an object. The methods must have previously existed in that object (e.g., because it was created through \fBoo::objdefine method\fR). Does not affect the classes that the object is an instance of, or remove the exposure of those class-provided methods in the instance of that class. .TP \fBfilter\fR ?\fI\-slotOperation\fR? ?\fImethodName ...\fR? . This slot (see \fBSLOTTED DEFINITIONS\fR below) sets or updates the list of method names that are used to guard whether a method call to the object may be called and what the method's results are. Each \fImethodName\fR names a single filtering method (which may be exposed or not exposed); it is not an error for a non-existent method to be named. Note that the actual list of filters also depends on the filters set upon any classes that the object is an instance of. By default, this slot works by appending. .TP \fBrenamemethod\fI fromName toName\fR . This renames the method called \fIfromName\fR in an object to \fItoName\fR. The method must have previously existed in the object, and \fItoName\fR must not previously refer to a method in that object. Does not affect the classes that the object is an instance of and cannot rename in an instance object the methods provided by those classes (though a \fBoo::objdefine forward\fRed method may provide an equivalent capability). Does not change the export status of the method; if it was exported before, it will be afterwards. .TP \fBself \fR .VS TIP470 This gives the name of the object currently being configured. .VE TIP470 .SH "PRIVATE METHODS" .VS TIP500 |
| ︙ | ︙ |
Changes to doc/dict.n.
| ︙ | ︙ | |||
115 116 117 118 119 120 121 122 123 124 125 126 127 128 | elements in a manner similar to \fBarray get\fR. That is, the first element of each pair would be the key and the second element would be the value for that key. .PP It is an error to attempt to retrieve a value for a key that is not present in the dictionary. .RE .TP \fBdict incr \fIdictionaryVariable key \fR?\fIincrement\fR? . This adds the given increment value (an integer that defaults to 1 if not specified) to the value that the given key maps to in the dictionary value contained in the given variable, writing the resulting dictionary value back to that variable. Non-existent keys | > > > > > > > > > > > > > > > > | 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 | elements in a manner similar to \fBarray get\fR. That is, the first element of each pair would be the key and the second element would be the value for that key. .PP It is an error to attempt to retrieve a value for a key that is not present in the dictionary. .RE .TP \fBdict getdef \fIdictionaryValue \fR?\fIkey ...\fR? \fIkey default\fR .TP \fBdict getwithdefault \fIdictionaryValue \fR?\fIkey ...\fR? \fIkey default\fR .VS "8.7, TIP342" This behaves the same as \fBdict get\fR (with at least one \fIkey\fR argument), returning the value that the key path maps to in the dictionary \fIdictionaryValue\fR, except that instead of producing an error because the \fIkey\fR (or one of the \fIkey\fRs on the key path) is absent, it returns the \fIdefault\fR argument instead. .RS .PP Note that there must always be at least one \fIkey\fR provided, and that \fBdict getdef\fR and \fBdict getwithdefault\fR are aliases for each other. .RE .VE "8.7, TIP342" .TP \fBdict incr \fIdictionaryVariable key \fR?\fIincrement\fR? . This adds the given increment value (an integer that defaults to 1 if not specified) to the value that the given key maps to in the dictionary value contained in the given variable, writing the resulting dictionary value back to that variable. Non-existent keys |
| ︙ | ︙ |
Changes to doc/interp.n.
| ︙ | ︙ | |||
197 198 199 200 201 202 203 | \fBinterp\fR \fBdebug \fIpath\fR ?\fB\-frame\fR ?\fIbool\fR?? . Controls whether frame-level stack information is captured in the slave interpreter identified by \fIpath\fR. If no arguments are given, option and current setting are returned. If \fB\-frame\fR is given, the debug setting is set to the given boolean if provided and the current setting is returned. | | | 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 | \fBinterp\fR \fBdebug \fIpath\fR ?\fB\-frame\fR ?\fIbool\fR?? . Controls whether frame-level stack information is captured in the slave interpreter identified by \fIpath\fR. If no arguments are given, option and current setting are returned. If \fB\-frame\fR is given, the debug setting is set to the given boolean if provided and the current setting is returned. This only affects the output of \fBinfo frame\fR, in that exact frame-level information for command invocation at the bytecode level is only captured with this setting on. .RS .PP For example, with code like .PP .CS |
| ︙ | ︙ |
Changes to doc/lrange.n.
| ︙ | ︙ | |||
68 69 70 71 72 73 74 |
% lindex $var 1
elements to
% \fBlrange\fR $var 1 1
{elements to}
.CE
.SH "SEE ALSO"
list(n), lappend(n), lindex(n), linsert(n), llength(n), lsearch(n),
| | | 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 |
% lindex $var 1
elements to
% \fBlrange\fR $var 1 1
{elements to}
.CE
.SH "SEE ALSO"
list(n), lappend(n), lindex(n), linsert(n), llength(n), lsearch(n),
lset(n), lremove(n), lreplace(n), lsort(n),
string(n)
.SH KEYWORDS
element, list, range, sublist
'\" Local Variables:
'\" mode: nroff
'\" fill-column: 78
'\" End:
|
Added doc/lremove.n.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
'\"
'\" 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 lremove n 8.7 Tcl "Tcl Built-In Commands"
.so man.macros
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
lremove \- Remove elements from a list by index
.SH SYNOPSIS
\fBlremove \fIlist\fR ?\fIindex ...\fR?
.BE
.SH DESCRIPTION
.PP
\fBlremove\fR returns a new list formed by simultaneously removing zero or
more elements of \fIlist\fR at each of the indices given by an arbirary number
of \fIindex\fR arguments. The indices may be in any order and may be repeated;
the element at index will only be removed once. The index values are
interpreted the same as index values for the command \fBstring index\fR,
supporting simple index arithmetic and indices relative to the end of the
list. 0 refers to the first element of the list, and \fBend\fR refers to the
last element of the list.
.SH EXAMPLES
.PP
Removing the third element of a list:
.PP
.CS
% \fBlremove\fR {a b c d e} 2
a b d e
.CE
.PP
Removing two elements from a list:
.PP
.CS
% \fBlremove\fR {a b c d e} end-1 1
a c e
.CE
.PP
Removing the same element indicated in two different ways:
.PP
.CS
% \fBlremove\fR {a b c d e} 2 end-2
a b d e
.CE
.SH "SEE ALSO"
list(n), lrange(n), lsearch(n), lsearch(n)
.SH KEYWORDS
element, list, remove
.\" Local variables:
.\" mode: nroff
.\" fill-column: 78
.\" End:
|
Changes to doc/lreplace.n.
| ︙ | ︙ | |||
92 93 94 95 96 97 98 | a b c d e % set var [\fBlreplace\fR $var 12345 end+2 f g h i] a b c d e f g h i .CE .VE TIP505 .SH "SEE ALSO" list(n), lappend(n), lindex(n), linsert(n), llength(n), lsearch(n), | | | 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 | a b c d e % set var [\fBlreplace\fR $var 12345 end+2 f g h i] a b c d e f g h i .CE .VE TIP505 .SH "SEE ALSO" list(n), lappend(n), lindex(n), linsert(n), llength(n), lsearch(n), lset(n), lrange(n), lremove(n), lsort(n), string(n) .SH KEYWORDS element, list, replace .\" Local variables: .\" mode: nroff .\" fill-column: 78 .\" End: |
Changes to doc/open.n.
| ︙ | ︙ | |||
162 163 164 165 166 167 168 | .SH "SERIAL COMMUNICATIONS" .PP If \fIfileName\fR refers to a serial port, then the specified serial port is opened and initialized in a platform-dependent manner. Acceptable values for the \fIfileName\fR to use to open a serial port are described in the PORTABILITY ISSUES section. .PP | | | > | 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 | .SH "SERIAL COMMUNICATIONS" .PP If \fIfileName\fR refers to a serial port, then the specified serial port is opened and initialized in a platform-dependent manner. Acceptable values for the \fIfileName\fR to use to open a serial port are described in the PORTABILITY ISSUES section. .PP The \fBchan configure\fR and \fBfconfigure\fR commands can be used to query and set additional configuration options specific to serial ports (where supported): .TP \fB\-mode\fR \fIbaud\fB,\fIparity\fB,\fIdata\fB,\fIstop\fR . This option is a set of 4 comma-separated values: the baud rate, parity, number of data bits, and number of stop bits for this serial port. The \fIbaud\fR rate is a simple integer that specifies the connection speed. \fIParity\fR is one of the following letters: \fBn\fR, \fBo\fR, \fBe\fR, |
| ︙ | ︙ | |||
244 245 246 247 248 249 250 251 252 253 254 255 256 257 |
.TP
\fB\-xchar\fR \fI{xonChar xoffChar}\fR
.
(Windows and Unix). This option is used to query or change the software
handshake characters. Normally the operating system default should be
DC1 (0x11) and DC3 (0x13) representing the ASCII standard
XON and XOFF characters.
.TP
\fB\-pollinterval\fR \fImsec\fR
.
(Windows only). This option is used to set the maximum time between
polling for fileevents.
This affects the time interval between checking for events throughout the Tcl
interpreter (the smallest value always wins). Use this option only if
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
.TP
\fB\-xchar\fR \fI{xonChar xoffChar}\fR
.
(Windows and Unix). This option is used to query or change the software
handshake characters. Normally the operating system default should be
DC1 (0x11) and DC3 (0x13) representing the ASCII standard
XON and XOFF characters.
.TP
\fB\-closemode\fR \fIcloseMode\fR
.VS "8.7, TIP 160"
(Windows and Unix). This option is used to query or change the close mode of
the serial channel, which defines how pending output in operating system
buffers is handled when the channel is closed. The following values for
\fIcloseMode\fR are supported:
.RS
.TP
\fBdefault\fR
.
indicates that a system default operation should be used; all serial channels
default to this.
.TP
\fBdiscard\fR
.
indicates that the contents of the OS buffers should be discarded. Note that
this is \fInot recommended\fR when writing to a POSIX terminal, as it can
interact unexpectedly with handling of \fBstderr\fR.
.TP
\fBdrain\fR
.
indicates that Tcl should wait when closing the channel until all output has
been consumed. This may slow down \fBclose\fR noticeably.
.RE
.VE "8.7, TIP 160"
.TP
\fB\-inputmode\fR \fIinputMode\fR
.VS "8.7, TIP 160"
(Unix only; Windows has the equivalent option on console channels). This
option is used to query or change the input mode of the serial channel under
the assumption that it is talking to a terminal, which controls how interactive
input from users is handled. The following values for \fIinputMode\fR are
supported:
.RS
.TP
\fBnormal\fR
.
indicates that normal line-oriented input should be used, with standard
terminal editing capabilities enabled.
.TP
\fBpassword\fR
.
indicates that non-echoing input should be used, with standard terminal
editing capabilities enabled but no writing of typed characters to the
terminal (except for newlines). Some terminals may indicate this specially.
.TP
\fBraw\fR
.
indicates that all keyboard input should be given directly to Tcl with the
terminal doing no processing at all. It does not echo the keys, leaving it up
to the Tcl script to interpret what to do.
.TP
\fBreset\fR (set only)
.
indicates that the terminal should be reset to what state it was in when the
terminal was opened.
.PP
Note that setting this option (technically, anything that changes the terminal
state from its initial value \fIvia this option\fR) will cause the channel to
turn on an automatic reset of the terminal when the channel is closed.
.RE
.TP
\fB\-winsize\fR
.
(Unix only; Windows has the equivalent option on console channels). This
option is query only. It retrieves a two-element list with the the current
width and height of the terminal.
.VE "8.7, TIP 160"
.TP
\fB\-pollinterval\fR \fImsec\fR
.
(Windows only). This option is used to set the maximum time between
polling for fileevents.
This affects the time interval between checking for events throughout the Tcl
interpreter (the smallest value always wins). Use this option only if
|
| ︙ | ︙ | |||
271 272 273 274 275 276 277 | \fB\-lasterror\fR . (Windows only). This option is query only. In case of a serial communication error, \fBread\fR or \fBputs\fR returns a general Tcl file I/O error. \fBfconfigure\fR \fB\-lasterror\fR can be called to get a list of error details. See below for an explanation of the various error codes. | | | 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 | \fB\-lasterror\fR . (Windows only). This option is query only. In case of a serial communication error, \fBread\fR or \fBputs\fR returns a general Tcl file I/O error. \fBfconfigure\fR \fB\-lasterror\fR can be called to get a list of error details. See below for an explanation of the various error codes. .SS "SERIAL PORT SIGNALS" .PP RS-232 is the most commonly used standard electrical interface for serial communications. A negative voltage (-3V..-12V) define a mark (on=1) bit and a positive voltage (+3..+12V) define a space (off=0) bit (RS-232C). The following signals are specified for incoming and outgoing data, status lines and handshaking. Here we are using the terms \fIworkstation\fR for your computer and \fImodem\fR for the external device, because some signal |
| ︙ | ︙ | |||
312 313 314 315 316 317 318 | .IP \fBBREAK\fR A BREAK condition is not a hardware signal line, but a logical zero on the TXD or RXD lines for a long period of time, usually 250 to 500 milliseconds. Normally a receive or transmit data signal stays at the mark (on=1) voltage until the next character is transferred. A BREAK is sometimes used to reset the communications line or change the operating mode of communications hardware. | | | 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 | .IP \fBBREAK\fR A BREAK condition is not a hardware signal line, but a logical zero on the TXD or RXD lines for a long period of time, usually 250 to 500 milliseconds. Normally a receive or transmit data signal stays at the mark (on=1) voltage until the next character is transferred. A BREAK is sometimes used to reset the communications line or change the operating mode of communications hardware. .SS "ERROR CODES (Windows only)" .PP A lot of different errors may occur during serial read operations or during event polling in background. The external device may have been switched off, the data lines may be noisy, system buffers may overrun or your mode settings may be wrong. That is why a reliable software should always \fBcatch\fR serial read operations. In cases of an error Tcl returns a general file I/O error. Then \fBfconfigure\fR \fB\-lasterror\fR may help to |
| ︙ | ︙ | |||
355 356 357 358 359 360 361 | A stop-bit error has been detected by your UART. Wrong mode settings with \fBfconfigure\fR \fB\-mode\fR or a noisy data line (RXD) may cause this error. .TP 10 \fBBREAK\fR . A BREAK condition has been detected by your UART (see above). | | | 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 | A stop-bit error has been detected by your UART. Wrong mode settings with \fBfconfigure\fR \fB\-mode\fR or a noisy data line (RXD) may cause this error. .TP 10 \fBBREAK\fR . A BREAK condition has been detected by your UART (see above). .SS "PORTABILITY ISSUES" .TP \fBWindows \fR . Valid values for \fIfileName\fR to open a serial port are of the form \fBcom\fIX\fB\fR, where \fIX\fR is a number, generally from 1 to 9. A legacy form accepted as well is \fBcom\fIX\fB:\fR. This notation only works for serial ports from 1 to 9. An attempt to open a serial port that |
| ︙ | ︙ | |||
404 405 406 407 408 409 410 | not accessing the console, or if the command pipeline does not use standard input, but is redirected from a file, then the above problem does not occur. .RE .PP See the \fBPORTABILITY ISSUES\fR section of the \fBexec\fR command for additional information not specific to command pipelines about executing applications on the various platforms | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > | 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 |
not accessing the console, or if the command pipeline does not use standard
input, but is redirected from a file, then the above problem does not occur.
.RE
.PP
See the \fBPORTABILITY ISSUES\fR section of the \fBexec\fR command for
additional information not specific to command pipelines about executing
applications on the various platforms
.SH "CONSOLE CHANNELS"
.VS "8.7, TIP 160"
On Windows only, console channels (usually \fBstdin\fR or \fBstdout\fR)
support the following options:
.TP
\fB\-inputmode\fR \fIinputMode\fR
.
This option is used to query or change the input mode of the console channel,
which controls how interactive input from users is handled. The following
values for \fIinputMode\fR are supported:
.RS
.TP
\fBnormal\fR
.
indicates that normal line-oriented input should be used, with standard
console editing capabilities enabled.
.TP
\fBpassword\fR
.
indicates that non-echoing input should be used, with standard console
editing capabilitied enabled but no writing of typed characters to the
terminal (except for newlines).
.TP
\fBraw\fR
.
indicates that all keyboard input should be given directly to Tcl with the
console doing no processing at all. It does not echo the keys, leaving it up
to the Tcl script to interpret what to do.
.TP
\fBreset\fR (set only)
.
indicates that the console should be reset to what state it was in when the
console channel was opened.
.PP
Note that setting this option (technically, anything that changes the console
state from its default \fIvia this option\fR) will cause the channel to turn
on an automatic reset of the console when the channel is closed.
.RE
.TP
\fB\-winsize\fR
.
This option is query only.
It retrieves a two-element list with the the current width and height of the
console that this channel is talking to.
.PP
Note that the equivalent options exist on Unix, but are on the serial channel
type.
.VE "8.7, TIP 160"
.SH "EXAMPLES"
.PP
Open a command pipeline and catch any errors:
.PP
.CS
set fl [\fBopen\fR "| ls this_file_does_not_exist"]
set data [read $fl]
if {[catch {close $fl} err]} {
puts "ls command failed: $err"
}
.CE
.PP
.VS "8.7, TIP 160"
Read a password securely from the user (assuming that the script is being run
interactively):
.PP
.CS
chan configure stdin \fB-inputmode password\fR
try {
chan puts -nonewline "Password: "
chan flush stdout
set thePassword [chan gets stdin]
} finally {
chan configure stdin \fB-inputmode reset\fR
}
.CE
.VE "8.7, TIP 160"
.SH "SEE ALSO"
file(n), close(n), filename(n), fconfigure(n), gets(n), read(n),
puts(n), exec(n), pid(n), fopen(3)
.SH KEYWORDS
access mode, append, create, file, non-blocking, open, permissions,
pipeline, process, serial
'\"Local Variables:
'\"mode: nroff
'\"End:
|
Changes to doc/string.n.
| ︙ | ︙ | |||
83 84 85 86 87 88 89 90 91 92 93 94 95 96 | string. \fIcharIndex\fR may be specified as described in the \fBSTRING INDICES\fR section. .RS .PP If \fIcharIndex\fR is less than 0 or greater than or equal to the length of the string then this command returns an empty string. .RE .TP \fBstring is \fIclass\fR ?\fB\-strict\fR? ?\fB\-failindex \fIvarname\fR? \fIstring\fR . Returns 1 if \fIstring\fR is a valid member of the specified character class, otherwise returns 0. If \fB\-strict\fR is specified, then an empty string returns 0, otherwise an empty string will return 1 on any class. If \fB\-failindex\fR is specified, then if the function | > > > > > > > > > > > > > > > > > > | 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 | string. \fIcharIndex\fR may be specified as described in the \fBSTRING INDICES\fR section. .RS .PP If \fIcharIndex\fR is less than 0 or greater than or equal to the length of the string then this command returns an empty string. .RE .TP \fBstring insert \fIstring index insertString\fR .VS "TIP 504" Returns a copy of \fIstring\fR with \fIinsertString\fR inserted at the \fIindex\fR'th character. The \fIindex\fR may be specified as described in the \fBSTRING INDICES\fR section. .RS .PP If \fIindex\fR is start-relative, the first character inserted in the returned string will be at the specified index. If \fIindex\fR is end-relative, the last character inserted in the returned string will be at the specified index. .PP If \fIindex\fR is at or before the start of \fIstring\fR (e.g., \fIindex\fR is \fB0\fR), \fIinsertString\fR is prepended to \fIstring\fR. If \fIindex\fR is at or after the end of \fIstring\fR (e.g., \fIindex\fR is \fBend\fR), \fIinsertString\fR is appended to \fIstring\fR. .RE .VE "TIP 504" .TP \fBstring is \fIclass\fR ?\fB\-strict\fR? ?\fB\-failindex \fIvarname\fR? \fIstring\fR . Returns 1 if \fIstring\fR is a valid member of the specified character class, otherwise returns 0. If \fB\-strict\fR is specified, then an empty string returns 0, otherwise an empty string will return 1 on any class. If \fB\-failindex\fR is specified, then if the function |
| ︙ | ︙ | |||
270 271 272 273 274 275 276 | \fIpattern\fR. .RE .TP \fBstring range \fIstring first last\fR . Returns a range of consecutive characters from \fIstring\fR, starting with the character whose index is \fIfirst\fR and ending with the | | > > | > > | > | 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 | \fIpattern\fR. .RE .TP \fBstring range \fIstring first last\fR . Returns a range of consecutive characters from \fIstring\fR, starting with the character whose index is \fIfirst\fR and ending with the character whose index is \fIlast\fR (using the forms described in \fBSTRING INDICES\fR). An index of \fB0\fR refers to the first character of the string; an index of \fBend\fR refers to last character of the string. \fIfirst\fR and \fIlast\fR may be specified as for the \fBindex\fR method. If \fIfirst\fR is less than zero then it is treated as if it were zero, and if \fIlast\fR is greater than or equal to the length of the string then it is treated as if it were \fBend\fR. If \fIfirst\fR is greater than \fIlast\fR then an empty string is returned. .TP \fBstring repeat \fIstring count\fR . Returns a string consisting of \fIstring\fR concatenated with itself \fIcount\fR times. If \fIcount\fR is 0, the empty string will be returned. .TP \fBstring replace \fIstring first last\fR ?\fInewstring\fR? . Removes a range of consecutive characters from \fIstring\fR, starting with the character whose index is \fIfirst\fR and ending with the character whose index is \fIlast\fR (using the forms described in \fBSTRING INDICES\fR). An index of 0 refers to the first character of the string. \fIFirst\fR and \fIlast\fR may be specified as for the \fBindex\fR method. If \fInewstring\fR is specified, then it is placed in the removed character range. If \fIfirst\fR is less than zero then it is treated as if it were zero, and if \fIlast\fR is greater than or equal to the length of the string then it is treated as if it were \fBend\fR. If \fIfirst\fR is greater than \fIlast\fR or the length of the initial string, or \fIlast\fR is |
| ︙ | ︙ |
Changes to doc/timerate.n.
1 2 3 4 5 6 7 8 9 10 11 | '\" '\" Copyright (c) 2005 Sergey Brester aka sebres. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH timerate n "" Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME | | | | | > > > > > > > > > > | | | | | < < | < < | | < | | | | > > > > | | | > > | | | < | | | | > | | < | | | > | > | > | | > | > | > > | | | | 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 |
'\"
'\" Copyright (c) 2005 Sergey Brester aka sebres.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.TH timerate n "" Tcl "Tcl Built-In Commands"
.so man.macros
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
timerate \- Calibrated performance measurements of script execution time
.SH SYNOPSIS
\fBtimerate \fIscript\fR ?\fItime\fR? ?\fImax-count\fR?
.sp
\fBtimerate \fR?\fB\-direct\fR? ?\fB\-overhead\fI double\fR? \fIscript\fR ?\fItime\fR? ?\fImax-count\fR?
.sp
\fBtimerate \fR?\fB\-calibrate\fR? ?\fB\-direct\fR? \fIscript\fR ?\fItime\fR? ?\fImax-count\fR?
.BE
.SH DESCRIPTION
.PP
The \fBtimerate\fR command does calibrated performance measurement of a Tcl
command or script, \fIscript\fR. The \fIscript\fR should be written so that it
can be executed multiple times during the performance measurement process.
Time is measured in elapsed time using the finest timer resolution as possible,
not CPU time; if \fIscript\fR interacts with the OS, the cost of that
interaction is included.
This command may be used to provide information as to how well a script or
Tcl command is performing, and can help determine bottlenecks and fine-tune
application performance.
.PP
The first and second form will evaluate \fIscript\fR until the interval
\fItime\fR given in milliseconds elapses, or for 1000 milliseconds (1 second)
if \fItime\fR is not specified.
.sp
The parameter \fImax-count\fR could additionally impose a further restriction
by the maximal number of iterations to evaluate the script.
If \fImax-count\fR is specified, the evalution will stop either this count of
iterations is reached or the time is exceeded.
.sp
It will then return a canonical tcl-list of the form:
.PP
.CS
\fB0.095977 \(mcs/# 52095836 # 10419167 #/sec 5000.000 nett-ms\fR
.CE
.PP
which indicates:
.IP \(bu 3
the average amount of time required per iteration, in microseconds ([\fBlindex\fR $result 0])
.IP \(bu 3
the count how many times it was executed ([\fBlindex\fR $result 2])
.IP \(bu 3
the estimated rate per second ([\fBlindex\fR $result 4])
.IP \(bu 3
the estimated real execution time without measurement overhead ([\fBlindex\fR $result 6])
.PP
The following options may be supplied to the \fBtimerate\fR command:
.TP
\fB\-calibrate\fR
.
To measure very fast scripts as exactly as possible, a calibration process
may be required.
The \fB\-calibrate\fR option is used to calibrate \fBtimerate\fR itself,
calculating the estimated overhead of the given script as the default overhead
for future invocations of the \fBtimerate\fR command. If the \fItime\fR
parameter is not specified, the calibrate procedure runs for up to 10 seconds.
.RS
.PP
Note that calibration is not thread safe in the current implementation.
.RE
.TP
\fB\-overhead \fIdouble\fR
.
The \fB\-overhead\fR parameter supplies an estimate (in microseconds) of the
measurement overhead of each iteration of the tested script. This quantity
will be subtracted from the measured time prior to reporting results. This can
be useful for removing the cost of interpreter state reset commands from the
script being measured.
.TP
\fB\-direct\fR
.
The \fB-direct\fR option causes direct execution of the supplied script,
without compilation, in a manner similar to the \fBtime\fR command. It can be
used to measure the cost of \fBTcl_EvalObjEx\fR, of the invocation of canonical
lists, and of the uncompiled versions of bytecoded commands.
.PP
As opposed to the \fBtime\fR commmand, which runs the tested script for a fixed
number of iterations, the timerate command runs it for a fixed time.
Additionally, the compiled variant of the script will be used during the entire
measurement, as if the script were part of a compiled procedure, if the \fB\-direct\fR
option is not specified. The fixed time period and possibility of compilation allow
for more precise results and prevent very long execution times by slow scripts, making
it practical for measuring scripts with highly uncertain execution times.
.SH EXAMPLES
Estimate how fast it takes for a simple Tcl \fBfor\fR loop (including
operations on variable \fIi\fR) to count to ten:
.PP
.CS
\fI# calibrate\fR
\fBtimerate\fR -calibrate {}
\fI# measure\fR
\fBtimerate\fR { for {set i 0} {$i<10} {incr i} {} } 5000
.CE
.PP
Estimate how fast it takes for a simple Tcl \fBfor\fR loop, ignoring the
overhead of the management of the variable that controls the loop:
.PP
.CS
\fI# calibrate for overhead of variable operations\fR
set i 0; \fBtimerate\fR -calibrate {expr {$i<10}; incr i} 1000
\fI# measure\fR
\fBtimerate\fR {
for {set i 0} {$i<10} {incr i} {}
} 5000
.CE
.PP
Estimate the speed of calculating the hour of the day using \fBclock format\fR only,
ignoring overhead of the portion of the script that prepares the time for it to
calculate:
.PP
.CS
\fI# calibrate\fR
\fBtimerate\fR -calibrate {}
\fI# estimate overhead\fR
set tm 0
set ovh [lindex [\fBtimerate\fR {
incr tm [expr {24*60*60}]
}] 0]
\fI# measure using estimated overhead\fR
set tm 0
\fBtimerate\fR -overhead $ovh {
clock format $tm -format %H
incr tm [expr {24*60*60}]; # overhead for this is ignored
} 5000
.CE
.SH "SEE ALSO"
time(n)
.SH KEYWORDS
performance measurement, script, time
.\" Local Variables:
.\" mode: nroff
.\" End:
|
Changes to generic/tcl.decls.
| ︙ | ︙ | |||
635 636 637 638 639 640 641 |
}
declare 172 {
Tcl_Interp *Tcl_GetSlave(Tcl_Interp *interp, const char *slaveName)
}
declare 173 {
Tcl_Channel Tcl_GetStdChannel(int type)
}
| > | | < > | 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 |
}
declare 172 {
Tcl_Interp *Tcl_GetSlave(Tcl_Interp *interp, const char *slaveName)
}
declare 173 {
Tcl_Channel Tcl_GetStdChannel(int type)
}
# Removed in 9.0, replaced by macro.
#declare 174 {
# const char *Tcl_GetStringResult(Tcl_Interp *interp)
#}
# Removed in 9.0, replaced by macro.
#declare 175 {deprecated {No longer in use, changed to macro}} {
# const char *Tcl_GetVar(Tcl_Interp *interp, const char *varName,
# int flags)
#}
declare 176 {
const char *Tcl_GetVar2(Tcl_Interp *interp, const char *part1,
|
| ︙ | ︙ | |||
683 684 685 686 687 688 689 |
}
# Obsolete, use Tcl_FSJoinPath
declare 186 {
char *Tcl_JoinPath(int argc, const char *const *argv,
Tcl_DString *resultPtr)
}
declare 187 {
| | | 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 |
}
# Obsolete, use Tcl_FSJoinPath
declare 186 {
char *Tcl_JoinPath(int argc, const char *const *argv,
Tcl_DString *resultPtr)
}
declare 187 {
int Tcl_LinkVar(Tcl_Interp *interp, const char *varName, void *addr,
int type)
}
# This slot is reserved for use by the plus patch:
# declare 188 {
# Tcl_MainLoop
# }
|
| ︙ | ︙ | |||
2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 2440 |
declare 642 {
void Tcl_DecrRefCount(Tcl_Obj *objPtr)
}
declare 643 {
int Tcl_IsShared(Tcl_Obj *objPtr)
}
# ----- BASELINE -- FOR -- 8.7.0 ----- #
##############################################################################
# Define the platform specific public Tcl interface. These functions are only
# available on the designated platform.
| > > > > > > | 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 2440 2441 2442 2443 2444 2445 2446 2447 |
declare 642 {
void Tcl_DecrRefCount(Tcl_Obj *objPtr)
}
declare 643 {
int Tcl_IsShared(Tcl_Obj *objPtr)
}
# TIP#312 New Tcl_LinkArray() function
declare 644 {
int Tcl_LinkArray(Tcl_Interp *interp, const char *varName, void *addr,
int type, int size)
}
# ----- BASELINE -- FOR -- 8.7.0 ----- #
##############################################################################
# Define the platform specific public Tcl interface. These functions are only
# available on the designated platform.
|
| ︙ | ︙ |
Changes to generic/tcl.h.
| ︙ | ︙ | |||
932 933 934 935 936 937 938 939 940 941 942 943 944 945 | #define TCL_LINK_ULONG ((sizeof(long) != sizeof(int)) ? TCL_LINK_WIDE_UINT : TCL_LINK_UINT) #else #define TCL_LINK_LONG 11 #define TCL_LINK_ULONG 12 #endif #define TCL_LINK_FLOAT 13 #define TCL_LINK_WIDE_UINT 14 #define TCL_LINK_READ_ONLY 0x80 /* *---------------------------------------------------------------------------- * Forward declarations of Tcl_HashTable and related types. */ | > > | 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 | #define TCL_LINK_ULONG ((sizeof(long) != sizeof(int)) ? TCL_LINK_WIDE_UINT : TCL_LINK_UINT) #else #define TCL_LINK_LONG 11 #define TCL_LINK_ULONG 12 #endif #define TCL_LINK_FLOAT 13 #define TCL_LINK_WIDE_UINT 14 #define TCL_LINK_CHARS 15 #define TCL_LINK_BINARY 16 #define TCL_LINK_READ_ONLY 0x80 /* *---------------------------------------------------------------------------- * Forward declarations of Tcl_HashTable and related types. */ |
| ︙ | ︙ |
Changes to generic/tclAssembly.c.
| ︙ | ︙ | |||
140 141 142 143 144 145 146 147 148 149 150 151 152 153 |
ASSEM_BOOL_LVT4, /* One Boolean, one 4-byte LVT ref. */
ASSEM_CLOCK_READ, /* 1-byte unsigned-integer case number, in the
* range 0-3 */
ASSEM_CONCAT1, /* 1-byte unsigned-integer operand count, must
* be strictly positive, consumes N, produces
* 1 */
ASSEM_DICT_GET, /* 'dict get' and related - consumes N+1
* operands, produces 1, N > 0 */
ASSEM_DICT_SET, /* specifies key count and LVT index, consumes
* N+1 operands, produces 1, N > 0 */
ASSEM_DICT_UNSET, /* specifies key count and LVT index, consumes
* N operands, produces 1, N > 0 */
ASSEM_END_CATCH, /* End catch. No args. Exception range popped
* from stack and stack pointer restored. */
| > > | 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 |
ASSEM_BOOL_LVT4, /* One Boolean, one 4-byte LVT ref. */
ASSEM_CLOCK_READ, /* 1-byte unsigned-integer case number, in the
* range 0-3 */
ASSEM_CONCAT1, /* 1-byte unsigned-integer operand count, must
* be strictly positive, consumes N, produces
* 1 */
ASSEM_DICT_GET, /* 'dict get' and related - consumes N+1
* operands, produces 1, N > 0 */
ASSEM_DICT_GET_DEF, /* 'dict getwithdefault' - consumes N+2
* operands, produces 1, N > 0 */
ASSEM_DICT_SET, /* specifies key count and LVT index, consumes
* N+1 operands, produces 1, N > 0 */
ASSEM_DICT_UNSET, /* specifies key count and LVT index, consumes
* N operands, produces 1, N > 0 */
ASSEM_END_CATCH, /* End catch. No args. Exception range popped
* from stack and stack pointer restored. */
|
| ︙ | ︙ | |||
358 359 360 361 362 363 364 365 366 367 368 369 370 371 |
{"concatStk", ASSEM_LIST, INST_CONCAT_STK, INT_MIN,1},
{"coroName", ASSEM_1BYTE, INST_COROUTINE_NAME, 0, 1},
{"currentNamespace",ASSEM_1BYTE, INST_NS_CURRENT, 0, 1},
{"dictAppend", ASSEM_LVT4, INST_DICT_APPEND, 2, 1},
{"dictExists", ASSEM_DICT_GET, INST_DICT_EXISTS, INT_MIN,1},
{"dictExpand", ASSEM_1BYTE, INST_DICT_EXPAND, 3, 1},
{"dictGet", ASSEM_DICT_GET, INST_DICT_GET, INT_MIN,1},
{"dictIncrImm", ASSEM_SINT4_LVT4,
INST_DICT_INCR_IMM, 1, 1},
{"dictLappend", ASSEM_LVT4, INST_DICT_LAPPEND, 2, 1},
{"dictRecombineStk",ASSEM_1BYTE, INST_DICT_RECOMBINE_STK,3, 0},
{"dictRecombineImm",ASSEM_LVT4, INST_DICT_RECOMBINE_IMM,2, 0},
{"dictSet", ASSEM_DICT_SET, INST_DICT_SET, INT_MIN,1},
{"dictUnset", ASSEM_DICT_UNSET,
| > | 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 |
{"concatStk", ASSEM_LIST, INST_CONCAT_STK, INT_MIN,1},
{"coroName", ASSEM_1BYTE, INST_COROUTINE_NAME, 0, 1},
{"currentNamespace",ASSEM_1BYTE, INST_NS_CURRENT, 0, 1},
{"dictAppend", ASSEM_LVT4, INST_DICT_APPEND, 2, 1},
{"dictExists", ASSEM_DICT_GET, INST_DICT_EXISTS, INT_MIN,1},
{"dictExpand", ASSEM_1BYTE, INST_DICT_EXPAND, 3, 1},
{"dictGet", ASSEM_DICT_GET, INST_DICT_GET, INT_MIN,1},
{"dictGetDef", ASSEM_DICT_GET_DEF, INST_DICT_GET_DEF, INT_MIN,1},
{"dictIncrImm", ASSEM_SINT4_LVT4,
INST_DICT_INCR_IMM, 1, 1},
{"dictLappend", ASSEM_LVT4, INST_DICT_LAPPEND, 2, 1},
{"dictRecombineStk",ASSEM_1BYTE, INST_DICT_RECOMBINE_STK,3, 0},
{"dictRecombineImm",ASSEM_LVT4, INST_DICT_RECOMBINE_IMM,2, 0},
{"dictSet", ASSEM_DICT_SET, INST_DICT_SET, INT_MIN,1},
{"dictUnset", ASSEM_DICT_UNSET,
|
| ︙ | ︙ | |||
613 614 615 616 617 618 619 |
int count) /* Count of operands for variadic insts */
{
int consumed = TalInstructionTable[tblIdx].operandsConsumed;
int produced = TalInstructionTable[tblIdx].operandsProduced;
if (consumed == INT_MIN) {
/*
| | > > > > | 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 |
int count) /* Count of operands for variadic insts */
{
int consumed = TalInstructionTable[tblIdx].operandsConsumed;
int produced = TalInstructionTable[tblIdx].operandsProduced;
if (consumed == INT_MIN) {
/*
* The instruction is variadic; it consumes 'count' operands, or
* 'count+1' for ASSEM_DICT_GET_DEF.
*/
consumed = count;
if (TalInstructionTable[tblIdx].instType == ASSEM_DICT_GET_DEF) {
consumed++;
}
}
if (produced < 0) {
/*
* The instruction leaves some of its variadic operands on the stack,
* with net stack effect of '-1-produced'
*/
|
| ︙ | ︙ | |||
1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 |
|| CheckStrictlyPositive(interp, opnd) != TCL_OK) {
goto cleanup;
}
BBEmitInstInt1(assemEnvPtr, tblIdx, opnd, opnd);
break;
case ASSEM_DICT_GET:
if (parsePtr->numWords != 2) {
Tcl_WrongNumArgs(interp, 1, &instNameObj, "count");
goto cleanup;
}
if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK
|| CheckStrictlyPositive(interp, opnd) != TCL_OK) {
goto cleanup;
| > | 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 |
|| CheckStrictlyPositive(interp, opnd) != TCL_OK) {
goto cleanup;
}
BBEmitInstInt1(assemEnvPtr, tblIdx, opnd, opnd);
break;
case ASSEM_DICT_GET:
case ASSEM_DICT_GET_DEF:
if (parsePtr->numWords != 2) {
Tcl_WrongNumArgs(interp, 1, &instNameObj, "count");
goto cleanup;
}
if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK
|| CheckStrictlyPositive(interp, opnd) != TCL_OK) {
goto cleanup;
|
| ︙ | ︙ |
Changes to generic/tclBasic.c.
| ︙ | ︙ | |||
153 154 155 156 157 158 159 160 161 162 163 164 165 166 | static Tcl_NRPostProc TEOV_RestoreVarFrame; static Tcl_NRPostProc TEOV_RunLeaveTraces; static Tcl_NRPostProc EvalObjvCore; static Tcl_NRPostProc Dispatch; static Tcl_ObjCmdProc NRCoroInjectObjCmd; static Tcl_NRPostProc NRPostInvoke; MODULE_SCOPE const TclStubs tclStubs; /* * Magical counts for the number of arguments accepted by a coroutine command * after particular kinds of [yield]. */ | > | 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 | static Tcl_NRPostProc TEOV_RestoreVarFrame; static Tcl_NRPostProc TEOV_RunLeaveTraces; static Tcl_NRPostProc EvalObjvCore; static Tcl_NRPostProc Dispatch; static Tcl_ObjCmdProc NRCoroInjectObjCmd; static Tcl_NRPostProc NRPostInvoke; static Tcl_ObjCmdProc CoroTypeObjCmd; MODULE_SCOPE const TclStubs tclStubs; /* * Magical counts for the number of arguments accepted by a coroutine command * after particular kinds of [yield]. */ |
| ︙ | ︙ | |||
239 240 241 242 243 244 245 246 247 248 249 250 251 252 |
{"lindex", Tcl_LindexObjCmd, TclCompileLindexCmd, NULL, CMD_IS_SAFE},
{"linsert", Tcl_LinsertObjCmd, TclCompileLinsertCmd, NULL, CMD_IS_SAFE},
{"list", Tcl_ListObjCmd, TclCompileListCmd, NULL, CMD_IS_SAFE|CMD_COMPILES_EXPANDED},
{"llength", Tcl_LlengthObjCmd, TclCompileLlengthCmd, NULL, CMD_IS_SAFE},
{"lmap", Tcl_LmapObjCmd, TclCompileLmapCmd, TclNRLmapCmd, CMD_IS_SAFE},
{"lpop", Tcl_LpopObjCmd, NULL, NULL, CMD_IS_SAFE},
{"lrange", Tcl_LrangeObjCmd, TclCompileLrangeCmd, NULL, CMD_IS_SAFE},
{"lrepeat", Tcl_LrepeatObjCmd, NULL, NULL, CMD_IS_SAFE},
{"lreplace", Tcl_LreplaceObjCmd, TclCompileLreplaceCmd, NULL, CMD_IS_SAFE},
{"lreverse", Tcl_LreverseObjCmd, NULL, NULL, CMD_IS_SAFE},
{"lsearch", Tcl_LsearchObjCmd, NULL, NULL, CMD_IS_SAFE},
{"lset", Tcl_LsetObjCmd, TclCompileLsetCmd, NULL, CMD_IS_SAFE},
{"lsort", Tcl_LsortObjCmd, NULL, NULL, CMD_IS_SAFE},
{"package", Tcl_PackageObjCmd, NULL, TclNRPackageObjCmd, CMD_IS_SAFE},
| > | 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 |
{"lindex", Tcl_LindexObjCmd, TclCompileLindexCmd, NULL, CMD_IS_SAFE},
{"linsert", Tcl_LinsertObjCmd, TclCompileLinsertCmd, NULL, CMD_IS_SAFE},
{"list", Tcl_ListObjCmd, TclCompileListCmd, NULL, CMD_IS_SAFE|CMD_COMPILES_EXPANDED},
{"llength", Tcl_LlengthObjCmd, TclCompileLlengthCmd, NULL, CMD_IS_SAFE},
{"lmap", Tcl_LmapObjCmd, TclCompileLmapCmd, TclNRLmapCmd, CMD_IS_SAFE},
{"lpop", Tcl_LpopObjCmd, NULL, NULL, CMD_IS_SAFE},
{"lrange", Tcl_LrangeObjCmd, TclCompileLrangeCmd, NULL, CMD_IS_SAFE},
{"lremove", Tcl_LremoveObjCmd, NULL, NULL, CMD_IS_SAFE},
{"lrepeat", Tcl_LrepeatObjCmd, NULL, NULL, CMD_IS_SAFE},
{"lreplace", Tcl_LreplaceObjCmd, TclCompileLreplaceCmd, NULL, CMD_IS_SAFE},
{"lreverse", Tcl_LreverseObjCmd, NULL, NULL, CMD_IS_SAFE},
{"lsearch", Tcl_LsearchObjCmd, NULL, NULL, CMD_IS_SAFE},
{"lset", Tcl_LsetObjCmd, TclCompileLsetCmd, NULL, CMD_IS_SAFE},
{"lsort", Tcl_LsortObjCmd, NULL, NULL, CMD_IS_SAFE},
{"package", Tcl_PackageObjCmd, NULL, TclNRPackageObjCmd, CMD_IS_SAFE},
|
| ︙ | ︙ | |||
932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 |
/* Adding the bytecode assembler command */
cmdPtr = (Command *) Tcl_NRCreateCommand(interp,
"::tcl::unsupported::assemble", Tcl_AssembleObjCmd,
TclNRAssembleObjCmd, NULL, NULL);
cmdPtr->compileProc = &TclCompileAssembleCmd;
Tcl_NRCreateCommand(interp, "::tcl::unsupported::inject", NULL,
NRCoroInjectObjCmd, NULL, NULL);
/* Export unsupported commands */
nsPtr = Tcl_FindNamespace(interp, "::tcl::unsupported", NULL, 0);
if (nsPtr) {
Tcl_Export(interp, nsPtr, "*", 1);
}
| > > > | 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 |
/* Adding the bytecode assembler command */
cmdPtr = (Command *) Tcl_NRCreateCommand(interp,
"::tcl::unsupported::assemble", Tcl_AssembleObjCmd,
TclNRAssembleObjCmd, NULL, NULL);
cmdPtr->compileProc = &TclCompileAssembleCmd;
/* Coroutine monkeybusiness */
Tcl_NRCreateCommand(interp, "::tcl::unsupported::inject", NULL,
NRCoroInjectObjCmd, NULL, NULL);
Tcl_CreateObjCommand(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);
}
|
| ︙ | ︙ | |||
2324 2325 2326 2327 2328 2329 2330 | /* * isNew - No conflict with existing command. * deleted - We've already deleted a conflicting command */ break; } | > | > > | | | < | | | < | 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 2355 2356 2357 2358 2359 2360 2361 2362 2363 2364 2365 2366 2367 2368 2369 2370 2371 2372 2373 2374 2375 2376 2377 2378 2379 2380 |
/*
* isNew - No conflict with existing command.
* deleted - We've already deleted a conflicting command
*/
break;
}
/*
* An existing command conflicts. Try to delete it...
*/
cmdPtr = Tcl_GetHashValue(hPtr);
/*
* Be careful to preserve any existing import links so we can restore
* them down below. That way, you can redefine a command and its
* import status will remain intact.
*/
cmdPtr->refCount++;
if (cmdPtr->importRefPtr) {
cmdPtr->flags |= CMD_REDEF_IN_PROGRESS;
}
Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr);
if (cmdPtr->flags & CMD_REDEF_IN_PROGRESS) {
oldRefPtr = cmdPtr->importRefPtr;
cmdPtr->importRefPtr = NULL;
}
TclCleanupCommandMacro(cmdPtr);
deleted = 1;
}
if (!isNew) {
/*
* If the deletion callback recreated the command, just throw away the
* new command (if we try to delete it again, we could get stuck in an
* infinite loop).
*/
Tcl_Free(Tcl_GetHashValue(hPtr));
}
if (!deleted) {
/*
* Command resolvers (per-interp, per-namespace) might have resolved
* to a command for the given namespace scope with this command not
* being registered with the namespace's command table. During BC
* compilation, the so-resolved command turns into a CmdName literal.
* Without invalidating a possible CmdName literal here explicitly,
* such literals keep being reused while pointing to overhauled
|
| ︙ | ︙ | |||
2542 2543 2544 2545 2546 2547 2548 | * isNew - No conflict with existing command. * deleted - We've already deleted a conflicting command */ break; } /* | | | 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 |
* isNew - No conflict with existing command.
* deleted - We've already deleted a conflicting command
*/
break;
}
/*
* An existing command conflicts. Try to delete it...
*/
cmdPtr = Tcl_GetHashValue(hPtr);
/*
* Command already exists; delete it. Be careful to preserve any
* existing import links so we can restore them down below. That way,
|
| ︙ | ︙ | |||
4167 4168 4169 4170 4171 4172 4173 |
/*
* Lookup the Command to dispatch.
*/
reresolve:
assert(cmdPtr == NULL);
if (preCmdPtr) {
| > | > > > | > > | | > < < > < | | | | | | < | | | | 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 4213 4214 4215 4216 4217 4218 4219 4220 4221 4222 4223 4224 4225 4226 4227 4228 4229 4230 4231 4232 4233 4234 4235 4236 4237 4238 4239 4240 4241 4242 4243 4244 4245 4246 4247 4248 4249 4250 4251 4252 4253 4254 4255 4256 4257 |
/*
* Lookup the Command to dispatch.
*/
reresolve:
assert(cmdPtr == NULL);
if (preCmdPtr) {
/*
* Caller gave it to us.
*/
if (!(preCmdPtr->flags & CMD_IS_DELETED)) {
/*
* So long as it exists, use it.
*/
cmdPtr = preCmdPtr;
} else if (flags & TCL_EVAL_NORESOLVE) {
/*
* When it's been deleted, and we're told not to attempt resolving
* it ourselves, all we can do is raise an error.
*/
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"attempt to invoke a deleted command"));
Tcl_SetErrorCode(interp, "TCL", "EVAL", "DELETEDCOMMAND", NULL);
return TCL_ERROR;
}
}
if (cmdPtr == NULL) {
cmdPtr = TEOV_LookupCmdFromObj(interp, objv[0], lookupNsPtr);
if (!cmdPtr) {
return TEOV_NotFound(interp, objc, objv, lookupNsPtr);
}
}
if (enterTracesDone || iPtr->tracePtr
|| (cmdPtr->flags & CMD_HAS_EXEC_TRACES)) {
Tcl_Obj *commandPtr = TclGetSourceFromFrame(
flags & TCL_EVAL_SOURCE_IN_FRAME ? iPtr->cmdFramePtr : NULL,
objc, objv);
Tcl_IncrRefCount(commandPtr);
if (!enterTracesDone) {
int code = TEOV_RunEnterTraces(interp, &cmdPtr, commandPtr,
objc, objv);
/*
* Send any exception from enter traces back as an exception
* raised by the traced command.
* TODO: Is this a bug? Letting an execution trace BREAK or
* CONTINUE or RETURN in the place of the traced command? Would
* either converting all exceptions to TCL_ERROR, or just
* swallowing them be better? (Swallowing them has the problem of
* permanently hiding program errors.)
*/
if (code != TCL_OK) {
Tcl_DecrRefCount(commandPtr);
return code;
}
/*
* If the enter traces made the resolved cmdPtr unusable, go back
* and resolve again, but next time don't run enter traces again.
*/
if (cmdPtr == NULL) {
enterTracesDone = 1;
Tcl_DecrRefCount(commandPtr);
goto reresolve;
}
}
/*
* Schedule leave traces. Raise the refCount on the resolved cmdPtr,
* so that when it passes to the leave traces we know it's still
* valid.
*/
cmdPtr->refCount++;
TclNRAddCallback(interp, TEOV_RunLeaveTraces, INT2PTR(objc),
commandPtr, cmdPtr, objv);
}
|
| ︙ | ︙ | |||
4300 4301 4302 4303 4304 4305 4306 |
TclNRRunCallbacks(
Tcl_Interp *interp,
int result,
struct NRE_callback *rootPtr)
/* All callbacks down to rootPtr not inclusive
* are to be run. */
{
| > | | < < < | 4310 4311 4312 4313 4314 4315 4316 4317 4318 4319 4320 4321 4322 4323 4324 4325 4326 4327 |
TclNRRunCallbacks(
Tcl_Interp *interp,
int result,
struct NRE_callback *rootPtr)
/* All callbacks down to rootPtr not inclusive
* are to be run. */
{
while (TOP_CB(interp) != rootPtr) {
NRE_callback *callbackPtr = TOP_CB(interp);
Tcl_NRPostProc *procPtr = callbackPtr->procPtr;
TOP_CB(interp) = callbackPtr->nextPtr;
result = procPtr(callbackPtr->data, interp, result);
TCLNR_FREE(interp, callbackPtr);
}
return result;
}
|
| ︙ | ︙ | |||
4465 4466 4467 4468 4469 4470 4471 |
Interp *iPtr = (Interp *) interp;
Tcl_Obj *listPtr;
const char *cmdString;
size_t cmdLen;
int objc = PTR2INT(data[0]);
Tcl_Obj **objv = data[1];
| | | 4473 4474 4475 4476 4477 4478 4479 4480 4481 4482 4483 4484 4485 4486 4487 |
Interp *iPtr = (Interp *) interp;
Tcl_Obj *listPtr;
const char *cmdString;
size_t cmdLen;
int objc = PTR2INT(data[0]);
Tcl_Obj **objv = data[1];
if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) {
/*
* If there was an error, a command string will be needed for the
* error log: get it out of the itemPtr. The details depend on the
* type.
*/
listPtr = Tcl_NewListObj(objc, objv);
|
| ︙ | ︙ | |||
4674 4675 4676 4677 4678 4679 4680 |
Tcl_Obj *commandPtr = data[1];
Command *cmdPtr = data[2];
Tcl_Obj **objv = data[3];
size_t length;
const char *command = TclGetStringFromObj(commandPtr, &length);
if (!(cmdPtr->flags & CMD_IS_DELETED)) {
| | | 4682 4683 4684 4685 4686 4687 4688 4689 4690 4691 4692 4693 4694 4695 4696 |
Tcl_Obj *commandPtr = data[1];
Command *cmdPtr = data[2];
Tcl_Obj **objv = data[3];
size_t length;
const char *command = TclGetStringFromObj(commandPtr, &length);
if (!(cmdPtr->flags & CMD_IS_DELETED)) {
if (cmdPtr->flags & CMD_HAS_EXEC_TRACES) {
traceCode = TclCheckExecutionTraces(interp, command, length,
cmdPtr, result, TCL_TRACE_LEAVE_EXEC, objc, objv);
}
if (iPtr->tracePtr != NULL && traceCode == TCL_OK) {
traceCode = TclCheckInterpTraces(interp, command, length,
cmdPtr, result, TCL_TRACE_LEAVE_EXEC, objc, objv);
}
|
| ︙ | ︙ | |||
6373 6374 6375 6376 6377 6378 6379 |
"invalid hidden command name \"%s\"", cmdName));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "HIDDENTOKEN", cmdName,
NULL);
return TCL_ERROR;
}
cmdPtr = Tcl_GetHashValue(hPtr);
| > | > > | | | 6381 6382 6383 6384 6385 6386 6387 6388 6389 6390 6391 6392 6393 6394 6395 6396 6397 6398 6399 6400 6401 6402 6403 6404 6405 |
"invalid hidden command name \"%s\"", cmdName));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "HIDDENTOKEN", cmdName,
NULL);
return TCL_ERROR;
}
cmdPtr = Tcl_GetHashValue(hPtr);
/*
* Avoid the exception-handling brain damage when numLevels == 0
*/
iPtr->numLevels++;
Tcl_NRAddCallback(interp, NRPostInvoke, NULL, NULL, NULL, NULL);
/*
* Normal command resolution of objv[0] isn't going to find cmdPtr.
* That's the whole point of **hidden** commands. So tell the Eval core
* machinery not to even try (and risk finding something wrong).
*/
return TclNREvalObjv(interp, objc, objv, TCL_EVAL_NORESOLVE, cmdPtr);
}
static int
NRPostInvoke(
|
| ︙ | ︙ | |||
7621 7622 7623 7624 7625 7626 7627 |
kini("line"); kini("level");
#undef kini
}
for (i = 0; i < 6; i++) {
Tcl_DictObjGet(NULL, info, *k++, &val);
args[i] = val ? TclGetString(val) : NULL;
}
| > > | > > > > | > > | 7632 7633 7634 7635 7636 7637 7638 7639 7640 7641 7642 7643 7644 7645 7646 7647 7648 7649 7650 7651 7652 7653 7654 7655 7656 7657 7658 7659 7660 |
kini("line"); kini("level");
#undef kini
}
for (i = 0; i < 6; i++) {
Tcl_DictObjGet(NULL, info, *k++, &val);
args[i] = val ? TclGetString(val) : NULL;
}
/*
* no "proc" -> use "lambda"
*/
if (!args[2]) {
Tcl_DictObjGet(NULL, info, *k, &val);
args[2] = val ? TclGetString(val) : NULL;
}
k++;
/*
* no "class" -> use "object"
*/
if (!args[5]) {
Tcl_DictObjGet(NULL, info, *k, &val);
args[5] = val ? TclGetString(val) : NULL;
}
k++;
for (i = 0; i < 2; i++) {
Tcl_DictObjGet(NULL, info, *k++, &val);
|
| ︙ | ︙ | |||
7981 7982 7983 7984 7985 7986 7987 |
* at the proper time.
*/
if (objc > 1) {
Tcl_Obj *listPtr, *nsObjPtr;
Tcl_Namespace *nsPtr = (Tcl_Namespace *) iPtr->varFramePtr->nsPtr;
| > | | > | 8000 8001 8002 8003 8004 8005 8006 8007 8008 8009 8010 8011 8012 8013 8014 8015 8016 8017 |
* at the proper time.
*/
if (objc > 1) {
Tcl_Obj *listPtr, *nsObjPtr;
Tcl_Namespace *nsPtr = (Tcl_Namespace *) iPtr->varFramePtr->nsPtr;
/*
* The tailcall data is in a Tcl list: the first element is the
* namespace, the rest the command to be tailcalled.
*/
nsObjPtr = Tcl_NewStringObj(nsPtr->fullName, -1);
listPtr = Tcl_NewListObj(objc, objv);
TclListObjSetElement(interp, listPtr, 0, nsObjPtr);
iPtr->varFramePtr->tailcallPtr = listPtr;
}
|
| ︙ | ︙ | |||
8433 8434 8435 8436 8437 8438 8439 8440 8441 8442 8443 8444 8445 8446 |
TclListObjGetElements(NULL, listPtr, &objc, &objv);
return TclNREvalObjv(interp, objc, objv, 0, NULL);
}
/*
*----------------------------------------------------------------------
*
* NRCoroInjectObjCmd --
*
* Implementation of [::tcl::unsupported::inject] command.
*
*----------------------------------------------------------------------
*/
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 8454 8455 8456 8457 8458 8459 8460 8461 8462 8463 8464 8465 8466 8467 8468 8469 8470 8471 8472 8473 8474 8475 8476 8477 8478 8479 8480 8481 8482 8483 8484 8485 8486 8487 8488 8489 8490 8491 8492 8493 8494 8495 8496 8497 8498 8499 8500 8501 8502 8503 8504 8505 8506 8507 8508 8509 8510 8511 8512 8513 8514 8515 8516 8517 8518 8519 8520 8521 8522 8523 8524 8525 8526 8527 8528 8529 8530 8531 8532 8533 8534 8535 8536 |
TclListObjGetElements(NULL, listPtr, &objc, &objv);
return TclNREvalObjv(interp, objc, objv, 0, NULL);
}
/*
*----------------------------------------------------------------------
*
* CoroTypeObjCmd --
*
* Implementation of [::tcl::unsupported::corotype] command.
*
*----------------------------------------------------------------------
*/
static int
CoroTypeObjCmd(
ClientData clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Command *cmdPtr;
CoroutineData *corPtr;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "coroName");
return TCL_ERROR;
}
/*
* Look up the coroutine.
*/
cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[1]);
if ((!cmdPtr) || (cmdPtr->nreProc != TclNRInterpCoroutine)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"can only get coroutine type of a coroutine", -1));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COROUTINE",
TclGetString(objv[1]), NULL);
return TCL_ERROR;
}
/*
* An active coroutine is "active". Can't tell what it might do in the
* future.
*/
corPtr = cmdPtr->objClientData;
if (!COR_IS_SUSPENDED(corPtr)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj("active", -1));
return TCL_OK;
}
/*
* Inactive coroutines are classified by the (effective) command used to
* suspend them, which matters when you're injecting a probe.
*/
switch (corPtr->nargs) {
case COROUTINE_ARGUMENTS_SINGLE_OPTIONAL:
Tcl_SetObjResult(interp, Tcl_NewStringObj("yield", -1));
return TCL_OK;
case COROUTINE_ARGUMENTS_ARBITRARY:
Tcl_SetObjResult(interp, Tcl_NewStringObj("yieldto", -1));
return TCL_OK;
default:
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"unknown coroutine type", -1));
Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "BAD_TYPE", NULL);
return TCL_ERROR;
}
}
/*
*----------------------------------------------------------------------
*
* NRCoroInjectObjCmd --
*
* Implementation of [::tcl::unsupported::inject] command.
*
*----------------------------------------------------------------------
*/
|
| ︙ | ︙ | |||
8663 8664 8665 8666 8667 8668 8669 |
corPtr->callerEEPtr = iPtr->execEnvPtr;
RESTORE_CONTEXT(corPtr->running);
iPtr->execEnvPtr = corPtr->eePtr;
TclNRAddCallback(interp, NRCoroutineExitCallback, corPtr,
NULL, NULL, NULL);
| > | > > | | 8753 8754 8755 8756 8757 8758 8759 8760 8761 8762 8763 8764 8765 8766 8767 8768 8769 8770 8771 8772 |
corPtr->callerEEPtr = iPtr->execEnvPtr;
RESTORE_CONTEXT(corPtr->running);
iPtr->execEnvPtr = corPtr->eePtr;
TclNRAddCallback(interp, NRCoroutineExitCallback, corPtr,
NULL, NULL, NULL);
/*
* Ensure that the command is looked up in the correct namespace.
*/
iPtr->lookupNsPtr = lookupNsPtr;
Tcl_NREvalObj(interp, Tcl_NewListObj(objc - 2, objv + 2), 0);
iPtr->numLevels--;
SAVE_CONTEXT(corPtr->running);
RESTORE_CONTEXT(corPtr->caller);
iPtr->execEnvPtr = corPtr->callerEEPtr;
/*
|
| ︙ | ︙ |
Changes to generic/tclBinary.c.
| ︙ | ︙ | |||
754 755 756 757 758 759 760 |
Tcl_Panic("%s called with shared object","TclAppendBytesToByteArray");
}
if (len == TCL_AUTO_LENGTH) {
Tcl_Panic("%s must be called with definite number of bytes to append",
"TclAppendBytesToByteArray");
}
if (len == 0) {
| > | > > | 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 |
Tcl_Panic("%s called with shared object","TclAppendBytesToByteArray");
}
if (len == TCL_AUTO_LENGTH) {
Tcl_Panic("%s must be called with definite number of bytes to append",
"TclAppendBytesToByteArray");
}
if (len == 0) {
/*
* Append zero bytes is a no-op.
*/
return;
}
irPtr = TclFetchIntRep(objPtr, &properByteArrayType);
if (irPtr == NULL) {
irPtr = TclFetchIntRep(objPtr, &tclByteArrayType);
if (irPtr == NULL) {
|
| ︙ | ︙ |
Changes to generic/tclCmdIL.c.
| ︙ | ︙ | |||
2582 2583 2584 2585 2586 2587 2588 |
ClientData notUsed, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
register Tcl_Obj *const objv[])
/* Argument objects. */
{
int listLen, result;
| | | 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 |
ClientData notUsed, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
register Tcl_Obj *const objv[])
/* Argument objects. */
{
int listLen, result;
Tcl_Obj *elemPtr, *stored;
Tcl_Obj *listPtr, **elemPtrs;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "listvar ?index?");
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 |
}
}
Tcl_SetObjResult(interp, elemPtr);
Tcl_DecrRefCount(elemPtr);
/*
* Second, remove the element.
*/
if (objc == 2) {
if (Tcl_IsShared(listPtr)) {
listPtr = TclListObjCopy(NULL, listPtr);
}
result = Tcl_ListObjReplace(interp, listPtr, listLen - 1, 1, 0, NULL);
if (result != TCL_OK) {
return result;
}
} else {
listPtr = TclLsetFlat(interp, listPtr, objc-2, objv+2, NULL);
if (listPtr == NULL) {
return TCL_ERROR;
}
}
| > > | > | | 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 |
}
}
Tcl_SetObjResult(interp, elemPtr);
Tcl_DecrRefCount(elemPtr);
/*
* Second, remove the element.
* TclLsetFlat adds a ref count which is handled.
*/
if (objc == 2) {
if (Tcl_IsShared(listPtr)) {
listPtr = TclListObjCopy(NULL, listPtr);
}
result = Tcl_ListObjReplace(interp, listPtr, listLen - 1, 1, 0, NULL);
if (result != TCL_OK) {
return result;
}
Tcl_IncrRefCount(listPtr);
} else {
listPtr = TclLsetFlat(interp, listPtr, objc-2, objv+2, NULL);
if (listPtr == NULL) {
return TCL_ERROR;
}
}
stored = Tcl_ObjSetVar2(interp, objv[1], NULL, listPtr, TCL_LEAVE_ERR_MSG);
Tcl_DecrRefCount(listPtr);
if (stored == NULL) {
return TCL_ERROR;
}
return TCL_OK;
}
/*
|
| ︙ | ︙ | |||
2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 |
if (result != TCL_OK) {
return result;
}
Tcl_SetObjResult(interp, TclListObjRange(objv[1], first, last));
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_LrepeatObjCmd --
*
* This procedure is invoked to process the "lrepeat" Tcl command. See
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 2808 2809 2810 2811 2812 2813 2814 2815 2816 2817 2818 2819 2820 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 2847 2848 2849 |
if (result != TCL_OK) {
return result;
}
Tcl_SetObjResult(interp, TclListObjRange(objv[1], first, last));
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_LremoveObjCmd --
*
* This procedure is invoked to process the "lremove" Tcl command. See the
* user documentation for details on what it does.
*
* Results:
* A standard Tcl object result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
LremoveIndexCompare(
const void *el1Ptr,
const void *el2Ptr)
{
size_t idx1 = *((const size_t *) el1Ptr);
size_t idx2 = *((const size_t *) el2Ptr);
/*
* This will put the larger element first.
*/
return (idx1 < idx2) ? 1 : (idx1 > idx2) ? -1 : 0;
}
int
Tcl_LremoveObjCmd(
ClientData notUsed, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int i, idxc, listLen, prevIdx, first, num;
size_t *idxv;
Tcl_Obj *listObj;
/*
* Parse the arguments.
*/
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "list ?index ...?");
return TCL_ERROR;
}
listObj = objv[1];
if (TclListObjLength(interp, listObj, &listLen) != TCL_OK) {
return TCL_ERROR;
}
idxc = objc - 2;
if (idxc == 0) {
Tcl_SetObjResult(interp, listObj);
return TCL_OK;
}
idxv = Tcl_Alloc((objc - 2) * sizeof(size_t));
for (i = 2; i < objc; i++) {
if (TclGetIntForIndexM(interp, objv[i], /*endValue*/ listLen - 1,
&idxv[i - 2]) != TCL_OK) {
Tcl_Free(idxv);
return TCL_ERROR;
}
}
/*
* Sort the indices, large to small so that when we remove an index we
* don't change the indices still to be processed.
*/
if (idxc > 1) {
qsort(idxv, idxc, sizeof(size_t), LremoveIndexCompare);
}
/*
* Make our working copy, then do the actual removes piecemeal.
*/
if (Tcl_IsShared(listObj)) {
listObj = TclListObjCopy(NULL, listObj);
}
num = 0;
first = listLen;
for (i = 0, prevIdx = -1 ; i < idxc ; i++) {
int idx = idxv[i];
/*
* Repeated index and sanity check.
*/
if (idx == prevIdx) {
continue;
}
prevIdx = idx;
if (idx < 0 || idx >= listLen) {
continue;
}
/*
* Coalesce adjacent removes to reduce the number of copies.
*/
if (num == 0) {
num = 1;
first = idx;
} else if (idx + 1 == first) {
num++;
first = idx;
} else {
/*
* Note that this operation can't fail now; we know we have a list
* and we're only ever contracting that list.
*/
(void) Tcl_ListObjReplace(interp, listObj, first, num, 0, NULL);
listLen -= num;
num = 1;
first = idx;
}
}
if (num != 0) {
(void) Tcl_ListObjReplace(interp, listObj, first, num, 0, NULL);
}
Tcl_Free(idxv);
Tcl_SetObjResult(interp, listObj);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_LrepeatObjCmd --
*
* This procedure is invoked to process the "lrepeat" Tcl command. See
|
| ︙ | ︙ | |||
4185 4186 4187 4188 4189 4190 4191 |
/*
* The following loop creates a SortElement for each list element and
* begins sorting it into the sublists as it appears.
*/
elementArray = Tcl_Alloc(length * sizeof(SortElement));
| | | 4322 4323 4324 4325 4326 4327 4328 4329 4330 4331 4332 4333 4334 4335 4336 |
/*
* The following loop creates a SortElement for each list element and
* begins sorting it into the sublists as it appears.
*/
elementArray = Tcl_Alloc(length * sizeof(SortElement));
for (i=0; i < length; i++) {
idx = groupSize * i + groupOffset;
if (indexc) {
/*
* If this is an indexed sort, retrieve the corresponding element
*/
indexPtr = SelectObjFromSublist(listObjPtrs[idx], &sortInfo);
if (sortInfo.resultCode != TCL_OK) {
|
| ︙ | ︙ |
Changes to generic/tclCmdMZ.c.
| ︙ | ︙ | |||
1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 |
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* StringIsCmd --
*
* This procedure is invoked to process the "string is" Tcl command. See
* the user documentation for details on what it does. Note that this
* command only functions correctly on properly formed Tcl UTF strings.
*
* Results:
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 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 |
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* StringInsertCmd --
*
* This procedure is invoked to process the "string insert" Tcl command.
* See the user documentation for details on what it does. Note that this
* command only functions correctly on properly formed Tcl UTF strings.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
StringInsertCmd(
ClientData dummy, /* Not used */
Tcl_Interp *interp, /* Current interpreter */
int objc, /* Number of arguments */
Tcl_Obj *const objv[]) /* Argument objects */
{
size_t length; /* String length */
size_t index; /* Insert index */
Tcl_Obj *outObj; /* Output object */
if (objc != 4) {
Tcl_WrongNumArgs(interp, 1, objv, "string index insertString");
return TCL_ERROR;
}
length = Tcl_GetCharLength(objv[1]);
if (TclGetIntForIndexM(interp, objv[2], length, &index) != TCL_OK) {
return TCL_ERROR;
}
if (index == TCL_INDEX_NONE) {
index = TCL_INDEX_START;
}
if (index > length) {
index = length;
}
outObj = TclStringReplace(interp, objv[1], index, 0, objv[3],
TCL_STRING_IN_PLACE);
if (outObj != NULL) {
Tcl_SetObjResult(interp, outObj);
return TCL_OK;
}
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* StringIsCmd --
*
* This procedure is invoked to process the "string is" Tcl command. See
* the user documentation for details on what it does. Note that this
* command only functions correctly on properly formed Tcl UTF strings.
*
* Results:
|
| ︙ | ︙ | |||
1952 1953 1954 1955 1956 1957 1958 |
/*
* This test is tricky, but has to be that way or you get other strange
* inconsistencies (see test string-10.20.1 for illustration why!)
*/
if (!TclHasStringRep(objv[objc-2])
| | | 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 |
/*
* This test is tricky, but has to be that way or you get other strange
* inconsistencies (see test string-10.20.1 for illustration why!)
*/
if (!TclHasStringRep(objv[objc-2])
&& TclHasIntRep(objv[objc-2], &tclDictType)) {
int i, done;
Tcl_DictSearch search;
/*
* We know the type exactly, so all dict operations will succeed for
* sure. This shortens this code quite a bit.
*/
|
| ︙ | ︙ | |||
2369 2370 2371 2372 2373 2374 2375 |
Tcl_WrongNumArgs(interp, 1, objv, "string first last ?string?");
return TCL_ERROR;
}
end = Tcl_GetCharLength(objv[1]) - 1;
if (TclGetIntForIndexM(interp, objv[2], end, &first) != TCL_OK ||
| | | | | > | < > | 2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 |
Tcl_WrongNumArgs(interp, 1, objv, "string first last ?string?");
return TCL_ERROR;
}
end = Tcl_GetCharLength(objv[1]) - 1;
if (TclGetIntForIndexM(interp, objv[2], end, &first) != TCL_OK ||
TclGetIntForIndexM(interp, objv[3], end, &last) != TCL_OK) {
return TCL_ERROR;
}
/*
* The following test screens out most empty substrings as candidates for
* replacement. When they are detected, no replacement is done, and the
* result is the original string.
*/
if ((last == TCL_INDEX_NONE) || /* Range ends before start of string */
(first + 1 > end + 1) || /* Range begins after end of string */
(last + 1 < first + 1)) { /* Range begins after it starts */
/*
* BUT!!! when (end < 0) -- an empty original string -- we can
* have (first <= end < 0 <= last) and an empty string is permitted
* to be replaced.
*/
Tcl_SetObjResult(interp, objv[1]);
} else {
Tcl_Obj *resultPtr;
if (first == TCL_INDEX_NONE) {
first = TCL_INDEX_START;
}
|
| ︙ | ︙ | |||
3276 3277 3278 3279 3280 3281 3282 3283 3284 3285 3286 3287 3288 3289 |
static const EnsembleImplMap stringImplMap[] = {
{"bytelength", StringBytesCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"cat", StringCatCmd, TclCompileStringCatCmd, NULL, NULL, 0},
{"compare", StringCmpCmd, TclCompileStringCmpCmd, NULL, NULL, 0},
{"equal", StringEqualCmd, TclCompileStringEqualCmd, NULL, NULL, 0},
{"first", StringFirstCmd, TclCompileStringFirstCmd, NULL, NULL, 0},
{"index", StringIndexCmd, TclCompileStringIndexCmd, NULL, NULL, 0},
{"is", StringIsCmd, TclCompileStringIsCmd, NULL, NULL, 0},
{"last", StringLastCmd, TclCompileStringLastCmd, NULL, NULL, 0},
{"length", StringLenCmd, TclCompileStringLenCmd, NULL, NULL, 0},
{"map", StringMapCmd, TclCompileStringMapCmd, NULL, NULL, 0},
{"match", StringMatchCmd, TclCompileStringMatchCmd, NULL, NULL, 0},
{"range", StringRangeCmd, TclCompileStringRangeCmd, NULL, NULL, 0},
{"repeat", StringReptCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
| > | 3334 3335 3336 3337 3338 3339 3340 3341 3342 3343 3344 3345 3346 3347 3348 |
static const EnsembleImplMap stringImplMap[] = {
{"bytelength", StringBytesCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"cat", StringCatCmd, TclCompileStringCatCmd, NULL, NULL, 0},
{"compare", StringCmpCmd, TclCompileStringCmpCmd, NULL, NULL, 0},
{"equal", StringEqualCmd, TclCompileStringEqualCmd, NULL, NULL, 0},
{"first", StringFirstCmd, TclCompileStringFirstCmd, NULL, NULL, 0},
{"index", StringIndexCmd, TclCompileStringIndexCmd, NULL, NULL, 0},
{"insert", StringInsertCmd, TclCompileStringInsertCmd, NULL, NULL, 0},
{"is", StringIsCmd, TclCompileStringIsCmd, NULL, NULL, 0},
{"last", StringLastCmd, TclCompileStringLastCmd, NULL, NULL, 0},
{"length", StringLenCmd, TclCompileStringLenCmd, NULL, NULL, 0},
{"map", StringMapCmd, TclCompileStringMapCmd, NULL, NULL, 0},
{"match", StringMatchCmd, TclCompileStringMatchCmd, NULL, NULL, 0},
{"range", StringRangeCmd, TclCompileStringRangeCmd, NULL, NULL, 0},
{"repeat", StringReptCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
|
| ︙ | ︙ | |||
3573 3574 3575 3576 3577 3578 3579 |
*/
splitObjs = 0;
if (objc == 1) {
Tcl_Obj **listv;
blist = objv[0];
| | | 3632 3633 3634 3635 3636 3637 3638 3639 3640 3641 3642 3643 3644 3645 3646 |
*/
splitObjs = 0;
if (objc == 1) {
Tcl_Obj **listv;
blist = objv[0];
if (TclListObjGetElements(interp, objv[0], &objc, &listv) != TCL_OK) {
return TCL_ERROR;
}
/*
* Ensure that the list is non-empty.
*/
|
| ︙ | ︙ | |||
4083 4084 4085 4086 4087 4088 4089 4090 4091 4092 4093 | /* *---------------------------------------------------------------------- * * Tcl_TimeRateObjCmd -- * * This object-based procedure is invoked to process the "timerate" Tcl * command. * This is similar to command "time", except the execution limited by * given time (in milliseconds) instead of repetition count. * * Example: | > | | > | | | > | < < | | > | 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_TimeRateObjCmd --
*
* This object-based procedure is invoked to process the "timerate" Tcl
* command.
*
* This is similar to command "time", except the execution limited by
* given time (in milliseconds) instead of repetition count.
*
* Example:
* timerate {after 5} 1000; # equivalent to: time {after 5} [expr 1000/5]
*
* Results:
* A standard Tcl object result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_TimeRateObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
static double measureOverhead = 0;
/* global measure-overhead */
double overhead = -1; /* given measure-overhead */
register Tcl_Obj *objPtr;
register int result, i;
Tcl_Obj *calibrate = NULL, *direct = NULL;
Tcl_WideUInt count = 0; /* Holds repetition count */
Tcl_WideInt maxms = WIDE_MIN;
/* Maximal running time (in milliseconds) */
Tcl_WideUInt maxcnt = WIDE_MAX;
/* Maximal count of iterations. */
Tcl_WideUInt threshold = 1; /* Current threshold for check time (faster
* repeat count without time check) */
Tcl_WideUInt maxIterTm = 1; /* Max time of some iteration as max
* threshold, additionally avoiding divide to
* zero (i.e., never < 1) */
unsigned short factor = 50; /* Factor (4..50) limiting threshold to avoid
* growth of execution time. */
register Tcl_WideInt start, middle, stop;
#ifndef TCL_WIDE_CLICKS
Tcl_Time now;
#endif /* !TCL_WIDE_CLICKS */
static const char *const options[] = {
"-direct", "-overhead", "-calibrate", "--", NULL
};
enum options {
TMRT_EV_DIRECT, TMRT_OVERHEAD, TMRT_CALIBRATE, TMRT_LAST
};
NRE_callback *rootPtr;
ByteCode *codePtr = NULL;
for (i = 1; i < objc - 1; i++) {
int index;
if (Tcl_GetIndexFromObj(NULL, objv[i], options, "option", TCL_EXACT,
&index) != TCL_OK) {
break;
}
if (index == TMRT_LAST) {
i++;
break;
|
| ︙ | ︙ | |||
4164 4165 4166 4167 4168 4169 4170 |
break;
case TMRT_CALIBRATE:
calibrate = objv[i];
break;
}
}
| | | | > > > > | > > | | > > | > | > > | > | | > > | > | > > | > | > > | | > > | > > | > > | > | | < > | > > > | > > > | > > | < | > | > > > > | > > > | > > > > | > > | > > > > | > > | > | > > | | > | < > > | < | | | | < | | | > | > > > | | | > > | > > | | | | > | > > | > | > > | > > | | | | | > > | > | | | > | | > > > | | > | > > > > > > > > > > > > < < | | < | | > | | > | > | > | > > | > > | > | | | | > > | | | > > > | | | | > > | > > | | > | | | > | > > | | > | > > > | > > > | > > > | > | > > | | | | > | > | > | | > > > | > | > > | > > | > | | > > > | > > | > > | | | | < < | 4225 4226 4227 4228 4229 4230 4231 4232 4233 4234 4235 4236 4237 4238 4239 4240 4241 4242 4243 4244 4245 4246 4247 4248 4249 4250 4251 4252 4253 4254 4255 4256 4257 4258 4259 4260 4261 4262 4263 4264 4265 4266 4267 4268 4269 4270 4271 4272 4273 4274 4275 4276 4277 4278 4279 4280 4281 4282 4283 4284 4285 4286 4287 4288 4289 4290 4291 4292 4293 4294 4295 4296 4297 4298 4299 4300 4301 4302 4303 4304 4305 4306 4307 4308 4309 4310 4311 4312 4313 4314 4315 4316 4317 4318 4319 4320 4321 4322 4323 4324 4325 4326 4327 4328 4329 4330 4331 4332 4333 4334 4335 4336 4337 4338 4339 4340 4341 4342 4343 4344 4345 4346 4347 4348 4349 4350 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 4392 4393 4394 4395 4396 4397 4398 4399 4400 4401 4402 4403 4404 4405 4406 4407 4408 4409 4410 4411 4412 4413 4414 4415 4416 4417 4418 4419 4420 4421 4422 4423 4424 4425 4426 4427 4428 4429 4430 4431 4432 4433 4434 4435 4436 4437 4438 4439 4440 4441 4442 4443 4444 4445 4446 4447 4448 4449 4450 4451 4452 4453 4454 4455 4456 4457 4458 4459 4460 4461 4462 4463 4464 4465 4466 4467 4468 4469 4470 4471 4472 4473 4474 4475 4476 4477 4478 4479 4480 4481 4482 4483 4484 4485 4486 4487 4488 4489 4490 4491 4492 4493 4494 4495 4496 4497 4498 4499 4500 4501 4502 4503 4504 4505 4506 4507 4508 4509 4510 4511 4512 4513 4514 4515 4516 4517 4518 4519 4520 4521 4522 4523 4524 4525 4526 4527 4528 4529 4530 4531 4532 4533 4534 4535 4536 4537 4538 4539 4540 4541 4542 4543 4544 4545 4546 4547 4548 4549 4550 4551 4552 4553 4554 4555 4556 4557 4558 4559 4560 4561 4562 4563 4564 4565 4566 4567 4568 4569 4570 4571 4572 4573 4574 4575 4576 4577 4578 4579 4580 4581 4582 4583 4584 4585 4586 4587 4588 4589 4590 4591 4592 4593 4594 4595 4596 4597 4598 4599 4600 4601 4602 4603 4604 4605 4606 4607 4608 4609 4610 4611 4612 4613 4614 4615 4616 4617 4618 4619 4620 4621 4622 4623 4624 4625 4626 4627 4628 4629 4630 4631 4632 4633 4634 4635 4636 4637 4638 4639 4640 4641 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 |
break;
case TMRT_CALIBRATE:
calibrate = objv[i];
break;
}
}
if (i >= objc || i < objc - 3) {
usage:
Tcl_WrongNumArgs(interp, 1, objv,
"?-direct? ?-calibrate? ?-overhead double? "
"command ?time ?max-count??");
return TCL_ERROR;
}
objPtr = objv[i++];
if (i < objc) { /* max-time */
result = Tcl_GetWideIntFromObj(interp, objv[i++], &maxms);
if (result != TCL_OK) {
return result;
}
if (i < objc) { /* max-count*/
Tcl_WideInt v;
result = Tcl_GetWideIntFromObj(interp, objv[i], &v);
if (result != TCL_OK) {
return result;
}
maxcnt = (v > 0) ? v : 0;
}
}
/*
* If we are doing calibration.
*/
if (calibrate) {
/*
* If no time specified for the calibration.
*/
if (maxms == WIDE_MIN) {
Tcl_Obj *clobjv[6];
Tcl_WideInt maxCalTime = 5000;
double lastMeasureOverhead = measureOverhead;
clobjv[0] = objv[0];
i = 1;
if (direct) {
clobjv[i++] = direct;
}
clobjv[i++] = objPtr;
/*
* Reset last measurement overhead.
*/
measureOverhead = (double) 0;
/*
* Self-call with 100 milliseconds to warm-up, before entering the
* calibration cycle.
*/
TclNewIntObj(clobjv[i], 100);
Tcl_IncrRefCount(clobjv[i]);
result = Tcl_TimeRateObjCmd(NULL, interp, i + 1, clobjv);
Tcl_DecrRefCount(clobjv[i]);
if (result != TCL_OK) {
return result;
}
i--;
clobjv[i++] = calibrate;
clobjv[i++] = objPtr;
/*
* Set last measurement overhead to max.
*/
measureOverhead = (double) UWIDE_MAX;
/*
* Run the calibration cycle until it is more precise.
*/
maxms = -1000;
do {
lastMeasureOverhead = measureOverhead;
TclNewIntObj(clobjv[i], (int) maxms);
Tcl_IncrRefCount(clobjv[i]);
result = Tcl_TimeRateObjCmd(NULL, interp, i + 1, clobjv);
Tcl_DecrRefCount(clobjv[i]);
if (result != TCL_OK) {
return result;
}
maxCalTime += maxms;
/*
* Increase maxms for more precise calibration.
*/
maxms -= -maxms / 4;
/*
* As long as new value more as 0.05% better
*/
} while ((measureOverhead >= lastMeasureOverhead
|| measureOverhead / lastMeasureOverhead <= 0.9995)
&& maxCalTime > 0);
return result;
}
if (maxms == 0) {
/*
* Reset last measurement overhead
*/
measureOverhead = 0;
Tcl_SetObjResult(interp, Tcl_NewLongObj(0));
return TCL_OK;
}
/*
* If time is negative, make current overhead more precise.
*/
if (maxms > 0) {
/*
* Set last measurement overhead to max.
*/
measureOverhead = (double) UWIDE_MAX;
} else {
maxms = -maxms;
}
}
if (maxms == WIDE_MIN) {
maxms = 1000;
}
if (overhead == -1) {
overhead = measureOverhead;
}
/*
* Ensure that resetting of result will not smudge the further
* measurement.
*/
Tcl_ResetResult(interp);
/*
* Compile object if needed.
*/
if (!direct) {
if (TclInterpReady(interp) != TCL_OK) {
return TCL_ERROR;
}
codePtr = TclCompileObj(interp, objPtr, NULL, 0);
TclPreserveByteCode(codePtr);
}
/*
* Get start and stop time.
*/
#ifdef TCL_WIDE_CLICKS
start = middle = TclpGetWideClicks();
/*
* Time to stop execution (in wide clicks).
*/
stop = start + (maxms * 1000 / TclpWideClickInMicrosec());
#else
Tcl_GetTime(&now);
start = now.sec;
start *= 1000000;
start += now.usec;
middle = start;
/*
* Time to stop execution (in microsecs).
*/
stop = start + maxms * 1000;
#endif /* TCL_WIDE_CLICKS */
/*
* Start measurement.
*/
if (maxcnt > 0) {
while (1) {
/*
* Evaluate a single iteration.
*/
count++;
if (!direct) { /* precompiled */
rootPtr = TOP_CB(interp);
result = TclNRExecuteByteCode(interp, codePtr);
result = TclNRRunCallbacks(interp, result, rootPtr);
} else { /* eval */
result = TclEvalObjEx(interp, objPtr, 0, NULL, 0);
}
if (result != TCL_OK) {
/*
* Allow break from measurement cycle (used for conditional
* stop).
*/
if (result != TCL_BREAK) {
goto done;
}
/*
* Force stop immediately.
*/
threshold = 1;
maxcnt = 0;
result = TCL_OK;
}
/*
* Don't check time up to threshold.
*/
if (--threshold > 0) {
continue;
}
/*
* Check stop time reached, estimate new threshold.
*/
#ifdef TCL_WIDE_CLICKS
middle = TclpGetWideClicks();
#else
Tcl_GetTime(&now);
middle = now.sec;
middle *= 1000000;
middle += now.usec;
#endif /* TCL_WIDE_CLICKS */
if (middle >= stop || count >= maxcnt) {
break;
}
/*
* Don't calculate threshold by few iterations, because sometimes
* first iteration(s) can be too fast or slow (cached, delayed
* clean up, etc).
*/
if (count < 10) {
threshold = 1;
continue;
}
/*
* Average iteration time in microsecs.
*/
threshold = (middle - start) / count;
if (threshold > maxIterTm) {
maxIterTm = threshold;
/*
* Iterations seem to be longer.
*/
if (threshold > maxIterTm * 2) {
factor *= 2;
if (factor > 50) {
factor = 50;
}
} else {
if (factor < 50) {
factor++;
}
}
} else if (factor > 4) {
/*
* Iterations seem to be shorter.
*/
if (threshold < (maxIterTm / 2)) {
factor /= 2;
if (factor < 4) {
factor = 4;
}
} else {
factor--;
}
}
/*
* As relation between remaining time and time since last check,
* maximal some % of time (by factor), so avoid growing of the
* execution time if iterations are not consistent, e.g. was
* continuously on time).
*/
threshold = ((stop - middle) / maxIterTm) / factor + 1;
if (threshold > 100000) { /* fix for too large threshold */
threshold = 100000;
}
/*
* Consider max-count
*/
if (threshold > maxcnt - count) {
threshold = maxcnt - count;
}
}
}
{
Tcl_Obj *objarr[8], **objs = objarr;
Tcl_WideInt val;
int digits;
middle -= start; /* execution time in microsecs */
#ifdef TCL_WIDE_CLICKS
/*
* convert execution time in wide clicks to microsecs.
*/
middle *= TclpWideClickInMicrosec();
#endif /* TCL_WIDE_CLICKS */
if (!count) { /* no iterations - avoid divide by zero */
objs[0] = objs[2] = objs[4] = Tcl_NewWideIntObj(0);
goto retRes;
}
/*
* If not calibrating...
*/
if (!calibrate) {
/*
* Minimize influence of measurement overhead.
*/
if (overhead > 0) {
/*
* Estimate the time of overhead (microsecs).
*/
Tcl_WideUInt curOverhead = overhead * count;
if (middle > (Tcl_WideInt) curOverhead) {
middle -= curOverhead;
} else {
middle = 0;
}
}
} else {
/*
* Calibration: obtaining new measurement overhead.
*/
if (measureOverhead > ((double) middle) / count) {
measureOverhead = ((double) middle) / count;
}
objs[0] = Tcl_NewDoubleObj(measureOverhead);
TclNewLiteralStringObj(objs[1], "\xC2\xB5s/#-overhead"); /* mics */
objs += 2;
}
val = middle / count; /* microsecs per iteration */
if (val >= 1000000) {
objs[0] = Tcl_NewWideIntObj(val);
} else {
if (val < 10) {
digits = 6;
} else if (val < 100) {
digits = 4;
} else if (val < 1000) {
digits = 3;
} else if (val < 10000) {
digits = 2;
} else {
digits = 1;
}
objs[0] = Tcl_ObjPrintf("%.*f", digits, ((double) middle)/count);
}
objs[2] = Tcl_NewWideIntObj(count); /* iterations */
/*
* Calculate speed as rate (count) per sec
*/
if (!middle) {
middle++; /* Avoid divide by zero. */
}
if (count < (WIDE_MAX / 1000000)) {
val = (count * 1000000) / middle;
if (val < 100000) {
if (val < 100) {
digits = 3;
} else if (val < 1000) {
digits = 2;
} else {
digits = 1;
}
objs[4] = Tcl_ObjPrintf("%.*f",
digits, ((double) (count * 1000000)) / middle);
} else {
objs[4] = Tcl_NewWideIntObj(val);
}
} else {
objs[4] = Tcl_NewWideIntObj((count / middle) * 1000000);
}
retRes:
/*
* Estimated net execution time (in millisecs).
*/
if (!calibrate) {
if (middle >= 1) {
objs[6] = Tcl_ObjPrintf("%.3f", (double)middle / 1000);
} else {
objs[6] = Tcl_NewWideIntObj(0);
}
TclNewLiteralStringObj(objs[7], "nett-ms");
}
/*
* Construct the result as a list because many programs have always
* parsed as such (extracting the first element, typically).
*/
TclNewLiteralStringObj(objs[1], "\xC2\xB5s/#"); /* mics/# */
TclNewLiteralStringObj(objs[3], "#");
TclNewLiteralStringObj(objs[5], "#/sec");
Tcl_SetObjResult(interp, Tcl_NewListObj(8, objarr));
}
done:
if (codePtr != NULL) {
TclReleaseByteCode(codePtr);
}
return result;
}
/*
*----------------------------------------------------------------------
*
* Tcl_TryObjCmd, TclNRTryObjCmd --
|
| ︙ | ︙ |
Changes to generic/tclCompCmds.c.
| ︙ | ︙ | |||
1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 |
CompileWord(envPtr, tokenPtr, interp, i);
tokenPtr = TokenAfter(tokenPtr);
}
TclEmitInstInt4(INST_DICT_GET, parsePtr->numWords-2, envPtr);
TclAdjustStackDepth(-1, envPtr);
return TCL_OK;
}
int
TclCompileDictExistsCmd(
Tcl_Interp *interp, /* Used for looking up stuff. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
Command *cmdPtr, /* Points to defintion of command being
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 |
CompileWord(envPtr, tokenPtr, interp, i);
tokenPtr = TokenAfter(tokenPtr);
}
TclEmitInstInt4(INST_DICT_GET, parsePtr->numWords-2, envPtr);
TclAdjustStackDepth(-1, envPtr);
return TCL_OK;
}
int
TclCompileDictGetWithDefaultCmd(
Tcl_Interp *interp, /* Used for looking up stuff. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
Command *cmdPtr, /* Points to defintion of command being
* compiled. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
Tcl_Token *tokenPtr;
int i;
DefineLineInformation; /* TIP #280 */
/*
* There must be at least three arguments after the command.
*/
/* TODO: Consider support for compiling expanded args. */
if (parsePtr->numWords < 4) {
return TCL_ERROR;
}
tokenPtr = TokenAfter(parsePtr->tokenPtr);
for (i=1 ; i<parsePtr->numWords ; i++) {
CompileWord(envPtr, tokenPtr, interp, i);
tokenPtr = TokenAfter(tokenPtr);
}
TclEmitInstInt4(INST_DICT_GET_DEF, parsePtr->numWords-3, envPtr);
TclAdjustStackDepth(-2, envPtr);
return TCL_OK;
}
int
TclCompileDictExistsCmd(
Tcl_Interp *interp, /* Used for looking up stuff. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
Command *cmdPtr, /* Points to defintion of command being
|
| ︙ | ︙ |
Changes to generic/tclCompCmdsGR.c.
| ︙ | ︙ | |||
430 431 432 433 434 435 436 |
jumpFalseDist += 3;
TclStoreInt1AtPtr(jumpFalseDist, (ifFalsePc + 1));
} else if (opCode == INST_JUMP_FALSE4) {
jumpFalseDist = TclGetInt4AtPtr(ifFalsePc + 1);
jumpFalseDist += 3;
TclStoreInt4AtPtr(jumpFalseDist, (ifFalsePc + 1));
} else {
| | | 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 |
jumpFalseDist += 3;
TclStoreInt1AtPtr(jumpFalseDist, (ifFalsePc + 1));
} else if (opCode == INST_JUMP_FALSE4) {
jumpFalseDist = TclGetInt4AtPtr(ifFalsePc + 1);
jumpFalseDist += 3;
TclStoreInt4AtPtr(jumpFalseDist, (ifFalsePc + 1));
} else {
Tcl_Panic("TclCompileIfCmd: unexpected opcode \"%d\" updating ifFalse jump", opCode);
}
}
}
/*
* Free the jumpFixupArray array if malloc'ed storage was used.
*/
|
| ︙ | ︙ |
Changes to generic/tclCompCmdsSZ.c.
| ︙ | ︙ | |||
441 442 443 444 445 446 447 448 449 450 451 452 453 454 |
*/
tokenPtr = TokenAfter(parsePtr->tokenPtr);
CompileWord(envPtr, tokenPtr, interp, 1);
tokenPtr = TokenAfter(tokenPtr);
CompileWord(envPtr, tokenPtr, interp, 2);
TclEmitOpcode(INST_STR_INDEX, envPtr);
return TCL_OK;
}
int
TclCompileStringIsCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
*/
tokenPtr = TokenAfter(parsePtr->tokenPtr);
CompileWord(envPtr, tokenPtr, interp, 1);
tokenPtr = TokenAfter(tokenPtr);
CompileWord(envPtr, tokenPtr, interp, 2);
TclEmitOpcode(INST_STR_INDEX, envPtr);
return TCL_OK;
}
int
TclCompileStringInsertCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
Command *cmdPtr, /* Points to defintion of command being
* compiled. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
Tcl_Token *tokenPtr;
DefineLineInformation; /* TIP #280 */
int idx;
if (parsePtr->numWords != 4) {
return TCL_ERROR;
}
/* Compute and push the string in which to insert */
tokenPtr = TokenAfter(parsePtr->tokenPtr);
CompileWord(envPtr, tokenPtr, interp, 1);
/* See what can be discovered about index at compile time */
tokenPtr = TokenAfter(tokenPtr);
if (TCL_OK != TclGetIndexFromToken(tokenPtr, TCL_INDEX_START,
TCL_INDEX_END, &idx)) {
/* Nothing useful knowable - cease compile; let it direct eval */
return TCL_OK;
}
/* Compute and push the string to be inserted */
tokenPtr = TokenAfter(tokenPtr);
CompileWord(envPtr, tokenPtr, interp, 3);
if (idx == (int)TCL_INDEX_START) {
/* Prepend the insertion string */
OP4( REVERSE, 2);
OP1( STR_CONCAT1, 2);
} else if (idx == (int)TCL_INDEX_END) {
/* Append the insertion string */
OP1( STR_CONCAT1, 2);
} else {
/* Prefix + insertion + suffix */
if (idx < (int)TCL_INDEX_END) {
/* See comments in compiler for [linsert]. */
idx++;
}
OP4( OVER, 1);
OP44( STR_RANGE_IMM, 0, idx-1);
OP4( REVERSE, 3);
OP44( STR_RANGE_IMM, idx, TCL_INDEX_END);
OP1( STR_CONCAT1, 3);
}
return TCL_OK;
}
int
TclCompileStringIsCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
|
| ︙ | ︙ |
Changes to generic/tclCompile.c.
| ︙ | ︙ | |||
637 638 639 640 641 642 643 644 645 646 647 648 649 650 |
* Stack: ... varName list => ... listVarContents */
{"clockRead", 2, +1, 1, {OPERAND_UINT1}},
/* Read clock out to the stack. Operand is which clock to read
* 0=clicks, 1=microseconds, 2=milliseconds, 3=seconds.
* Stack: ... => ... time */
{NULL, 0, 0, 0, {OPERAND_NONE}}
};
/*
* Prototypes for procedures defined later in this file:
*/
| > > > > > > > > | 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 |
* Stack: ... varName list => ... listVarContents */
{"clockRead", 2, +1, 1, {OPERAND_UINT1}},
/* Read clock out to the stack. Operand is which clock to read
* 0=clicks, 1=microseconds, 2=milliseconds, 3=seconds.
* Stack: ... => ... time */
{"dictGetDef", 5, INT_MIN, 1, {OPERAND_UINT4}},
/* The top word is the default, the next op4 words (min 1) are a key
* path into the dictionary just below the keys on the stack, and all
* those values are replaced by the value read out of that key-path
* (like [dict get]) except if there is no such key, when instead the
* default is pushed instead.
* Stack: ... dict key1 ... keyN default => ... value */
{NULL, 0, 0, 0, {OPERAND_NONE}}
};
/*
* Prototypes for procedures defined later in this file:
*/
|
| ︙ | ︙ | |||
674 675 676 677 678 679 680 | /* * TIP #280: Helper for building the per-word line information of all compiled * commands. */ static void EnterCmdWordData(ExtCmdLoc *eclPtr, int srcOffset, Tcl_Token *tokenPtr, const char *cmd, | | | 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 | /* * TIP #280: Helper for building the per-word line information of all compiled * commands. */ static void EnterCmdWordData(ExtCmdLoc *eclPtr, int srcOffset, Tcl_Token *tokenPtr, const char *cmd, int numWords, int line, int *clNext, int **lines, CompileEnv *envPtr); static void ReleaseCmdWordData(ExtCmdLoc *eclPtr); /* * The structure below defines the bytecode Tcl object type by means of * procedures that can be invoked by generic object code. */ |
| ︙ | ︙ | |||
3235 3236 3237 3238 3239 3240 3241 |
EnterCmdWordData(
ExtCmdLoc *eclPtr, /* Points to the map environment structure in
* which to enter command location
* information. */
int srcOffset, /* Offset of first char of the command. */
Tcl_Token *tokenPtr,
const char *cmd,
| | < | | 3243 3244 3245 3246 3247 3248 3249 3250 3251 3252 3253 3254 3255 3256 3257 3258 3259 3260 3261 3262 3263 3264 3265 |
EnterCmdWordData(
ExtCmdLoc *eclPtr, /* Points to the map environment structure in
* which to enter command location
* information. */
int srcOffset, /* Offset of first char of the command. */
Tcl_Token *tokenPtr,
const char *cmd,
int numWords,
int line,
int *clNext,
int **wlines,
CompileEnv *envPtr)
{
ECL *ePtr;
const char *last;
int wordIdx, wordLine, *wwlines, *wordNext;
if (eclPtr->nuloc >= eclPtr->nloc) {
/*
* Expand the ECL array by allocating more storage from the heap. The
* currently allocated ECL entries are stored from eclPtr->loc[0] up
* to eclPtr->loc[eclPtr->nuloc-1] (inclusive).
*/
|
| ︙ | ︙ |
Changes to generic/tclCompile.h.
| ︙ | ︙ | |||
537 538 539 540 541 542 543 |
* entries in the table of instruction descriptions, tclInstructionTable, in
* tclCompile.c. Also, the order and number of the expression opcodes (e.g.,
* INST_BITOR) must match the entries in the array operatorStrings in
* tclExecute.c.
*/
enum TclInstruction {
| < | 537 538 539 540 541 542 543 544 545 546 547 548 549 550 |
* entries in the table of instruction descriptions, tclInstructionTable, in
* tclCompile.c. Also, the order and number of the expression opcodes (e.g.,
* INST_BITOR) must match the entries in the array operatorStrings in
* tclExecute.c.
*/
enum TclInstruction {
/* Opcodes 0 to 9 */
INST_DONE = 0,
INST_PUSH1,
INST_PUSH4,
INST_POP,
INST_DUP,
INST_STR_CONCAT1,
|
| ︙ | ︙ | |||
813 814 815 816 817 818 819 820 821 822 823 |
INST_LAPPEND_LIST,
INST_LAPPEND_LIST_ARRAY,
INST_LAPPEND_LIST_ARRAY_STK,
INST_LAPPEND_LIST_STK,
INST_CLOCK_READ,
/* The last opcode */
LAST_INST_OPCODE
};
| > > < | 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 |
INST_LAPPEND_LIST,
INST_LAPPEND_LIST_ARRAY,
INST_LAPPEND_LIST_ARRAY_STK,
INST_LAPPEND_LIST_STK,
INST_CLOCK_READ,
INST_DICT_GET_DEF,
/* The last opcode */
LAST_INST_OPCODE
};
/*
* Table describing the Tcl bytecode instructions: their name (for displaying
* code), total number of code bytes required (including operand bytes), and a
* description of the type of each operand. These operand types include signed
* and unsigned integers of length one and four bytes. The unsigned integers
* are used for indexes or for, e.g., the count of objects to push in a "push"
|
| ︙ | ︙ |
Changes to generic/tclDecls.h.
| ︙ | ︙ | |||
511 512 513 514 515 516 517 | /* 171 */ EXTERN int Tcl_GetServiceMode(void); /* 172 */ EXTERN Tcl_Interp * Tcl_GetSlave(Tcl_Interp *interp, const char *slaveName); /* 173 */ EXTERN Tcl_Channel Tcl_GetStdChannel(int type); | | < | 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 | /* 171 */ EXTERN int Tcl_GetServiceMode(void); /* 172 */ EXTERN Tcl_Interp * Tcl_GetSlave(Tcl_Interp *interp, const char *slaveName); /* 173 */ EXTERN Tcl_Channel Tcl_GetStdChannel(int type); /* Slot 174 is reserved */ /* Slot 175 is reserved */ /* 176 */ EXTERN const char * Tcl_GetVar2(Tcl_Interp *interp, const char *part1, const char *part2, int flags); /* Slot 177 is reserved */ /* Slot 178 is reserved */ /* 179 */ |
| ︙ | ︙ | |||
541 542 543 544 545 546 547 | /* 185 */ EXTERN int Tcl_IsSafe(Tcl_Interp *interp); /* 186 */ EXTERN char * Tcl_JoinPath(int argc, const char *const *argv, Tcl_DString *resultPtr); /* 187 */ EXTERN int Tcl_LinkVar(Tcl_Interp *interp, const char *varName, | | | 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 | /* 185 */ EXTERN int Tcl_IsSafe(Tcl_Interp *interp); /* 186 */ EXTERN char * Tcl_JoinPath(int argc, const char *const *argv, Tcl_DString *resultPtr); /* 187 */ EXTERN int Tcl_LinkVar(Tcl_Interp *interp, const char *varName, void *addr, int type); /* Slot 188 is reserved */ /* 189 */ EXTERN Tcl_Channel Tcl_MakeFileChannel(void *handle, int mode); /* 190 */ EXTERN int Tcl_MakeSafe(Tcl_Interp *interp); /* 191 */ EXTERN Tcl_Channel Tcl_MakeTcpClientChannel(void *tcpSocket); |
| ︙ | ︙ | |||
1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 |
EXTERN int Tcl_HasStringRep(Tcl_Obj *objPtr);
/* 641 */
EXTERN void Tcl_IncrRefCount(Tcl_Obj *objPtr);
/* 642 */
EXTERN void Tcl_DecrRefCount(Tcl_Obj *objPtr);
/* 643 */
EXTERN int Tcl_IsShared(Tcl_Obj *objPtr);
typedef struct {
const struct TclPlatStubs *tclPlatStubs;
const struct TclIntStubs *tclIntStubs;
const struct TclIntPlatStubs *tclIntPlatStubs;
} TclStubHooks;
| > > > > | 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 |
EXTERN int Tcl_HasStringRep(Tcl_Obj *objPtr);
/* 641 */
EXTERN void Tcl_IncrRefCount(Tcl_Obj *objPtr);
/* 642 */
EXTERN void Tcl_DecrRefCount(Tcl_Obj *objPtr);
/* 643 */
EXTERN int Tcl_IsShared(Tcl_Obj *objPtr);
/* 644 */
EXTERN int Tcl_LinkArray(Tcl_Interp *interp,
const char *varName, void *addr, int type,
int size);
typedef struct {
const struct TclPlatStubs *tclPlatStubs;
const struct TclIntStubs *tclIntStubs;
const struct TclIntPlatStubs *tclIntPlatStubs;
} TclStubHooks;
|
| ︙ | ︙ | |||
1955 1956 1957 1958 1959 1960 1961 |
#endif /* MACOSX */
Tcl_PathType (*tcl_GetPathType) (const char *path); /* 168 */
size_t (*tcl_Gets) (Tcl_Channel chan, Tcl_DString *dsPtr); /* 169 */
size_t (*tcl_GetsObj) (Tcl_Channel chan, Tcl_Obj *objPtr); /* 170 */
int (*tcl_GetServiceMode) (void); /* 171 */
Tcl_Interp * (*tcl_GetSlave) (Tcl_Interp *interp, const char *slaveName); /* 172 */
Tcl_Channel (*tcl_GetStdChannel) (int type); /* 173 */
| | | | 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 1981 1982 1983 1984 1985 |
#endif /* MACOSX */
Tcl_PathType (*tcl_GetPathType) (const char *path); /* 168 */
size_t (*tcl_Gets) (Tcl_Channel chan, Tcl_DString *dsPtr); /* 169 */
size_t (*tcl_GetsObj) (Tcl_Channel chan, Tcl_Obj *objPtr); /* 170 */
int (*tcl_GetServiceMode) (void); /* 171 */
Tcl_Interp * (*tcl_GetSlave) (Tcl_Interp *interp, const char *slaveName); /* 172 */
Tcl_Channel (*tcl_GetStdChannel) (int type); /* 173 */
void (*reserved174)(void);
void (*reserved175)(void);
const char * (*tcl_GetVar2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags); /* 176 */
void (*reserved177)(void);
void (*reserved178)(void);
int (*tcl_HideCommand) (Tcl_Interp *interp, const char *cmdName, const char *hiddenCmdToken); /* 179 */
int (*tcl_Init) (Tcl_Interp *interp); /* 180 */
void (*tcl_InitHashTable) (Tcl_HashTable *tablePtr, int keyType); /* 181 */
int (*tcl_InputBlocked) (Tcl_Channel chan); /* 182 */
int (*tcl_InputBuffered) (Tcl_Channel chan); /* 183 */
int (*tcl_InterpDeleted) (Tcl_Interp *interp); /* 184 */
int (*tcl_IsSafe) (Tcl_Interp *interp); /* 185 */
char * (*tcl_JoinPath) (int argc, const char *const *argv, Tcl_DString *resultPtr); /* 186 */
int (*tcl_LinkVar) (Tcl_Interp *interp, const char *varName, void *addr, int type); /* 187 */
void (*reserved188)(void);
Tcl_Channel (*tcl_MakeFileChannel) (void *handle, int mode); /* 189 */
int (*tcl_MakeSafe) (Tcl_Interp *interp); /* 190 */
Tcl_Channel (*tcl_MakeTcpClientChannel) (void *tcpSocket); /* 191 */
char * (*tcl_Merge) (int argc, const char *const *argv); /* 192 */
Tcl_HashEntry * (*tcl_NextHashEntry) (Tcl_HashSearch *searchPtr); /* 193 */
void (*tcl_NotifyChannel) (Tcl_Channel channel, int mask); /* 194 */
|
| ︙ | ︙ | |||
2425 2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 |
char * (*tcl_InitStringRep) (Tcl_Obj *objPtr, const char *bytes, size_t numBytes); /* 637 */
Tcl_ObjIntRep * (*tcl_FetchIntRep) (Tcl_Obj *objPtr, const Tcl_ObjType *typePtr); /* 638 */
void (*tcl_StoreIntRep) (Tcl_Obj *objPtr, const Tcl_ObjType *typePtr, const Tcl_ObjIntRep *irPtr); /* 639 */
int (*tcl_HasStringRep) (Tcl_Obj *objPtr); /* 640 */
void (*tcl_IncrRefCount) (Tcl_Obj *objPtr); /* 641 */
void (*tcl_DecrRefCount) (Tcl_Obj *objPtr); /* 642 */
int (*tcl_IsShared) (Tcl_Obj *objPtr); /* 643 */
} TclStubs;
extern const TclStubs *tclStubsPtr;
#ifdef __cplusplus
}
#endif
| > | 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 2440 2441 2442 |
char * (*tcl_InitStringRep) (Tcl_Obj *objPtr, const char *bytes, size_t numBytes); /* 637 */
Tcl_ObjIntRep * (*tcl_FetchIntRep) (Tcl_Obj *objPtr, const Tcl_ObjType *typePtr); /* 638 */
void (*tcl_StoreIntRep) (Tcl_Obj *objPtr, const Tcl_ObjType *typePtr, const Tcl_ObjIntRep *irPtr); /* 639 */
int (*tcl_HasStringRep) (Tcl_Obj *objPtr); /* 640 */
void (*tcl_IncrRefCount) (Tcl_Obj *objPtr); /* 641 */
void (*tcl_DecrRefCount) (Tcl_Obj *objPtr); /* 642 */
int (*tcl_IsShared) (Tcl_Obj *objPtr); /* 643 */
int (*tcl_LinkArray) (Tcl_Interp *interp, const char *varName, void *addr, int type, int size); /* 644 */
} TclStubs;
extern const TclStubs *tclStubsPtr;
#ifdef __cplusplus
}
#endif
|
| ︙ | ︙ | |||
2787 2788 2789 2790 2791 2792 2793 | (tclStubsPtr->tcl_GetsObj) /* 170 */ #define Tcl_GetServiceMode \ (tclStubsPtr->tcl_GetServiceMode) /* 171 */ #define Tcl_GetSlave \ (tclStubsPtr->tcl_GetSlave) /* 172 */ #define Tcl_GetStdChannel \ (tclStubsPtr->tcl_GetStdChannel) /* 173 */ | < | | 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 | (tclStubsPtr->tcl_GetsObj) /* 170 */ #define Tcl_GetServiceMode \ (tclStubsPtr->tcl_GetServiceMode) /* 171 */ #define Tcl_GetSlave \ (tclStubsPtr->tcl_GetSlave) /* 172 */ #define Tcl_GetStdChannel \ (tclStubsPtr->tcl_GetStdChannel) /* 173 */ /* Slot 174 is reserved */ /* Slot 175 is reserved */ #define Tcl_GetVar2 \ (tclStubsPtr->tcl_GetVar2) /* 176 */ /* Slot 177 is reserved */ /* Slot 178 is reserved */ #define Tcl_HideCommand \ (tclStubsPtr->tcl_HideCommand) /* 179 */ |
| ︙ | ︙ | |||
3690 3691 3692 3693 3694 3695 3696 3697 3698 3699 3700 3701 3702 3703 | (tclStubsPtr->tcl_HasStringRep) /* 640 */ #define Tcl_IncrRefCount \ (tclStubsPtr->tcl_IncrRefCount) /* 641 */ #define Tcl_DecrRefCount \ (tclStubsPtr->tcl_DecrRefCount) /* 642 */ #define Tcl_IsShared \ (tclStubsPtr->tcl_IsShared) /* 643 */ #endif /* defined(USE_TCL_STUBS) */ /* !END!: Do not edit above this line. */ #if defined(USE_TCL_STUBS) # undef Tcl_CreateInterp | > > < < | 3693 3694 3695 3696 3697 3698 3699 3700 3701 3702 3703 3704 3705 3706 3707 3708 3709 3710 3711 3712 3713 3714 3715 3716 3717 3718 | (tclStubsPtr->tcl_HasStringRep) /* 640 */ #define Tcl_IncrRefCount \ (tclStubsPtr->tcl_IncrRefCount) /* 641 */ #define Tcl_DecrRefCount \ (tclStubsPtr->tcl_DecrRefCount) /* 642 */ #define Tcl_IsShared \ (tclStubsPtr->tcl_IsShared) /* 643 */ #define Tcl_LinkArray \ (tclStubsPtr->tcl_LinkArray) /* 644 */ #endif /* defined(USE_TCL_STUBS) */ /* !END!: Do not edit above this line. */ #if defined(USE_TCL_STUBS) # undef Tcl_CreateInterp # undef Tcl_Init # undef Tcl_ObjSetVar2 # define Tcl_CreateInterp() (tclStubsPtr->tcl_CreateInterp()) # define Tcl_Init(interp) (tclStubsPtr->tcl_Init(interp)) # define Tcl_ObjSetVar2(interp, part1, part2, newValue, flags) \ (tclStubsPtr->tcl_ObjSetVar2(interp, part1, part2, newValue, flags)) #endif #if defined(_WIN32) && defined(UNICODE) # define Tcl_FindExecutable(arg) ((Tcl_FindExecutable)((const char *)(arg))) |
| ︙ | ︙ | |||
3755 3756 3757 3758 3759 3760 3761 3762 3763 3764 3765 3766 3767 3768 |
Tcl_AppendObjToErrorInfo(interp, Tcl_NewStringObj(message, -1))
#define Tcl_AddObjErrorInfo(interp, message, length) \
Tcl_AppendObjToErrorInfo(interp, Tcl_NewStringObj(message, length))
#define Tcl_Eval(interp, objPtr) \
Tcl_EvalEx(interp, objPtr, -1, 0)
#define Tcl_GlobalEval(interp, objPtr) \
Tcl_EvalEx(interp, objPtr, -1, TCL_EVAL_GLOBAL)
#define Tcl_SaveResult(interp, statePtr) \
do { \
*(statePtr) = Tcl_GetObjResult(interp); \
Tcl_IncrRefCount(*(statePtr)); \
Tcl_SetObjResult(interp, Tcl_NewObj()); \
} while(0)
#define Tcl_RestoreResult(interp, statePtr) \
| > | 3758 3759 3760 3761 3762 3763 3764 3765 3766 3767 3768 3769 3770 3771 3772 |
Tcl_AppendObjToErrorInfo(interp, Tcl_NewStringObj(message, -1))
#define Tcl_AddObjErrorInfo(interp, message, length) \
Tcl_AppendObjToErrorInfo(interp, Tcl_NewStringObj(message, length))
#define Tcl_Eval(interp, objPtr) \
Tcl_EvalEx(interp, objPtr, -1, 0)
#define Tcl_GlobalEval(interp, objPtr) \
Tcl_EvalEx(interp, objPtr, -1, TCL_EVAL_GLOBAL)
#define Tcl_GetStringResult(interp) Tcl_GetString(Tcl_GetObjResult(interp))
#define Tcl_SaveResult(interp, statePtr) \
do { \
*(statePtr) = Tcl_GetObjResult(interp); \
Tcl_IncrRefCount(*(statePtr)); \
Tcl_SetObjResult(interp, Tcl_NewObj()); \
} while(0)
#define Tcl_RestoreResult(interp, statePtr) \
|
| ︙ | ︙ |
Changes to generic/tclDictObj.c.
| ︙ | ︙ | |||
30 31 32 33 34 35 36 37 38 39 40 41 42 43 | int objc, Tcl_Obj *const *objv); static int DictExistsCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); static int DictFilterCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); static int DictGetCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); static int DictIncrCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); static int DictInfoCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); static int DictKeysCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); static int DictLappendCmd(ClientData dummy, Tcl_Interp *interp, | > > | 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 | int objc, Tcl_Obj *const *objv); static int DictExistsCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); static int DictFilterCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); static int DictGetCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); static int DictGetDefCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); static int DictIncrCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); static int DictInfoCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); static int DictKeysCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); static int DictLappendCmd(ClientData dummy, Tcl_Interp *interp, |
| ︙ | ︙ | |||
85 86 87 88 89 90 91 92 93 94 95 96 97 98 |
static const EnsembleImplMap implementationMap[] = {
{"append", DictAppendCmd, TclCompileDictAppendCmd, NULL, NULL, 0 },
{"create", DictCreateCmd, TclCompileDictCreateCmd, NULL, NULL, 0 },
{"exists", DictExistsCmd, TclCompileDictExistsCmd, NULL, NULL, 0 },
{"filter", DictFilterCmd, NULL, NULL, NULL, 0 },
{"for", NULL, TclCompileDictForCmd, DictForNRCmd, NULL, 0 },
{"get", DictGetCmd, TclCompileDictGetCmd, NULL, NULL, 0 },
{"incr", DictIncrCmd, TclCompileDictIncrCmd, NULL, NULL, 0 },
{"info", DictInfoCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0 },
{"keys", DictKeysCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0 },
{"lappend", DictLappendCmd, TclCompileDictLappendCmd, NULL, NULL, 0 },
{"map", NULL, TclCompileDictMapCmd, DictMapNRCmd, NULL, 0 },
{"merge", DictMergeCmd, TclCompileDictMergeCmd, NULL, NULL, 0 },
{"remove", DictRemoveCmd, TclCompileBasicMin1ArgCmd, NULL, NULL, 0 },
| > > > | 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 |
static const EnsembleImplMap implementationMap[] = {
{"append", DictAppendCmd, TclCompileDictAppendCmd, NULL, NULL, 0 },
{"create", DictCreateCmd, TclCompileDictCreateCmd, NULL, NULL, 0 },
{"exists", DictExistsCmd, TclCompileDictExistsCmd, NULL, NULL, 0 },
{"filter", DictFilterCmd, NULL, NULL, NULL, 0 },
{"for", NULL, TclCompileDictForCmd, DictForNRCmd, NULL, 0 },
{"get", DictGetCmd, TclCompileDictGetCmd, NULL, NULL, 0 },
{"getdef", DictGetDefCmd, TclCompileDictGetWithDefaultCmd, NULL,NULL,0},
{"getwithdefault", DictGetDefCmd, TclCompileDictGetWithDefaultCmd,
NULL, NULL, 0 },
{"incr", DictIncrCmd, TclCompileDictIncrCmd, NULL, NULL, 0 },
{"info", DictInfoCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0 },
{"keys", DictKeysCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0 },
{"lappend", DictLappendCmd, TclCompileDictLappendCmd, NULL, NULL, 0 },
{"map", NULL, TclCompileDictMapCmd, DictMapNRCmd, NULL, 0 },
{"merge", DictMergeCmd, TclCompileDictMergeCmd, NULL, NULL, 0 },
{"remove", DictRemoveCmd, TclCompileBasicMin1ArgCmd, NULL, NULL, 0 },
|
| ︙ | ︙ | |||
1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 |
Tcl_SetObjResult(interp, valuePtr);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* DictReplaceCmd --
*
* This function implements the "dict replace" Tcl command. See the user
* documentation for details on what it does, and TIP#111 for the formal
* specification.
*
* Results:
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 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 |
Tcl_SetObjResult(interp, valuePtr);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* DictGetDefCmd --
*
* This function implements the "dict getdef" and "dict getwithdefault"
* Tcl commands. See the user documentation for details on what it does,
* and TIP#342 for the formal specification.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
DictGetDefCmd(
ClientData dummy,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Tcl_Obj *dictPtr, *keyPtr, *valuePtr, *defaultPtr;
Tcl_Obj *const *keyPath;
int numKeys;
if (objc < 4) {
Tcl_WrongNumArgs(interp, 1, objv, "dictionary ?key ...? key default");
return TCL_ERROR;
}
/*
* Give the bits of arguments names for clarity.
*/
dictPtr = objv[1];
keyPath = &objv[2];
numKeys = objc - 4; /* Number of keys in keyPath; there's always
* one extra key afterwards too. */
keyPtr = objv[objc - 2];
defaultPtr = objv[objc - 1];
/*
* Implement the getting-with-default operation.
*/
dictPtr = TclTraceDictPath(interp, dictPtr, numKeys, keyPath,
DICT_PATH_EXISTS);
if (dictPtr == NULL) {
return TCL_ERROR;
} else if (dictPtr == DICT_PATH_NON_EXISTENT) {
Tcl_SetObjResult(interp, defaultPtr);
} else if (Tcl_DictObjGet(interp, dictPtr, keyPtr, &valuePtr) != TCL_OK) {
return TCL_ERROR;
} else if (valuePtr == NULL) {
Tcl_SetObjResult(interp, defaultPtr);
} else {
Tcl_SetObjResult(interp, valuePtr);
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* DictReplaceCmd --
*
* This function implements the "dict replace" Tcl command. See the user
* documentation for details on what it does, and TIP#111 for the formal
* specification.
*
* Results:
|
| ︙ | ︙ | |||
2003 2004 2005 2006 2007 2008 2009 |
Tcl_Obj *dictPtr, *valuePtr;
if (objc < 3) {
Tcl_WrongNumArgs(interp, 1, objv, "dictionary key ?key ...?");
return TCL_ERROR;
}
| | < | < | | 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 |
Tcl_Obj *dictPtr, *valuePtr;
if (objc < 3) {
Tcl_WrongNumArgs(interp, 1, objv, "dictionary key ?key ...?");
return TCL_ERROR;
}
dictPtr = TclTraceDictPath(NULL, objv[1], objc-3, objv+2,DICT_PATH_EXISTS);
if (dictPtr == NULL || dictPtr == DICT_PATH_NON_EXISTENT ||
Tcl_DictObjGet(NULL, dictPtr, objv[objc-1], &valuePtr) != TCL_OK) {
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(0));
} else {
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(valuePtr != NULL));
}
return TCL_OK;
}
|
| ︙ | ︙ |
Changes to generic/tclExecute.c.
| ︙ | ︙ | |||
5419 5420 5421 5422 5423 5424 5425 |
if (GetNumberFromObj(NULL, OBJ_AT_TOS, &ptr1, &type1) != TCL_OK) {
type1 = 0;
} else if (type1 == TCL_NUMBER_BIG) {
/* value is an integer outside the WIDE_MIN to WIDE_MAX range */
/* [string is wideinteger] is WIDE_MIN to WIDE_MAX range */
Tcl_WideInt w;
| | | 5419 5420 5421 5422 5423 5424 5425 5426 5427 5428 5429 5430 5431 5432 5433 |
if (GetNumberFromObj(NULL, OBJ_AT_TOS, &ptr1, &type1) != TCL_OK) {
type1 = 0;
} else if (type1 == TCL_NUMBER_BIG) {
/* value is an integer outside the WIDE_MIN to WIDE_MAX range */
/* [string is wideinteger] is WIDE_MIN to WIDE_MAX range */
Tcl_WideInt w;
if (TclGetWideIntFromObj(NULL, OBJ_AT_TOS, &w) == TCL_OK) {
type1 = TCL_NUMBER_INT;
}
}
TclNewIntObj(objResultPtr, type1);
TRACE(("\"%.20s\" => %d\n", O2S(OBJ_AT_TOS), type1));
NEXT_INST_F(1, 1, 1);
|
| ︙ | ︙ | |||
6393 6394 6395 6396 6397 6398 6399 |
TRACE_APPEND(("ERROR verifying dictionary nature of \"%.30s\": %s\n",
O2S(dictPtr), O2S(Tcl_GetObjResult(interp))));
goto gotError;
}
TRACE_APPEND(("OK\n"));
NEXT_INST_F(1, 1, 0);
| < < < < < | | | < | | | < < < < < | < | < | < < < < < < < < < < < < < < < < < < < > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 6393 6394 6395 6396 6397 6398 6399 6400 6401 6402 6403 6404 6405 6406 6407 6408 6409 6410 6411 6412 6413 6414 6415 6416 6417 6418 6419 6420 6421 6422 6423 6424 6425 6426 6427 6428 6429 6430 6431 6432 6433 6434 6435 6436 6437 6438 6439 6440 6441 6442 6443 6444 6445 6446 6447 6448 6449 6450 6451 6452 6453 6454 6455 6456 6457 6458 6459 6460 6461 6462 6463 6464 6465 6466 6467 6468 6469 6470 6471 6472 6473 6474 6475 6476 6477 6478 6479 6480 6481 6482 6483 6484 6485 6486 6487 6488 6489 6490 6491 6492 6493 6494 6495 6496 6497 6498 6499 6500 |
TRACE_APPEND(("ERROR verifying dictionary nature of \"%.30s\": %s\n",
O2S(dictPtr), O2S(Tcl_GetObjResult(interp))));
goto gotError;
}
TRACE_APPEND(("OK\n"));
NEXT_INST_F(1, 1, 0);
case INST_DICT_EXISTS: {
int found;
opnd = TclGetUInt4AtPtr(pc+1);
TRACE(("%u => ", opnd));
dictPtr = OBJ_AT_DEPTH(opnd);
if (opnd > 1) {
dictPtr = TclTraceDictPath(NULL, dictPtr, opnd-1,
&OBJ_AT_DEPTH(opnd-1), DICT_PATH_EXISTS);
if (dictPtr == NULL || dictPtr == DICT_PATH_NON_EXISTENT) {
found = 0;
goto afterDictExists;
}
}
if (Tcl_DictObjGet(NULL, dictPtr, OBJ_AT_TOS,
&objResultPtr) == TCL_OK) {
found = (objResultPtr ? 1 : 0);
} else {
found = 0;
}
afterDictExists:
TRACE_APPEND(("%d\n", found));
/*
* The INST_DICT_EXISTS instruction is usually followed by a
* conditional jump, so we can take advantage of this to do some
* peephole optimization (note that we're careful to not close out
* someone doing something else).
*/
JUMP_PEEPHOLE_V(found, 5, opnd+1);
}
case INST_DICT_GET:
opnd = TclGetUInt4AtPtr(pc+1);
TRACE(("%u => ", opnd));
dictPtr = OBJ_AT_DEPTH(opnd);
if (opnd > 1) {
dictPtr = TclTraceDictPath(interp, dictPtr, opnd-1,
&OBJ_AT_DEPTH(opnd-1), DICT_PATH_READ);
if (dictPtr == NULL) {
TRACE_WITH_OBJ((
"ERROR tracing dictionary path into \"%.30s\": ",
O2S(OBJ_AT_DEPTH(opnd))),
Tcl_GetObjResult(interp));
goto gotError;
}
}
if (Tcl_DictObjGet(interp, dictPtr, OBJ_AT_TOS,
&objResultPtr) != TCL_OK) {
TRACE_APPEND(("ERROR reading leaf dictionary key \"%.30s\": %s",
O2S(dictPtr), O2S(Tcl_GetObjResult(interp))));
goto gotError;
}
if (!objResultPtr) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"key \"%s\" not known in dictionary",
TclGetString(OBJ_AT_TOS)));
DECACHE_STACK_INFO();
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "DICT",
TclGetString(OBJ_AT_TOS), NULL);
CACHE_STACK_INFO();
TRACE_ERROR(interp);
goto gotError;
}
TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
NEXT_INST_V(5, opnd+1, 1);
case INST_DICT_GET_DEF:
opnd = TclGetUInt4AtPtr(pc+1);
TRACE(("%u => ", opnd));
dictPtr = OBJ_AT_DEPTH(opnd+1);
if (opnd > 1) {
dictPtr = TclTraceDictPath(interp, dictPtr, opnd-1,
&OBJ_AT_DEPTH(opnd), DICT_PATH_EXISTS);
if (dictPtr == NULL) {
TRACE_WITH_OBJ((
"ERROR tracing dictionary path into \"%.30s\": ",
O2S(OBJ_AT_DEPTH(opnd+1))),
Tcl_GetObjResult(interp));
goto gotError;
} else if (dictPtr == DICT_PATH_NON_EXISTENT) {
goto dictGetDefUseDefault;
}
}
if (Tcl_DictObjGet(interp, dictPtr, OBJ_UNDER_TOS,
&objResultPtr) != TCL_OK) {
TRACE_APPEND(("ERROR reading leaf dictionary key \"%.30s\": %s",
O2S(dictPtr), O2S(Tcl_GetObjResult(interp))));
goto gotError;
} else if (!objResultPtr) {
dictGetDefUseDefault:
objResultPtr = OBJ_AT_TOS;
}
TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
NEXT_INST_V(5, opnd+2, 1);
case INST_DICT_SET:
case INST_DICT_UNSET:
case INST_DICT_INCR_IMM:
opnd = TclGetUInt4AtPtr(pc+1);
opnd2 = TclGetUInt4AtPtr(pc+5);
|
| ︙ | ︙ | |||
7974 7975 7976 7977 7978 7979 7980 |
if (w1 == -2) {
int signum = oddExponent ? -1 : 1;
/*
* Reduce small powers of 2 to shifts.
*/
| | | 8004 8005 8006 8007 8008 8009 8010 8011 8012 8013 8014 8015 8016 8017 8018 |
if (w1 == -2) {
int signum = oddExponent ? -1 : 1;
/*
* Reduce small powers of 2 to shifts.
*/
if ((Tcl_WideUInt) w2 < CHAR_BIT * sizeof(Tcl_WideInt) - 1) {
WIDE_RESULT(signum * (((Tcl_WideInt) 1) << (int) w2));
}
goto overflowExpon;
}
if (w2 - 2 < (long)MaxBase64Size
&& w1 <= MaxBase64[w2 - 2]
&& w1 >= -MaxBase64[w2 - 2]) {
|
| ︙ | ︙ | |||
8025 8026 8027 8028 8029 8030 8031 |
wResult = oddExponent ? -Exp64Value[base] : Exp64Value[base];
WIDE_RESULT(wResult);
}
}
overflowExpon:
| > | < | | < < < | < | 8055 8056 8057 8058 8059 8060 8061 8062 8063 8064 8065 8066 8067 8068 8069 8070 8071 8072 8073 8074 8075 8076 8077 8078 8079 8080 |
wResult = oddExponent ? -Exp64Value[base] : Exp64Value[base];
WIDE_RESULT(wResult);
}
}
overflowExpon:
if ((TclGetWideIntFromObj(NULL, value2Ptr, &w2) != TCL_OK)
|| (value2Ptr->typePtr != &tclIntType)
|| (Tcl_WideUInt)w2 >= (1<<28)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"exponent too large", -1));
return GENERAL_ARITHMETIC_ERROR;
}
Tcl_TakeBignumFromObj(NULL, valuePtr, &big1);
mp_init(&bigResult);
mp_expt_d_ex(&big1, w2, &bigResult, 1);
mp_clear(&big1);
BIG_RESULT(&bigResult);
}
case INST_ADD:
case INST_SUB:
case INST_MULT:
case INST_DIV:
|
| ︙ | ︙ |
Changes to generic/tclIO.c.
| ︙ | ︙ | |||
3458 3459 3460 3461 3462 3463 3464 3465 3466 3467 3468 3469 3470 3471 |
TclDecrRefCount(statePtr->chanMsg);
statePtr->chanMsg = NULL;
}
}
Tcl_ClearChannelHandlers(chan);
/*
* Invoke the registered close callbacks and delete their records.
*/
while (statePtr->closeCbPtr != NULL) {
cbPtr = statePtr->closeCbPtr;
statePtr->closeCbPtr = cbPtr->nextPtr;
| > > > > > | 3458 3459 3460 3461 3462 3463 3464 3465 3466 3467 3468 3469 3470 3471 3472 3473 3474 3475 3476 |
TclDecrRefCount(statePtr->chanMsg);
statePtr->chanMsg = NULL;
}
}
Tcl_ClearChannelHandlers(chan);
/*
* Cancel any outstanding timer.
*/
Tcl_DeleteTimerHandler(statePtr->timer);
/*
* Invoke the registered close callbacks and delete their records.
*/
while (statePtr->closeCbPtr != NULL) {
cbPtr = statePtr->closeCbPtr;
statePtr->closeCbPtr = cbPtr->nextPtr;
|
| ︙ | ︙ | |||
4443 4444 4445 4446 4447 4448 4449 4450 4451 4452 4453 4454 4455 4456 |
}
if ((flushed < total) && (GotFlag(statePtr, CHANNEL_UNBUFFERED) ||
(needNlFlush && GotFlag(statePtr, CHANNEL_LINEBUFFERED)))) {
if (FlushChannel(NULL, chanPtr, 0) != 0) {
return -1;
}
}
return total;
}
/*
*---------------------------------------------------------------------------
*
| > > | 4448 4449 4450 4451 4452 4453 4454 4455 4456 4457 4458 4459 4460 4461 4462 4463 |
}
if ((flushed < total) && (GotFlag(statePtr, CHANNEL_UNBUFFERED) ||
(needNlFlush && GotFlag(statePtr, CHANNEL_LINEBUFFERED)))) {
if (FlushChannel(NULL, chanPtr, 0) != 0) {
return -1;
}
}
UpdateInterest(chanPtr);
return total;
}
/*
*---------------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
8475 8476 8477 8478 8479 8480 8481 | * - It does not process all events in the event queue, but only * one, at least in some situations. * * In that case we can get into a situation where * * - Tcl drops READABLE here, because it has data in its own * buffers waiting to be read by the extension. | | | | 8482 8483 8484 8485 8486 8487 8488 8489 8490 8491 8492 8493 8494 8495 8496 8497 8498 | * - It does not process all events in the event queue, but only * one, at least in some situations. * * In that case we can get into a situation where * * - Tcl drops READABLE here, because it has data in its own * buffers waiting to be read by the extension. * - A READABLE event is synthesized via timer. * - The OS still reports the EXCEPTION condition on the file. * - And the extension gets the EXCEPTION event first, and handles * this as EOF. * * End result ==> Premature end of reading from a file. * * The concrete example is 'Expect', and its [expect] command * (and at the C-level, deep in the bowels of Expect, * 'exp_get_next_event'. See marker 'SunOS' for commentary in |
| ︙ | ︙ | |||
8503 8504 8505 8506 8507 8508 8509 8510 8511 8512 8513 8514 8515 8516 |
if (!statePtr->timer) {
statePtr->timer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME,
ChannelTimerProc, chanPtr);
}
}
}
ChanWatch(chanPtr, mask);
}
/*
*----------------------------------------------------------------------
*
* ChannelTimerProc --
| > > > > > > > > > > | 8510 8511 8512 8513 8514 8515 8516 8517 8518 8519 8520 8521 8522 8523 8524 8525 8526 8527 8528 8529 8530 8531 8532 8533 |
if (!statePtr->timer) {
statePtr->timer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME,
ChannelTimerProc, chanPtr);
}
}
}
if (!statePtr->timer
&& mask & TCL_WRITABLE
&& GotFlag(statePtr, CHANNEL_NONBLOCKING)) {
statePtr->timer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME,
ChannelTimerProc,chanPtr);
}
ChanWatch(chanPtr, mask);
}
/*
*----------------------------------------------------------------------
*
* ChannelTimerProc --
|
| ︙ | ︙ | |||
8530 8531 8532 8533 8534 8535 8536 8537 8538 8539 8540 8541 8542 8543 8544 8545 8546 8547 8548 |
static void
ChannelTimerProc(
ClientData clientData)
{
Channel *chanPtr = clientData;
ChannelState *statePtr = chanPtr->state;
/* State info for channel */
if (!GotFlag(statePtr, CHANNEL_NEED_MORE_DATA)
&& (statePtr->interestMask & TCL_READABLE)
&& (statePtr->inQueueHead != NULL)
&& IsBufferReady(statePtr->inQueueHead)) {
/*
* Restart the timer in case a channel handler reenters the event loop
* before UpdateInterest gets called by Tcl_NotifyChannel.
*/
statePtr->timer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME,
ChannelTimerProc,chanPtr);
| > > > > > > > > > > > > > > > < < < > | 8547 8548 8549 8550 8551 8552 8553 8554 8555 8556 8557 8558 8559 8560 8561 8562 8563 8564 8565 8566 8567 8568 8569 8570 8571 8572 8573 8574 8575 8576 8577 8578 8579 8580 8581 8582 8583 8584 8585 8586 8587 8588 8589 8590 8591 8592 |
static void
ChannelTimerProc(
ClientData clientData)
{
Channel *chanPtr = clientData;
ChannelState *statePtr = chanPtr->state;
/* State info for channel */
Tcl_Preserve(statePtr);
statePtr->timer = NULL;
if (statePtr->interestMask & TCL_WRITABLE
&& GotFlag(statePtr, CHANNEL_NONBLOCKING)
&& !GotFlag(statePtr, BG_FLUSH_SCHEDULED)
) {
/*
* Restart the timer in case a channel handler reenters the event loop
* before UpdateInterest gets called by Tcl_NotifyChannel.
*/
statePtr->timer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME,
ChannelTimerProc,chanPtr);
Tcl_NotifyChannel((Tcl_Channel) chanPtr, TCL_WRITABLE);
}
if (!GotFlag(statePtr, CHANNEL_NEED_MORE_DATA)
&& (statePtr->interestMask & TCL_READABLE)
&& (statePtr->inQueueHead != NULL)
&& IsBufferReady(statePtr->inQueueHead)) {
/*
* Restart the timer in case a channel handler reenters the event loop
* before UpdateInterest gets called by Tcl_NotifyChannel.
*/
statePtr->timer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME,
ChannelTimerProc,chanPtr);
Tcl_NotifyChannel((Tcl_Channel) chanPtr, TCL_READABLE);
} else {
UpdateInterest(chanPtr);
}
Tcl_Release(statePtr);
}
/*
*----------------------------------------------------------------------
*
* Tcl_CreateChannelHandler --
*
|
| ︙ | ︙ |
Changes to generic/tclIORChan.c.
| ︙ | ︙ | |||
50 51 52 53 54 55 56 57 58 59 60 61 62 63 |
int mode, int *errorCodePtr);
static int ReflectGetOption(ClientData clientData,
Tcl_Interp *interp, const char *optionName,
Tcl_DString *dsPtr);
static int ReflectSetOption(ClientData clientData,
Tcl_Interp *interp, const char *optionName,
const char *newValue);
/*
* The C layer channel type/driver definition used by the reflection. This is
* a version 3 structure.
*/
static const Tcl_ChannelType tclRChannelType = {
| > > | 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 |
int mode, int *errorCodePtr);
static int ReflectGetOption(ClientData clientData,
Tcl_Interp *interp, const char *optionName,
Tcl_DString *dsPtr);
static int ReflectSetOption(ClientData clientData,
Tcl_Interp *interp, const char *optionName,
const char *newValue);
static void TimerRunRead(ClientData clientData);
static void TimerRunWrite(ClientData clientData);
/*
* The C layer channel type/driver definition used by the reflection. This is
* a version 3 structure.
*/
static const Tcl_ChannelType tclRChannelType = {
|
| ︙ | ︙ | |||
108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 |
int mode; /* Mask of R/W mode */
int interest; /* Mask of events the channel is interested
* in. */
int dead; /* Boolean signal that some operations
* should no longer be attempted. */
/*
* Note regarding the usage of timers.
*
* Most channel implementations need a timer in the C level to ensure that
* data in buffers is flushed out through the generation of fake file
* events.
*
* See 'rechan', 'memchan', etc.
*
| > > > > > > > > > > > < < | < | > | 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 |
int mode; /* Mask of R/W mode */
int interest; /* Mask of events the channel is interested
* in. */
int dead; /* Boolean signal that some operations
* should no longer be attempted. */
Tcl_TimerToken readTimer; /*
A token for the timer that is scheduled in
order to call Tcl_NotifyChannel when the
channel is readable
*/
Tcl_TimerToken writeTimer; /*
A token for the timer that is scheduled in
order to call Tcl_NotifyChannel when the
channel is writable
*/
/*
* Note regarding the usage of timers.
*
* Most channel implementations need a timer in the C level to ensure that
* data in buffers is flushed out through the generation of fake file
* events.
*
* See 'rechan', 'memchan', etc.
*
* A timer is used here as well in order to ensure at least on pass through
* the event loop when a channel becomes ready. See issues 67a5eabbd3d1 and
* ef28eb1f1516.
*/
} ReflectedChannel;
/*
* Structure of the table maping from channel handles to reflected
* channels. Each interpreter which has the handler command for one or more
* reflected channels records them in such a table, so that 'chan postevent'
|
| ︙ | ︙ | |||
916 917 918 919 920 921 922 |
/*
* We have the channel and the events to post.
*/
#if TCL_THREADS
if (rcPtr->owner == rcPtr->thread) {
#endif
| | > > > > > > > > > > > | 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 |
/*
* We have the channel and the events to post.
*/
#if TCL_THREADS
if (rcPtr->owner == rcPtr->thread) {
#endif
if (events & TCL_READABLE) {
if (rcPtr->readTimer == NULL) {
rcPtr->readTimer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME,
TimerRunRead, rcPtr);
}
}
if (events & TCL_WRITABLE) {
if (rcPtr->writeTimer == NULL) {
rcPtr->writeTimer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME,
TimerRunWrite, rcPtr);
}
}
#if TCL_THREADS
} else {
ReflectEvent *ev = Tcl_Alloc(sizeof(ReflectEvent));
ev->header.proc = ReflectEventRun;
ev->events = events;
ev->rcPtr = rcPtr;
|
| ︙ | ︙ | |||
963 964 965 966 967 968 969 970 971 972 973 974 975 976 |
Tcl_ResetResult(interp);
return TCL_OK;
#undef CHAN
#undef EVENT
}
/*
* Channel error message marshalling utilities.
*/
static Tcl_Obj *
MarshallError(
| > > > > > > > > > > > > > > > > > > | 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 |
Tcl_ResetResult(interp);
return TCL_OK;
#undef CHAN
#undef EVENT
}
static void
TimerRunRead(
ClientData clientData)
{
ReflectedChannel *rcPtr = clientData;
rcPtr->readTimer = NULL;
Tcl_NotifyChannel(rcPtr->chan, TCL_READABLE);
}
static void
TimerRunWrite(
ClientData clientData)
{
ReflectedChannel *rcPtr = clientData;
rcPtr->writeTimer = NULL;
Tcl_NotifyChannel(rcPtr->chan, TCL_WRITABLE);
}
/*
* Channel error message marshalling utilities.
*/
static Tcl_Obj *
MarshallError(
|
| ︙ | ︙ | |||
1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 |
#endif
tctPtr = ((Channel *)rcPtr->chan)->typePtr;
if (tctPtr && tctPtr != &tclRChannelType) {
Tcl_Free((void *)tctPtr);
((Channel *)rcPtr->chan)->typePtr = NULL;
}
Tcl_EventuallyFree(rcPtr, (Tcl_FreeProc *) FreeReflectedChannel);
return EOK;
}
/*
* Are we in the correct thread?
*/
| > > > > > > | 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 |
#endif
tctPtr = ((Channel *)rcPtr->chan)->typePtr;
if (tctPtr && tctPtr != &tclRChannelType) {
Tcl_Free((void *)tctPtr);
((Channel *)rcPtr->chan)->typePtr = NULL;
}
if (rcPtr->readTimer != NULL) {
Tcl_DeleteTimerHandler(rcPtr->readTimer);
}
if (rcPtr->writeTimer != NULL) {
Tcl_DeleteTimerHandler(rcPtr->writeTimer);
}
Tcl_EventuallyFree(rcPtr, (Tcl_FreeProc *) FreeReflectedChannel);
return EOK;
}
/*
* Are we in the correct thread?
*/
|
| ︙ | ︙ | |||
1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 |
}
#endif
tctPtr = ((Channel *)rcPtr->chan)->typePtr;
if (tctPtr && tctPtr != &tclRChannelType) {
Tcl_Free((void *)tctPtr);
((Channel *)rcPtr->chan)->typePtr = NULL;
}
Tcl_EventuallyFree(rcPtr, (Tcl_FreeProc *) FreeReflectedChannel);
return (result == TCL_OK) ? EOK : EINVAL;
}
/*
*----------------------------------------------------------------------
*
| > > > > > > | 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 |
}
#endif
tctPtr = ((Channel *)rcPtr->chan)->typePtr;
if (tctPtr && tctPtr != &tclRChannelType) {
Tcl_Free((void *)tctPtr);
((Channel *)rcPtr->chan)->typePtr = NULL;
}
if (rcPtr->readTimer != NULL) {
Tcl_DeleteTimerHandler(rcPtr->readTimer);
}
if (rcPtr->writeTimer != NULL) {
Tcl_DeleteTimerHandler(rcPtr->writeTimer);
}
Tcl_EventuallyFree(rcPtr, (Tcl_FreeProc *) FreeReflectedChannel);
return (result == TCL_OK) ? EOK : EINVAL;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 |
rcPtr = Tcl_Alloc(sizeof(ReflectedChannel));
/* rcPtr->chan: Assigned by caller. Dummy data here. */
rcPtr->chan = NULL;
rcPtr->interp = interp;
rcPtr->dead = 0;
#if TCL_THREADS
rcPtr->thread = Tcl_GetCurrentThread();
#endif
rcPtr->mode = mode;
rcPtr->interest = 0; /* Initially no interest registered */
/* ASSERT: cmdpfxObj is a Tcl List */
| > > | 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 2192 2193 2194 |
rcPtr = Tcl_Alloc(sizeof(ReflectedChannel));
/* rcPtr->chan: Assigned by caller. Dummy data here. */
rcPtr->chan = NULL;
rcPtr->interp = interp;
rcPtr->dead = 0;
rcPtr->readTimer = 0;
rcPtr->writeTimer = 0;
#if TCL_THREADS
rcPtr->thread = Tcl_GetCurrentThread();
#endif
rcPtr->mode = mode;
rcPtr->interest = 0; /* Initially no interest registered */
/* ASSERT: cmdpfxObj is a Tcl List */
|
| ︙ | ︙ |
Changes to generic/tclInt.h.
| ︙ | ︙ | |||
3030 3031 3032 3033 3034 3035 3036 3037 3038 3039 3040 3041 3042 3043 | const char **endPtr); MODULE_SCOPE int TclMergeReturnOptions(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], Tcl_Obj **optionsPtrPtr, int *codePtr, int *levelPtr); MODULE_SCOPE Tcl_Obj * TclNoErrorStack(Tcl_Interp *interp, Tcl_Obj *options); MODULE_SCOPE int TclNokia770Doubles(void); MODULE_SCOPE void TclNsDecrRefCount(Namespace *nsPtr); MODULE_SCOPE void TclObjVarErrMsg(Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, const char *operation, const char *reason, int index); MODULE_SCOPE int TclObjInvokeNamespace(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], Tcl_Namespace *nsPtr, int flags); MODULE_SCOPE int TclObjUnsetVar2(Tcl_Interp *interp, | > | 3030 3031 3032 3033 3034 3035 3036 3037 3038 3039 3040 3041 3042 3043 3044 | const char **endPtr); MODULE_SCOPE int TclMergeReturnOptions(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], Tcl_Obj **optionsPtrPtr, int *codePtr, int *levelPtr); MODULE_SCOPE Tcl_Obj * TclNoErrorStack(Tcl_Interp *interp, Tcl_Obj *options); MODULE_SCOPE int TclNokia770Doubles(void); MODULE_SCOPE void TclNsDecrRefCount(Namespace *nsPtr); MODULE_SCOPE int TclNamespaceDeleted(Namespace *nsPtr); MODULE_SCOPE void TclObjVarErrMsg(Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, const char *operation, const char *reason, int index); MODULE_SCOPE int TclObjInvokeNamespace(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], Tcl_Namespace *nsPtr, int flags); MODULE_SCOPE int TclObjUnsetVar2(Tcl_Interp *interp, |
| ︙ | ︙ | |||
3390 3391 3392 3393 3394 3395 3396 3397 3398 3399 3400 3401 3402 3403 | Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_LpopObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_LrangeObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_LrepeatObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_LreplaceObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); | > > > | 3391 3392 3393 3394 3395 3396 3397 3398 3399 3400 3401 3402 3403 3404 3405 3406 3407 | Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_LpopObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_LrangeObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_LremoveObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_LrepeatObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_LreplaceObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); |
| ︙ | ︙ | |||
3564 3565 3566 3567 3568 3569 3570 3571 3572 3573 3574 3575 3576 3577 | Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileDictForCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileDictGetCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileDictIncrCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileDictLappendCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); | > > > | 3568 3569 3570 3571 3572 3573 3574 3575 3576 3577 3578 3579 3580 3581 3582 3583 3584 | Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileDictForCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileDictGetCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileDictGetWithDefaultCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileDictIncrCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileDictLappendCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); |
| ︙ | ︙ | |||
3726 3727 3728 3729 3730 3731 3732 3733 3734 3735 3736 3737 3738 3739 | Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileStringFirstCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileStringIndexCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileStringIsCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileStringLastCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); | > > > | 3733 3734 3735 3736 3737 3738 3739 3740 3741 3742 3743 3744 3745 3746 3747 3748 3749 | Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileStringFirstCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileStringIndexCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileStringInsertCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileStringIsCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileStringLastCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); |
| ︙ | ︙ | |||
4459 4460 4461 4462 4463 4464 4465 4466 4467 4468 4469 4470 4471 4472 | * * MODULE_SCOPE int TclHasStringRep(Tcl_Obj *objPtr); *---------------------------------------------------------------- */ #define TclHasStringRep(objPtr) ((objPtr)->bytes != NULL) /* *---------------------------------------------------------------- * Macros used by the Tcl core to grow Tcl_Token arrays. They use the same * growth algorithm as used in tclStringObj.c for growing strings. The ANSI C * "prototype" for this macro is: * * MODULE_SCOPE void TclGrowTokenArray(Tcl_Token *tokenPtr, int used, | > > > > > > > > > > > > > > > > > > > > > > > > > | 4469 4470 4471 4472 4473 4474 4475 4476 4477 4478 4479 4480 4481 4482 4483 4484 4485 4486 4487 4488 4489 4490 4491 4492 4493 4494 4495 4496 4497 4498 4499 4500 4501 4502 4503 4504 4505 4506 4507 |
*
* MODULE_SCOPE int TclHasStringRep(Tcl_Obj *objPtr);
*----------------------------------------------------------------
*/
#define TclHasStringRep(objPtr) ((objPtr)->bytes != NULL)
/*
*----------------------------------------------------------------
* Macro used by the Tcl core to get the bignum out of the bignum
* representation of a Tcl_Obj.
* The ANSI C "prototype" for this macro is:
*
* MODULE_SCOPE void TclUnpackBignum(Tcl_Obj *objPtr, mp_int bignum);
*----------------------------------------------------------------
*/
#define TclUnpackBignum(objPtr, bignum) \
do { \
register Tcl_Obj *bignumObj = (objPtr); \
register int bignumPayload = \
PTR2INT(bignumObj->internalRep.twoPtrValue.ptr2); \
if (bignumPayload == -1) { \
(bignum) = *((mp_int *) bignumObj->internalRep.twoPtrValue.ptr1); \
} else { \
(bignum).dp = bignumObj->internalRep.twoPtrValue.ptr1; \
(bignum).sign = bignumPayload >> 30; \
(bignum).alloc = (bignumPayload >> 15) & 0x7fff; \
(bignum).used = bignumPayload & 0x7fff; \
} \
} while (0)
/*
*----------------------------------------------------------------
* Macros used by the Tcl core to grow Tcl_Token arrays. They use the same
* growth algorithm as used in tclStringObj.c for growing strings. The ANSI C
* "prototype" for this macro is:
*
* MODULE_SCOPE void TclGrowTokenArray(Tcl_Token *tokenPtr, int used,
|
| ︙ | ︙ |
Changes to generic/tclLink.c.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 |
/*
* tclLink.c --
*
* This file implements linked variables (a C variable that is tied to a
* Tcl variable). The idea of linked variables was first suggested by
* Andreas Stolcke and this implementation is based heavily on a
* prototype implementation provided by him.
*
* Copyright (c) 1993 The Regents of the University of California.
* Copyright (c) 1994-1997 Sun Microsystems, Inc.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include "tclInt.h"
/*
* For each linked variable there is a data structure of the following type,
* which describes the link and is the clientData for the trace set on the Tcl
* variable.
*/
typedef struct {
Tcl_Interp *interp; /* Interpreter containing Tcl variable. */
Tcl_Obj *varName; /* Name of variable (must be global). This is
* needed during trace callbacks, since the
* actual variable may be aliased at that time
* via upvar. */
| > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > < | > > > > > > > > > > > > > > > | 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 |
/*
* tclLink.c --
*
* This file implements linked variables (a C variable that is tied to a
* Tcl variable). The idea of linked variables was first suggested by
* Andreas Stolcke and this implementation is based heavily on a
* prototype implementation provided by him.
*
* Copyright (c) 1993 The Regents of the University of California.
* Copyright (c) 1994-1997 Sun Microsystems, Inc.
* Copyright (c) 2008 Rene Zaumseil
* 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.
*/
#include "tclInt.h"
#include "tommath.h"
#include <math.h>
/*
* For each linked variable there is a data structure of the following type,
* which describes the link and is the clientData for the trace set on the Tcl
* variable.
*/
typedef struct {
Tcl_Interp *interp; /* Interpreter containing Tcl variable. */
Namespace *nsPtr; /* Namespace containing Tcl variable */
Tcl_Obj *varName; /* Name of variable (must be global). This is
* needed during trace callbacks, since the
* actual variable may be aliased at that time
* via upvar. */
void *addr; /* Location of C variable. */
int bytes; /* Size of C variable array. This is 0 when
* single variables, and >0 used for array
* variables. */
int numElems; /* Number of elements in C variable array.
* Zero for single variables. */
int type; /* Type of link (TCL_LINK_INT, etc.). */
union {
char c;
unsigned char uc;
int i;
unsigned int ui;
short s;
unsigned short us;
#if !defined(TCL_WIDE_INT_IS_LONG) && !defined(_WIN32) && !defined(__CYGWIN__)
long l;
unsigned long ul;
#endif
Tcl_WideInt w;
Tcl_WideUInt uw;
float f;
double d;
void *aryPtr; /* Generic array. */
char *cPtr; /* char array */
unsigned char *ucPtr; /* unsigned char array */
short *sPtr; /* short array */
unsigned short *usPtr; /* unsigned short array */
int *iPtr; /* int array */
unsigned int *uiPtr; /* unsigned int array */
long *lPtr; /* long array */
unsigned long *ulPtr; /* unsigned long array */
Tcl_WideInt *wPtr; /* wide (long long) array */
Tcl_WideUInt *uwPtr; /* unsigned wide (long long) array */
float *fPtr; /* float array */
double *dPtr; /* double array */
} lastValue; /* Last known value of C variable; used to
* avoid string conversions. */
int flags; /* Miscellaneous one-bit values; see below for
* definitions. */
} Link;
/*
* Definitions for flag bits:
* LINK_READ_ONLY - 1 means errors should be generated if Tcl
* script attempts to write variable.
* LINK_BEING_UPDATED - 1 means that a call to Tcl_UpdateLinkedVar is
* in progress for this variable, so trace
* callbacks on the variable should be ignored.
* LINK_ALLOC_ADDR - 1 means linkPtr->addr was allocated on the
* heap.
* LINK_ALLOC_LAST - 1 means linkPtr->valueLast.p was allocated on
* the heap.
*/
#define LINK_READ_ONLY 1
#define LINK_BEING_UPDATED 2
#define LINK_ALLOC_ADDR 4
#define LINK_ALLOC_LAST 8
/*
* Forward references to functions defined later in this file:
*/
static char * LinkTraceProc(ClientData clientData,Tcl_Interp *interp,
const char *name1, const char *name2, int flags);
static Tcl_Obj * ObjValue(Link *linkPtr);
static void LinkFree(Link *linkPtr);
static int GetInvalidIntFromObj(Tcl_Obj *objPtr, int *intPtr);
static int GetInvalidDoubleFromObj(Tcl_Obj *objPtr,
double *doublePtr);
static int SetInvalidRealFromAny(Tcl_Interp *interp,
Tcl_Obj *objPtr);
/*
* A marker type used to flag weirdnesses so we can pass them around right.
*/
static Tcl_ObjType invalidRealType = {
"invalidReal", /* name */
NULL, /* freeIntRepProc */
NULL, /* dupIntRepProc */
NULL, /* updateStringProc */
NULL /* setFromAnyProc */
};
/*
* Convenience macro for accessing the value of the C variable pointed to by a
* link. Note that this macro produces something that may be regarded as an
* lvalue or rvalue; it may be assigned to as well as read. Also note that
* this macro assumes the name of the variable being accessed (linkPtr); this
* is not strictly a good thing, but it keeps the code much shorter and
|
| ︙ | ︙ | |||
104 105 106 107 108 109 110 |
*----------------------------------------------------------------------
*/
int
Tcl_LinkVar(
Tcl_Interp *interp, /* Interpreter in which varName exists. */
const char *varName, /* Name of a global variable in interp. */
| | > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | 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 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 |
*----------------------------------------------------------------------
*/
int
Tcl_LinkVar(
Tcl_Interp *interp, /* Interpreter in which varName exists. */
const char *varName, /* Name of a global variable in interp. */
void *addr, /* Address of a C variable to be linked to
* varName. */
int type) /* Type of C variable: TCL_LINK_INT, etc. Also
* may have TCL_LINK_READ_ONLY OR'ed in. */
{
Tcl_Obj *objPtr;
Link *linkPtr;
Namespace *dummy;
const char *name;
int code;
linkPtr = (Link *) Tcl_VarTraceInfo2(interp, varName, NULL,
TCL_GLOBAL_ONLY, LinkTraceProc, (ClientData) NULL);
if (linkPtr != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"variable '%s' is already linked", varName));
return TCL_ERROR;
}
linkPtr = Tcl_Alloc(sizeof(Link));
linkPtr->interp = interp;
linkPtr->nsPtr = NULL;
linkPtr->varName = Tcl_NewStringObj(varName, -1);
Tcl_IncrRefCount(linkPtr->varName);
linkPtr->addr = addr;
linkPtr->type = type & ~TCL_LINK_READ_ONLY;
#if !defined(TCL_NO_DEPRECATED) && (defined(TCL_WIDE_INT_IS_LONG) \
|| defined(_WIN32) || defined(__CYGWIN__))
if (linkPtr->type == 11 /* legacy TCL_LINK_LONG */) {
linkPtr->type = TCL_LINK_LONG;
} else if (linkPtr->type == 12 /* legacy TCL_LINK_ULONG */) {
linkPtr->type = TCL_LINK_ULONG;
}
#endif
if (type & TCL_LINK_READ_ONLY) {
linkPtr->flags = LINK_READ_ONLY;
} else {
linkPtr->flags = 0;
}
linkPtr->bytes = 0;
linkPtr->numElems = 0;
objPtr = ObjValue(linkPtr);
if (Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, objPtr,
TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) == NULL) {
Tcl_DecrRefCount(linkPtr->varName);
LinkFree(linkPtr);
return TCL_ERROR;
}
TclGetNamespaceForQualName(interp, varName, NULL, TCL_GLOBAL_ONLY,
&(linkPtr->nsPtr), &dummy, &dummy, &name);
linkPtr->nsPtr->refCount++;
code = Tcl_TraceVar2(interp, varName, NULL,
TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
LinkTraceProc, linkPtr);
if (code != TCL_OK) {
Tcl_DecrRefCount(linkPtr->varName);
LinkFree(linkPtr);
}
return code;
}
/*
*----------------------------------------------------------------------
*
* Tcl_LinkArray --
*
* Link a C variable array to a Tcl variable so that changes to either
* one causes the other to change.
*
* Results:
* The return value is TCL_OK if everything went well or TCL_ERROR if an
* error occurred (the interp's result is also set after errors).
*
* Side effects:
* The value at *addr is linked to the Tcl variable "varName", using
* "type" to convert between string values for Tcl and binary values for
* *addr.
*
*----------------------------------------------------------------------
*/
int
Tcl_LinkArray(
Tcl_Interp *interp, /* Interpreter in which varName exists. */
const char *varName, /* Name of a global variable in interp. */
void *addr, /* Address of a C variable to be linked to
* varName. If NULL then the necessary space
* will be allocated and returned as the
* interpreter result. */
int type, /* Type of C variable: TCL_LINK_INT, etc. Also
* may have TCL_LINK_READ_ONLY OR'ed in. */
int size) /* Size of C variable array, >1 if array */
{
Tcl_Obj *objPtr;
Link *linkPtr;
Namespace *dummy;
const char *name;
int code;
if (size < 1) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"wrong array size given", -1));
return TCL_ERROR;
}
linkPtr = Tcl_Alloc(sizeof(Link));
linkPtr->type = type & ~TCL_LINK_READ_ONLY;
linkPtr->numElems = size;
if (type & TCL_LINK_READ_ONLY) {
linkPtr->flags = LINK_READ_ONLY;
} else {
linkPtr->flags = 0;
}
switch (linkPtr->type) {
case TCL_LINK_INT:
case TCL_LINK_BOOLEAN:
linkPtr->bytes = size * sizeof(int);
break;
case TCL_LINK_DOUBLE:
linkPtr->bytes = size * sizeof(double);
break;
case TCL_LINK_WIDE_INT:
linkPtr->bytes = size * sizeof(Tcl_WideInt);
break;
case TCL_LINK_WIDE_UINT:
linkPtr->bytes = size * sizeof(Tcl_WideUInt);
break;
case TCL_LINK_CHAR:
linkPtr->bytes = size * sizeof(char);
break;
case TCL_LINK_UCHAR:
linkPtr->bytes = size * sizeof(unsigned char);
break;
case TCL_LINK_SHORT:
linkPtr->bytes = size * sizeof(short);
break;
case TCL_LINK_USHORT:
linkPtr->bytes = size * sizeof(unsigned short);
break;
case TCL_LINK_UINT:
linkPtr->bytes = size * sizeof(unsigned int);
break;
#if !defined(TCL_WIDE_INT_IS_LONG) && !defined(_WIN32) && !defined(__CYGWIN__)
case TCL_LINK_LONG:
linkPtr->bytes = size * sizeof(long);
break;
case TCL_LINK_ULONG:
linkPtr->bytes = size * sizeof(unsigned long);
break;
#endif
case TCL_LINK_FLOAT:
linkPtr->bytes = size * sizeof(float);
break;
case TCL_LINK_STRING:
linkPtr->bytes = size * sizeof(char);
size = 1; /* This is a variable length string, no need
* to check last value. */
/*
* If no address is given create one and use as address the
* not needed linkPtr->lastValue
*/
if (addr == NULL) {
linkPtr->lastValue.aryPtr = Tcl_Alloc(linkPtr->bytes);
linkPtr->flags |= LINK_ALLOC_LAST;
addr = (char *) &linkPtr->lastValue.cPtr;
}
break;
case TCL_LINK_CHARS:
case TCL_LINK_BINARY:
linkPtr->bytes = size * sizeof(char);
break;
default:
LinkFree(linkPtr);
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"bad linked array variable type", -1));
return TCL_ERROR;
}
/*
* Allocate C variable space in case no address is given
*/
if (addr == NULL) {
linkPtr->addr = Tcl_Alloc(linkPtr->bytes);
linkPtr->flags |= LINK_ALLOC_ADDR;
} else {
linkPtr->addr = addr;
}
/*
* If necessary create space for last used value.
*/
if (size > 1) {
linkPtr->lastValue.aryPtr = Tcl_Alloc(linkPtr->bytes);
linkPtr->flags |= LINK_ALLOC_LAST;
}
/*
* Initialize allocated space.
*/
if (linkPtr->flags & LINK_ALLOC_ADDR) {
memset(linkPtr->addr, 0, linkPtr->bytes);
}
if (linkPtr->flags & LINK_ALLOC_LAST) {
memset(linkPtr->lastValue.aryPtr, 0, linkPtr->bytes);
}
/*
* Set common structure values.
*/
linkPtr->interp = interp;
linkPtr->varName = Tcl_NewStringObj(varName, -1);
Tcl_IncrRefCount(linkPtr->varName);
TclGetNamespaceForQualName(interp, varName, NULL, TCL_GLOBAL_ONLY,
&(linkPtr->nsPtr), &dummy, &dummy, &name);
linkPtr->nsPtr->refCount++;
objPtr = ObjValue(linkPtr);
if (Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, objPtr,
TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) == NULL) {
Tcl_DecrRefCount(linkPtr->varName);
LinkFree(linkPtr);
return TCL_ERROR;
}
code = Tcl_TraceVar2(interp, varName, NULL,
TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
LinkTraceProc, linkPtr);
if (code != TCL_OK) {
Tcl_DecrRefCount(linkPtr->varName);
LinkFree(linkPtr);
}
return code;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
190 191 192 193 194 195 196 |
if (linkPtr == NULL) {
return;
}
Tcl_UntraceVar2(interp, varName, NULL,
TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
LinkTraceProc, linkPtr);
Tcl_DecrRefCount(linkPtr->varName);
| | | 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 |
if (linkPtr == NULL) {
return;
}
Tcl_UntraceVar2(interp, varName, NULL,
TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
LinkTraceProc, linkPtr);
Tcl_DecrRefCount(linkPtr->varName);
LinkFree(linkPtr);
}
/*
*----------------------------------------------------------------------
*
* Tcl_UpdateLinkedVar --
*
|
| ︙ | ︙ | |||
241 242 243 244 245 246 247 248 249 250 251 252 253 254 |
linkPtr->flags = (linkPtr->flags & ~LINK_BEING_UPDATED) | savedFlag;
}
}
/*
*----------------------------------------------------------------------
*
* LinkTraceProc --
*
* This function is invoked when a linked Tcl variable is read, written,
* or unset from Tcl. It's responsible for keeping the C variable in sync
* with the Tcl variable.
*
* Results:
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
linkPtr->flags = (linkPtr->flags & ~LINK_BEING_UPDATED) | savedFlag;
}
}
/*
*----------------------------------------------------------------------
*
* GetInt, GetWide, GetUWide, GetDouble, EqualDouble, IsSpecial --
*
* Helper functions for LinkTraceProc and ObjValue. These are all
* factored out here to make those functions simpler.
*
*----------------------------------------------------------------------
*/
static inline int
GetInt(
Tcl_Obj *objPtr,
int *intPtr)
{
return (Tcl_GetIntFromObj(NULL, objPtr, intPtr) != TCL_OK
&& GetInvalidIntFromObj(objPtr, intPtr) != TCL_OK);
}
static inline int
GetWide(
Tcl_Obj *objPtr,
Tcl_WideInt *widePtr)
{
if (Tcl_GetWideIntFromObj(NULL, objPtr, widePtr) != TCL_OK) {
int intValue;
if (GetInvalidIntFromObj(objPtr, &intValue) != TCL_OK) {
return 1;
}
*widePtr = intValue;
}
return 0;
}
static inline int
GetUWide(
Tcl_Obj *objPtr,
Tcl_WideUInt *uwidePtr)
{
Tcl_WideInt *widePtr = (Tcl_WideInt *) uwidePtr;
ClientData clientData;
int type, intValue;
if (TclGetNumberFromObj(NULL, objPtr, &clientData, &type) == TCL_OK) {
if (type == TCL_NUMBER_INT) {
*widePtr = *((const Tcl_WideInt *) clientData);
return (*widePtr < 0);
} else if (type == TCL_NUMBER_BIG) {
mp_int *numPtr = clientData;
Tcl_WideUInt value = 0;
union {
Tcl_WideUInt value;
unsigned char bytes[sizeof(Tcl_WideUInt)];
} scratch;
unsigned long numBytes = sizeof(Tcl_WideUInt);
unsigned char *bytes = scratch.bytes;
if (numPtr->sign || (MP_OKAY != mp_to_unsigned_bin_n(numPtr,
bytes, &numBytes))) {
/*
* If the sign bit is set (a negative value) or if the value
* can't possibly fit in the bits of an unsigned wide, there's
* no point in doing further conversion.
*/
return 1;
}
#ifdef WORDS_BIGENDIAN
while (numBytes-- > 0) {
value = (value << CHAR_BIT) | *bytes++;
}
#else /* !WORDS_BIGENDIAN */
/*
* Little-endian can read the value directly.
*/
value = scratch.value;
#endif /* WORDS_BIGENDIAN */
*uwidePtr = value;
return 0;
}
}
/*
* Evil edge case fallback.
*/
if (GetInvalidIntFromObj(objPtr, &intValue) != TCL_OK) {
return 1;
}
*uwidePtr = intValue;
return 0;
}
static inline int
GetDouble(
Tcl_Obj *objPtr,
double *dblPtr)
{
if (Tcl_GetDoubleFromObj(NULL, objPtr, dblPtr) == TCL_OK) {
return 0;
} else {
#ifdef ACCEPT_NAN
Tcl_ObjIntRep *irPtr = TclFetchIntRep(objPtr, &tclDoubleType);
if (irPtr != NULL) {
*dblPtr = irPtr->doubleValue;
return 0;
}
#endif /* ACCEPT_NAN */
return GetInvalidDoubleFromObj(objPtr, dblPtr) != TCL_OK;
}
}
static inline int
EqualDouble(
double a,
double b)
{
return (a == b)
#ifdef ACCEPT_NAN
|| (TclIsNaN(a) && TclIsNaN(b))
#endif /* ACCEPT_NAN */
;
}
static inline int
IsSpecial(
double a)
{
return TclIsInfinite(a)
#ifdef ACCEPT_NAN
|| TclIsNaN(a)
#endif /* ACCEPT_NAN */
;
}
/*
* Mark an object as holding a weird double.
*/
static int
SetInvalidRealFromAny(
Tcl_Interp *interp,
Tcl_Obj *objPtr)
{
size_t length;
const char *str, *endPtr;
str = TclGetStringFromObj(objPtr, &length);
if ((length == 1) && (str[0] == '.')) {
objPtr->typePtr = &invalidRealType;
objPtr->internalRep.doubleValue = 0.0;
return TCL_OK;
}
if (TclParseNumber(NULL, objPtr, NULL, str, length, &endPtr,
TCL_PARSE_DECIMAL_ONLY) == TCL_OK) {
/*
* If number is followed by [eE][+-]?, then it is an invalid double,
* but it could be the start of a valid double.
*/
if (*endPtr == 'e' || *endPtr == 'E') {
++endPtr;
if (*endPtr == '+' || *endPtr == '-') {
++endPtr;
}
if (*endPtr == 0) {
double doubleValue = 0.0;
Tcl_GetDoubleFromObj(NULL, objPtr, &doubleValue);
TclFreeIntRep(objPtr);
objPtr->typePtr = &invalidRealType;
objPtr->internalRep.doubleValue = doubleValue;
return TCL_OK;
}
}
}
return TCL_ERROR;
}
/*
* This function checks for integer representations, which are valid when
* linking with C variables, but which are invalid in other contexts in Tcl.
* Handled are "+", "-", "", "0x", "0b", "0d" and "0o" (upper- and
* lower-case). See bug [39f6304c2e].
*/
static int
GetInvalidIntFromObj(
Tcl_Obj *objPtr,
int *intPtr)
{
size_t length;
const char *str = TclGetStringFromObj(objPtr, &length);
if ((length == 0) ||
((length == 2) && (str[0] == '0') && strchr("xXbBoOdD", str[1]))) {
*intPtr = 0;
return TCL_OK;
} else if ((length == 1) && strchr("+-", str[0])) {
*intPtr = (str[0] == '+');
return TCL_OK;
}
return TCL_ERROR;
}
/*
* This function checks for double representations, which are valid when
* linking with C variables, but which are invalid in other contexts in Tcl.
* Handled are "+", "-", "", ".", "0x", "0b" and "0o" (upper- and lower-case)
* and sequences like "1e-". See bug [39f6304c2e].
*/
static int
GetInvalidDoubleFromObj(
Tcl_Obj *objPtr,
double *doublePtr)
{
int intValue;
if (TclHasIntRep(objPtr, &invalidRealType)) {
goto gotdouble;
}
if (GetInvalidIntFromObj(objPtr, &intValue) == TCL_OK) {
*doublePtr = (double) intValue;
return TCL_OK;
}
if (SetInvalidRealFromAny(NULL, objPtr) == TCL_OK) {
gotdouble:
*doublePtr = objPtr->internalRep.doubleValue;
return TCL_OK;
}
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* LinkTraceProc --
*
* This function is invoked when a linked Tcl variable is read, written,
* or unset from Tcl. It's responsible for keeping the C variable in sync
* with the Tcl variable.
*
* Results:
|
| ︙ | ︙ | |||
269 270 271 272 273 274 275 |
Tcl_Interp *interp, /* Interpreter containing Tcl variable. */
const char *name1, /* First part of variable name. */
const char *name2, /* Second part of variable name. */
int flags) /* Miscellaneous additional information. */
{
Link *linkPtr = clientData;
int changed;
| | > > > > | | | 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 |
Tcl_Interp *interp, /* Interpreter containing Tcl variable. */
const char *name1, /* First part of variable name. */
const char *name2, /* Second part of variable name. */
int flags) /* Miscellaneous additional information. */
{
Link *linkPtr = clientData;
int changed;
int valueLength;
const char *value;
char **pp;
Tcl_Obj *valueObj;
int valueInt;
Tcl_WideInt valueWide;
Tcl_WideUInt valueUWide;
double valueDouble;
int objc;
Tcl_Obj **objv;
int i;
/*
* If the variable is being unset, then just re-create it (with a trace)
* unless the whole interpreter is going away.
*/
if (flags & TCL_TRACE_UNSETS) {
if (Tcl_InterpDeleted(interp) || TclNamespaceDeleted(linkPtr->nsPtr)) {
Tcl_DecrRefCount(linkPtr->varName);
LinkFree(linkPtr);
} else if (flags & TCL_TRACE_DESTROYED) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
Tcl_TraceVar2(interp, TclGetString(linkPtr->varName), NULL,
TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES
|TCL_TRACE_UNSETS, LinkTraceProc, linkPtr);
}
|
| ︙ | ︙ | |||
312 313 314 315 316 317 318 |
/*
* For read accesses, update the Tcl variable if the C variable has
* changed since the last time we updated the Tcl variable.
*/
if (flags & TCL_TRACE_READS) {
| > > > > > > > > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > > | | | > | > | 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 |
/*
* For read accesses, update the Tcl variable if the C variable has
* changed since the last time we updated the Tcl variable.
*/
if (flags & TCL_TRACE_READS) {
/*
* Variable arrays
*/
if (linkPtr->flags & LINK_ALLOC_LAST) {
changed = memcmp(linkPtr->addr, linkPtr->lastValue.aryPtr,
linkPtr->bytes);
} else {
/* single variables */
switch (linkPtr->type) {
case TCL_LINK_INT:
case TCL_LINK_BOOLEAN:
changed = (LinkedVar(int) != linkPtr->lastValue.i);
break;
case TCL_LINK_DOUBLE:
changed = !EqualDouble(LinkedVar(double), linkPtr->lastValue.d);
break;
case TCL_LINK_WIDE_INT:
changed = (LinkedVar(Tcl_WideInt) != linkPtr->lastValue.w);
break;
case TCL_LINK_WIDE_UINT:
changed = (LinkedVar(Tcl_WideUInt) != linkPtr->lastValue.uw);
break;
case TCL_LINK_CHAR:
changed = (LinkedVar(char) != linkPtr->lastValue.c);
break;
case TCL_LINK_UCHAR:
changed = (LinkedVar(unsigned char) != linkPtr->lastValue.uc);
break;
case TCL_LINK_SHORT:
changed = (LinkedVar(short) != linkPtr->lastValue.s);
break;
case TCL_LINK_USHORT:
changed = (LinkedVar(unsigned short) != linkPtr->lastValue.us);
break;
case TCL_LINK_UINT:
changed = (LinkedVar(unsigned int) != linkPtr->lastValue.ui);
break;
#if !defined(TCL_WIDE_INT_IS_LONG) && !defined(_WIN32) && !defined(__CYGWIN__)
case TCL_LINK_LONG:
changed = (LinkedVar(long) != linkPtr->lastValue.l);
break;
case TCL_LINK_ULONG:
changed = (LinkedVar(unsigned long) != linkPtr->lastValue.ul);
break;
#endif
case TCL_LINK_FLOAT:
changed = !EqualDouble(LinkedVar(float), linkPtr->lastValue.f);
break;
case TCL_LINK_STRING:
case TCL_LINK_CHARS:
case TCL_LINK_BINARY:
changed = 1;
break;
default:
changed = 0;
/* return (char *) "internal error: bad linked variable type"; */
}
}
if (changed) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
}
return NULL;
}
|
| ︙ | ︙ | |||
388 389 390 391 392 393 394 |
/*
* This shouldn't ever happen.
*/
return (char *) "internal error: linked variable couldn't be read";
}
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < > | < < < < < | < < | < < < < < < < < < < < > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 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 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 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 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 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 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 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 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 |
/*
* This shouldn't ever happen.
*/
return (char *) "internal error: linked variable couldn't be read";
}
/*
* Special cases.
*/
switch (linkPtr->type) {
case TCL_LINK_STRING:
value = TclGetStringFromObj(valueObj, &valueLength);
pp = (char **) linkPtr->addr;
*pp = Tcl_Realloc(*pp, ++valueLength);
memcpy(*pp, value, valueLength);
return NULL;
case TCL_LINK_CHARS:
value = (char *) Tcl_GetStringFromObj(valueObj, &valueLength);
valueLength++; /* include end of string char */
if (valueLength > linkPtr->bytes) {
return (char *) "wrong size of char* value";
}
if (linkPtr->flags & LINK_ALLOC_LAST) {
memcpy(linkPtr->lastValue.aryPtr, value, (size_t) valueLength);
memcpy(linkPtr->addr, value, (size_t) valueLength);
} else {
linkPtr->lastValue.c = '\0';
LinkedVar(char) = linkPtr->lastValue.c;
}
return NULL;
case TCL_LINK_BINARY:
value = (char *) Tcl_GetByteArrayFromObj(valueObj, &valueLength);
if (valueLength != linkPtr->bytes) {
return (char *) "wrong size of binary value";
}
if (linkPtr->flags & LINK_ALLOC_LAST) {
memcpy(linkPtr->lastValue.aryPtr, value, (size_t) valueLength);
memcpy(linkPtr->addr, value, (size_t) valueLength);
} else {
linkPtr->lastValue.uc = (unsigned char) *value;
LinkedVar(unsigned char) = linkPtr->lastValue.uc;
}
return NULL;
}
/*
* A helper macro. Writing this as a function is messy because of type
* variance.
*/
#define InRange(lowerLimit, value, upperLimit) \
((value) >= (lowerLimit) && (value) <= (upperLimit))
/*
* If we're working with an array of numbers, extract the Tcl list.
*/
if (linkPtr->flags & LINK_ALLOC_LAST) {
if (Tcl_ListObjGetElements(NULL, (valueObj), &objc, &objv) == TCL_ERROR
|| objc != linkPtr->numElems) {
return (char *) "wrong dimension";
}
}
switch (linkPtr->type) {
case TCL_LINK_INT:
if (linkPtr->flags & LINK_ALLOC_LAST) {
for (i=0; i < objc; i++) {
int *varPtr = &linkPtr->lastValue.iPtr[i];
if (GetInt(objv[i], varPtr)) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
ObjValue(linkPtr), TCL_GLOBAL_ONLY);
return (char *) "variable array must have integer values";
}
}
} else {
int *varPtr = &linkPtr->lastValue.i;
if (GetInt(valueObj, varPtr)) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
ObjValue(linkPtr), TCL_GLOBAL_ONLY);
return (char *) "variable must have integer value";
}
LinkedVar(int) = *varPtr;
}
break;
case TCL_LINK_WIDE_INT:
if (linkPtr->flags & LINK_ALLOC_LAST) {
for (i=0; i < objc; i++) {
Tcl_WideInt *varPtr = &linkPtr->lastValue.wPtr[i];
if (GetWide(objv[i], varPtr)) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
ObjValue(linkPtr), TCL_GLOBAL_ONLY);
return (char *)
"variable array must have wide integer value";
}
}
} else {
Tcl_WideInt *varPtr = &linkPtr->lastValue.w;
if (GetWide(valueObj, varPtr)) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
ObjValue(linkPtr), TCL_GLOBAL_ONLY);
return (char *) "variable must have wide integer value";
}
LinkedVar(Tcl_WideInt) = *varPtr;
}
break;
case TCL_LINK_DOUBLE:
if (linkPtr->flags & LINK_ALLOC_LAST) {
for (i=0; i < objc; i++) {
if (GetDouble(objv[i], &linkPtr->lastValue.dPtr[i])) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
ObjValue(linkPtr), TCL_GLOBAL_ONLY);
return (char *) "variable array must have real value";
}
}
} else {
double *varPtr = &linkPtr->lastValue.d;
if (GetDouble(valueObj, varPtr)) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
ObjValue(linkPtr), TCL_GLOBAL_ONLY);
return (char *) "variable must have real value";
}
LinkedVar(double) = *varPtr;
}
break;
case TCL_LINK_BOOLEAN:
if (linkPtr->flags & LINK_ALLOC_LAST) {
for (i=0; i < objc; i++) {
int *varPtr = &linkPtr->lastValue.iPtr[i];
if (Tcl_GetBooleanFromObj(NULL, objv[i], varPtr) != TCL_OK) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
ObjValue(linkPtr), TCL_GLOBAL_ONLY);
return (char *) "variable array must have boolean value";
}
}
} else {
int *varPtr = &linkPtr->lastValue.i;
if (Tcl_GetBooleanFromObj(NULL, valueObj, varPtr) != TCL_OK) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
ObjValue(linkPtr), TCL_GLOBAL_ONLY);
return (char *) "variable must have boolean value";
}
LinkedVar(int) = *varPtr;
}
break;
case TCL_LINK_CHAR:
if (linkPtr->flags & LINK_ALLOC_LAST) {
for (i=0; i < objc; i++) {
if (GetInt(objv[i], &valueInt)
|| !InRange(SCHAR_MIN, valueInt, SCHAR_MAX)) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
ObjValue(linkPtr), TCL_GLOBAL_ONLY);
return (char *) "variable array must have char value";
}
linkPtr->lastValue.cPtr[i] = (char) valueInt;
}
} else {
if (GetInt(valueObj, &valueInt)
|| !InRange(SCHAR_MIN, valueInt, SCHAR_MAX)) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
ObjValue(linkPtr), TCL_GLOBAL_ONLY);
return (char *) "variable must have char value";
}
LinkedVar(char) = linkPtr->lastValue.c = (char) valueInt;
}
break;
case TCL_LINK_UCHAR:
if (linkPtr->flags & LINK_ALLOC_LAST) {
for (i=0; i < objc; i++) {
if (GetInt(objv[i], &valueInt)
|| !InRange(0, valueInt, UCHAR_MAX)) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
ObjValue(linkPtr), TCL_GLOBAL_ONLY);
return (char *)
"variable array must have unsigned char value";
}
linkPtr->lastValue.ucPtr[i] = (unsigned char) valueInt;
}
} else {
if (GetInt(valueObj, &valueInt)
|| !InRange(0, valueInt, UCHAR_MAX)) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
ObjValue(linkPtr), TCL_GLOBAL_ONLY);
return (char *) "variable must have unsigned char value";
}
LinkedVar(unsigned char) = linkPtr->lastValue.uc =
(unsigned char) valueInt;
}
break;
case TCL_LINK_SHORT:
if (linkPtr->flags & LINK_ALLOC_LAST) {
for (i=0; i < objc; i++) {
if (GetInt(objv[i], &valueInt)
|| !InRange(SHRT_MIN, valueInt, SHRT_MAX)) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
ObjValue(linkPtr), TCL_GLOBAL_ONLY);
return (char *) "variable array must have short value";
}
linkPtr->lastValue.sPtr[i] = (short) valueInt;
}
} else {
if (GetInt(valueObj, &valueInt)
|| !InRange(SHRT_MIN, valueInt, SHRT_MAX)) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
ObjValue(linkPtr), TCL_GLOBAL_ONLY);
return (char *) "variable must have short value";
}
LinkedVar(short) = linkPtr->lastValue.s = (short) valueInt;
}
break;
case TCL_LINK_USHORT:
if (linkPtr->flags & LINK_ALLOC_LAST) {
for (i=0; i < objc; i++) {
if (GetInt(objv[i], &valueInt)
|| !InRange(0, valueInt, USHRT_MAX)) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
ObjValue(linkPtr), TCL_GLOBAL_ONLY);
return (char *)
"variable array must have unsigned short value";
}
linkPtr->lastValue.usPtr[i] = (unsigned short) valueInt;
}
} else {
if (GetInt(valueObj, &valueInt)
|| !InRange(0, valueInt, USHRT_MAX)) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
ObjValue(linkPtr), TCL_GLOBAL_ONLY);
return (char *) "variable must have unsigned short value";
}
LinkedVar(unsigned short) = linkPtr->lastValue.us =
(unsigned short) valueInt;
}
break;
case TCL_LINK_UINT:
if (linkPtr->flags & LINK_ALLOC_LAST) {
for (i=0; i < objc; i++) {
if (GetWide(objv[i], &valueWide)
|| !InRange(0, valueWide, UINT_MAX)) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
ObjValue(linkPtr), TCL_GLOBAL_ONLY);
return (char *)
"variable array must have unsigned int value";
}
linkPtr->lastValue.uiPtr[i] = (unsigned int) valueWide;
}
} else {
if (GetWide(valueObj, &valueWide)
|| !InRange(0, valueWide, UINT_MAX)) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
ObjValue(linkPtr), TCL_GLOBAL_ONLY);
return (char *) "variable must have unsigned int value";
}
LinkedVar(unsigned int) = linkPtr->lastValue.ui =
(unsigned int) valueWide;
}
break;
#if !defined(TCL_WIDE_INT_IS_LONG) && !defined(_WIN32) && !defined(__CYGWIN__)
case TCL_LINK_LONG:
if (linkPtr->flags & LINK_ALLOC_LAST) {
for (i=0; i < objc; i++) {
if (GetWide(objv[i], &valueWide)
|| !InRange(LONG_MIN, valueWide, LONG_MAX)) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
ObjValue(linkPtr), TCL_GLOBAL_ONLY);
return (char *) "variable array must have long value";
}
linkPtr->lastValue.lPtr[i] = (long) valueWide;
}
} else {
if (GetWide(valueObj, &valueWide)
|| !InRange(LONG_MIN, valueWide, LONG_MAX)) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
ObjValue(linkPtr), TCL_GLOBAL_ONLY);
return (char *) "variable must have long value";
}
LinkedVar(long) = linkPtr->lastValue.l = (long) valueWide;
}
break;
case TCL_LINK_ULONG:
if (linkPtr->flags & LINK_ALLOC_LAST) {
for (i=0; i < objc; i++) {
if (GetUWide(objv[i], &valueUWide)
|| !InRange(0, valueUWide, ULONG_MAX)) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
ObjValue(linkPtr), TCL_GLOBAL_ONLY);
return (char *)
"variable array must have unsigned long value";
}
linkPtr->lastValue.ulPtr[i] = (unsigned long) valueUWide;
}
} else {
if (GetUWide(valueObj, &valueUWide)
|| !InRange(0, valueUWide, ULONG_MAX)) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
ObjValue(linkPtr), TCL_GLOBAL_ONLY);
return (char *) "variable must have unsigned long value";
}
LinkedVar(unsigned long) = linkPtr->lastValue.ul =
(unsigned long) valueUWide;
}
break;
#endif
case TCL_LINK_WIDE_UINT:
if (linkPtr->flags & LINK_ALLOC_LAST) {
for (i=0; i < objc; i++) {
if (GetUWide(objv[i], &valueUWide)) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
ObjValue(linkPtr), TCL_GLOBAL_ONLY);
return (char *)
"variable array must have unsigned wide int value";
}
linkPtr->lastValue.uwPtr[i] = valueUWide;
}
} else {
if (GetUWide(valueObj, &valueUWide)) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
ObjValue(linkPtr), TCL_GLOBAL_ONLY);
return (char *) "variable must have unsigned wide int value";
}
LinkedVar(Tcl_WideUInt) = linkPtr->lastValue.uw = valueUWide;
}
break;
case TCL_LINK_FLOAT:
if (linkPtr->flags & LINK_ALLOC_LAST) {
for (i=0; i < objc; i++) {
if (GetDouble(objv[i], &valueDouble)
&& !InRange(FLT_MIN, fabs(valueDouble), FLT_MAX)
&& !IsSpecial(valueDouble)) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
ObjValue(linkPtr), TCL_GLOBAL_ONLY);
return (char *) "variable array must have float value";
}
linkPtr->lastValue.fPtr[i] = (float) valueDouble;
}
} else {
if (GetDouble(valueObj, &valueDouble)
&& !InRange(FLT_MIN, fabs(valueDouble), FLT_MAX)
&& !IsSpecial(valueDouble)) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
ObjValue(linkPtr), TCL_GLOBAL_ONLY);
return (char *) "variable must have float value";
}
LinkedVar(float) = linkPtr->lastValue.f = (float) valueDouble;
}
break;
default:
return (char *) "internal error: bad linked variable type";
}
if (linkPtr->flags & LINK_ALLOC_LAST) {
memcpy(linkPtr->addr, linkPtr->lastValue.aryPtr, linkPtr->bytes);
}
return NULL;
}
/*
*----------------------------------------------------------------------
*
* ObjValue --
|
| ︙ | ︙ | |||
577 578 579 580 581 582 583 |
*/
static Tcl_Obj *
ObjValue(
Link *linkPtr) /* Structure describing linked variable. */
{
char *p;
| | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > < < < > > > > > > > > > > > > > > > > > > > > | < > > | < < | < < < < | < < < < > | < < < < < < < < < < < < < < < < | < < | < < < < < | > > | < < < < < > < < | < < | < < | < < < < < < < | < < | | < < | | | | < < < < < < < < < < | < < < | < < < < < < < < | 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 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 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 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 |
*/
static Tcl_Obj *
ObjValue(
Link *linkPtr) /* Structure describing linked variable. */
{
char *p;
Tcl_Obj *resultObj, **objv;
int i;
switch (linkPtr->type) {
case TCL_LINK_INT:
if (linkPtr->flags & LINK_ALLOC_LAST) {
memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes);
objv = Tcl_Alloc(linkPtr->numElems * sizeof(Tcl_Obj *));
for (i=0; i < linkPtr->numElems; i++) {
objv[i] = Tcl_NewIntObj(linkPtr->lastValue.iPtr[i]);
}
resultObj = Tcl_NewListObj(linkPtr->numElems, objv);
Tcl_Free(objv);
return resultObj;
}
linkPtr->lastValue.i = LinkedVar(int);
return Tcl_NewIntObj(linkPtr->lastValue.i);
case TCL_LINK_WIDE_INT:
if (linkPtr->flags & LINK_ALLOC_LAST) {
memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes);
objv = Tcl_Alloc(linkPtr->numElems * sizeof(Tcl_Obj *));
for (i=0; i < linkPtr->numElems; i++) {
objv[i] = Tcl_NewWideIntObj(linkPtr->lastValue.wPtr[i]);
}
resultObj = Tcl_NewListObj(linkPtr->numElems, objv);
Tcl_Free(objv);
return resultObj;
}
linkPtr->lastValue.w = LinkedVar(Tcl_WideInt);
return Tcl_NewWideIntObj(linkPtr->lastValue.w);
case TCL_LINK_DOUBLE:
if (linkPtr->flags & LINK_ALLOC_LAST) {
memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes);
objv = Tcl_Alloc(linkPtr->numElems * sizeof(Tcl_Obj *));
for (i=0; i < linkPtr->numElems; i++) {
objv[i] = Tcl_NewDoubleObj(linkPtr->lastValue.dPtr[i]);
}
resultObj = Tcl_NewListObj(linkPtr->numElems, objv);
Tcl_Free(objv);
return resultObj;
}
linkPtr->lastValue.d = LinkedVar(double);
return Tcl_NewDoubleObj(linkPtr->lastValue.d);
case TCL_LINK_BOOLEAN:
if (linkPtr->flags & LINK_ALLOC_LAST) {
memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes);
objv = Tcl_Alloc(linkPtr->numElems * sizeof(Tcl_Obj *));
for (i=0; i < linkPtr->numElems; i++) {
objv[i] = Tcl_NewBooleanObj(linkPtr->lastValue.iPtr[i] != 0);
}
resultObj = Tcl_NewListObj(linkPtr->numElems, objv);
Tcl_Free(objv);
return resultObj;
}
linkPtr->lastValue.i = LinkedVar(int);
return Tcl_NewBooleanObj(linkPtr->lastValue.i);
case TCL_LINK_CHAR:
if (linkPtr->flags & LINK_ALLOC_LAST) {
memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes);
objv = Tcl_Alloc(linkPtr->numElems * sizeof(Tcl_Obj *));
for (i=0; i < linkPtr->numElems; i++) {
objv[i] = Tcl_NewIntObj(linkPtr->lastValue.cPtr[i]);
}
resultObj = Tcl_NewListObj(linkPtr->numElems, objv);
Tcl_Free(objv);
return resultObj;
}
linkPtr->lastValue.c = LinkedVar(char);
return Tcl_NewIntObj(linkPtr->lastValue.c);
case TCL_LINK_UCHAR:
if (linkPtr->flags & LINK_ALLOC_LAST) {
memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes);
objv = Tcl_Alloc(linkPtr->numElems * sizeof(Tcl_Obj *));
for (i=0; i < linkPtr->numElems; i++) {
objv[i] = Tcl_NewIntObj(linkPtr->lastValue.ucPtr[i]);
}
resultObj = Tcl_NewListObj(linkPtr->numElems, objv);
Tcl_Free(objv);
return resultObj;
}
linkPtr->lastValue.uc = LinkedVar(unsigned char);
return Tcl_NewIntObj(linkPtr->lastValue.uc);
case TCL_LINK_SHORT:
if (linkPtr->flags & LINK_ALLOC_LAST) {
memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes);
objv = Tcl_Alloc(linkPtr->numElems * sizeof(Tcl_Obj *));
for (i=0; i < linkPtr->numElems; i++) {
objv[i] = Tcl_NewIntObj(linkPtr->lastValue.sPtr[i]);
}
resultObj = Tcl_NewListObj(linkPtr->numElems, objv);
Tcl_Free(objv);
return resultObj;
}
linkPtr->lastValue.s = LinkedVar(short);
return Tcl_NewIntObj(linkPtr->lastValue.s);
case TCL_LINK_USHORT:
if (linkPtr->flags & LINK_ALLOC_LAST) {
memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes);
objv = Tcl_Alloc(linkPtr->numElems * sizeof(Tcl_Obj *));
for (i=0; i < linkPtr->numElems; i++) {
objv[i] = Tcl_NewIntObj(linkPtr->lastValue.usPtr[i]);
}
resultObj = Tcl_NewListObj(linkPtr->numElems, objv);
Tcl_Free(objv);
return resultObj;
}
linkPtr->lastValue.us = LinkedVar(unsigned short);
return Tcl_NewIntObj(linkPtr->lastValue.us);
case TCL_LINK_UINT:
if (linkPtr->flags & LINK_ALLOC_LAST) {
memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes);
objv = Tcl_Alloc(linkPtr->numElems * sizeof(Tcl_Obj *));
for (i=0; i < linkPtr->numElems; i++) {
objv[i] = Tcl_NewWideIntObj(linkPtr->lastValue.uiPtr[i]);
}
resultObj = Tcl_NewListObj(linkPtr->numElems, objv);
Tcl_Free(objv);
return resultObj;
}
linkPtr->lastValue.ui = LinkedVar(unsigned int);
return Tcl_NewWideIntObj((Tcl_WideInt) linkPtr->lastValue.ui);
#if !defined(TCL_WIDE_INT_IS_LONG) && !defined(_WIN32) && !defined(__CYGWIN__)
case TCL_LINK_LONG:
if (linkPtr->flags & LINK_ALLOC_LAST) {
memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes);
objv = Tcl_Alloc(linkPtr->numElems * sizeof(Tcl_Obj *));
for (i=0; i < linkPtr->numElems; i++) {
objv[i] = Tcl_NewWideIntObj(linkPtr->lastValue.lPtr[i]);
}
resultObj = Tcl_NewListObj(linkPtr->numElems, objv);
Tcl_Free(objv);
return resultObj;
}
linkPtr->lastValue.l = LinkedVar(long);
return Tcl_NewWideIntObj((Tcl_WideInt) linkPtr->lastValue.l);
case TCL_LINK_ULONG:
if (linkPtr->flags & LINK_ALLOC_LAST) {
memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes);
objv = Tcl_Alloc(linkPtr->numElems * sizeof(Tcl_Obj *));
for (i=0; i < linkPtr->numElems; i++) {
objv[i] = Tcl_NewWideIntObj(linkPtr->lastValue.ulPtr[i]);
}
resultObj = Tcl_NewListObj(linkPtr->numElems, objv);
Tcl_Free(objv);
return resultObj;
}
linkPtr->lastValue.ul = LinkedVar(unsigned long);
return Tcl_NewWideIntObj((Tcl_WideInt) linkPtr->lastValue.ul);
#endif
case TCL_LINK_FLOAT:
if (linkPtr->flags & LINK_ALLOC_LAST) {
memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes);
objv = Tcl_Alloc(linkPtr->numElems * sizeof(Tcl_Obj *));
for (i=0; i < linkPtr->numElems; i++) {
objv[i] = Tcl_NewDoubleObj(linkPtr->lastValue.fPtr[i]);
}
resultObj = Tcl_NewListObj(linkPtr->numElems, objv);
Tcl_Free(objv);
return resultObj;
}
linkPtr->lastValue.f = LinkedVar(float);
return Tcl_NewDoubleObj(linkPtr->lastValue.f);
case TCL_LINK_WIDE_UINT:
if (linkPtr->flags & LINK_ALLOC_LAST) {
memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes);
objv = Tcl_Alloc(linkPtr->numElems * sizeof(Tcl_Obj *));
for (i=0; i < linkPtr->numElems; i++) {
objv[i] = Tcl_NewWideIntObj((Tcl_WideInt)
linkPtr->lastValue.uwPtr[i]);
}
resultObj = Tcl_NewListObj(linkPtr->numElems, objv);
Tcl_Free(objv);
return resultObj;
}
linkPtr->lastValue.uw = LinkedVar(Tcl_WideUInt);
return Tcl_NewWideIntObj((Tcl_WideInt) linkPtr->lastValue.uw);
case TCL_LINK_STRING:
p = LinkedVar(char *);
if (p == NULL) {
TclNewLiteralStringObj(resultObj, "NULL");
return resultObj;
}
return Tcl_NewStringObj(p, -1);
case TCL_LINK_CHARS:
if (linkPtr->flags & LINK_ALLOC_LAST) {
memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes);
linkPtr->lastValue.cPtr[linkPtr->bytes-1] = '\0';
/* take care of proper string end */
return Tcl_NewStringObj(linkPtr->lastValue.cPtr, linkPtr->bytes);
}
linkPtr->lastValue.c = '\0';
return Tcl_NewStringObj(&linkPtr->lastValue.c, 1);
case TCL_LINK_BINARY:
if (linkPtr->flags & LINK_ALLOC_LAST) {
memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes);
return Tcl_NewByteArrayObj((unsigned char *) linkPtr->addr,
linkPtr->bytes);
}
linkPtr->lastValue.uc = LinkedVar(unsigned char);
return Tcl_NewByteArrayObj(&linkPtr->lastValue.uc, 1);
/*
* This code only gets executed if the link type is unknown (shouldn't
* ever happen).
*/
default:
TclNewLiteralStringObj(resultObj, "??");
return resultObj;
}
}
/*
*----------------------------------------------------------------------
*
* LinkFree --
*
* Free's allocated space of given link and link structure.
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static void
LinkFree(
Link *linkPtr) /* Structure describing linked variable. */
{
if (linkPtr->nsPtr) {
TclNsDecrRefCount(linkPtr->nsPtr);
}
if (linkPtr->flags & LINK_ALLOC_ADDR) {
Tcl_Free(linkPtr->addr);
}
if (linkPtr->flags & LINK_ALLOC_LAST) {
Tcl_Free(linkPtr->lastValue.aryPtr);
}
Tcl_Free(linkPtr);
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to generic/tclListObj.c.
| ︙ | ︙ | |||
1088 1089 1090 1091 1092 1093 1094 | * both. Allocate a new struct and insert elements into it. */ List *oldListRepPtr = listRepPtr; Tcl_Obj **oldPtrs = elemPtrs; int newMax; | | | 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 |
* both. Allocate a new struct and insert elements into it.
*/
List *oldListRepPtr = listRepPtr;
Tcl_Obj **oldPtrs = elemPtrs;
int newMax;
if (needGrow) {
newMax = 2 * numRequired;
} else {
newMax = listRepPtr->maxElemCount;
}
listRepPtr = AttemptNewList(NULL, newMax, NULL);
if (listRepPtr == NULL) {
|
| ︙ | ︙ |
Changes to generic/tclNamesp.c.
| ︙ | ︙ | |||
1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 |
*/
nsPtr->flags &= ~(NS_DYING|NS_KILLED);
}
}
TclNsDecrRefCount(nsPtr);
}
/*
*----------------------------------------------------------------------
*
* TclTeardownNamespace --
*
* Used internally to dismantle and unlink a namespace when it is
| > > > > > > > | 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 |
*/
nsPtr->flags &= ~(NS_DYING|NS_KILLED);
}
}
TclNsDecrRefCount(nsPtr);
}
int
TclNamespaceDeleted(
Namespace *nsPtr)
{
return (nsPtr->flags & NS_DYING) ? 1 : 0;
}
/*
*----------------------------------------------------------------------
*
* TclTeardownNamespace --
*
* Used internally to dismantle and unlink a namespace when it is
|
| ︙ | ︙ |
Changes to generic/tclOO.c.
| ︙ | ︙ | |||
342 343 344 345 346 347 348 |
Tcl_SetNamespaceUnknownHandler(interp, fPtr->objdefNs, namePtr);
/*
* Create the subcommands in the oo::define and oo::objdefine spaces.
*/
Tcl_DStringInit(&buffer);
| | | | | | | 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 |
Tcl_SetNamespaceUnknownHandler(interp, fPtr->objdefNs, namePtr);
/*
* Create the subcommands in the oo::define and oo::objdefine spaces.
*/
Tcl_DStringInit(&buffer);
for (i = 0 ; defineCmds[i].name ; i++) {
TclDStringAppendLiteral(&buffer, "::oo::define::");
Tcl_DStringAppend(&buffer, defineCmds[i].name, -1);
Tcl_CreateObjCommand(interp, Tcl_DStringValue(&buffer),
defineCmds[i].objProc, INT2PTR(defineCmds[i].flag), NULL);
Tcl_DStringFree(&buffer);
}
for (i = 0 ; objdefCmds[i].name ; i++) {
TclDStringAppendLiteral(&buffer, "::oo::objdefine::");
Tcl_DStringAppend(&buffer, objdefCmds[i].name, -1);
Tcl_CreateObjCommand(interp, Tcl_DStringValue(&buffer),
objdefCmds[i].objProc, INT2PTR(objdefCmds[i].flag), NULL);
Tcl_DStringFree(&buffer);
}
Tcl_CallWhenDeleted(interp, KillFoundation, NULL);
/*
* Create the special objects at the core of the object system.
*/
InitClassSystemRoots(interp, fPtr);
/*
* Basic method declarations for the core classes.
*/
for (i = 0 ; objMethods[i].name ; i++) {
TclOONewBasicMethod(interp, fPtr->objectCls, &objMethods[i]);
}
for (i = 0 ; clsMethods[i].name ; i++) {
TclOONewBasicMethod(interp, fPtr->classCls, &clsMethods[i]);
}
/*
* Finish setting up the class of classes by marking the 'new' method as
* private; classes, unlike general objects, must have explicit names. We
* also need to create the constructor for classes.
*/
TclNewLiteralStringObj(namePtr, "new");
Tcl_NewInstanceMethod(interp, (Tcl_Object) fPtr->classCls->thisPtr,
namePtr /* keeps ref */, 0 /* private */, NULL, NULL);
fPtr->classCls->constructorPtr = (Method *) Tcl_NewMethod(interp,
(Tcl_Class) fPtr->classCls, NULL, 0, &classConstructor, NULL);
/*
* Create non-object commands and plug ourselves into the Tcl [info]
* ensemble.
*/
|
| ︙ | ︙ | |||
663 664 665 666 667 668 669 |
* have to get rid of the error message from Tcl_CreateNamespace,
* since that's something that should not be exposed to the user.
*/
Tcl_ResetResult(interp);
}
| < < | | 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 |
* have to get rid of the error message from Tcl_CreateNamespace,
* since that's something that should not be exposed to the user.
*/
Tcl_ResetResult(interp);
}
configNamespace:
((Namespace *) oPtr->namespacePtr)->refCount++;
/*
* Make the namespace know about the helper commands. This grants access
* to the [self] and [next] commands.
*/
if (fPtr->helpersNs != NULL) {
|
| ︙ | ︙ | |||
870 871 872 873 874 875 876 |
/*
* Squelch classes that this class has been mixed into.
*/
if (clsPtr->mixinSubs.num > 0) {
while (clsPtr->mixinSubs.num > 0) {
| > | > > | > | | > | 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 |
/*
* Squelch classes that this class has been mixed into.
*/
if (clsPtr->mixinSubs.num > 0) {
while (clsPtr->mixinSubs.num > 0) {
mixinSubclassPtr =
clsPtr->mixinSubs.list[clsPtr->mixinSubs.num - 1];
/*
* This condition also covers the case where mixinSubclassPtr ==
* clsPtr
*/
if (!Deleted(mixinSubclassPtr->thisPtr)
&& !(mixinSubclassPtr->thisPtr->flags & DONT_DELETE)) {
Tcl_DeleteCommandFromToken(interp,
mixinSubclassPtr->thisPtr->command);
}
TclOORemoveFromMixinSubs(mixinSubclassPtr, clsPtr);
}
}
if (clsPtr->mixinSubs.size > 0) {
Tcl_Free(clsPtr->mixinSubs.list);
clsPtr->mixinSubs.size = 0;
}
/*
* Squelch subclasses of this class.
*/
if (clsPtr->subclasses.num > 0) {
while (clsPtr->subclasses.num > 0) {
subclassPtr = clsPtr->subclasses.list[clsPtr->subclasses.num - 1];
if (!Deleted(subclassPtr->thisPtr) && !IsRoot(subclassPtr)
&& !(subclassPtr->thisPtr->flags & DONT_DELETE)) {
Tcl_DeleteCommandFromToken(interp,
subclassPtr->thisPtr->command);
}
TclOORemoveFromSubclasses(subclassPtr, clsPtr);
}
}
if (clsPtr->subclasses.size > 0) {
Tcl_Free(clsPtr->subclasses.list);
clsPtr->subclasses.list = NULL;
clsPtr->subclasses.size = 0;
}
/*
* Squelch instances of this class (includes objects we're mixed into).
*/
if (clsPtr->instances.num > 0) {
while (clsPtr->instances.num > 0) {
instancePtr = clsPtr->instances.list[clsPtr->instances.num - 1];
/*
* This condition also covers the case where instancePtr == oPtr
*/
if (!Deleted(instancePtr) && !IsRoot(instancePtr) &&
!(instancePtr->flags & DONT_DELETE)) {
Tcl_DeleteCommandFromToken(interp, instancePtr->command);
|
| ︙ | ︙ | |||
1115 1116 1117 1118 1119 1120 1121 |
Tcl_Obj *filterObj, *variableObj;
PrivateVariableMapping *privateVariable;
Tcl_Interp *interp = oPtr->fPtr->interp;
int i;
if (Deleted(oPtr)) {
/*
| | | > | > > < > | | | | | 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 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 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 |
Tcl_Obj *filterObj, *variableObj;
PrivateVariableMapping *privateVariable;
Tcl_Interp *interp = oPtr->fPtr->interp;
int i;
if (Deleted(oPtr)) {
/*
* TODO: Can ObjectNamespaceDeleted ever be called twice? If not,
* this guard could be removed.
*/
return;
}
/*
* One rule for the teardown routines is that if an object is in the
* process of being deleted, nothing else may modify its bookeeping
* records. This is the flag that
*/
oPtr->flags |= OBJECT_DELETED;
/*
* Let the dominoes fall!
*/
if (oPtr->classPtr) {
TclOODeleteDescendants(interp, oPtr);
}
/*
* We do not run destructors on the core class objects when the
* interpreter is being deleted; their incestuous nature causes problems
* in that case when the destructor is partially deleted before the uses
* of it have gone. [Bug 2949397]
*/
if (!Tcl_InterpDeleted(interp) && !(oPtr->flags & DESTRUCTOR_CALLED)) {
CallContext *contextPtr =
TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL, NULL, NULL);
int result;
Tcl_InterpState state;
oPtr->flags |= DESTRUCTOR_CALLED;
if (contextPtr != NULL) {
contextPtr->callPtr->flags |= DESTRUCTOR;
contextPtr->skip = 0;
state = Tcl_SaveInterpState(interp, TCL_OK);
result = Tcl_NRCallObjProc(interp, TclOOInvokeContext,
contextPtr, 0, NULL);
if (result != TCL_OK) {
Tcl_BackgroundException(interp, result);
}
Tcl_RestoreInterpState(interp, state);
TclOODeleteContext(contextPtr);
}
}
/*
* Instruct everyone to no longer use any allocated fields of the object.
* Also delete the command that refers to the object at this point (if it
* still exists) because otherwise its pointer to the object points into
* freed memory.
*/
if (((Command *) oPtr->command)->flags && CMD_IS_DELETED) {
/*
* Something has already started the command deletion process. We can
* go ahead and clean up the the namespace,
*/
} else {
/*
* The namespace must have been deleted directly. Delete the command
|
| ︙ | ︙ | |||
1197 1198 1199 1200 1201 1202 1203 |
}
/*
* Splice the object out of its context. After this, we must *not* call
* methods on the object.
*/
| < | < < | 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 |
}
/*
* Splice the object out of its context. After this, we must *not* call
* methods on the object.
*/
/* TODO: Should this be protected with a !IsRoot() condition? */
TclOORemoveFromInstances(oPtr, oPtr->selfCls);
if (oPtr->mixins.num > 0) {
FOREACH(mixinPtr, oPtr->mixins) {
TclOORemoveFromInstances(oPtr, mixinPtr);
TclOODecrRefCount(mixinPtr->thisPtr);
}
|
| ︙ | ︙ | |||
1761 1762 1763 1764 1765 1766 1767 |
*/
TclNRAddCallback(interp, FinalizeAlloc, contextPtr, oPtr, state,
objectPtr);
TclPushTailcallPoint(interp);
return TclOOInvokeContext(contextPtr, interp, objc, objv);
}
| < < | | < < < < < < < | 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 |
*/
TclNRAddCallback(interp, FinalizeAlloc, contextPtr, oPtr, state,
objectPtr);
TclPushTailcallPoint(interp);
return TclOOInvokeContext(contextPtr, interp, objc, objv);
}
Object *
TclNewObjectInstanceCommon(
Tcl_Interp *interp,
Class *classPtr,
const char *nameStr,
const char *nsNameStr)
{
Tcl_HashEntry *hPtr;
Foundation *fPtr = GetFoundation(interp);
Object *oPtr;
const char *simpleName = NULL;
Namespace *nsPtr = NULL, *dummy;
Namespace *inNsPtr = (Namespace *) TclGetCurrentNamespace(interp);
if (nameStr) {
TclGetNamespaceForQualName(interp, nameStr, inNsPtr,
TCL_CREATE_NS_IF_UNKNOWN, &nsPtr, &dummy, &dummy, &simpleName);
/*
* Disallow creation of an object over an existing command.
*/
hPtr = Tcl_FindHashEntry(&nsPtr->cmdTable, simpleName);
if (hPtr) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't create object \"%s\": command already exists with"
" that name", nameStr));
Tcl_SetErrorCode(interp, "TCL", "OO", "OVERWRITE_OBJECT", NULL);
return NULL;
}
}
/*
* Create the object.
*/
oPtr = AllocObject(interp, simpleName, nsPtr, nsNameStr);
|
| ︙ | ︙ | |||
1833 1834 1835 1836 1837 1838 1839 |
TclOOAddToSubclasses(oPtr->classPtr, fPtr->objectCls);
} else {
oPtr->classPtr = NULL;
}
return oPtr;
}
| < < | 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 |
TclOOAddToSubclasses(oPtr->classPtr, fPtr->objectCls);
} else {
oPtr->classPtr = NULL;
}
return oPtr;
}
static int
FinalizeAlloc(
ClientData data[],
Tcl_Interp *interp,
int result)
{
CallContext *contextPtr = data[0];
|
| ︙ | ︙ | |||
1970 1971 1972 1973 1974 1975 1976 |
Tcl_Free(o2Ptr->mixins.list);
}
DUPLICATE(o2Ptr->mixins, oPtr->mixins, Class *);
FOREACH(mixinPtr, o2Ptr->mixins) {
if (mixinPtr && mixinPtr != o2Ptr->selfCls) {
TclOOAddToInstances(o2Ptr, mixinPtr);
}
| > > | > > | 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 |
Tcl_Free(o2Ptr->mixins.list);
}
DUPLICATE(o2Ptr->mixins, oPtr->mixins, Class *);
FOREACH(mixinPtr, o2Ptr->mixins) {
if (mixinPtr && mixinPtr != o2Ptr->selfCls) {
TclOOAddToInstances(o2Ptr, mixinPtr);
}
/*
* For the reference just created in DUPLICATE.
*/
AddRef(mixinPtr->thisPtr);
}
/*
* Copy the object's filter list to the new object.
*/
|
| ︙ | ︙ | |||
2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 |
* kept object-local. The duplicate is never deleted at this point, nor is
* it the root of the object system or in the midst of processing a filter
* call.
*/
o2Ptr->flags = oPtr->flags & ~(
OBJECT_DELETED | ROOT_OBJECT | ROOT_CLASS | FILTER_HANDLING);
/*
* Copy the object's metadata.
*/
if (oPtr->metadataPtr != NULL) {
Tcl_ObjectMetadataType *metadataTypePtr;
ClientData value, duplicate;
| > | 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 |
* kept object-local. The duplicate is never deleted at this point, nor is
* it the root of the object system or in the midst of processing a filter
* call.
*/
o2Ptr->flags = oPtr->flags & ~(
OBJECT_DELETED | ROOT_OBJECT | ROOT_CLASS | FILTER_HANDLING);
/*
* Copy the object's metadata.
*/
if (oPtr->metadataPtr != NULL) {
Tcl_ObjectMetadataType *metadataTypePtr;
ClientData value, duplicate;
|
| ︙ | ︙ | |||
2071 2072 2073 2074 2075 2076 2077 |
}
memcpy(cls2Ptr->superclasses.list, clsPtr->superclasses.list,
sizeof(Class *) * clsPtr->superclasses.num);
cls2Ptr->superclasses.num = clsPtr->superclasses.num;
FOREACH(superPtr, cls2Ptr->superclasses) {
TclOOAddToSubclasses(cls2Ptr, superPtr);
| > | | > | 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 |
}
memcpy(cls2Ptr->superclasses.list, clsPtr->superclasses.list,
sizeof(Class *) * clsPtr->superclasses.num);
cls2Ptr->superclasses.num = clsPtr->superclasses.num;
FOREACH(superPtr, cls2Ptr->superclasses) {
TclOOAddToSubclasses(cls2Ptr, superPtr);
/*
* For the new item in cls2Ptr->superclasses that memcpy just
* created.
*/
AddRef(superPtr->thisPtr);
}
/*
* Duplicate the source class's filters.
*/
|
| ︙ | ︙ | |||
2117 2118 2119 2120 2121 2122 2123 |
TclOODecrRefCount(mixinPtr->thisPtr);
}
Tcl_Free(clsPtr->mixins.list);
}
DUPLICATE(cls2Ptr->mixins, clsPtr->mixins, Class *);
FOREACH(mixinPtr, cls2Ptr->mixins) {
TclOOAddToMixinSubs(cls2Ptr, mixinPtr);
| > > | > > | 2116 2117 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 |
TclOODecrRefCount(mixinPtr->thisPtr);
}
Tcl_Free(clsPtr->mixins.list);
}
DUPLICATE(cls2Ptr->mixins, clsPtr->mixins, Class *);
FOREACH(mixinPtr, cls2Ptr->mixins) {
TclOOAddToMixinSubs(cls2Ptr, mixinPtr);
/*
* For the copy just created in DUPLICATE.
*/
AddRef(mixinPtr->thisPtr);
}
/*
* Duplicate the source class's methods, constructor and destructor.
*/
|
| ︙ | ︙ | |||
2779 2780 2781 2782 2783 2784 2785 |
int skip)
{
CallContext *contextPtr = (CallContext *) context;
int savedIndex = contextPtr->index;
int savedSkip = contextPtr->skip;
int result;
| | | 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 |
int skip)
{
CallContext *contextPtr = (CallContext *) context;
int savedIndex = contextPtr->index;
int savedSkip = contextPtr->skip;
int result;
if (contextPtr->index + 1 >= contextPtr->callPtr->numChain) {
/*
* We're at the end of the chain; generate an error message unless the
* interpreter is being torn down, in which case we might be getting
* here because of methods/destructors doing a [next] (or equivalent)
* unexpectedly.
*/
|
| ︙ | ︙ | |||
2848 2849 2850 2851 2852 2853 2854 |
Tcl_ObjectContext context,
int objc,
Tcl_Obj *const *objv,
int skip)
{
register CallContext *contextPtr = (CallContext *) context;
| | | 2851 2852 2853 2854 2855 2856 2857 2858 2859 2860 2861 2862 2863 2864 2865 |
Tcl_ObjectContext context,
int objc,
Tcl_Obj *const *objv,
int skip)
{
register CallContext *contextPtr = (CallContext *) context;
if (contextPtr->index + 1 >= contextPtr->callPtr->numChain) {
/*
* We're at the end of the chain; generate an error message unless the
* interpreter is being torn down, in which case we might be getting
* here because of methods/destructors doing a [next] (or equivalent)
* unexpectedly.
*/
|
| ︙ | ︙ |
Changes to generic/tclOOCall.c.
| ︙ | ︙ | |||
324 325 326 327 328 329 330 |
* entries in the chain so that they do not get deleted out from under our
* feet.
*/
if (contextPtr->index == 0) {
int i;
| | | 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 |
* entries in the chain so that they do not get deleted out from under our
* feet.
*/
if (contextPtr->index == 0) {
int i;
for (i = 0 ; i < contextPtr->callPtr->numChain ; i++) {
AddRef(contextPtr->callPtr->chain[i].mPtr);
}
/*
* Ensure that the method name itself is part of the arguments when
* we're doing unknown processing.
*/
|
| ︙ | ︙ | |||
402 403 404 405 406 407 408 |
ClientData data[],
Tcl_Interp *interp,
int result)
{
CallContext *contextPtr = data[0];
int i;
| | | 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 |
ClientData data[],
Tcl_Interp *interp,
int result)
{
CallContext *contextPtr = data[0];
int i;
for (i = 0 ; i < contextPtr->callPtr->numChain ; i++) {
TclOODelMethodRef(contextPtr->callPtr->chain[i].mPtr);
}
return result;
}
/*
* ----------------------------------------------------------------------
|
| ︙ | ︙ | |||
637 638 639 640 641 642 643 |
} else {
Tcl_Free((void *)strings);
*stringsPtr = NULL;
}
return i;
}
| > | > > | 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 |
} else {
Tcl_Free((void *)strings);
*stringsPtr = NULL;
}
return i;
}
/*
* Comparator for SortMethodNames
*/
static int
CmpStr(
const void *ptr1,
const void *ptr2)
{
const char **strPtr1 = (const char **) ptr1;
const char **strPtr2 = (const char **) ptr2;
|
| ︙ | ︙ | |||
1000 1001 1002 1003 1004 1005 1006 |
}
/*
* First test whether the method is already in the call chain. Skip over
* any leading filters.
*/
| | | | | 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 |
}
/*
* First test whether the method is already in the call chain. Skip over
* any leading filters.
*/
for (i = cbPtr->filterLength ; i < callPtr->numChain ; i++) {
if (callPtr->chain[i].mPtr == mPtr &&
callPtr->chain[i].isFilter == (doneFilters != NULL)) {
/*
* Call chain semantics states that methods come as *late* in the
* call chain as possible. This is done by copying down the
* following methods. Note that this does not change the number of
* method invocations in the call chain; it just rearranges them.
*/
Class *declCls = callPtr->chain[i].filterDeclarer;
for (; i + 1 < callPtr->numChain ; i++) {
callPtr->chain[i] = callPtr->chain[i + 1];
}
callPtr->chain[i].mPtr = mPtr;
callPtr->chain[i].isFilter = (doneFilters != NULL);
callPtr->chain[i].filterDeclarer = declCls;
return;
}
}
|
| ︙ | ︙ | |||
1813 1814 1815 1816 1817 1818 1819 |
* special because it's a filter method). The second word is the name of
* the method in question (which differs for "unknown" and "filter" types)
* and the third word is the full name of the class that declares the
* method (or "object" if it is declared on the instance).
*/
objv = TclStackAlloc(interp, callPtr->numChain * sizeof(Tcl_Obj *));
| | | 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 |
* special because it's a filter method). The second word is the name of
* the method in question (which differs for "unknown" and "filter" types)
* and the third word is the full name of the class that declares the
* method (or "object" if it is declared on the instance).
*/
objv = TclStackAlloc(interp, callPtr->numChain * sizeof(Tcl_Obj *));
for (i = 0 ; i < callPtr->numChain ; i++) {
struct MInvoke *miPtr = &callPtr->chain[i];
descObjs[0] =
miPtr->isFilter ? filterLiteral :
callPtr->flags & OO_UNKNOWN_METHOD ? fPtr->unknownMethodNameObj :
IS_PRIVATE(miPtr->mPtr) ? privateLiteral :
methodLiteral;
|
| ︙ | ︙ |
Changes to generic/tclOODefineCmds.c.
| ︙ | ︙ | |||
45 46 47 48 49 50 51 52 53 54 55 56 57 58 |
{TCL_OO_METHOD_VERSION_CURRENT, "core method: " name " Getter", \
getter, NULL, NULL}, \
{TCL_OO_METHOD_VERSION_CURRENT, "core method: " name " Setter", \
setter, NULL, NULL}, \
{TCL_OO_METHOD_VERSION_CURRENT, "core method: " name " Resolver", \
resolver, NULL, NULL}}
/*
* Forward declarations.
*/
static inline void BumpGlobalEpoch(Tcl_Interp *interp, Class *classPtr);
static Tcl_Command FindCommand(Tcl_Interp *interp, Tcl_Obj *stringObj,
Tcl_Namespace *const namespacePtr);
| > > > > > > | 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 |
{TCL_OO_METHOD_VERSION_CURRENT, "core method: " name " Getter", \
getter, NULL, NULL}, \
{TCL_OO_METHOD_VERSION_CURRENT, "core method: " name " Setter", \
setter, NULL, NULL}, \
{TCL_OO_METHOD_VERSION_CURRENT, "core method: " name " Resolver", \
resolver, NULL, NULL}}
/*
* A [string match] pattern used to determine if a method should be exported.
*/
#define PUBLIC_PATTERN "[a-z]*"
/*
* Forward declarations.
*/
static inline void BumpGlobalEpoch(Tcl_Interp *interp, Class *classPtr);
static Tcl_Command FindCommand(Tcl_Interp *interp, Tcl_Obj *stringObj,
Tcl_Namespace *const namespacePtr);
|
| ︙ | ︙ | |||
274 275 276 277 278 279 280 |
int size = sizeof(Tcl_Obj *) * numFilters; /* should be size_t */
if (oPtr->filters.num == 0) {
filtersList = Tcl_Alloc(size);
} else {
filtersList = Tcl_Realloc(oPtr->filters.list, size);
}
| | | 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 |
int size = sizeof(Tcl_Obj *) * numFilters; /* should be size_t */
if (oPtr->filters.num == 0) {
filtersList = Tcl_Alloc(size);
} else {
filtersList = Tcl_Realloc(oPtr->filters.list, size);
}
for (i = 0 ; i < numFilters ; i++) {
filtersList[i] = filters[i];
Tcl_IncrRefCount(filters[i]);
}
oPtr->filters.list = filtersList;
oPtr->filters.num = numFilters;
oPtr->flags &= ~USE_CLASS_CACHE;
}
|
| ︙ | ︙ | |||
333 334 335 336 337 338 339 |
int size = sizeof(Tcl_Obj *) * numFilters; /* should be size_t */
if (classPtr->filters.num == 0) {
filtersList = Tcl_Alloc(size);
} else {
filtersList = Tcl_Realloc(classPtr->filters.list, size);
}
| | | 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 |
int size = sizeof(Tcl_Obj *) * numFilters; /* should be size_t */
if (classPtr->filters.num == 0) {
filtersList = Tcl_Alloc(size);
} else {
filtersList = Tcl_Realloc(classPtr->filters.list, size);
}
for (i = 0 ; i < numFilters ; i++) {
filtersList[i] = filters[i];
Tcl_IncrRefCount(filters[i]);
}
classPtr->filters.list = filtersList;
classPtr->filters.num = numFilters;
}
|
| ︙ | ︙ | |||
396 397 398 399 400 401 402 |
oPtr->flags &= ~USE_CLASS_CACHE;
}
oPtr->mixins.num = numMixins;
memcpy(oPtr->mixins.list, mixins, sizeof(Class *) * numMixins);
FOREACH(mixinPtr, oPtr->mixins) {
if (mixinPtr != oPtr->selfCls) {
TclOOAddToInstances(oPtr, mixinPtr);
| > > | > > | 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 |
oPtr->flags &= ~USE_CLASS_CACHE;
}
oPtr->mixins.num = numMixins;
memcpy(oPtr->mixins.list, mixins, sizeof(Class *) * numMixins);
FOREACH(mixinPtr, oPtr->mixins) {
if (mixinPtr != oPtr->selfCls) {
TclOOAddToInstances(oPtr, mixinPtr);
/*
* For the new copy created by memcpy().
*/
AddRef(mixinPtr->thisPtr);
}
}
}
oPtr->epoch++;
}
|
| ︙ | ︙ | |||
448 449 450 451 452 453 454 |
} else {
classPtr->mixins.list = Tcl_Alloc(sizeof(Class *) * numMixins);
}
classPtr->mixins.num = numMixins;
memcpy(classPtr->mixins.list, mixins, sizeof(Class *) * numMixins);
FOREACH(mixinPtr, classPtr->mixins) {
TclOOAddToMixinSubs(classPtr, mixinPtr);
| > > | > > | 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 |
} else {
classPtr->mixins.list = Tcl_Alloc(sizeof(Class *) * numMixins);
}
classPtr->mixins.num = numMixins;
memcpy(classPtr->mixins.list, mixins, sizeof(Class *) * numMixins);
FOREACH(mixinPtr, classPtr->mixins) {
TclOOAddToMixinSubs(classPtr, mixinPtr);
/*
* For the new copy created by memcpy.
*/
AddRef(mixinPtr->thisPtr);
}
}
BumpGlobalEpoch(interp, classPtr);
}
/*
|
| ︙ | ︙ | |||
720 721 722 723 724 725 726 |
}
if (matchedStr != NULL) {
/*
* Got one match, and only one match!
*/
| | > | | | 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 |
}
if (matchedStr != NULL) {
/*
* Got one match, and only one match!
*/
Tcl_Obj **newObjv =
TclStackAlloc(interp, sizeof(Tcl_Obj*) * (objc - 1));
int result;
newObjv[0] = Tcl_NewStringObj(matchedStr, -1);
Tcl_IncrRefCount(newObjv[0]);
if (objc > 2) {
memcpy(newObjv + 1, objv + 2, sizeof(Tcl_Obj *) * (objc - 2));
}
result = Tcl_EvalObjv(interp, objc - 1, newObjv, 0);
Tcl_DecrRefCount(newObjv[0]);
TclStackFree(interp, newObjv);
return result;
}
noMatch:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
|
| ︙ | ︙ | |||
1035 1036 1037 1038 1039 1040 1041 |
* comments above for why these contortions are necessary.
*/
objPtr = Tcl_NewObj();
obj2Ptr = Tcl_NewObj();
cmd = FindCommand(interp, objv[cmdIndex], nsPtr);
if (cmd == NULL) {
| > | > > | | | 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 |
* comments above for why these contortions are necessary.
*/
objPtr = Tcl_NewObj();
obj2Ptr = Tcl_NewObj();
cmd = FindCommand(interp, objv[cmdIndex], nsPtr);
if (cmd == NULL) {
/*
* Punt this case!
*/
Tcl_AppendObjToObj(obj2Ptr, objv[cmdIndex]);
} else {
Tcl_GetCommandFullName(interp, cmd, obj2Ptr);
}
Tcl_ListObjAppendElement(NULL, objPtr, obj2Ptr);
/* TODO: overflow? */
Tcl_ListObjReplace(NULL, objPtr, 1, 0, objc - offset, objv + offset);
Tcl_ListObjGetElements(NULL, objPtr, &dummy, &objs);
result = Tcl_EvalObjv(interp, objc - cmdIndex, objs, TCL_EVAL_INVOKE);
if (isRoot) {
TclResetRewriteEnsemble(interp, 1);
}
Tcl_DecrRefCount(objPtr);
return result;
}
|
| ︙ | ︙ | |||
1681 1682 1683 1684 1685 1686 1687 |
if (!isInstanceDeleteMethod && !oPtr->classPtr) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"attempt to misuse API", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
return TCL_ERROR;
}
| | | 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 |
if (!isInstanceDeleteMethod && !oPtr->classPtr) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"attempt to misuse API", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
return TCL_ERROR;
}
for (i = 1; i < objc; i++) {
/*
* Delete the method structure from the appropriate hash table.
*/
if (RenameDeleteMethod(interp, oPtr, !isInstanceDeleteMethod,
objv[i], NULL) != TCL_OK) {
return TCL_ERROR;
|
| ︙ | ︙ | |||
1807 1808 1809 1810 1811 1812 1813 |
if (!isInstanceExport && !clsPtr) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"attempt to misuse API", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
return TCL_ERROR;
}
| | | 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 |
if (!isInstanceExport && !clsPtr) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"attempt to misuse API", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
return TCL_ERROR;
}
for (i = 1; i < objc; i++) {
/*
* Exporting is done by adding the PUBLIC_METHOD flag to the method
* record. If there is no such method in this object or class (i.e.
* the method comes from something inherited from or that we're an
* instance of) then we put in a blank record with that flag; such
* records are skipped over by the call chain engine *except* for
* their flags member.
|
| ︙ | ︙ | |||
1900 1901 1902 1903 1904 1905 1906 |
}
if (!isInstanceForward && !oPtr->classPtr) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"attempt to misuse API", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
return TCL_ERROR;
}
| | | | 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 |
}
if (!isInstanceForward && !oPtr->classPtr) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"attempt to misuse API", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
return TCL_ERROR;
}
isPublic = Tcl_StringMatch(TclGetString(objv[1]), PUBLIC_PATTERN)
? PUBLIC_METHOD : 0;
if (IsPrivateDefine(interp)) {
isPublic = TRUE_PRIVATE_METHOD;
}
/*
* Create the method structure.
*/
prefixObj = Tcl_NewListObj(objc - 2, objv + 2);
if (isInstanceForward) {
mPtr = TclOONewForwardInstanceMethod(interp, oPtr, isPublic, objv[1],
prefixObj);
} else {
mPtr = TclOONewForwardMethod(interp, oPtr->classPtr, isPublic,
objv[1], prefixObj);
}
|
| ︙ | ︙ | |||
1998 1999 2000 2001 2002 2003 2004 |
isPublic = 0;
break;
}
} else {
if (IsPrivateDefine(interp)) {
isPublic = TRUE_PRIVATE_METHOD;
} else {
| | | 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 |
isPublic = 0;
break;
}
} else {
if (IsPrivateDefine(interp)) {
isPublic = TRUE_PRIVATE_METHOD;
} else {
isPublic = Tcl_StringMatch(TclGetString(objv[1]), PUBLIC_PATTERN)
? PUBLIC_METHOD : 0;
}
}
/*
* Create the method by using the right back-end API.
*/
|
| ︙ | ︙ | |||
2120 2121 2122 2123 2124 2125 2126 |
if (!isInstanceUnexport && !clsPtr) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"attempt to misuse API", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
return TCL_ERROR;
}
| | | 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 |
if (!isInstanceUnexport && !clsPtr) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"attempt to misuse API", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
return TCL_ERROR;
}
for (i = 1; i < objc; i++) {
/*
* Unexporting is done by removing the PUBLIC_METHOD flag from the
* method record. If there is no such method in this object or class
* (i.e. the method comes from something inherited from or that we're
* an instance of) then we put in a blank record without that flag;
* such records are skipped over by the call chain engine *except* for
* their flags member.
|
| ︙ | ︙ | |||
2336 2337 2338 2339 2340 2341 2342 |
int objc,
Tcl_Obj *const *objv)
{
Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
int filterc;
Tcl_Obj **filterv;
| | | 2354 2355 2356 2357 2358 2359 2360 2361 2362 2363 2364 2365 2366 2367 2368 |
int objc,
Tcl_Obj *const *objv)
{
Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
int filterc;
Tcl_Obj **filterv;
if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
"filterList");
return TCL_ERROR;
}
objv += Tcl_ObjectContextSkippedArgs(context);
if (oPtr == NULL) {
|
| ︙ | ︙ | |||
2420 2421 2422 2423 2424 2425 2426 |
Tcl_Obj *const *objv)
{
Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
int mixinc, i;
Tcl_Obj **mixinv;
Class **mixins;
| | | | 2438 2439 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 2470 2471 2472 2473 |
Tcl_Obj *const *objv)
{
Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
int mixinc, i;
Tcl_Obj **mixinv;
Class **mixins;
if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
"mixinList");
return TCL_ERROR;
}
objv += Tcl_ObjectContextSkippedArgs(context);
if (oPtr == NULL) {
return TCL_ERROR;
} else if (!oPtr->classPtr) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"attempt to misuse API", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
return TCL_ERROR;
} else if (Tcl_ListObjGetElements(interp, objv[0], &mixinc,
&mixinv) != TCL_OK) {
return TCL_ERROR;
}
mixins = TclStackAlloc(interp, sizeof(Class *) * mixinc);
for (i = 0; i < mixinc; i++) {
mixins[i] = GetClassInOuterContext(interp, mixinv[i],
"may only mix in classes");
if (mixins[i] == NULL) {
i--;
goto freeAndError;
}
if (TclOOIsReachable(oPtr->classPtr, mixins[i])) {
|
| ︙ | ︙ | |||
2525 2526 2527 2528 2529 2530 2531 |
Tcl_Obj *const *objv)
{
Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
int superc, i, j;
Tcl_Obj **superv;
Class **superclasses, *superPtr;
| | | 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 |
Tcl_Obj *const *objv)
{
Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
int superc, i, j;
Tcl_Obj **superv;
Class **superclasses, *superPtr;
if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
"superclassList");
return TCL_ERROR;
}
objv += Tcl_ObjectContextSkippedArgs(context);
if (oPtr == NULL) {
|
| ︙ | ︙ | |||
2572 2573 2574 2575 2576 2577 2578 |
superclasses[0] = oPtr->fPtr->classCls;
} else {
superclasses[0] = oPtr->fPtr->objectCls;
}
superc = 1;
AddRef(superclasses[0]->thisPtr);
} else {
| | | | 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 |
superclasses[0] = oPtr->fPtr->classCls;
} else {
superclasses[0] = oPtr->fPtr->objectCls;
}
superc = 1;
AddRef(superclasses[0]->thisPtr);
} else {
for (i = 0; i < superc; i++) {
superclasses[i] = GetClassInOuterContext(interp, superv[i],
"only a class can be a superclass");
if (superclasses[i] == NULL) {
i--;
goto failedAfterAlloc;
}
for (j = 0; j < i; j++) {
if (superclasses[j] == superclasses[i]) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"class should only be a direct superclass once",
-1));
Tcl_SetErrorCode(interp, "TCL", "OO", "REPETITIOUS",NULL);
goto failedAfterAlloc;
}
|
| ︙ | ︙ | |||
2701 2702 2703 2704 2705 2706 2707 |
Tcl_Obj *const *objv)
{
Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
int varc;
Tcl_Obj **varv;
int i;
| | | | 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 |
Tcl_Obj *const *objv)
{
Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
int varc;
Tcl_Obj **varv;
int i;
if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
"filterList");
return TCL_ERROR;
}
objv += Tcl_ObjectContextSkippedArgs(context);
if (oPtr == NULL) {
return TCL_ERROR;
} else if (!oPtr->classPtr) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"attempt to misuse API", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
return TCL_ERROR;
} else if (Tcl_ListObjGetElements(interp, objv[0], &varc,
&varv) != TCL_OK) {
return TCL_ERROR;
}
for (i = 0; i < varc; i++) {
const char *varName = TclGetString(varv[i]);
if (strstr(varName, "::") != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"invalid declared variable name \"%s\": must not %s",
varName, "contain namespace separators"));
Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_DECLVAR", NULL);
|
| ︙ | ︙ | |||
2799 2800 2801 2802 2803 2804 2805 |
int objc,
Tcl_Obj *const *objv)
{
Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
int filterc;
Tcl_Obj **filterv;
| | | 2817 2818 2819 2820 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 |
int objc,
Tcl_Obj *const *objv)
{
Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
int filterc;
Tcl_Obj **filterv;
if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
"filterList");
return TCL_ERROR;
} else if (oPtr == NULL) {
return TCL_ERROR;
}
objv += Tcl_ObjectContextSkippedArgs(context);
|
| ︙ | ︙ | |||
2873 2874 2875 2876 2877 2878 2879 |
{
Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
int mixinc;
Tcl_Obj **mixinv;
Class **mixins;
int i;
| | | | 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 |
{
Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
int mixinc;
Tcl_Obj **mixinv;
Class **mixins;
int i;
if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
"mixinList");
return TCL_ERROR;
} else if (oPtr == NULL) {
return TCL_ERROR;
}
objv += Tcl_ObjectContextSkippedArgs(context);
if (Tcl_ListObjGetElements(interp, objv[0], &mixinc,
&mixinv) != TCL_OK) {
return TCL_ERROR;
}
mixins = TclStackAlloc(interp, sizeof(Class *) * mixinc);
for (i = 0; i < mixinc; i++) {
mixins[i] = GetClassInOuterContext(interp, mixinv[i],
"may only mix in classes");
if (mixins[i] == NULL) {
TclStackFree(interp, mixins);
return TCL_ERROR;
}
}
|
| ︙ | ︙ | |||
2963 2964 2965 2966 2967 2968 2969 |
int objc,
Tcl_Obj *const *objv)
{
Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
int varc, i;
Tcl_Obj **varv;
| | | | 2981 2982 2983 2984 2985 2986 2987 2988 2989 2990 2991 2992 2993 2994 2995 2996 2997 2998 2999 3000 3001 3002 3003 3004 3005 3006 3007 3008 |
int objc,
Tcl_Obj *const *objv)
{
Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
int varc, i;
Tcl_Obj **varv;
if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
"variableList");
return TCL_ERROR;
} else if (oPtr == NULL) {
return TCL_ERROR;
}
objv += Tcl_ObjectContextSkippedArgs(context);
if (Tcl_ListObjGetElements(interp, objv[0], &varc,
&varv) != TCL_OK) {
return TCL_ERROR;
}
for (i = 0; i < varc; i++) {
const char *varName = TclGetString(varv[i]);
if (strstr(varName, "::") != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"invalid declared variable name \"%s\": must not %s",
varName, "contain namespace separators"));
Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_DECLVAR", NULL);
|
| ︙ | ︙ |
Changes to generic/tclObj.c.
| ︙ | ︙ | |||
187 188 189 190 191 192 193 |
mp_shrink(&(bignum)); \
} \
(objPtr)->internalRep.twoPtrValue.ptr1 = (bignum).dp; \
(objPtr)->internalRep.twoPtrValue.ptr2 = INT2PTR( ((bignum).sign << 30) \
| ((bignum).alloc << 15) | ((bignum).used)); \
}
| < < < < < < < < < < < | 187 188 189 190 191 192 193 194 195 196 197 198 199 200 |
mp_shrink(&(bignum)); \
} \
(objPtr)->internalRep.twoPtrValue.ptr1 = (bignum).dp; \
(objPtr)->internalRep.twoPtrValue.ptr2 = INT2PTR( ((bignum).sign << 30) \
| ((bignum).alloc << 15) | ((bignum).used)); \
}
/*
* Prototypes for functions defined later in this file:
*/
static int ParseBoolean(Tcl_Obj *objPtr);
static int SetDoubleFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
static int SetIntFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
|
| ︙ | ︙ | |||
2326 2327 2328 2329 2330 2331 2332 |
if (objPtr->typePtr == &tclIntType) {
*dblPtr = (double) objPtr->internalRep.wideValue;
return TCL_OK;
}
if (objPtr->typePtr == &tclBignumType) {
mp_int big;
| | | 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 2325 2326 2327 2328 2329 |
if (objPtr->typePtr == &tclIntType) {
*dblPtr = (double) objPtr->internalRep.wideValue;
return TCL_OK;
}
if (objPtr->typePtr == &tclBignumType) {
mp_int big;
TclUnpackBignum(objPtr, big);
*dblPtr = TclBignumToDouble(&big);
return TCL_OK;
}
} while (SetDoubleFromAny(interp, objPtr) == TCL_OK);
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
2710 2711 2712 2713 2714 2715 2716 | * values in the unsigned long range will fit in a long. */ mp_int big; unsigned long scratch, value = 0, numBytes = sizeof(unsigned long); unsigned char *bytes = (unsigned char *) &scratch; | | | 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 2713 |
* values in the unsigned long range will fit in a long.
*/
mp_int big;
unsigned long scratch, value = 0, numBytes = sizeof(unsigned long);
unsigned char *bytes = (unsigned char *) &scratch;
TclUnpackBignum(objPtr, big);
if (mp_to_unsigned_bin_n(&big, bytes, &numBytes) == MP_OKAY) {
while (numBytes-- > 0) {
value = (value << CHAR_BIT) | *bytes++;
}
if (big.sign) {
if (value <= 1 + (unsigned long)LONG_MAX) {
*longPtr = - (long) value;
|
| ︙ | ︙ | |||
2950 2951 2952 2953 2954 2955 2956 | mp_int big; Tcl_WideUInt value = 0; unsigned long numBytes = sizeof(Tcl_WideInt); Tcl_WideInt scratch; unsigned char *bytes = (unsigned char *) &scratch; | | | 2939 2940 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 |
mp_int big;
Tcl_WideUInt value = 0;
unsigned long numBytes = sizeof(Tcl_WideInt);
Tcl_WideInt scratch;
unsigned char *bytes = (unsigned char *) &scratch;
TclUnpackBignum(objPtr, big);
if (mp_to_unsigned_bin_n(&big, bytes, &numBytes) == MP_OKAY) {
while (numBytes-- > 0) {
value = (value << CHAR_BIT) | *bytes++;
}
if (big.sign) {
if (value <= 1 + ~(Tcl_WideUInt)WIDE_MIN) {
*wideIntPtr = - (Tcl_WideInt) value;
|
| ︙ | ︙ | |||
3064 3065 3066 3067 3068 3069 3070 |
static void
FreeBignum(
Tcl_Obj *objPtr)
{
mp_int toFree; /* Bignum to free */
| | | 3053 3054 3055 3056 3057 3058 3059 3060 3061 3062 3063 3064 3065 3066 3067 |
static void
FreeBignum(
Tcl_Obj *objPtr)
{
mp_int toFree; /* Bignum to free */
TclUnpackBignum(objPtr, toFree);
mp_clear(&toFree);
if (PTR2INT(objPtr->internalRep.twoPtrValue.ptr2) < 0) {
Tcl_Free(objPtr->internalRep.twoPtrValue.ptr1);
}
objPtr->typePtr = NULL;
}
|
| ︙ | ︙ | |||
3097 3098 3099 3100 3101 3102 3103 |
Tcl_Obj *srcPtr,
Tcl_Obj *copyPtr)
{
mp_int bignumVal;
mp_int bignumCopy;
copyPtr->typePtr = &tclBignumType;
| | | 3086 3087 3088 3089 3090 3091 3092 3093 3094 3095 3096 3097 3098 3099 3100 |
Tcl_Obj *srcPtr,
Tcl_Obj *copyPtr)
{
mp_int bignumVal;
mp_int bignumCopy;
copyPtr->typePtr = &tclBignumType;
TclUnpackBignum(srcPtr, bignumVal);
if (mp_init_copy(&bignumCopy, &bignumVal) != MP_OKAY) {
Tcl_Panic("initialization failure in DupBignum");
}
PACK_BIGNUM(bignumCopy, copyPtr);
}
/*
|
| ︙ | ︙ | |||
3132 3133 3134 3135 3136 3137 3138 |
UpdateStringOfBignum(
Tcl_Obj *objPtr)
{
mp_int bignumVal;
int size;
char *stringVal;
| | | 3121 3122 3123 3124 3125 3126 3127 3128 3129 3130 3131 3132 3133 3134 3135 |
UpdateStringOfBignum(
Tcl_Obj *objPtr)
{
mp_int bignumVal;
int size;
char *stringVal;
TclUnpackBignum(objPtr, bignumVal);
if (MP_OKAY != mp_radix_size(&bignumVal, 10, &size)) {
Tcl_Panic("radix size failure in UpdateStringOfBignum");
}
if (size < 2) {
/*
* mp_radix_size() returns < 2 when more than INT_MAX bytes would be
* needed to hold the string rep (because mp_radix_size ignores
|
| ︙ | ︙ | |||
3271 3272 3273 3274 3275 3276 3277 |
mp_int *bignumValue) /* Returned bignum value. */
{
do {
if (objPtr->typePtr == &tclBignumType) {
if (copy || Tcl_IsShared(objPtr)) {
mp_int temp;
| | | | 3260 3261 3262 3263 3264 3265 3266 3267 3268 3269 3270 3271 3272 3273 3274 3275 3276 3277 |
mp_int *bignumValue) /* Returned bignum value. */
{
do {
if (objPtr->typePtr == &tclBignumType) {
if (copy || Tcl_IsShared(objPtr)) {
mp_int temp;
TclUnpackBignum(objPtr, temp);
mp_init_copy(bignumValue, &temp);
} else {
TclUnpackBignum(objPtr, *bignumValue);
/* Optimized TclFreeIntRep */
objPtr->internalRep.twoPtrValue.ptr1 = NULL;
objPtr->internalRep.twoPtrValue.ptr2 = NULL;
objPtr->typePtr = NULL;
/*
* TODO: If objPtr has a string rep, this leaves
* it undisturbed. Not clear that's proper. Pure
|
| ︙ | ︙ | |||
3514 3515 3516 3517 3518 3519 3520 |
*clientDataPtr = &objPtr->internalRep.wideValue;
return TCL_OK;
}
if (objPtr->typePtr == &tclBignumType) {
static Tcl_ThreadDataKey bignumKey;
mp_int *bigPtr = Tcl_GetThreadData(&bignumKey, sizeof(mp_int));
| | | 3503 3504 3505 3506 3507 3508 3509 3510 3511 3512 3513 3514 3515 3516 3517 |
*clientDataPtr = &objPtr->internalRep.wideValue;
return TCL_OK;
}
if (objPtr->typePtr == &tclBignumType) {
static Tcl_ThreadDataKey bignumKey;
mp_int *bigPtr = Tcl_GetThreadData(&bignumKey, sizeof(mp_int));
TclUnpackBignum(objPtr, *bigPtr);
*typePtr = TCL_NUMBER_BIG;
*clientDataPtr = bigPtr;
return TCL_OK;
}
} while (TCL_OK ==
TclParseNumber(interp, objPtr, "number", NULL, -1, NULL, 0));
return TCL_ERROR;
|
| ︙ | ︙ |
Changes to generic/tclPkg.c.
| ︙ | ︙ | |||
34 35 36 37 38 39 40 |
* Tcl_Preserve and Tcl_Release. */
char *pkgIndex; /* Full file name of pkgIndex file */
struct PkgAvail *nextPtr; /* Next in list of available versions of the
* same package. */
} PkgAvail;
typedef struct PkgName {
| | > | > | > < | | 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 |
* Tcl_Preserve and Tcl_Release. */
char *pkgIndex; /* Full file name of pkgIndex file */
struct PkgAvail *nextPtr; /* Next in list of available versions of the
* same package. */
} PkgAvail;
typedef struct PkgName {
struct PkgName *nextPtr; /* Next in list of package names being
* initialized. */
char name[1];
} PkgName;
typedef struct PkgFiles {
PkgName *names; /* Package names being initialized. Must be
* first field. */
Tcl_HashTable table; /* Table which contains files for each
* package. */
} PkgFiles;
/*
* For each package that is known in any way to an interpreter, there is one
* record of the following type. These records are stored in the
* "packageTable" hash table in the interpreter, keyed by package name such as
* "Tk" (no version number).
*/
typedef struct {
Tcl_Obj *version;
PkgAvail *availPtr; /* First in list of all available versions of
* this package. */
const void *clientData; /* Client data. */
} Package;
typedef struct Require {
void *clientDataPtr;
const char *name;
Package *pkgPtr;
char *versionToProvide;
} Require;
typedef struct RequireProcArgs {
const char *name;
|
| ︙ | ︙ | |||
217 218 219 220 221 222 223 | * Side effects: * The script from some previous "package ifneeded" command may be * invoked to provide the package. * *---------------------------------------------------------------------- */ | > > | | > > > > | > | > > > > > > | | > > | 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 |
* Side effects:
* The script from some previous "package ifneeded" command may be
* invoked to provide the package.
*
*----------------------------------------------------------------------
*/
static void
PkgFilesCleanupProc(
ClientData clientData,
Tcl_Interp *interp)
{
PkgFiles *pkgFiles = (PkgFiles *) clientData;
Tcl_HashSearch search;
Tcl_HashEntry *entry;
while (pkgFiles->names) {
PkgName *name = pkgFiles->names;
pkgFiles->names = name->nextPtr;
Tcl_Free(name);
}
entry = Tcl_FirstHashEntry(&pkgFiles->table, &search);
while (entry) {
Tcl_Obj *obj = (Tcl_Obj *)Tcl_GetHashValue(entry);
Tcl_DecrRefCount(obj);
entry = Tcl_NextHashEntry(&search);
}
Tcl_DeleteHashTable(&pkgFiles->table);
Tcl_Free(pkgFiles);
return;
}
void *
TclInitPkgFiles(
Tcl_Interp *interp)
{
/*
* If assocdata "tclPkgFiles" doesn't exist yet, create it.
*/
PkgFiles *pkgFiles = Tcl_GetAssocData(interp, "tclPkgFiles", NULL);
if (!pkgFiles) {
pkgFiles = Tcl_Alloc(sizeof(PkgFiles));
pkgFiles->names = NULL;
Tcl_InitHashTable(&pkgFiles->table, TCL_STRING_KEYS);
Tcl_SetAssocData(interp, "tclPkgFiles", PkgFilesCleanupProc, pkgFiles);
}
return pkgFiles;
}
void
TclPkgFileSeen(
Tcl_Interp *interp,
const char *fileName)
{
PkgFiles *pkgFiles = (PkgFiles *)
Tcl_GetAssocData(interp, "tclPkgFiles", NULL);
if (pkgFiles && pkgFiles->names) {
const char *name = pkgFiles->names->name;
Tcl_HashTable *table = &pkgFiles->table;
int new;
Tcl_HashEntry *entry = Tcl_CreateHashEntry(table, name, &new);
Tcl_Obj *list;
|
| ︙ | ︙ | |||
343 344 345 346 347 348 349 | * those unresolved references may cause the loading of the package to * also load a second copy of the Tcl library, leading to all kinds of * trouble. We would like to catch that error and report a useful * message back to the user. That's what we're doing. * * Second, how does this work? If we reach this point, then the global * variable tclEmptyStringRep has the value NULL. Compare that with | | | | | | | | 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 | * those unresolved references may cause the loading of the package to * also load a second copy of the Tcl library, leading to all kinds of * trouble. We would like to catch that error and report a useful * message back to the user. That's what we're doing. * * Second, how does this work? If we reach this point, then the global * variable tclEmptyStringRep has the value NULL. Compare that with * the definition of tclEmptyStringRep near the top of this file. It * clearly should not have the value NULL; it should point to the char * tclEmptyString. If we see it having the value NULL, then somehow we * are seeing a Tcl library that isn't completely initialized, and * that's an indicator for the error condition described above. * (Further explanation is welcome.) * * Third, so what do we do about it? This situation indicates the * package we just loaded wasn't properly compiled to be stub-enabled, * yet it thinks it is stub-enabled (it called Tcl_InitStubs()). We * want to report that the package just loaded is broken, so we want * to place an error message in the interpreter result and return NULL * to indicate failure to Tcl_InitStubs() so that it will also fail. |
| ︙ | ︙ | |||
412 413 414 415 416 417 418 419 420 |
int reqc, /* Requirements constraining the desired
* version. */
Tcl_Obj *const reqv[], /* 0 means to use the latest version
* available. */
void *clientDataPtr)
{
RequireProcArgs args;
args.name = name;
args.clientDataPtr = clientDataPtr;
| > | > | > > | > > | > > > > > | > > | | > > > > > > > > > > | > > > > > | | | | | | > > > > > | > > | > > > > | | | | > | | | > | < | < < < < < | > > > > | > > > | > > > | > | > > > > | > | 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 |
int reqc, /* Requirements constraining the desired
* version. */
Tcl_Obj *const reqv[], /* 0 means to use the latest version
* available. */
void *clientDataPtr)
{
RequireProcArgs args;
args.name = name;
args.clientDataPtr = clientDataPtr;
return Tcl_NRCallObjProc(interp,
TclNRPkgRequireProc, (void *) &args, reqc, reqv);
}
static int
TclNRPkgRequireProc(
ClientData clientData,
Tcl_Interp *interp,
int reqc,
Tcl_Obj *const reqv[])
{
RequireProcArgs *args = clientData;
Tcl_NRAddCallback(interp,
PkgRequireCore, (void *) args->name, INT2PTR(reqc), (void *) reqv,
args->clientDataPtr);
return TCL_OK;
}
static int
PkgRequireCore(
ClientData data[],
Tcl_Interp *interp,
int result)
{
const char *name = data[0];
int reqc = PTR2INT(data[1]);
Tcl_Obj *const *reqv = data[2];
int code = CheckAllRequirements(interp, reqc, reqv);
Require *reqPtr;
if (code != TCL_OK) {
return code;
}
reqPtr = Tcl_Alloc(sizeof(Require));
Tcl_NRAddCallback(interp, PkgRequireCoreCleanup, reqPtr, NULL, NULL, NULL);
reqPtr->clientDataPtr = data[3];
reqPtr->name = name;
reqPtr->pkgPtr = FindPackage(interp, name);
if (reqPtr->pkgPtr->version == NULL) {
Tcl_NRAddCallback(interp,
SelectPackage, reqPtr, INT2PTR(reqc), (void *) reqv,
PkgRequireCoreStep1);
} else {
Tcl_NRAddCallback(interp,
PkgRequireCoreFinal, reqPtr, INT2PTR(reqc), (void *) reqv,NULL);
}
return TCL_OK;
}
static int
PkgRequireCoreStep1(
ClientData data[],
Tcl_Interp *interp,
int result)
{
Tcl_DString command;
char *script;
Require *reqPtr = data[0];
int reqc = PTR2INT(data[1]);
Tcl_Obj **const reqv = data[2];
const char *name = reqPtr->name /* Name of desired package. */;
/*
* If we've got the package in the DB already, go on to actually loading
* it.
*/
if (reqPtr->pkgPtr->version != NULL) {
Tcl_NRAddCallback(interp,
PkgRequireCoreFinal, reqPtr, INT2PTR(reqc), (void *)reqv, NULL);
return TCL_OK;
}
/*
* The package is not in the database. If there is a "package unknown"
* command, invoke it.
*/
script = ((Interp *) interp)->packageUnknown;
if (script == NULL) {
/*
* No package unknown script. Move on to finalizing.
*/
Tcl_NRAddCallback(interp,
PkgRequireCoreFinal, reqPtr, INT2PTR(reqc), (void *)reqv, NULL);
return TCL_OK;
}
/*
* Invoke the "package unknown" script synchronously.
*/
Tcl_DStringInit(&command);
Tcl_DStringAppend(&command, script, -1);
Tcl_DStringAppendElement(&command, name);
AddRequirementsToDString(&command, reqc, reqv);
Tcl_NRAddCallback(interp,
PkgRequireCoreStep2, reqPtr, INT2PTR(reqc), (void *) reqv, NULL);
Tcl_NREvalObj(interp,
Tcl_NewStringObj(Tcl_DStringValue(&command),
Tcl_DStringLength(&command)),
TCL_EVAL_GLOBAL);
Tcl_DStringFree(&command);
return TCL_OK;
}
static int
PkgRequireCoreStep2(
ClientData data[],
Tcl_Interp *interp,
int result)
{
Require *reqPtr = data[0];
int reqc = PTR2INT(data[1]);
Tcl_Obj **const reqv = data[2];
const char *name = reqPtr->name; /* Name of desired package. */
if ((result != TCL_OK) && (result != TCL_ERROR)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad return code: %d", result));
Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "BADRESULT", NULL);
result = TCL_ERROR;
}
if (result == TCL_ERROR) {
Tcl_AddErrorInfo(interp,
"\n (\"package unknown\" script)");
return result;
}
Tcl_ResetResult(interp);
/*
* pkgPtr may now be invalid, so refresh it.
*/
reqPtr->pkgPtr = FindPackage(interp, name);
Tcl_NRAddCallback(interp,
SelectPackage, reqPtr, INT2PTR(reqc), (void *) reqv,
PkgRequireCoreFinal);
return TCL_OK;
}
static int
PkgRequireCoreFinal(
ClientData data[],
Tcl_Interp *interp,
int result)
{
Require *reqPtr = data[0];
int reqc = PTR2INT(data[1]), satisfies;
Tcl_Obj **const reqv = data[2];
char *pkgVersionI;
void *clientDataPtr = reqPtr->clientDataPtr;
const char *name = reqPtr->name; /* Name of desired package. */
if (reqPtr->pkgPtr->version == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't find package %s", name));
Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNFOUND", NULL);
AddRequirementsToResult(interp, reqc, reqv);
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
561 562 563 564 565 566 567 |
*ptr = reqPtr->pkgPtr->clientData;
}
Tcl_SetObjResult(interp, reqPtr->pkgPtr->version);
return TCL_OK;
}
static int
| | > > > > | < | > > > > | 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 |
*ptr = reqPtr->pkgPtr->clientData;
}
Tcl_SetObjResult(interp, reqPtr->pkgPtr->version);
return TCL_OK;
}
static int
PkgRequireCoreCleanup(
ClientData data[],
Tcl_Interp *interp,
int result)
{
Tcl_Free(data[0]);
return result;
}
static int
SelectPackage(
ClientData data[],
Tcl_Interp *interp,
int result)
{
PkgAvail *availPtr, *bestPtr, *bestStablePtr;
char *availVersion, *bestVersion, *bestStableVersion;
/* Internal rep. of versions */
int availStable, satisfies;
Require *reqPtr = data[0];
int reqc = PTR2INT(data[1]);
Tcl_Obj **const reqv = data[2];
|
| ︙ | ︙ | |||
596 597 598 599 600 601 602 |
name, (char *) pkgPtr->clientData, name));
AddRequirementsToResult(interp, reqc, reqv);
Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "CIRCULARITY", NULL);
return TCL_ERROR;
}
/*
| | | | | | | | > | > > > | 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 |
name, (char *) pkgPtr->clientData, name));
AddRequirementsToResult(interp, reqc, reqv);
Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "CIRCULARITY", NULL);
return TCL_ERROR;
}
/*
* The package isn't yet present. Search the list of available versions
* and invoke the script for the best available version. We are actually
* locating the best, and the best stable version. One of them is then
* chosen based on the selection mode.
*/
bestPtr = NULL;
bestStablePtr = NULL;
bestVersion = NULL;
bestStableVersion = NULL;
for (availPtr = pkgPtr->availPtr; availPtr != NULL;
availPtr = availPtr->nextPtr) {
if (CheckVersionAndConvert(interp, availPtr->version,
&availVersion, &availStable) != TCL_OK) {
/*
* The provided version number has invalid syntax. This should not
* happen. This should have been caught by the 'package ifneeded'
* registering the package.
*/
continue;
}
/*
* Check satisfaction of requirements before considering the current
* version further.
*/
if (reqc > 0) {
satisfies = SomeRequirementSatisfied(availVersion, reqc, reqv);
if (!satisfies) {
Tcl_Free(availVersion);
availVersion = NULL;
continue;
}
|
| ︙ | ︙ | |||
642 643 644 645 646 647 648 649 650 651 652 653 654 |
*/
if (res > 0) {
/*
* The version of the package sought is better than the
* currently selected version.
*/
Tcl_Free(bestVersion);
bestVersion = NULL;
goto newbest;
}
} else {
newbest:
| > > | > | | > > | > > > | > | 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 |
*/
if (res > 0) {
/*
* The version of the package sought is better than the
* currently selected version.
*/
Tcl_Free(bestVersion);
bestVersion = NULL;
goto newbest;
}
} else {
newbest:
/*
* We have found a version which is better than our max.
*/
bestPtr = availPtr;
CheckVersionAndConvert(interp, bestPtr->version, &bestVersion, NULL);
}
if (!availStable) {
Tcl_Free(availVersion);
availVersion = NULL;
continue;
}
if (bestStablePtr != NULL) {
int res = CompareVersions(availVersion, bestStableVersion, NULL);
/*
* Note: Used internal reps in the comparison!
*/
if (res > 0) {
/*
* This stable version of the package sought is better than
* the currently selected stable version.
*/
Tcl_Free(bestStableVersion);
bestStableVersion = NULL;
goto newstable;
}
} else {
newstable:
/*
* We have found a stable version which is better than our max
* stable.
*/
bestStablePtr = availPtr;
CheckVersionAndConvert(interp, bestStablePtr->version,
&bestStableVersion, NULL);
}
Tcl_Free(availVersion);
availVersion = NULL;
} /* end for */
/*
|
| ︙ | ︙ | |||
702 703 704 705 706 707 708 |
if (bestStableVersion != NULL) {
Tcl_Free(bestStableVersion);
bestStableVersion = NULL;
}
/*
| | | | > | | | > > | > > > | > | > | > > > > > | > > | 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 862 863 864 865 866 867 868 869 870 |
if (bestStableVersion != NULL) {
Tcl_Free(bestStableVersion);
bestStableVersion = NULL;
}
/*
* Now choose a version among the two best. For 'latest' we simply take
* (actually keep) the best. For 'stable' we take the best stable, if
* there is any, or the best if there is nothing stable.
*/
if ((iPtr->packagePrefer == PKG_PREFER_STABLE)
&& (bestStablePtr != NULL)) {
bestPtr = bestStablePtr;
}
if (bestPtr == NULL) {
Tcl_NRAddCallback(interp,
data[3], reqPtr, INT2PTR(reqc), (void *)reqv, NULL);
} else {
/*
* We found an ifneeded script for the package. Be careful while
* executing it: this could cause reentrancy, so (a) protect the
* script itself from deletion and (b) don't assume that bestPtr will
* still exist when the script completes.
*/
char *versionToProvide = bestPtr->version;
PkgFiles *pkgFiles;
PkgName *pkgName;
Tcl_Preserve(versionToProvide);
pkgPtr->clientData = versionToProvide;
pkgFiles = TclInitPkgFiles(interp);
/*
* Push "ifneeded" package name in "tclPkgFiles" assocdata.
*/
pkgName = Tcl_Alloc(sizeof(PkgName) + strlen(name));
pkgName->nextPtr = pkgFiles->names;
strcpy(pkgName->name, name);
pkgFiles->names = pkgName;
if (bestPtr->pkgIndex) {
TclPkgFileSeen(interp, bestPtr->pkgIndex);
}
reqPtr->versionToProvide = versionToProvide;
Tcl_NRAddCallback(interp,
SelectPackageFinal, reqPtr, INT2PTR(reqc), (void *)reqv,
data[3]);
Tcl_NREvalObj(interp, Tcl_NewStringObj(bestPtr->script, -1),
TCL_EVAL_GLOBAL);
}
return TCL_OK;
}
static int
SelectPackageFinal(
ClientData data[],
Tcl_Interp *interp,
int result)
{
Require *reqPtr = data[0];
int reqc = PTR2INT(data[1]);
Tcl_Obj **const reqv = data[2];
const char *name = reqPtr->name;
char *versionToProvide = reqPtr->versionToProvide;
/*
* Pop the "ifneeded" package name from "tclPkgFiles" assocdata
*/
PkgFiles *pkgFiles = Tcl_GetAssocData(interp, "tclPkgFiles", NULL);
PkgName *pkgName = pkgFiles->names;
pkgFiles->names = pkgName->nextPtr;
Tcl_Free(pkgName);
reqPtr->pkgPtr = FindPackage(interp, name);
if (result == TCL_OK) {
|
| ︙ | ︙ | |||
818 819 820 821 822 823 824 |
"\n (\"package ifneeded %s %s\" script)",
name, versionToProvide));
}
Tcl_Release(versionToProvide);
if (result != TCL_OK) {
/*
| | | | | | | < | > | 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 950 951 952 953 |
"\n (\"package ifneeded %s %s\" script)",
name, versionToProvide));
}
Tcl_Release(versionToProvide);
if (result != TCL_OK) {
/*
* Take a non-TCL_OK code from the script as an indication the package
* wasn't loaded properly, so the package system should not remember
* an improper load.
*
* This is consistent with our returning NULL. If we're not willing to
* tell our caller we got a particular version, we shouldn't store
* that version for telling future callers either.
*/
if (reqPtr->pkgPtr->version != NULL) {
Tcl_DecrRefCount(reqPtr->pkgPtr->version);
reqPtr->pkgPtr->version = NULL;
}
reqPtr->pkgPtr->clientData = NULL;
return result;
}
Tcl_NRAddCallback(interp,
data[3], reqPtr, INT2PTR(reqc), (void *) reqv, NULL);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_PkgPresent / Tcl_PkgPresentEx --
|
| ︙ | ︙ | |||
1002 1003 1004 1005 1006 1007 1008 |
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "package");
return TCL_ERROR;
}
pkgFiles = (PkgFiles *) Tcl_GetAssocData(interp, "tclPkgFiles", NULL);
if (pkgFiles) {
| | > > | > | 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 |
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "package");
return TCL_ERROR;
}
pkgFiles = (PkgFiles *) Tcl_GetAssocData(interp, "tclPkgFiles", NULL);
if (pkgFiles) {
Tcl_HashEntry *entry = Tcl_FindHashEntry(&pkgFiles->table,
TclGetString(objv[2]));
if (entry) {
Tcl_SetObjResult(interp, (Tcl_Obj *)Tcl_GetHashValue(entry));
}
}
break;
}
case PKG_FORGET: {
const char *keyString;
PkgFiles *pkgFiles = (PkgFiles *)
Tcl_GetAssocData(interp, "tclPkgFiles", NULL);
for (i = 2; i < objc; i++) {
keyString = TclGetString(objv[i]);
if (pkgFiles) {
hPtr = Tcl_FindHashEntry(&pkgFiles->table, keyString);
if (hPtr) {
Tcl_Obj *obj = Tcl_GetHashValue(hPtr);
|
| ︙ | ︙ | |||
1085 1086 1087 1088 1089 1090 1091 | Tcl_Free(argv3i); return TCL_ERROR; } res = CompareVersions(avi, argv3i, NULL); Tcl_Free(avi); | | | 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 |
Tcl_Free(argv3i);
return TCL_ERROR;
}
res = CompareVersions(avi, argv3i, NULL);
Tcl_Free(avi);
if (res == 0) {
if (objc == 4) {
Tcl_Free(argv3i);
Tcl_SetObjResult(interp,
Tcl_NewStringObj(availPtr->script, -1));
return TCL_OK;
}
Tcl_EventuallyFree(availPtr->script, TCL_DYNAMIC);
|
| ︙ | ︙ | |||
1253 1254 1255 1256 1257 1258 1259 | Tcl_IncrRefCount(objv[3]); objvListPtr = Tcl_NewListObj(0, NULL); Tcl_IncrRefCount(objvListPtr); Tcl_ListObjAppendElement(interp, objvListPtr, ov); Tcl_ListObjGetElements(interp, objvListPtr, &newobjc, &newObjvPtr); | > | | > > > < | > > | | > > | 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 |
Tcl_IncrRefCount(objv[3]);
objvListPtr = Tcl_NewListObj(0, NULL);
Tcl_IncrRefCount(objvListPtr);
Tcl_ListObjAppendElement(interp, objvListPtr, ov);
Tcl_ListObjGetElements(interp, objvListPtr, &newobjc, &newObjvPtr);
Tcl_NRAddCallback(interp,
TclNRPackageObjCmdCleanup, objv[3], objvListPtr, NULL,NULL);
Tcl_NRAddCallback(interp,
PkgRequireCore, (void *) argv3, INT2PTR(newobjc),
newObjvPtr, NULL);
return TCL_OK;
} else {
int i, newobjc = objc-3;
Tcl_Obj *const *newobjv = objv + 3;
if (CheckAllRequirements(interp, objc-3, objv+3) != TCL_OK) {
return TCL_ERROR;
}
objvListPtr = Tcl_NewListObj(0, NULL);
Tcl_IncrRefCount(objvListPtr);
Tcl_IncrRefCount(objv[2]);
for (i = 0; i < newobjc; i++) {
/*
* Tcl_Obj structures may have come from another interpreter,
* so duplicate them.
*/
Tcl_ListObjAppendElement(interp, objvListPtr,
Tcl_DuplicateObj(newobjv[i]));
}
Tcl_ListObjGetElements(interp, objvListPtr, &newobjc, &newObjvPtr);
Tcl_NRAddCallback(interp,
TclNRPackageObjCmdCleanup, objv[2], objvListPtr, NULL,NULL);
Tcl_NRAddCallback(interp,
PkgRequireCore, (void *) argv2, INT2PTR(newobjc),
newObjvPtr, NULL);
return TCL_OK;
}
break;
case PKG_UNKNOWN: {
size_t length;
if (objc == 2) {
|
| ︙ | ︙ | |||
1419 1420 1421 1422 1423 1424 1425 |
default:
Tcl_Panic("Tcl_PackageObjCmd: bad option index to pkgOptions");
}
return TCL_OK;
}
static int
| | > > > > | | | 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 |
default:
Tcl_Panic("Tcl_PackageObjCmd: bad option index to pkgOptions");
}
return TCL_OK;
}
static int
TclNRPackageObjCmdCleanup(
ClientData data[],
Tcl_Interp *interp,
int result)
{
TclDecrRefCount((Tcl_Obj *) data[0]);
TclDecrRefCount((Tcl_Obj *) data[1]);
return result;
}
/*
*----------------------------------------------------------------------
*
* FindPackage --
|
| ︙ | ︙ |
Changes to generic/tclResult.c.
| ︙ | ︙ | |||
202 203 204 205 206 207 208 |
}
if (statePtr->errorStack) {
Tcl_DecrRefCount(statePtr->errorStack);
}
Tcl_DecrRefCount(statePtr->objResult);
Tcl_Free(statePtr);
}
| < < < < < < < < < < < < < < < < < < < < < < < < < < | 202 203 204 205 206 207 208 209 210 211 212 213 214 215 |
}
if (statePtr->errorStack) {
Tcl_DecrRefCount(statePtr->errorStack);
}
Tcl_DecrRefCount(statePtr->objResult);
Tcl_Free(statePtr);
}
/*
*----------------------------------------------------------------------
*
* Tcl_SetObjResult --
*
* Arrange for objPtr to be an interpreter's result value.
|
| ︙ | ︙ |
Changes to generic/tclStringObj.c.
| ︙ | ︙ | |||
3755 3756 3757 3758 3759 3760 3761 | } /* *--------------------------------------------------------------------------- * * TclStringReplace -- * | | > | 3755 3756 3757 3758 3759 3760 3761 3762 3763 3764 3765 3766 3767 3768 3769 3770 | } /* *--------------------------------------------------------------------------- * * TclStringReplace -- * * Implements the inner engine of the [string replace] and * [string insert] commands. * * The result is a concatenation of a prefix from objPtr, characters * 0 through first-1, the insertPtr string value, and a suffix from * objPtr, characters from first + count to the end. The effect is as if * the inner substring of characters first through first+count-1 are * removed and replaced with insertPtr. If insertPtr is NULL, it is * treated as an empty string. When passed the flag TCL_STRING_IN_PLACE, |
| ︙ | ︙ | |||
3798 3799 3800 3801 3802 3803 3804 |
} else {
return Tcl_DuplicateObj(objPtr);
}
}
/*
* The caller very likely had to call Tcl_GetCharLength() or similar
| | | 3799 3800 3801 3802 3803 3804 3805 3806 3807 3808 3809 3810 3811 3812 3813 |
} else {
return Tcl_DuplicateObj(objPtr);
}
}
/*
* The caller very likely had to call Tcl_GetCharLength() or similar
* to be able to process index values. This means it is likely that
* objPtr is either a proper "bytearray" or a "string" or else it has
* a known and short string rep.
*/
if (TclIsPureByteArray(objPtr)) {
size_t numBytes = 0;
unsigned char *bytes = TclGetByteArrayFromObj(objPtr, &numBytes);
|
| ︙ | ︙ |
Changes to generic/tclStubInit.c.
| ︙ | ︙ | |||
863 864 865 866 867 868 869 |
#endif /* MACOSX */
Tcl_GetPathType, /* 168 */
Tcl_Gets, /* 169 */
Tcl_GetsObj, /* 170 */
Tcl_GetServiceMode, /* 171 */
Tcl_GetSlave, /* 172 */
Tcl_GetStdChannel, /* 173 */
| | | 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 |
#endif /* MACOSX */
Tcl_GetPathType, /* 168 */
Tcl_Gets, /* 169 */
Tcl_GetsObj, /* 170 */
Tcl_GetServiceMode, /* 171 */
Tcl_GetSlave, /* 172 */
Tcl_GetStdChannel, /* 173 */
0, /* 174 */
0, /* 175 */
Tcl_GetVar2, /* 176 */
0, /* 177 */
0, /* 178 */
Tcl_HideCommand, /* 179 */
Tcl_Init, /* 180 */
Tcl_InitHashTable, /* 181 */
|
| ︙ | ︙ | |||
1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 |
Tcl_InitStringRep, /* 637 */
Tcl_FetchIntRep, /* 638 */
Tcl_StoreIntRep, /* 639 */
Tcl_HasStringRep, /* 640 */
Tcl_IncrRefCount, /* 641 */
Tcl_DecrRefCount, /* 642 */
Tcl_IsShared, /* 643 */
};
/* !END!: Do not edit above this line. */
| > | 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 |
Tcl_InitStringRep, /* 637 */
Tcl_FetchIntRep, /* 638 */
Tcl_StoreIntRep, /* 639 */
Tcl_HasStringRep, /* 640 */
Tcl_IncrRefCount, /* 641 */
Tcl_DecrRefCount, /* 642 */
Tcl_IsShared, /* 643 */
Tcl_LinkArray, /* 644 */
};
/* !END!: Do not edit above this line. */
|
Changes to generic/tclTest.c.
| ︙ | ︙ | |||
304 305 306 307 308 309 310 311 312 313 314 315 316 317 | static int TestgetvarfullnameCmd( void *dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int TestinterpdeleteCmd(void *dummy, Tcl_Interp *interp, int argc, const char **argv); static int TestlinkCmd(void *dummy, Tcl_Interp *interp, int argc, const char **argv); static int TestlocaleCmd(void *dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int TestmainthreadCmd(void *dummy, Tcl_Interp *interp, int argc, const char **argv); static int TestsetmainloopCmd(void *dummy, Tcl_Interp *interp, int argc, const char **argv); | > > | 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 | static int TestgetvarfullnameCmd( void *dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int TestinterpdeleteCmd(void *dummy, Tcl_Interp *interp, int argc, const char **argv); static int TestlinkCmd(void *dummy, Tcl_Interp *interp, int argc, const char **argv); static int TestlinkarrayCmd(void *dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); static int TestlocaleCmd(void *dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int TestmainthreadCmd(void *dummy, Tcl_Interp *interp, int argc, const char **argv); static int TestsetmainloopCmd(void *dummy, Tcl_Interp *interp, int argc, const char **argv); |
| ︙ | ︙ | |||
661 662 663 664 665 666 667 668 669 670 671 672 673 674 |
Tcl_CreateCommand(interp, "testgetplatform", TestgetplatformCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testgetvarfullname",
TestgetvarfullnameCmd, NULL, NULL);
Tcl_CreateCommand(interp, "testinterpdelete", TestinterpdeleteCmd,
NULL, NULL);
Tcl_CreateCommand(interp, "testlink", TestlinkCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testlocale", TestlocaleCmd, NULL,
NULL);
Tcl_CreateCommand(interp, "testpanic", TestpanicCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testparseargs", TestparseargsCmd,NULL,NULL);
Tcl_CreateObjCommand(interp, "testparser", TestparserObjCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testparsevar", TestparsevarObjCmd,
| > | 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 |
Tcl_CreateCommand(interp, "testgetplatform", TestgetplatformCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testgetvarfullname",
TestgetvarfullnameCmd, NULL, NULL);
Tcl_CreateCommand(interp, "testinterpdelete", TestinterpdeleteCmd,
NULL, NULL);
Tcl_CreateCommand(interp, "testlink", TestlinkCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testlinkarray", TestlinkarrayCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testlocale", TestlocaleCmd, NULL,
NULL);
Tcl_CreateCommand(interp, "testpanic", TestpanicCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testparseargs", TestparseargsCmd,NULL,NULL);
Tcl_CreateObjCommand(interp, "testparser", TestparserObjCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testparsevar", TestparsevarObjCmd,
|
| ︙ | ︙ | |||
965 966 967 968 969 970 971 |
int id = PTR2INT(clientData);
const char *listArgv[4];
char *cmd;
char string[TCL_INTEGER_SPACE];
Tcl_MutexLock(&asyncTestMutex);
for (asyncPtr = firstHandler; asyncPtr != NULL;
| | | > > | 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 |
int id = PTR2INT(clientData);
const char *listArgv[4];
char *cmd;
char string[TCL_INTEGER_SPACE];
Tcl_MutexLock(&asyncTestMutex);
for (asyncPtr = firstHandler; asyncPtr != NULL;
asyncPtr = asyncPtr->nextPtr) {
if (asyncPtr->id == id) {
break;
}
}
Tcl_MutexUnlock(&asyncTestMutex);
if (!asyncPtr) {
/* Woops - this one was deleted between the AsyncMark and now */
return TCL_OK;
}
|
| ︙ | ︙ | |||
3276 3277 3278 3279 3280 3281 3282 3283 3284 3285 3286 3287 3288 3289 |
} else {
Tcl_AppendResult(interp, "bad option \"", argv[1],
"\": should be create, delete, get, set, or update", NULL);
return TCL_ERROR;
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TestlocaleCmd --
*
* This procedure implements the "testlocale" command. It is used
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 3342 3343 3344 3345 3346 3347 3348 3349 3350 3351 3352 3353 3354 3355 3356 3357 3358 3359 3360 3361 3362 3363 3364 3365 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 3396 3397 3398 3399 3400 3401 3402 3403 3404 3405 3406 3407 3408 3409 3410 3411 3412 3413 3414 3415 |
} else {
Tcl_AppendResult(interp, "bad option \"", argv[1],
"\": should be create, delete, get, set, or update", NULL);
return TCL_ERROR;
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TestlinkarrayCmd --
*
* This function is invoked to process the "testlinkarray" Tcl command.
* It is used to test the 'Tcl_LinkArray' function.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Creates, deletes, and invokes variable links.
*
*----------------------------------------------------------------------
*/
static int
TestlinkarrayCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
static const char *LinkOption[] = {
"update", "remove", "create", NULL
};
enum LinkOption { LINK_UPDATE, LINK_REMOVE, LINK_CREATE };
static const char *LinkType[] = {
"char", "uchar", "short", "ushort", "int", "uint", "long", "ulong",
"wide", "uwide", "float", "double", "string", "char*", "binary", NULL
};
/* all values after TCL_LINK_CHARS_ARRAY are used as arrays (see below) */
static int LinkTypes[] = {
TCL_LINK_CHAR, TCL_LINK_UCHAR,
TCL_LINK_SHORT, TCL_LINK_USHORT, TCL_LINK_INT, TCL_LINK_UINT,
TCL_LINK_LONG, TCL_LINK_ULONG, TCL_LINK_WIDE_INT, TCL_LINK_WIDE_UINT,
TCL_LINK_FLOAT, TCL_LINK_DOUBLE, TCL_LINK_STRING, TCL_LINK_CHARS,
TCL_LINK_BINARY
};
int optionIndex, typeIndex, readonly, i, size, length;
char *name, *arg;
long addr; /* Wrong on Windows, but that's MS's fault for
* not supporting <stdint.h> correctly. They
* can suffer the warnings; the rest of us
* shouldn't have to! */
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "option args");
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[1], LinkOption, "option", 0,
&optionIndex) != TCL_OK) {
return TCL_ERROR;
}
switch ((enum LinkOption) optionIndex) {
case LINK_UPDATE:
for (i=2; i<objc; i++) {
Tcl_UpdateLinkedVar(interp, Tcl_GetString(objv[i]));
}
return TCL_OK;
case LINK_REMOVE:
for (i=2; i<objc; i++) {
Tcl_UnlinkVar(interp, Tcl_GetString(objv[i]));
}
return TCL_OK;
case LINK_CREATE:
if (objc < 4) {
goto wrongArgs;
}
readonly = 0;
i = 2;
/*
* test on switch -r...
*/
arg = Tcl_GetStringFromObj(objv[i], &length);
if (length < 2) {
goto wrongArgs;
}
if (arg[0] == '-') {
if (arg[1] != 'r') {
goto wrongArgs;
}
readonly = TCL_LINK_READ_ONLY;
i++;
}
if (Tcl_GetIndexFromObj(interp, objv[i++], LinkType, "type", 0,
&typeIndex) != TCL_OK) {
return TCL_ERROR;
}
if (Tcl_GetIntFromObj(interp, objv[i++], &size) == TCL_ERROR) {
Tcl_SetObjResult(interp, Tcl_NewStringObj("wrong size value", -1));
return TCL_ERROR;
}
name = Tcl_GetString(objv[i++]);
/*
* If no address is given request one in the underlying function
*/
if (i < objc) {
if (Tcl_GetLongFromObj(interp, objv[i], &addr) == TCL_ERROR) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"wrong address value", -1));
return TCL_ERROR;
}
} else {
addr = 0;
}
return Tcl_LinkArray(interp, name, (void *) addr,
LinkTypes[typeIndex] | readonly, size);
}
return TCL_OK;
wrongArgs:
Tcl_WrongNumArgs(interp, 2, objv, "?-readonly? type size name ?address?");
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* TestlocaleCmd --
*
* This procedure implements the "testlocale" command. It is used
|
| ︙ | ︙ |
Changes to generic/tclTimer.c.
| ︙ | ︙ | |||
306 307 308 309 310 311 312 |
memcpy(&timerHandlerPtr->time, timePtr, sizeof(Tcl_Time));
timerHandlerPtr->proc = proc;
timerHandlerPtr->clientData = clientData;
tsdPtr->lastTimerId++;
timerHandlerPtr->token = (Tcl_TimerToken) INT2PTR(tsdPtr->lastTimerId);
/*
| | | | 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 |
memcpy(&timerHandlerPtr->time, timePtr, sizeof(Tcl_Time));
timerHandlerPtr->proc = proc;
timerHandlerPtr->clientData = clientData;
tsdPtr->lastTimerId++;
timerHandlerPtr->token = (Tcl_TimerToken) INT2PTR(tsdPtr->lastTimerId);
/*
* Add the event to the queue in the correct position (ordered by event
* firing time).
*/
for (tPtr2 = tsdPtr->firstTimerHandlerPtr, prevPtr = NULL; tPtr2 != NULL;
prevPtr = tPtr2, tPtr2 = tPtr2->nextPtr) {
if (TCL_TIME_BEFORE(timerHandlerPtr->time, tPtr2->time)) {
break;
}
|
| ︙ | ︙ | |||
1009 1010 1011 1012 1013 1014 1015 |
Interp *iPtr = (Interp *) interp;
Tcl_Time endTime, now;
Tcl_WideInt diff;
Tcl_GetTime(&now);
endTime = now;
| | | | 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 |
Interp *iPtr = (Interp *) interp;
Tcl_Time endTime, now;
Tcl_WideInt diff;
Tcl_GetTime(&now);
endTime = now;
endTime.sec += (long)(ms / 1000);
endTime.usec += ((int)(ms % 1000)) * 1000;
if (endTime.usec >= 1000000) {
endTime.sec++;
endTime.usec -= 1000000;
}
do {
if (Tcl_AsyncReady()) {
|
| ︙ | ︙ | |||
1038 1039 1040 1041 1042 1043 1044 |
}
if (iPtr->limit.timeEvent == NULL
|| TCL_TIME_BEFORE(endTime, iPtr->limit.time)) {
diff = TCL_TIME_DIFF_MS_CEILING(endTime, now);
if (diff > TCL_TIME_MAXIMUM_SLICE) {
diff = TCL_TIME_MAXIMUM_SLICE;
}
| | | | | | | | | | | 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 |
}
if (iPtr->limit.timeEvent == NULL
|| TCL_TIME_BEFORE(endTime, iPtr->limit.time)) {
diff = TCL_TIME_DIFF_MS_CEILING(endTime, now);
if (diff > TCL_TIME_MAXIMUM_SLICE) {
diff = TCL_TIME_MAXIMUM_SLICE;
}
if (diff == 0 && TCL_TIME_BEFORE(now, endTime)) {
diff = 1;
}
if (diff > 0) {
Tcl_Sleep((long) diff);
if (diff < SLEEP_OFFLOAD_GETTIMEOFDAY) {
break;
}
} else {
break;
}
} else {
diff = TCL_TIME_DIFF_MS(iPtr->limit.time, now);
if (diff > TCL_TIME_MAXIMUM_SLICE) {
diff = TCL_TIME_MAXIMUM_SLICE;
}
if (diff > 0) {
Tcl_Sleep((int) diff);
|
| ︙ | ︙ |
Changes to generic/tclTomMath.h.
1 2 3 4 5 6 7 8 9 | /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * | | < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 | /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * SPDX-License-Identifier: Unlicense */ #ifndef BN_H_ #define BN_H_ #include "tclTomMathDecls.h" #ifndef MODULE_SCOPE #define MODULE_SCOPE extern |
| ︙ | ︙ | |||
124 125 126 127 128 129 130 131 132 133 134 135 136 137 | #define MP_ZPOS 0 /* positive integer */ #define MP_NEG 1 /* negative */ #define MP_OKAY 0 /* ok result */ #define MP_MEM -2 /* out of mem */ #define MP_VAL -3 /* invalid input */ #define MP_RANGE MP_VAL #define MP_YES 1 /* yes response */ #define MP_NO 0 /* no response */ /* Primality generation flags */ #define LTM_PRIME_BBS 0x0001 /* BBS style prime */ #define LTM_PRIME_SAFE 0x0002 /* Safe prime (p-1)/2 == prime */ | > | 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 | #define MP_ZPOS 0 /* positive integer */ #define MP_NEG 1 /* negative */ #define MP_OKAY 0 /* ok result */ #define MP_MEM -2 /* out of mem */ #define MP_VAL -3 /* invalid input */ #define MP_RANGE MP_VAL #define MP_ITER -4 /* Max. iterations reached */ #define MP_YES 1 /* yes response */ #define MP_NO 0 /* no response */ /* Primality generation flags */ #define LTM_PRIME_BBS 0x0001 /* BBS style prime */ #define LTM_PRIME_SAFE 0x0002 /* Safe prime (p-1)/2 == prime */ |
| ︙ | ︙ | |||
342 343 344 345 346 347 348 | /* Counts the number of lsbs which are zero before the first zero bit */ /* int mp_cnt_lsb(const mp_int *a); */ /* I Love Earth! */ | | > > > > | > | < > | 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 | /* Counts the number of lsbs which are zero before the first zero bit */ /* int mp_cnt_lsb(const mp_int *a); */ /* I Love Earth! */ /* makes a pseudo-random mp_int of a given size */ /* int mp_rand(mp_int *a, int digits); */ /* makes a pseudo-random small int of a given size */ /* int mp_rand_digit(mp_digit *r); */ #ifdef MP_PRNG_ENABLE_LTM_RNG /* A last resort to provide random data on systems without any of the other * implemented ways to gather entropy. * It is compatible with `rng_get_bytes()` from libtomcrypt so you could * provide that one and then set `ltm_rng = rng_get_bytes;` */ extern unsigned long (*ltm_rng)(unsigned char *out, unsigned long outlen, void (*callback)(void)); extern void (*ltm_rng_callback)(void); #endif /* ---> binary operations <--- */ /* c = a XOR b */ /* |
| ︙ | ︙ | |||
687 688 689 690 691 692 693 | /* This gives [for a given bit size] the number of trials required * such that Miller-Rabin gives a prob of failure lower than 2^-96 */ /* int mp_prime_rabin_miller_trials(int size); */ | | | > > > > > > > | 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 | /* This gives [for a given bit size] the number of trials required * such that Miller-Rabin gives a prob of failure lower than 2^-96 */ /* int mp_prime_rabin_miller_trials(int size); */ /* performs t random rounds of Miller-Rabin on "a" additional to * bases 2 and 3. Also performs an initial sieve of trial * division. Determines if "a" is prime with probability * of error no more than (1/4)**t. * Both a strong Lucas-Selfridge to complete the BPSW test * and a separate Frobenius test are available at compile time. * With t<0 a deterministic test is run for primes up to * 318665857834031151167461. With t<13 (abs(t)-13) additional * tests with sequential small primes are run starting at 43. * Is Fips 186.4 compliant if called with t as computed by * mp_prime_rabin_miller_trials(); * * Sets result to 1 if probably prime, 0 otherwise */ /* int mp_prime_is_prime(const mp_int *a, int t, int *result); */ |
| ︙ | ︙ |
Changes to generic/tclTomMathDecls.h.
| ︙ | ︙ | |||
25 26 27 28 29 30 31 32 33 34 35 36 37 38 |
#define TCLTOMMATH_REVISION 0
#define Tcl_TomMath_InitStubs(interp,version) \
(TclTomMathInitializeStubs((interp),(version),\
TCLTOMMATH_EPOCH,TCLTOMMATH_REVISION))
/* Define custom memory allocation for libtommath */
/* MODULE_SCOPE void* TclBNAlloc( size_t ); */
#define TclBNAlloc(s) ((void*)Tcl_Alloc((size_t)(s)))
/* MODULE_SCOPE void* TclBNRealloc( void*, size_t ); */
#define TclBNRealloc(x,s) ((void*)Tcl_Realloc((char*)(x),(size_t)(s)))
/* MODULE_SCOPE void TclBNFree( void* ); */
#define TclBNFree(x) (Tcl_Free((char*)(x)))
| > < < | | | | | 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 |
#define TCLTOMMATH_REVISION 0
#define Tcl_TomMath_InitStubs(interp,version) \
(TclTomMathInitializeStubs((interp),(version),\
TCLTOMMATH_EPOCH,TCLTOMMATH_REVISION))
/* Define custom memory allocation for libtommath */
/* MODULE_SCOPE void* TclBNAlloc( size_t ); */
#define TclBNAlloc(s) ((void*)Tcl_Alloc((size_t)(s)))
/* MODULE_SCOPE void* TclBNRealloc( void*, size_t ); */
#define TclBNRealloc(x,s) ((void*)Tcl_Realloc((char*)(x),(size_t)(s)))
/* MODULE_SCOPE void TclBNFree( void* ); */
#define TclBNFree(x) (Tcl_Free((char*)(x)))
#define XMALLOC(size) TclBNAlloc(size)
#define XFREE(mem, size) TclBNFree(mem)
#define XREALLOC(mem, oldsize, newsize) TclBNRealloc(mem, newsize)
/* Rename the global symbols in libtommath to avoid linkage conflicts */
#define bn_reverse TclBN_reverse
#define fast_s_mp_mul_digs TclBN_fast_s_mp_mul_digs
#define fast_s_mp_sqr TclBN_fast_s_mp_sqr
#define mp_add TclBN_mp_add
|
| ︙ | ︙ |
Changes to generic/tclTomMathInterface.c.
| ︙ | ︙ | |||
107 108 109 110 111 112 113 |
*/
void
TclInitBignumFromWideInt(
mp_int *a, /* Bignum to initialize */
Tcl_WideInt v) /* Initial value */
{
| | | 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 |
*/
void
TclInitBignumFromWideInt(
mp_int *a, /* Bignum to initialize */
Tcl_WideInt v) /* Initial value */
{
if (mp_init(a) != MP_OKAY) {
Tcl_Panic("initialization failure in TclInitBignumFromWideInt");
}
if (v < (Tcl_WideInt)0) {
mp_set_long_long(a, (Tcl_WideUInt)(-v));
mp_neg(a, a);
} else {
mp_set_long_long(a, (Tcl_WideUInt)v);
|
| ︙ | ︙ | |||
139 140 141 142 143 144 145 |
*/
void
TclInitBignumFromWideUInt(
mp_int *a, /* Bignum to initialize */
Tcl_WideUInt v) /* Initial value */
{
| | | 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 |
*/
void
TclInitBignumFromWideUInt(
mp_int *a, /* Bignum to initialize */
Tcl_WideUInt v) /* Initial value */
{
if (mp_init(a) != MP_OKAY) {
Tcl_Panic("initialization failure in TclInitBignumFromWideUInt");
}
mp_set_long_long(a, v);
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to generic/tclTomMathStubLib.c.
| ︙ | ︙ | |||
51 52 53 54 55 56 57 |
packageName, version, exact, &stubsPtr);
if (actualVersion == NULL) {
return NULL;
}
if (stubsPtr == NULL) {
errMsg = "missing stub table pointer";
| | | | 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 |
packageName, version, exact, &stubsPtr);
if (actualVersion == NULL) {
return NULL;
}
if (stubsPtr == NULL) {
errMsg = "missing stub table pointer";
} else if (stubsPtr->tclBN_epoch() != epoch) {
errMsg = "epoch number mismatch";
} else if (stubsPtr->tclBN_revision() != revision) {
errMsg = "requires a later revision";
} else {
tclTomMathStubsPtr = stubsPtr;
return actualVersion;
}
tclStubsPtr->tcl_ResetResult(interp);
tclStubsPtr->tcl_AppendResult(interp, "Error loading ", packageName,
|
| ︙ | ︙ |
Changes to generic/tclUtf.c.
| ︙ | ︙ | |||
1144 1145 1146 1147 1148 1149 1150 |
/*
* To keep badly formed Utf strings from getting inflated by the
* conversion (thereby causing a segfault), only copy the upper case
* char to dst if its size is <= the original char.
*/
if ((len < TclUtfCount(upChar)) || ((upChar & 0xF800) == 0xD800)) {
| | | 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 |
/*
* To keep badly formed Utf strings from getting inflated by the
* conversion (thereby causing a segfault), only copy the upper case
* char to dst if its size is <= the original char.
*/
if ((len < TclUtfCount(upChar)) || ((upChar & 0xF800) == 0xD800)) {
memmove(dst, src, len);
dst += len;
} else {
dst += Tcl_UniCharToUtf(upChar, dst);
}
src += len;
}
*dst = '\0';
|
| ︙ | ︙ | |||
1206 1207 1208 1209 1210 1211 1212 |
/*
* To keep badly formed Utf strings from getting inflated by the
* conversion (thereby causing a segfault), only copy the lower case
* char to dst if its size is <= the original char.
*/
if ((len < TclUtfCount(lowChar)) || ((lowChar & 0xF800) == 0xD800)) {
| | | 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 |
/*
* To keep badly formed Utf strings from getting inflated by the
* conversion (thereby causing a segfault), only copy the lower case
* char to dst if its size is <= the original char.
*/
if ((len < TclUtfCount(lowChar)) || ((lowChar & 0xF800) == 0xD800)) {
memmove(dst, src, len);
dst += len;
} else {
dst += Tcl_UniCharToUtf(lowChar, dst);
}
src += len;
}
*dst = '\0';
|
| ︙ | ︙ | |||
1265 1266 1267 1268 1269 1270 1271 |
/* Combine surrogates */
titleChar = (((titleChar & 0x3ff) << 10) | (ch & 0x3ff)) + 0x10000;
}
#endif
titleChar = Tcl_UniCharToTitle(titleChar);
if ((len < TclUtfCount(titleChar)) || ((titleChar & 0xF800) == 0xD800)) {
| | | 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 |
/* Combine surrogates */
titleChar = (((titleChar & 0x3ff) << 10) | (ch & 0x3ff)) + 0x10000;
}
#endif
titleChar = Tcl_UniCharToTitle(titleChar);
if ((len < TclUtfCount(titleChar)) || ((titleChar & 0xF800) == 0xD800)) {
memmove(dst, src, len);
dst += len;
} else {
dst += Tcl_UniCharToUtf(titleChar, dst);
}
src += len;
}
while (*src) {
|
| ︙ | ︙ | |||
1288 1289 1290 1291 1292 1293 1294 |
#endif
/* Special exception for Georgian Asomtavruli chars, no titlecase. */
if ((unsigned)(lowChar - 0x1C90) >= 0x30) {
lowChar = Tcl_UniCharToLower(lowChar);
}
if ((len < TclUtfCount(lowChar)) || ((lowChar & 0xF800) == 0xD800)) {
| | | 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 |
#endif
/* Special exception for Georgian Asomtavruli chars, no titlecase. */
if ((unsigned)(lowChar - 0x1C90) >= 0x30) {
lowChar = Tcl_UniCharToLower(lowChar);
}
if ((len < TclUtfCount(lowChar)) || ((lowChar & 0xF800) == 0xD800)) {
memmove(dst, src, len);
dst += len;
} else {
dst += Tcl_UniCharToUtf(lowChar, dst);
}
src += len;
}
*dst = '\0';
|
| ︙ | ︙ |
Changes to generic/tclVar.c.
| ︙ | ︙ | |||
718 719 720 721 722 723 724 |
/*
* An indexed local variable.
*/
Tcl_Obj *cachedNamePtr = localName(varFramePtr, index);
if (part1Ptr == cachedNamePtr) {
| | > > > > > > > > < | 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 |
/*
* An indexed local variable.
*/
Tcl_Obj *cachedNamePtr = localName(varFramePtr, index);
if (part1Ptr == cachedNamePtr) {
LocalSetIntRep(part1Ptr, index, NULL);
} else {
/*
* [80304238ac] Trickiness here. We will store and incr the
* refcount on cachedNamePtr. Trouble is that it's possible
* (see test var-22.1) for cachedNamePtr to have an intrep
* that contains a stored and refcounted part1Ptr. This
* would be a reference cycle which leads to a memory leak.
*
* The solution here is to wipe away all intrep(s) in
* cachedNamePtr and leave it as string only. This is
* radical and destructive, so a better idea would be welcome.
*/
/*
* Firstly set cached local var reference (avoid free before set,
* see [45b9faf103f2])
*/
LocalSetIntRep(part1Ptr, index, cachedNamePtr);
/* Then wipe it */
TclFreeIntRep(cachedNamePtr);
/*
* Now go ahead and convert it the the "localVarName" type,
* since we suspect at least some use of the value as a
* varname and we want to resolve it quickly.
*/
LocalSetIntRep(cachedNamePtr, index, NULL);
}
} else {
/*
* At least mark part1Ptr as already parsed.
*/
ParsedSetIntRep(part1Ptr, NULL, NULL);
}
|
| ︙ | ︙ |
Changes to generic/tclZipfs.c.
| ︙ | ︙ | |||
377 378 379 380 381 382 383 384 385 386 387 388 389 390 | static int ZipFSFileAttrsGetProc(Tcl_Interp *interp, int index, Tcl_Obj *pathPtr, Tcl_Obj **objPtrRef); static int ZipFSFileAttrsSetProc(Tcl_Interp *interp, int index, Tcl_Obj *pathPtr, Tcl_Obj *objPtr); static int ZipFSLoadFile(Tcl_Interp *interp, Tcl_Obj *path, Tcl_LoadHandle *loadHandle, Tcl_FSUnloadFileProc **unloadProcPtr, int flags); static void ZipfsSetup(void); static int ZipChannelClose(void *instanceData, Tcl_Interp *interp); static int ZipChannelGetFile(void *instanceData, int direction, void **handlePtr); static int ZipChannelRead(void *instanceData, char *buf, int toRead, int *errloc); | > | 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 | static int ZipFSFileAttrsGetProc(Tcl_Interp *interp, int index, Tcl_Obj *pathPtr, Tcl_Obj **objPtrRef); static int ZipFSFileAttrsSetProc(Tcl_Interp *interp, int index, Tcl_Obj *pathPtr, Tcl_Obj *objPtr); static int ZipFSLoadFile(Tcl_Interp *interp, Tcl_Obj *path, Tcl_LoadHandle *loadHandle, Tcl_FSUnloadFileProc **unloadProcPtr, int flags); static void ZipfsExitHandler(ClientData clientData); static void ZipfsSetup(void); static int ZipChannelClose(void *instanceData, Tcl_Interp *interp); static int ZipChannelGetFile(void *instanceData, int direction, void **handlePtr); static int ZipChannelRead(void *instanceData, char *buf, int toRead, int *errloc); |
| ︙ | ︙ | |||
1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 |
ZipFSCloseArchive(interp, zf0);
return TCL_ERROR;
}
Unlock();
*zf = *zf0;
zf->mountPoint = Tcl_GetHashKey(&ZipFS.zipHash, hPtr);
zf->mountPointLen = strlen(zf->mountPoint);
zf->nameLength = strlen(zipname);
zf->name = Tcl_Alloc(zf->nameLength + 1);
memcpy(zf->name, zipname, zf->nameLength + 1);
zf->entries = NULL;
zf->topEnts = NULL;
zf->numOpen = 0;
| > | 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 |
ZipFSCloseArchive(interp, zf0);
return TCL_ERROR;
}
Unlock();
*zf = *zf0;
zf->mountPoint = Tcl_GetHashKey(&ZipFS.zipHash, hPtr);
Tcl_CreateExitHandler(ZipfsExitHandler, (ClientData)zf);
zf->mountPointLen = strlen(zf->mountPoint);
zf->nameLength = strlen(zipname);
zf->name = Tcl_Alloc(zf->nameLength + 1);
memcpy(zf->name, zipname, zf->nameLength + 1);
zf->entries = NULL;
zf->topEnts = NULL;
zf->numOpen = 0;
|
| ︙ | ︙ | |||
1669 1670 1671 1672 1673 1674 1675 1676 1677 |
if (interp) {
Tcl_AppendResult(interp, "out of memory", (char *) NULL);
Tcl_SetErrorCode(interp, "TCL", "MALLOC", NULL);
}
return TCL_ERROR;
}
if (ZipFSOpenArchive(interp, zipname, 1, zf) != TCL_OK) {
return TCL_ERROR;
}
| > | > > > > > > | 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 |
if (interp) {
Tcl_AppendResult(interp, "out of memory", (char *) NULL);
Tcl_SetErrorCode(interp, "TCL", "MALLOC", NULL);
}
return TCL_ERROR;
}
if (ZipFSOpenArchive(interp, zipname, 1, zf) != TCL_OK) {
Tcl_Free(zf);
return TCL_ERROR;
}
if (ZipFSCatalogFilesystem(interp, zf, mountPoint, passwd, zipname)
!= TCL_OK) {
Tcl_Free(zf);
return TCL_ERROR;
}
Tcl_Free(zf);
return TCL_OK;
}
/*
*-------------------------------------------------------------------------
*
* TclZipfs_MountBuffer --
*
|
| ︙ | ︙ | |||
1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 |
Tcl_Interp *interp, /* Current interpreter. NULLable. */
const char *mountPoint, /* Mount point path. */
unsigned char *data,
size_t datalen,
int copy)
{
ZipFile *zf;
ReadLock();
if (!ZipFS.initialized) {
ZipfsSetup();
}
/*
| > | 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 |
Tcl_Interp *interp, /* Current interpreter. NULLable. */
const char *mountPoint, /* Mount point path. */
unsigned char *data,
size_t datalen,
int copy)
{
ZipFile *zf;
int result;
ReadLock();
if (!ZipFS.initialized) {
ZipfsSetup();
}
/*
|
| ︙ | ︙ | |||
1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 |
}
memcpy(zf->data, data, datalen);
zf->ptrToFree = zf->data;
} else {
zf->data = data;
zf->ptrToFree = NULL;
}
if (ZipFSFindTOC(interp, 0, zf) != TCL_OK) {
return TCL_ERROR;
}
| > | > > | 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 |
}
memcpy(zf->data, data, datalen);
zf->ptrToFree = zf->data;
} else {
zf->data = data;
zf->ptrToFree = NULL;
}
zf->passBuf[0] = 0; /* stop valgrind cries */
if (ZipFSFindTOC(interp, 0, zf) != TCL_OK) {
return TCL_ERROR;
}
result = ZipFSCatalogFilesystem(interp, zf, mountPoint, NULL,
"Memory Buffer");
Tcl_Free(zf);
return result;
}
/*
*-------------------------------------------------------------------------
*
* TclZipfs_Unmount --
*
|
| ︙ | ︙ | |||
1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 |
}
if (z->data) {
Tcl_Free(z->data);
}
Tcl_Free(z);
}
ZipFSCloseArchive(interp, zf);
Tcl_Free(zf);
unmounted = 1;
done:
Unlock();
if (unmounted) {
Tcl_FSMountsChanged(NULL);
}
| > | 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 |
}
if (z->data) {
Tcl_Free(z->data);
}
Tcl_Free(z);
}
ZipFSCloseArchive(interp, zf);
Tcl_DeleteExitHandler(ZipfsExitHandler, (ClientData)zf);
Tcl_Free(zf);
unmounted = 1;
done:
Unlock();
if (unmounted) {
Tcl_FSMountsChanged(NULL);
}
|
| ︙ | ︙ | |||
1901 1902 1903 1904 1905 1906 1907 |
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
const char *mountPoint; /* Mount point path. */
unsigned char *data;
size_t length = 0;
| | | 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 |
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
const char *mountPoint; /* Mount point path. */
unsigned char *data;
size_t length = 0;
if (objc > 3) {
Tcl_WrongNumArgs(interp, 1, objv, "?mountpoint? ?data?");
return TCL_ERROR;
}
if (objc < 2) {
int ret;
ReadLock();
|
| ︙ | ︙ | |||
4814 4815 4816 4817 4818 4819 4820 4821 4822 4823 4824 4825 4826 4827 |
if (found == 0) {
zipfs_literal_tcl_library = ZIPFS_ZIP_MOUNT "/tcl_library";
return TCL_OK;
}
return TCL_ERROR;
}
/*
*-------------------------------------------------------------------------
*
* TclZipfs_AppHook --
*
* Performs the argument munging for the shell
| > > > > > > > > > > > | 4828 4829 4830 4831 4832 4833 4834 4835 4836 4837 4838 4839 4840 4841 4842 4843 4844 4845 4846 4847 4848 4849 4850 4851 4852 |
if (found == 0) {
zipfs_literal_tcl_library = ZIPFS_ZIP_MOUNT "/tcl_library";
return TCL_OK;
}
return TCL_ERROR;
}
static void
ZipfsExitHandler(
ClientData clientData)
{
ZipFile *zf = (ZipFile *)clientData;
if (TCL_OK != TclZipfs_Unmount(NULL, zf->mountPoint)) {
Tcl_Panic("tried to unmount busy filesystem");
}
}
/*
*-------------------------------------------------------------------------
*
* TclZipfs_AppHook --
*
* Performs the argument munging for the shell
|
| ︙ | ︙ |
Changes to generic/tclZlib.c.
| ︙ | ︙ | |||
419 420 421 422 423 424 425 |
GzipHeader *headerPtr, /* Where to store the parsed-out values. */
int *extraSizePtr) /* Variable to add the length of header
* strings (filename, comment) to. */
{
Tcl_Obj *value;
int len, result = TCL_ERROR;
size_t length;
| | | 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 |
GzipHeader *headerPtr, /* Where to store the parsed-out values. */
int *extraSizePtr) /* Variable to add the length of header
* strings (filename, comment) to. */
{
Tcl_Obj *value;
int len, result = TCL_ERROR;
size_t length;
Tcl_WideInt wideValue = 0;
const char *valueStr;
Tcl_Encoding latin1enc;
static const char *const types[] = {
"binary", "text"
};
/*
|
| ︙ | ︙ |
Changes to library/msgs/ja.msg.
| ︙ | ︙ | |||
36 37 38 39 40 41 42 |
::msgcat::mcset ja DATE_FORMAT "%Y/%m/%d"
::msgcat::mcset ja TIME_FORMAT "%k:%M:%S"
::msgcat::mcset ja TIME_FORMAT_12 "%P %I:%M:%S"
::msgcat::mcset ja DATE_TIME_FORMAT "%Y/%m/%d %k:%M:%S %z"
::msgcat::mcset ja LOCALE_DATE_FORMAT "%EY年%m月%d日"
::msgcat::mcset ja LOCALE_TIME_FORMAT "%H時%M分%S秒"
::msgcat::mcset ja LOCALE_DATE_TIME_FORMAT "%EY年%m月%d日 (%a) %H時%M分%S秒 %z"
| | | 36 37 38 39 40 41 42 43 44 |
::msgcat::mcset ja DATE_FORMAT "%Y/%m/%d"
::msgcat::mcset ja TIME_FORMAT "%k:%M:%S"
::msgcat::mcset ja TIME_FORMAT_12 "%P %I:%M:%S"
::msgcat::mcset ja DATE_TIME_FORMAT "%Y/%m/%d %k:%M:%S %z"
::msgcat::mcset ja LOCALE_DATE_FORMAT "%EY年%m月%d日"
::msgcat::mcset ja LOCALE_TIME_FORMAT "%H時%M分%S秒"
::msgcat::mcset ja LOCALE_DATE_TIME_FORMAT "%EY年%m月%d日 (%a) %H時%M分%S秒 %z"
::msgcat::mcset ja LOCALE_ERAS "{-9223372036854775808 西暦 0} {-3061011600 明治 1867} {-1812186000 大正 1911} {-1357635600 昭和 1925} {600220800 平成 1988} {1556668800 令和 2018}"
}
|
Changes to libtommath/bn_mp_clear.c.
| ︙ | ︙ | |||
21 22 23 24 25 26 27 |
if (a->dp != NULL) {
/* first zero the digits */
for (i = 0; i < a->used; i++) {
a->dp[i] = 0;
}
/* free ram */
| | | 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 |
if (a->dp != NULL) {
/* first zero the digits */
for (i = 0; i < a->used; i++) {
a->dp[i] = 0;
}
/* free ram */
XFREE(a->dp, sizeof (mp_digit) * (size_t)a->alloc);
/* reset members to make debugging easier */
a->dp = NULL;
a->alloc = a->used = 0;
a->sign = MP_ZPOS;
}
}
|
| ︙ | ︙ |
Changes to libtommath/bn_mp_fwrite.c.
| ︙ | ︙ | |||
18 19 20 21 22 23 24 |
char *buf;
int err, len, x;
if ((err = mp_radix_size(a, radix, &len)) != MP_OKAY) {
return err;
}
| | | | | | 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 |
char *buf;
int err, len, x;
if ((err = mp_radix_size(a, radix, &len)) != MP_OKAY) {
return err;
}
buf = (char *) XMALLOC((size_t)len);
if (buf == NULL) {
return MP_MEM;
}
if ((err = mp_toradix(a, buf, radix)) != MP_OKAY) {
XFREE(buf, len);
return err;
}
for (x = 0; x < len; x++) {
if (fputc((int)buf[x], stream) == EOF) {
XFREE(buf, len);
return MP_VAL;
}
}
XFREE(buf, len);
return MP_OKAY;
}
#endif
#endif
/* ref: $Format:%D$ */
|
| ︙ | ︙ |
Changes to libtommath/bn_mp_get_double.c.
| ︙ | ︙ | |||
15 16 17 18 19 20 21 |
double mp_get_double(const mp_int *a)
{
int i;
double d = 0.0, fac = 1.0;
for (i = 0; i < DIGIT_BIT; ++i) {
fac *= 2.0;
}
| | | | | 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 |
double mp_get_double(const mp_int *a)
{
int i;
double d = 0.0, fac = 1.0;
for (i = 0; i < DIGIT_BIT; ++i) {
fac *= 2.0;
}
for (i = a->used; i --> 0;) {
d = (d * fac) + (double)a->dp[i];
}
return (a->sign == MP_NEG) ? -d : d;
}
#endif
/* ref: $Format:%D$ */
/* git commit: $Format:%H$ */
/* commit time: $Format:%ai$ */
|
Changes to libtommath/bn_mp_get_long.c.
| ︙ | ︙ | |||
14 15 16 17 18 19 20 |
/* get the lower unsigned long of an mp_int, platform dependent */
unsigned long mp_get_long(const mp_int *a)
{
int i;
unsigned long res;
| | | | | | | 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 |
/* get the lower unsigned long of an mp_int, platform dependent */
unsigned long mp_get_long(const mp_int *a)
{
int i;
unsigned long res;
if (IS_ZERO(a)) {
return 0;
}
/* get number of digits of the lsb we have to read */
i = MIN(a->used, (((CHAR_BIT * (int)sizeof(unsigned long)) + DIGIT_BIT - 1) / DIGIT_BIT)) - 1;
/* get most significant digit of result */
res = (unsigned long)a->dp[i];
#if (ULONG_MAX != 0xFFFFFFFFUL) || (DIGIT_BIT < 32)
while (--i >= 0) {
res = (res << DIGIT_BIT) | (unsigned long)a->dp[i];
}
#endif
return res;
}
#endif
/* ref: $Format:%D$ */
|
| ︙ | ︙ |
Changes to libtommath/bn_mp_get_long_long.c.
| ︙ | ︙ | |||
14 15 16 17 18 19 20 |
/* get the lower unsigned long long of an mp_int, platform dependent */
Tcl_WideUInt mp_get_long_long(const mp_int *a)
{
int i;
Tcl_WideUInt res;
| | | | | | 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 |
/* get the lower unsigned long long of an mp_int, platform dependent */
Tcl_WideUInt mp_get_long_long(const mp_int *a)
{
int i;
Tcl_WideUInt res;
if (IS_ZERO(a)) {
return 0;
}
/* get number of digits of the lsb we have to read */
i = MIN(a->used, (((CHAR_BIT * (int)sizeof(Tcl_WideUInt)) + DIGIT_BIT - 1) / DIGIT_BIT)) - 1;
/* get most significant digit of result */
res = (unsigned long long)a->dp[i];
#if DIGIT_BIT < 64
while (--i >= 0) {
res = (res << DIGIT_BIT) | (unsigned long long)a->dp[i];
}
#endif
return res;
}
#endif
/* ref: $Format:%D$ */
|
| ︙ | ︙ |
Changes to libtommath/bn_mp_grow.c.
| ︙ | ︙ | |||
25 26 27 28 29 30 31 |
/* reallocate the array a->dp
*
* We store the return in a temporary variable
* in case the operation failed we don't want
* to overwrite the dp member of a.
*/
| | > > | 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 |
/* reallocate the array a->dp
*
* We store the return in a temporary variable
* in case the operation failed we don't want
* to overwrite the dp member of a.
*/
tmp = (mp_digit *) XREALLOC(a->dp,
(size_t)a->alloc * sizeof (mp_digit),
(size_t)size * sizeof(mp_digit));
if (tmp == NULL) {
/* reallocation failed but "a" is still valid [can be freed] */
return MP_MEM;
}
/* reallocation succeeded so set a->dp */
a->dp = tmp;
|
| ︙ | ︙ |
Changes to libtommath/bn_mp_init.c.
| ︙ | ︙ | |||
14 15 16 17 18 19 20 |
/* init a new mp_int */
int mp_init(mp_int *a)
{
int i;
/* allocate memory required and clear it */
| | | 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 |
/* init a new mp_int */
int mp_init(mp_int *a)
{
int i;
/* allocate memory required and clear it */
a->dp = (mp_digit *) XMALLOC(MP_PREC * sizeof(mp_digit));
if (a->dp == NULL) {
return MP_MEM;
}
/* set the digits to zero */
for (i = 0; i < MP_PREC; i++) {
a->dp[i] = 0;
|
| ︙ | ︙ |
Changes to libtommath/bn_mp_init_size.c.
| ︙ | ︙ | |||
17 18 19 20 21 22 23 |
{
int x;
/* pad size so there are always extra digits */
size += (MP_PREC * 2) - (size % MP_PREC);
/* alloc mem */
| | | 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 |
{
int x;
/* pad size so there are always extra digits */
size += (MP_PREC * 2) - (size % MP_PREC);
/* alloc mem */
a->dp = (mp_digit *) XMALLOC((size_t)size * sizeof(mp_digit));
if (a->dp == NULL) {
return MP_MEM;
}
/* set the members */
a->used = 0;
a->alloc = size;
|
| ︙ | ︙ |
Changes to libtommath/bn_mp_is_square.c.
| ︙ | ︙ | |||
45 46 47 48 49 50 51 |
/* Default to Non-square :) */
*ret = MP_NO;
if (arg->sign == MP_NEG) {
return MP_VAL;
}
| < | | | 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 |
/* Default to Non-square :) */
*ret = MP_NO;
if (arg->sign == MP_NEG) {
return MP_VAL;
}
if (IS_ZERO(arg)) {
return MP_OKAY;
}
/* First check mod 128 (suppose that DIGIT_BIT is at least 7) */
if (rem_128[127u & arg->dp[0]] == (char)1) {
return MP_OKAY;
}
/* Next check mod 105 (3*5*7) */
if ((res = mp_mod_d(arg, 105uL, &c)) != MP_OKAY) {
return res;
}
|
| ︙ | ︙ |
Changes to libtommath/bn_mp_prime_random_ex.c.
| ︙ | ︙ | |||
42 43 44 45 46 47 48 |
flags |= LTM_PRIME_BBS;
}
/* calc the byte size */
bsize = (size>>3) + ((size&7)?1:0);
/* we need a buffer of bsize bytes */
| | | | | | 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 |
flags |= LTM_PRIME_BBS;
}
/* calc the byte size */
bsize = (size>>3) + ((size&7)?1:0);
/* we need a buffer of bsize bytes */
tmp = (unsigned char *) XMALLOC((size_t)bsize);
if (tmp == NULL) {
return MP_MEM;
}
/* calc the maskAND value for the MSbyte*/
maskAND = ((size&7) == 0) ? 0xFF : (unsigned char)(0xFF >> (8 - (size & 7)));
/* calc the maskOR_msb */
maskOR_msb = 0;
maskOR_msb_offset = ((size & 7) == 1) ? 1 : 0;
if ((flags & LTM_PRIME_2MSB_ON) != 0) {
maskOR_msb |= (unsigned char)(0x80 >> ((9 - size) & 7));
}
/* get the maskOR_lsb */
maskOR_lsb = 1;
if ((flags & LTM_PRIME_BBS) != 0) {
maskOR_lsb |= 3;
}
do {
/* read the bytes */
if (cb(tmp, bsize, dat) != bsize) {
err = MP_VAL;
goto error;
}
/* work over the MSbyte */
tmp[0] &= maskAND;
tmp[0] |= (unsigned char)(1 << ((size - 1) & 7));
/* mix in the maskORs */
tmp[maskOR_msb_offset] |= maskOR_msb;
tmp[bsize-1] |= maskOR_lsb;
/* read it in */
if ((err = mp_read_unsigned_bin(a, tmp, bsize)) != MP_OKAY) {
|
| ︙ | ︙ | |||
119 120 121 122 123 124 125 |
if ((err = mp_add_d(a, 1uL, a)) != MP_OKAY) {
goto error;
}
}
err = MP_OKAY;
error:
| | | 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 |
if ((err = mp_add_d(a, 1uL, a)) != MP_OKAY) {
goto error;
}
}
err = MP_OKAY;
error:
XFREE(tmp, bsize);
return err;
}
#endif
/* ref: $Format:%D$ */
/* git commit: $Format:%H$ */
/* commit time: $Format:%ai$ */
|
Changes to libtommath/bn_mp_read_radix.c.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 15 16 17 18 19 20 21 |
* The library was designed directly after the MPI library by
* Michael Fromberger but has been written from scratch with
* additional optimizations in place.
*
* SPDX-License-Identifier: Unlicense
*/
/* read a string [ASCII] in a given radix */
int mp_read_radix(mp_int *a, const char *str, int radix)
{
int y, res, neg;
unsigned pos;
char ch;
| > > | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 |
* The library was designed directly after the MPI library by
* Michael Fromberger but has been written from scratch with
* additional optimizations in place.
*
* SPDX-License-Identifier: Unlicense
*/
#define MP_TOUPPER(c) ((((c) >= 'a') && ((c) <= 'z')) ? (((c) + 'A') - 'a') : (c))
/* read a string [ASCII] in a given radix */
int mp_read_radix(mp_int *a, const char *str, int radix)
{
int y, res, neg;
unsigned pos;
char ch;
|
| ︙ | ︙ | |||
42 43 44 45 46 47 48 |
/* process each digit of the string */
while (*str != '\0') {
/* if the radix <= 36 the conversion is case insensitive
* this allows numbers like 1AB and 1ab to represent the same value
* [e.g. in hex]
*/
| | | 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 |
/* process each digit of the string */
while (*str != '\0') {
/* if the radix <= 36 the conversion is case insensitive
* this allows numbers like 1AB and 1ab to represent the same value
* [e.g. in hex]
*/
ch = (radix <= 36) ? (char)MP_TOUPPER((int)*str) : *str;
pos = (unsigned)(ch - '(');
if (mp_s_rmap_reverse_sz < pos) {
break;
}
y = (int)mp_s_rmap_reverse[pos];
/* if the char was found in the map
|
| ︙ | ︙ |
Changes to libtommath/bn_mp_set_double.c.
| ︙ | ︙ | |||
11 12 13 14 15 16 17 |
*
* SPDX-License-Identifier: Unlicense
*/
#if defined(__STDC_IEC_559__) || defined(__GCC_IEC_559)
int mp_set_double(mp_int *a, double b)
{
| | | | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 |
*
* SPDX-License-Identifier: Unlicense
*/
#if defined(__STDC_IEC_559__) || defined(__GCC_IEC_559)
int mp_set_double(mp_int *a, double b)
{
unsigned long long frac;
int exp, res;
union {
double dbl;
unsigned long long bits;
} cast;
cast.dbl = b;
exp = (int)((unsigned)(cast.bits >> 52) & 0x7FFU);
frac = (cast.bits & ((1ULL << 52) - 1ULL)) | (1ULL << 52);
if (exp == 0x7FF) { /* +-inf, NaN */
|
| ︙ | ︙ | |||
37 38 39 40 41 42 43 |
}
res = (exp < 0) ? mp_div_2d(a, -exp, a, NULL) : mp_mul_2d(a, exp, a);
if (res != MP_OKAY) {
return res;
}
| | | | 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 |
}
res = (exp < 0) ? mp_div_2d(a, -exp, a, NULL) : mp_mul_2d(a, exp, a);
if (res != MP_OKAY) {
return res;
}
if (((cast.bits >> 63) != 0ULL) && !IS_ZERO(a)) {
a->sign = MP_NEG;
}
return MP_OKAY;
}
#else
/* pragma message() not supported by several compilers (in mostly older but still used versions) */
# ifdef _MSC_VER
|
| ︙ | ︙ |
Changes to libtommath/bn_mp_shrink.c.
| ︙ | ︙ | |||
19 20 21 22 23 24 25 |
int used = 1;
if (a->used > 0) {
used = a->used;
}
if (a->alloc != used) {
| | > > | 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 |
int used = 1;
if (a->used > 0) {
used = a->used;
}
if (a->alloc != used) {
if ((tmp = (mp_digit *) XREALLOC(a->dp,
(size_t)a->alloc * sizeof (mp_digit),
(size_t)used * sizeof(mp_digit))) == NULL) {
return MP_MEM;
}
a->dp = tmp;
a->alloc = used;
}
return MP_OKAY;
}
|
| ︙ | ︙ |
Changes to libtommath/bn_mp_sqrt.c.
| ︙ | ︙ | |||
10 11 12 13 14 15 16 17 18 19 20 21 22 23 |
* additional optimizations in place.
*
* SPDX-License-Identifier: Unlicense
*/
#ifndef NO_FLOATING_POINT
#include <math.h>
#endif
/* this function is less generic than mp_n_root, simpler and faster */
int mp_sqrt(const mp_int *arg, mp_int *ret)
{
int res;
mp_int t1, t2;
| > > > < > > > < < | 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 |
* additional optimizations in place.
*
* SPDX-License-Identifier: Unlicense
*/
#ifndef NO_FLOATING_POINT
#include <math.h>
#if (DIGIT_BIT != 28) || (FLT_RADIX != 2) || (DBL_MANT_DIG != 53) || (DBL_MAX_EXP != 1024)
#define NO_FLOATING_POINT
#endif
#endif
/* this function is less generic than mp_n_root, simpler and faster */
int mp_sqrt(const mp_int *arg, mp_int *ret)
{
int res;
mp_int t1, t2;
#ifndef NO_FLOATING_POINT
int i, j, k;
volatile double d;
mp_digit dig;
#endif
/* must be positive */
if (arg->sign == MP_NEG) {
return MP_VAL;
}
/* easy out */
if (mp_iszero(arg) == MP_YES) {
mp_zero(ret);
return MP_OKAY;
}
#ifndef NO_FLOATING_POINT
i = (arg->used / 2) - 1;
j = 2 * i;
if ((res = mp_init_size(&t1, i+2)) != MP_OKAY) {
return res;
}
if ((res = mp_init(&t2)) != MP_OKAY) {
goto E2;
}
for (k = 0; k < i; ++k) {
t1.dp[k] = (mp_digit) 0;
}
/* Estimate the square root using the hardware floating point unit. */
d = 0.0;
for (k = arg->used-1; k >= j; --k) {
d = ldexp(d, DIGIT_BIT) + (double)(arg->dp[k]);
}
|
| ︙ | ︙ | |||
92 93 94 95 96 97 98 |
} else {
t1.used = i+1;
t1.dp[i] = ((mp_digit) d) - 1;
}
#else
| | > | | > > > | > | | 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 |
} else {
t1.used = i+1;
t1.dp[i] = ((mp_digit) d) - 1;
}
#else
if ((res = mp_init_copy(&t1, arg)) != MP_OKAY) {
return res;
}
if ((res = mp_init(&t2)) != MP_OKAY) {
goto E2;
}
/* First approx. (not very bad for large arg) */
mp_rshd(&t1, t1.used/2);
#endif
/* t1 > 0 */
if ((res = mp_div(arg, &t1, &t2, NULL)) != MP_OKAY) {
goto E1;
}
|
| ︙ | ︙ |
Changes to libtommath/tommath_private.h.
| ︙ | ︙ | |||
9 10 11 12 13 14 15 | * * SPDX-License-Identifier: Unlicense */ #ifndef TOMMATH_PRIV_H_ #define TOMMATH_PRIV_H_ #include <tommath.h> | < < < < < < < < < < | | | | | | > > > > > | 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 |
*
* SPDX-License-Identifier: Unlicense
*/
#ifndef TOMMATH_PRIV_H_
#define TOMMATH_PRIV_H_
#include <tommath.h>
#ifndef MIN
#define MIN(x, y) (((x) < (y)) ? (x) : (y))
#endif
#ifndef MAX
#define MAX(x, y) (((x) > (y)) ? (x) : (y))
#endif
#ifdef __cplusplus
extern "C" {
#endif
/* define heap macros */
#ifndef XMALLOC
/* default to libc stuff */
# define XMALLOC(size) malloc(size)
# define XFREE(mem, size) free(mem)
# define XREALLOC(mem, oldsize, newsize) realloc(mem, newsize)
#elif 0
/* prototypes for our heap functions */
extern void *XMALLOC(size_t size);
extern void *XREALLOC(void *mem, size_t oldsize, size_t newsize);
extern void XFREE(void *mem, size_t size);
#endif
/* you'll have to tune these... */
#define KARATSUBA_MUL_CUTOFF 80 /* Min. number of digits before Karatsuba multiplication is used. */
#define KARATSUBA_SQR_CUTOFF 120 /* Min. number of digits before Karatsuba squaring is used. */
#define TOOM_MUL_CUTOFF 350 /* no optimal values of these are known yet so set em high */
#define TOOM_SQR_CUTOFF 400
/* size of comba arrays, should be at least 2 * 2**(BITS_PER_WORD - BITS_PER_DIGIT*2) */
#define MP_WARRAY (1u << (((sizeof(mp_word) * CHAR_BIT) - (2 * DIGIT_BIT)) + 1))
/* ---> Basic Manipulations <--- */
#define IS_ZERO(a) ((a)->used == 0)
#define IS_EVEN(a) (((a)->used == 0) || (((a)->dp[0] & 1u) == 0u))
#define IS_ODD(a) (((a)->used > 0) && (((a)->dp[0] & 1u) == 1u))
/* lowlevel functions, do not call! */
int s_mp_add(const mp_int *a, const mp_int *b, mp_int *c);
int s_mp_sub(const mp_int *a, const mp_int *b, mp_int *c);
#define s_mp_mul(a, b, c) s_mp_mul_digs(a, b, c, (a)->used + (b)->used + 1)
int fast_s_mp_mul_digs(const mp_int *a, const mp_int *b, mp_int *c, int digs);
int s_mp_mul_digs(const mp_int *a, const mp_int *b, mp_int *c, int digs);
int fast_s_mp_mul_high_digs(const mp_int *a, const mp_int *b, mp_int *c, int digs);
|
| ︙ | ︙ | |||
81 82 83 84 85 86 87 | extern const char *const mp_s_rmap; extern const unsigned char mp_s_rmap_reverse[]; extern const size_t mp_s_rmap_reverse_sz; /* Fancy macro to set an MPI from another type. * There are several things assumed: | | | | < | < < < < | | | < < | < < > > | < < | | | < | 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 |
extern const char *const mp_s_rmap;
extern const unsigned char mp_s_rmap_reverse[];
extern const size_t mp_s_rmap_reverse_sz;
/* Fancy macro to set an MPI from another type.
* There are several things assumed:
* x is the counter
* a is the pointer to the MPI
* b is the original value that should be set in the MPI.
*/
#define MP_SET_XLONG(func_name, type) \
int func_name (mp_int * a, type b) \
{ \
int x = 0; \
int new_size = (((CHAR_BIT * sizeof(type)) + DIGIT_BIT) - 1) / DIGIT_BIT; \
int res = mp_grow(a, new_size); \
if (res == MP_OKAY) { \
mp_zero(a); \
while (b != 0u) { \
a->dp[x++] = ((mp_digit)b & MP_MASK); \
if ((CHAR_BIT * sizeof (b)) <= DIGIT_BIT) { break; } \
b >>= ((CHAR_BIT * sizeof (b)) <= DIGIT_BIT ? 0 : DIGIT_BIT); \
} \
a->used = x; \
} \
return res; \
}
#ifdef __cplusplus
}
#endif
#endif
/* ref: $Format:%D$ */
/* git commit: $Format:%H$ */
/* commit time: $Format:%ai$ */
|
Changes to tests-perf/test-performance.tcl.
| ︙ | ︙ | |||
90 91 92 93 94 95 96 97 98 99 100 101 |
puts $_(m)
puts "Min:"
puts [lindex $_(itm) $mini]
puts "Max:"
puts [lindex $_(itm) $maxi]
puts [string repeat ** 40]
puts ""
}
proc _test_run {args} {
upvar _ _
# parse args:
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > | > > | > | | | > | > > > | | > > > > > > > > | | | | | | > | > | 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 |
puts $_(m)
puts "Min:"
puts [lindex $_(itm) $mini]
puts "Max:"
puts [lindex $_(itm) $maxi]
puts [string repeat ** 40]
puts ""
unset -nocomplain _(itm) _(starttime)
}
proc _test_start {reptime} {
upvar _ _
array set _ [list itm {} reptime $reptime starttime [clock milliseconds] -from-run 0]
}
proc _test_iter {args} {
if {[llength $args] > 2} {
return -code error "wrong # args: should be \"[lindex [info level [info level]] 0] ?level? measure-result\""
}
set lvl 1
if {[llength $args] > 1} {
set args [lassign $args lvl]
}
upvar $lvl _ _
puts [set _(m) {*}$args]
lappend _(itm) $_(m)
puts ""
}
proc _adjust_maxcount {reptime maxcount} {
if {[llength $reptime] > 1} {
lreplace $reptime 1 1 [expr {min($maxcount,[lindex $reptime 1])}]
} else {
lappend reptime $maxcount
}
}
proc _test_run {args} {
upvar _ _
# parse args:
array set _ [set _opts {-no-result 0 -uplevel 0}]
while {[llength $args] > 2} {
if {[set o [lindex $args 0]] ni $_opts || $_($o)} {
break
}
set _($o) 1
set args [lrange $args 1 end]
}
unset -nocomplain _opts o
if {[llength $args] < 2 || [llength $args] > 3} {
return -code error "wrong # args: should be \"[lindex [info level [info level]] 0] ?-no-result? reptime lst ?outcmd?\""
}
set _(outcmd) {puts}
set args [lassign $args reptime lst]
if {[llength $args]} {
set _(outcmd) [lindex $args 0]
}
# avoid output if only once:
if {[lindex $reptime 0] <= 1 || ([llength $reptime] > 1 && [lindex $reptime 1] == 1)} {
set _(-no-result) 1
}
if {![info exists _(itm)]} {
array set _ [list itm {} reptime $reptime starttime [clock milliseconds] -from-run 1]
} else {
array set _ [list reptime $reptime]
}
# process measurement:
foreach _(c) [_test_get_commands $lst] {
{*}$_(outcmd) "% [regsub -all {\n[ \t]*} $_(c) {; }]"
if {[regexp {^\s*\#} $_(c)]} continue
if {[regexp {^\s*(?:setup|cleanup)\s+} $_(c)]} {
set _(c) [lindex $_(c) 1]
if {$_(-uplevel)} {
set _(c) [list uplevel 1 $_(c)]
}
{*}$_(outcmd) [if 1 $_(c)]
continue
}
if {$_(-uplevel)} {
set _(c) [list uplevel 1 $_(c)]
}
set _(ittime) $_(reptime)
# if output result (and not once):
if {!$_(-no-result)} {
set _(r) [if 1 $_(c)]
if {$_(outcmd) ne {}} {{*}$_(outcmd) $_(r)}
if {[llength $_(ittime)] > 1} { # decrement max-count
lset _(ittime) 1 [expr {[lindex $_(ittime) 1] - 1}]
}
}
{*}$_(outcmd) [set _(m) [timerate $_(c) {*}$_(ittime)]]
lappend _(itm) $_(m)
{*}$_(outcmd) ""
}
if {$_(-from-run)} {
_test_out_total
}
}
}; # end of namespace ::tclTestPerf
|
Changes to tests/basic.test.
| ︙ | ︙ | |||
959 960 961 962 963 964 965 966 967 968 969 970 971 972 |
} -result {0 10 1 Hejsan}
test basic-48.24.$noComp {expansion: empty not canonical list, regression test, bug [cc1e91552c]} -constraints $constraints -setup {
unset -nocomplain a
} -body {
run {list [list {*}{ }] [list {*}[format %c 32]] [list {*}[set a { }]]}
} -result [lrepeat 3 {}] -cleanup {unset -nocomplain a}
} ;# End of noComp loop
test basic-49.1 {Tcl_EvalEx: verify TCL_EVAL_GLOBAL operation} testevalex {
set ::x global
namespace eval ns {
variable x namespace
| > > > > > > > > > > > > | 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 |
} -result {0 10 1 Hejsan}
test basic-48.24.$noComp {expansion: empty not canonical list, regression test, bug [cc1e91552c]} -constraints $constraints -setup {
unset -nocomplain a
} -body {
run {list [list {*}{ }] [list {*}[format %c 32]] [list {*}[set a { }]]}
} -result [lrepeat 3 {}] -cleanup {unset -nocomplain a}
test basic-48.25.$noComp {Bug cc191552c: expansion: empty non-canonical list} -setup {
unset -nocomplain ::CRLF
set ::CRLF "\r\n"
} -body {
# Force variant that turned up in Bug 2c154a40be as that's externally
# noticeable in an important downstream project.
run {scan [list {*}$::CRLF]x %c%c%c}
} -cleanup {
unset -nocomplain ::CRLF
} -result {120 {} {}}
} ;# End of noComp loop
test basic-49.1 {Tcl_EvalEx: verify TCL_EVAL_GLOBAL operation} testevalex {
set ::x global
namespace eval ns {
variable x namespace
|
| ︙ | ︙ |
Changes to tests/clock.test.
| ︙ | ︙ | |||
36703 36704 36705 36706 36707 36708 36709 |
}
}
return $retval
}
}
-body {
set trouble {}
| | | | | | | | | | > > | | 36703 36704 36705 36706 36707 36708 36709 36710 36711 36712 36713 36714 36715 36716 36717 36718 36719 36720 36721 36722 36723 36724 36725 36726 36727 36728 |
}
}
return $retval
}
}
-body {
set trouble {}
foreach {date jdate} {
1872-12-31 \u897f\u66a61872\u5e7412\u670831\u65e5
1873-01-01 \u660e\u6cbb06\u5e7401\u670801\u65e5
1912-07-29 \u660e\u6cbb45\u5e7407\u670829\u65e5
1912-07-30 \u5927\u6b6301\u5e7407\u670830\u65e5
1926-12-24 \u5927\u6b6315\u5e7412\u670824\u65e5
1926-12-25 \u662d\u548c01\u5e7412\u670825\u65e5
1989-01-07 \u662d\u548c64\u5e7401\u670807\u65e5
1989-01-08 \u5e73\u621001\u5e7401\u670808\u65e5
2019-04-30 \u5e73\u621031\u5e7404\u670830\u65e5
2019-05-01 \u4ee4\u548c01\u5e7405\u670801\u65e5
} {
set status [catch {
set secs [clock scan $date \
-timezone +0900 \
-locale ja_JP \
-format %Y-%m-%d]
set jda [clock format $secs \
-timezone +0900 \
|
| ︙ | ︙ |
Changes to tests/cmdIL.test.
| ︙ | ︙ | |||
15 16 17 18 19 20 21 | ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] # Used for constraining memory leak tests testConstraint memory [llength [info commands memory]] testConstraint testobj [llength [info commands testobj]] | | | 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 |
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
# Used for constraining memory leak tests
testConstraint memory [llength [info commands memory]]
testConstraint testobj [llength [info commands testobj]]
test cmdIL-1.1 {Tcl_LsortObjCmd procedure} -returnCodes error -body {
lsort
} -result {wrong # args: should be "lsort ?-option value ...? list"}
test cmdIL-1.2 {Tcl_LsortObjCmd procedure} -returnCodes error -body {
lsort -foo {1 3 2 5}
} -result {bad option "-foo": must be -ascii, -command, -decreasing, -dictionary, -increasing, -index, -indices, -integer, -nocase, -real, -stride, or -unique}
test cmdIL-1.3 {Tcl_LsortObjCmd procedure, default options} {
|
| ︙ | ︙ | |||
769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 |
} -constraints testobj -body {
lreverse [K $y [unset y]]
lindex $x 0
} -cleanup {
unset -nocomplain x y
rename K {}
} -result 1
# This belongs in info test, but adding tests there breaks tests
# that compute source file line numbers.
test info-20.6 {Bug 3587651} -setup {
namespace eval my {namespace eval tcl {namespace eval mathfunc {
proc demo x {return 42}
}}}} -body { namespace eval my {expr {"demo" in [info functions]}}} -cleanup {
namespace delete my
} -result 1
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | < | 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 |
} -constraints testobj -body {
lreverse [K $y [unset y]]
lindex $x 0
} -cleanup {
unset -nocomplain x y
rename K {}
} -result 1
test cmdIL-8.1 {lremove command: error path} -returnCodes error -body {
lremove
} -result {wrong # args: should be "lremove list ?index ...?"}
test cmdIL-8.2 {lremove command: error path} -returnCodes error -body {
lremove {{}{}}
} -result {list element in braces followed by "{}" instead of space}
test cmdIL-8.3 {lremove command: error path} -returnCodes error -body {
lremove {a b c} gorp
} -result {bad index "gorp": must be integer?[+-]integer? or end?[+-]integer?}
test cmdIL-8.4 {lremove command: no indices} -body {
lremove {a b c}
} -result {a b c}
test cmdIL-8.5 {lremove command: before start} -body {
lremove {a b c} -1
} -result {a b c}
test cmdIL-8.6 {lremove command: after end} -body {
lremove {a b c} 3
} -result {a b c}
test cmdIL-8.7 {lremove command} -body {
lremove {a b c} 0
} -result {b c}
test cmdIL-8.8 {lremove command} -body {
lremove {a b c} 1
} -result {a c}
test cmdIL-8.9 {lremove command} -body {
lremove {a b c} end
} -result {a b}
test cmdIL-8.10 {lremove command} -body {
lremove {a b c} end-1
} -result {a c}
test cmdIL-8.11 {lremove command} -body {
lremove {a b c d e} 1 3
} -result {a c e}
test cmdIL-8.12 {lremove command} -body {
lremove {a b c d e} 3 1
} -result {a c e}
test cmdIL-8.13 {lremove command: same index twice} -body {
lremove {a b c d e} 2 2
} -result {a b d e}
test cmdIL-8.14 {lremove command: same index twice} -body {
lremove {a b c d e} 3 end-1
} -result {a b c e}
test cmdIL-8.15 {lremove command: many indices} -body {
lremove {a b c d e} 1 3 1 4 0
} -result {c}
# This belongs in info test, but adding tests there breaks tests
# that compute source file line numbers.
test info-20.6 {Bug 3587651} -setup {
namespace eval my {namespace eval tcl {namespace eval mathfunc {
proc demo x {return 42}
}}}} -body { namespace eval my {expr {"demo" in [info functions]}}} -cleanup {
namespace delete my
} -result 1
# cleanup
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
|
Changes to tests/cmdMZ.test.
| ︙ | ︙ | |||
311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 |
# if not UTF-8 aware, result is "a {} {} b qw\xe5 {} N wq"
split "a\u4e4eb qw\u5e4e\x4e wq" " \u4e4e"
} "a b qw\u5e4eN wq"
# The tests for Tcl_StringObjCmd are in string.test
# The tests for Tcl_SubstObjCmd are in subst.test
# The tests for Tcl_SwitchObjCmd are in switch.test
test cmdMZ-5.1 {Tcl_TimeObjCmd: basic format of command} -body {
time
} -returnCodes error -result {wrong # args: should be "time command ?count?"}
test cmdMZ-5.2 {Tcl_TimeObjCmd: basic format of command} -body {
time a b c
} -returnCodes error -result {wrong # args: should be "time command ?count?"}
test cmdMZ-5.3 {Tcl_TimeObjCmd: basic format of command} -body {
time a b
} -returnCodes error -result {expected integer but got "b"}
test cmdMZ-5.4 {Tcl_TimeObjCmd: nothing happens with negative iteration counts} {
time bogusCmd -12456
} {0 microseconds per iteration}
test cmdMZ-5.5 {Tcl_TimeObjCmd: result format} -body {
time {format 1}
} -match regexp -result {^\d+ microseconds per iteration}
test cmdMZ-5.6 {Tcl_TimeObjCmd: slower commands take longer} {
| > > > > > > > > | | 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 |
# if not UTF-8 aware, result is "a {} {} b qw\xe5 {} N wq"
split "a\u4e4eb qw\u5e4e\x4e wq" " \u4e4e"
} "a b qw\u5e4eN wq"
# The tests for Tcl_StringObjCmd are in string.test
# The tests for Tcl_SubstObjCmd are in subst.test
# The tests for Tcl_SwitchObjCmd are in switch.test
# todo: rewrite this if monotonic clock is provided resp. command "after"
# gets microsecond accuracy (RFE [fdfbd5e10] gets merged):
proc _nrt_sleep {msec} {
set usec [expr {$msec * 1000}]
set stime [clock microseconds]
while {abs([clock microseconds] - $stime) < $usec} {after 0}
}
test cmdMZ-5.1 {Tcl_TimeObjCmd: basic format of command} -body {
time
} -returnCodes error -result {wrong # args: should be "time command ?count?"}
test cmdMZ-5.2 {Tcl_TimeObjCmd: basic format of command} -body {
time a b c
} -returnCodes error -result {wrong # args: should be "time command ?count?"}
test cmdMZ-5.3 {Tcl_TimeObjCmd: basic format of command} -body {
time a b
} -returnCodes error -result {expected integer but got "b"}
test cmdMZ-5.4 {Tcl_TimeObjCmd: nothing happens with negative iteration counts} {
time bogusCmd -12456
} {0 microseconds per iteration}
test cmdMZ-5.5 {Tcl_TimeObjCmd: result format} -body {
time {format 1}
} -match regexp -result {^\d+ microseconds per iteration}
test cmdMZ-5.6 {Tcl_TimeObjCmd: slower commands take longer} {
expr {[lindex [time {_nrt_sleep 1}] 0] < [lindex [time {_nrt_sleep 20}] 0]}
} 1
test cmdMZ-5.7 {Tcl_TimeObjCmd: errors generate right trace} {
list [catch {time {error foo}} msg] $msg $::errorInfo
} {1 foo {foo
while executing
"error foo"
invoked from within
|
| ︙ | ︙ | |||
363 364 365 366 367 368 369 |
test cmdMZ-6.5a {Tcl_TimeRateObjCmd: result format and one iteration} {
regexp {^\d+(?:\.\d+)? \ws/# 1 # \d+(?:\.\d+)? #/sec \d+(?:\.\d+)? nett-ms$} [timerate {} 0]
} 1
test cmdMZ-6.5b {Tcl_TimeRateObjCmd: result format without iterations} {
regexp {^0 \ws/# 0 # 0 #/sec 0 nett-ms$} [timerate {} 0 0]
} 1
test cmdMZ-6.6 {Tcl_TimeRateObjCmd: slower commands take longer, but it remains almost the same time of measument} {
| | | | | | | | | | | > > > > > > > > > > > > > > > > > | 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 |
test cmdMZ-6.5a {Tcl_TimeRateObjCmd: result format and one iteration} {
regexp {^\d+(?:\.\d+)? \ws/# 1 # \d+(?:\.\d+)? #/sec \d+(?:\.\d+)? nett-ms$} [timerate {} 0]
} 1
test cmdMZ-6.5b {Tcl_TimeRateObjCmd: result format without iterations} {
regexp {^0 \ws/# 0 # 0 #/sec 0 nett-ms$} [timerate {} 0 0]
} 1
test cmdMZ-6.6 {Tcl_TimeRateObjCmd: slower commands take longer, but it remains almost the same time of measument} {
set m1 [timerate {_nrt_sleep 0} 20]
set m2 [timerate {_nrt_sleep 0.2} 20]
list \
[expr {[lindex $m1 0] < [lindex $m2 0]}] \
[expr {[lindex $m1 0] < 100}] \
[expr {[lindex $m2 0] > 100}] \
[expr {[lindex $m1 2] > 1000}] \
[expr {[lindex $m2 2] < 1000}] \
[expr {[lindex $m1 4] > 50000}] \
[expr {[lindex $m2 4] < 50000}] \
[expr {[lindex $m1 6] > 10 && [lindex $m1 6] < 100}] \
[expr {[lindex $m2 6] > 10 && [lindex $m2 6] < 100}]
} [lrepeat 9 1]
test cmdMZ-6.7 {Tcl_TimeRateObjCmd: errors generate right trace} {
list [catch {timerate {error foo} 1} msg] $msg $::errorInfo
} {1 foo {foo
while executing
"error foo"
invoked from within
"timerate {error foo} 1"}}
test cmdMZ-6.8 {Tcl_TimeRateObjCmd: allow (conditional) break from timerate} {
set m1 [timerate {break}]
list \
[expr {[lindex $m1 0] < 1000}] \
[expr {[lindex $m1 2] == 1}] \
[expr {[lindex $m1 4] > 1000}] \
[expr {[lindex $m1 6] < 10}]
} {1 1 1 1}
test cmdMZ-6.9 {Tcl_TimeRateObjCmd: max count of iterations} {
set m1 [timerate {} 1000 5]; # max-count wins
set m2 [timerate {_nrt_sleep 20} 1 5]; # max-time wins
list [lindex $m1 2] [lindex $m2 2]
} {5 1}
test cmdMZ-6.10 {Tcl_TimeRateObjCmd: huge overhead cause 0us result} {
set m1 [timerate -overhead 1e6 {_nrt_sleep 10} 100 1]
list \
[expr {[lindex $m1 0] == 0.0}] \
[expr {[lindex $m1 2] == 1}] \
[expr {[lindex $m1 4] == 1000000}] \
[expr {[lindex $m1 6] <= 0.001}]
} {1 1 1 1}
test cmdMZ-try-1.0 {
fix for issue 45b9faf103f2
[try] interaction with local variable names produces segmentation violation
} -body {
::apply {{} {
set cmd try
$cmd {
lindex 5
} on ok res {}
set res
}}
} -result 5
# The tests for Tcl_WhileObjCmd are in while.test
# cleanup
cleanupTests
}
namespace delete ::tcl::test::cmdMZ
return
# Local Variables:
# mode: tcl
# End:
|
Changes to tests/coroutine.test.
| ︙ | ︙ | |||
622 623 624 625 626 627 628 |
test coroutine-7.5 {return codes} {
set result {}
foreach code {0 1 2 3 4 5} {
lappend result [catch {coroutine demo return -level 0 -code $code}]
}
set result
} {0 1 2 3 4 5}
| | > > > > | | | | > > | > > > | > > | > | | | 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 |
test coroutine-7.5 {return codes} {
set result {}
foreach code {0 1 2 3 4 5} {
lappend result [catch {coroutine demo return -level 0 -code $code}]
}
set result
} {0 1 2 3 4 5}
test coroutine-7.6 {Early yield crashes} -setup {
set i [interp create]
} -body {
# Force into a child interpreter [bug 60559fd4a6]
$i eval {
proc foo args {}
trace add execution foo enter {catch yield}
coroutine demo foo
rename foo {}
return ok
}
} -cleanup {
interp delete $i
} -result ok
test coroutine-7.7 {Bug 2486550} -setup {
set i [interp create]
$i hide yield
} -body {
# Force into a child interpreter [bug 60559fd4a6]
$i eval {
coroutine demo interp invokehidden {} yield ok
}
} -cleanup {
$i eval demo
interp delete $i
} -result ok
test coroutine-7.8 {yieldto context nuke: Bug a90d9331bc} -setup {
namespace eval cotest {}
set ::result ""
} -body {
proc cotest::body {} {
lappend ::result a
|
| ︙ | ︙ | |||
777 778 779 780 781 782 783 |
slave eval demo
set result [slave eval {set ::result}]
interp delete slave
set result
} -result {inject-executed}
| > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 |
slave eval demo
set result [slave eval {set ::result}]
interp delete slave
set result
} -result {inject-executed}
test coroutine-9.1 {coro type} {
coroutine demo eval {
yield
yield "PHASE 1"
yieldto string cat "PHASE 2"
::tcl::unsupported::corotype [info coroutine]
}
list [demo] [::tcl::unsupported::corotype demo] \
[demo] [::tcl::unsupported::corotype demo] [demo]
} {{PHASE 1} yield {PHASE 2} yieldto active}
test coroutine-9.2 {coro type} -setup {
catch {rename nosuchcommand ""}
} -returnCodes error -body {
::tcl::unsupported::corotype nosuchcommand
} -result {can only get coroutine type of a coroutine}
test coroutine-9.3 {coro type} -returnCodes error -body {
proc notacoroutine {} {}
::tcl::unsupported::corotype notacoroutine
} -returnCodes error -cleanup {
rename notacoroutine {}
} -result {can only get coroutine type of a coroutine}
test coroutine-10.1 {coroutine general introspection} -setup {
set i [interp create]
} -body {
$i eval {
# Make the introspection code
namespace path tcl::unsupported
proc probe {type var} {
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} {
inject $c probe [corotype $c] $var
$c
}
# Coroutine implementations
proc cbody1 {} {
set val [info coroutine]
set accum {}
while {[set val [yield $val]] ne ""} {
lappend accum $val
set val ok
}
return $accum
}
proc cbody2 {} {
set val [info coroutine]
set accum {}
while {[llength [set val [yieldto string cat $val]]]} {
lappend accum {*}$val
set val ok
}
return $accum
}
# Make the coroutines
coroutine c1 cbody1
coroutine c2 cbody2
list [c1 abc] [c2 1 2 3] [pokecoro c1 accum] [pokecoro c2 accum] \
[c1 def] [c2 4 5 6] [pokecoro c1 accum] [pokecoro c2 accum] \
[c1] [c2]
}
} -cleanup {
interp delete $i
} -result {ok ok {abc ::cbody1} {{1 2 3} ::cbody2} ok ok {{abc def} ::cbody1} {{1 2 3 4 5 6} ::cbody2} {abc def} {1 2 3 4 5 6}}
# cleanup
unset lambda
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
|
Changes to tests/dict.test.
| ︙ | ︙ | |||
2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 |
test dict-25.1 {compiled dict update with low-refcount values [Bug d553228d9f]} {
# Test crashes on failure
apply {{} {
lassign {} item
dict update item item item two two {}
}}
} {}
# cleanup
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 2043 2044 2045 2046 2047 2048 2049 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 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 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 |
test dict-25.1 {compiled dict update with low-refcount values [Bug d553228d9f]} {
# Test crashes on failure
apply {{} {
lassign {} item
dict update item item item two two {}
}}
} {}
set dict dict; # Used to force interpretation, not compilation
test dict-26.1 {dict getdef command} -body {
dict getdef {a b} a c
} -result b
test dict-26.2 {dict getdef command} -body {
dict getdef {a b} b c
} -result c
test dict-26.3 {dict getdef command} -body {
dict getdef {a {b c}} a b d
} -result c
test dict-26.4 {dict getdef command} -body {
dict getdef {a {b c}} a c d
} -result d
test dict-26.5 {dict getdef command} -body {
dict getdef {a {b c}} b c d
} -result d
test dict-26.6 {dict getdef command} -returnCodes error -body {
dict getdef {a {b c d}} a b d
} -result {missing value to go with key}
test dict-26.7 {dict getdef command} -returnCodes error -body {
dict getdef
} -result {wrong # args: should be "dict getdef dictionary ?key ...? key default"}
test dict-26.8 {dict getdef command} -returnCodes error -body {
dict getdef {}
} -result {wrong # args: should be "dict getdef dictionary ?key ...? key default"}
test dict-26.9 {dict getdef command} -returnCodes error -body {
dict getdef {} {}
} -result {wrong # args: should be "dict getdef dictionary ?key ...? key default"}
test dict-26.10 {dict getdef command} -returnCodes error -body {
dict getdef {a b c} d e
} -result {missing value to go with key}
test dict-26.11 {dict getdef command} -body {
$dict getdef {a b} a c
} -result b
test dict-26.12 {dict getdef command} -body {
$dict getdef {a b} b c
} -result c
test dict-26.13 {dict getdef command} -body {
$dict getdef {a {b c}} a b d
} -result c
test dict-26.14 {dict getdef command} -body {
$dict getdef {a {b c}} a c d
} -result d
test dict-26.15 {dict getdef command} -body {
$dict getdef {a {b c}} b c d
} -result d
test dict-26.16 {dict getdef command} -returnCodes error -body {
$dict getdef {a {b c d}} a b d
} -result {missing value to go with key}
test dict-26.17 {dict getdef command} -returnCodes error -body {
$dict getdef {a b c} d e
} -result {missing value to go with key}
test dict-27.1 {dict getwithdefault command} -body {
dict getwithdefault {a b} a c
} -result b
test dict-27.2 {dict getwithdefault command} -body {
dict getwithdefault {a b} b c
} -result c
test dict-27.3 {dict getwithdefault command} -body {
dict getwithdefault {a {b c}} a b d
} -result c
test dict-27.4 {dict getwithdefault command} -body {
dict getwithdefault {a {b c}} a c d
} -result d
test dict-27.5 {dict getwithdefault command} -body {
dict getwithdefault {a {b c}} b c d
} -result d
test dict-27.6 {dict getwithdefault command} -returnCodes error -body {
dict getwithdefault {a {b c d}} a b d
} -result {missing value to go with key}
test dict-27.7 {dict getwithdefault command} -returnCodes error -body {
dict getwithdefault
} -result {wrong # args: should be "dict getwithdefault dictionary ?key ...? key default"}
test dict-27.8 {dict getwithdefault command} -returnCodes error -body {
dict getwithdefault {}
} -result {wrong # args: should be "dict getwithdefault dictionary ?key ...? key default"}
test dict-27.9 {dict getwithdefault command} -returnCodes error -body {
dict getwithdefault {} {}
} -result {wrong # args: should be "dict getwithdefault dictionary ?key ...? key default"}
test dict-27.10 {dict getdef command} -returnCodes error -body {
dict getwithdefault {a b c} d e
} -result {missing value to go with key}
test dict-27.11 {dict getwithdefault command} -body {
$dict getwithdefault {a b} a c
} -result b
test dict-27.12 {dict getwithdefault command} -body {
$dict getwithdefault {a b} b c
} -result c
test dict-27.13 {dict getwithdefault command} -body {
$dict getwithdefault {a {b c}} a b d
} -result c
test dict-27.14 {dict getwithdefault command} -body {
$dict getwithdefault {a {b c}} a c d
} -result d
test dict-27.15 {dict getwithdefault command} -body {
$dict getwithdefault {a {b c}} b c d
} -result d
test dict-27.16 {dict getwithdefault command} -returnCodes error -body {
$dict getwithdefault {a {b c d}} a b d
} -result {missing value to go with key}
test dict-27.17 {dict getdef command} -returnCodes error -body {
$dict getwithdefault {a b c} d e
} -result {missing value to go with key}
# cleanup
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
|
| ︙ | ︙ |
Changes to tests/httpTest.tcl.
| ︙ | ︙ | |||
64 65 66 67 68 69 70 |
::httpTest::LogRecord $txt
::httpTest::Puts $txt
} elseif {$::httpTest::testOptions(-verbose) > 1} {
::httpTest::Puts $txt
}
return
}
| | > > > > | 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 |
::httpTest::LogRecord $txt
::httpTest::Puts $txt
} elseif {$::httpTest::testOptions(-verbose) > 1} {
::httpTest::Puts $txt
}
return
}
# The http::Log routine above needs the variable ::httpTest::testOptions
# Set up to destroy it when that variable goes away.
trace add variable ::httpTest::testOptions unset {apply {args {
proc ::http::Log args {}
}}}
# Called by http::Log (the "testing" version) to record logs for later analysis.
proc httpTest::LogRecord {txt} {
variable testResults
set pos [string first ^ $txt]
|
| ︙ | ︙ |
Changes to tests/info.test.
| ︙ | ︙ | |||
764 765 766 767 768 769 770 |
test info-22.8 {info frame, basic trace} -match glob -body {
join [lrange [etrace] 0 2] \n
} -result {* {type source line 730 file info.test cmd {info frame $level} proc ::etrace level 0}
* {type source line 765 file info.test cmd etrace proc ::tcltest::RunTest}
* {type source line * file tcltest* cmd {uplevel 1 $script} proc ::tcltest::RunTest}}
unset -nocomplain msg
| | | | | | | | | | > | | | | | < | | | | | | 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 |
test info-22.8 {info frame, basic trace} -match glob -body {
join [lrange [etrace] 0 2] \n
} -result {* {type source line 730 file info.test cmd {info frame $level} proc ::etrace level 0}
* {type source line 765 file info.test cmd etrace proc ::tcltest::RunTest}
* {type source line * file tcltest* cmd {uplevel 1 $script} proc ::tcltest::RunTest}}
unset -nocomplain msg
## The line 1967 is off by 5 from the true value of 1972. This is a knownBug, see testcase 30.0
test info-23.0 {eval'd info frame} -constraints {!singleTestInterp} -body {
list [i eval {info frame}] [i eval {eval {info frame}}]
} -setup {interp create i} -cleanup {interp delete i} -result {1 2}
test info-23.1 {eval'd info frame, semi-dynamic} -constraints {!singleTestInterp} -body {
i eval {eval info frame}
} -setup {interp create i} -cleanup {interp delete i} -result 2
test info-23.2 {eval'd info frame, dynamic} -constraints {!singleTestInterp} -body {
i eval { set script {info frame}
eval $script}
} -setup {interp create i} -cleanup {interp delete i} -result 2
test info-23.3 {eval'd info frame, literal} -match glob -body {
eval {
info frame 0
}
} -result {type source line 793 file * cmd {info frame 0} proc ::tcltest::RunTest}
test info-23.4 {eval'd info frame, semi-dynamic} {
eval info frame 0
|
| ︙ | ︙ |
Changes to tests/io.test.
| ︙ | ︙ | |||
5959 5960 5961 5962 5963 5964 5965 5966 5967 5968 5969 5970 5971 5972 |
vwait [namespace which -variable x]
vwait [namespace which -variable x]
close $f4
set x
} {initial foo eof}
close $f
makeFile "foo bar" foo
test io-45.1 {DeleteFileEvent, cleanup on close} {fileevent} {
set f [open $path(foo) r]
fileevent $f readable [namespace code {
lappend x "binding triggered: \"[gets $f]\""
fileevent $f readable {}
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 5959 5960 5961 5962 5963 5964 5965 5966 5967 5968 5969 5970 5971 5972 5973 5974 5975 5976 5977 5978 5979 5980 5981 5982 5983 5984 5985 5986 5987 5988 5989 5990 5991 5992 5993 5994 5995 5996 5997 5998 5999 6000 6001 6002 6003 6004 6005 6006 6007 6008 6009 6010 6011 6012 6013 6014 6015 6016 6017 6018 6019 6020 6021 6022 6023 6024 6025 6026 6027 6028 6029 6030 6031 6032 6033 6034 6035 |
vwait [namespace which -variable x]
vwait [namespace which -variable x]
close $f4
set x
} {initial foo eof}
close $f
test chan-io-44.6 {FileEventProc procedure: write-only non-blocking channel} -setup {
} -constraints {stdio unixExecs fileevent openpipe} -body {
namespace eval refchan {
namespace ensemble create
namespace export *
proc finalize {chan args} {
namespace delete c_$chan
}
proc initialize {chan args} {
namespace eval c_$chan {}
namespace upvar c_$chan watching watching
set watching {}
list finalize initialize seek watch write
}
proc watch {chan args} {
namespace upvar c_$chan watching watching
foreach arg $args {
switch $arg {
write {
if {$arg ni $watching} {
lappend watching $arg
}
chan postevent $chan $arg
}
}
}
}
proc write {chan args} {
chan postevent $chan write
return 1
}
}
set f [chan create w [namespace which refchan]]
chan configure $f -blocking 0
set data "some data"
set x 0
chan event $f writable [namespace code {
puts $f $data
incr count [string length $data]
if {$count > 262144} {
chan event $f writable {}
set x done
}
}]
after 10000 [namespace code {
set x timeout
}]
vwait [namespace which -variable x]
return $x
} -cleanup {
catch {chan close $f}
} -result done
makeFile "foo bar" foo
test io-45.1 {DeleteFileEvent, cleanup on close} {fileevent} {
set f [open $path(foo) r]
fileevent $f readable [namespace code {
lappend x "binding triggered: \"[gets $f]\""
fileevent $f readable {}
|
| ︙ | ︙ |
Changes to tests/ioCmd.test.
| ︙ | ︙ | |||
202 203 204 205 206 207 208 |
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"
| > > > > > > > > | | | | | | | | | | > | > | < | | | | | | | > | > | < | | > > < > | < | | > | > | < | | | | | | > | | < | | > | | < | | > | | < | | 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 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 |
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"
proc expectedOpts {got extra} {
set basicOpts {
-blocking -buffering -buffersize -encoding -eofchar -translation
}
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 channelId ?-option value ...?"}
test iocmd-8.2 {fconfigure command} -returnCodes error -body {
fconfigure a b c d e f
} -result {wrong # args: should be "fconfigure channelId ?-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 {
fconfigure $f1 froboz
} -returnCodes error -cleanup {
close $f1
} -result [expectedOpts "froboz" {}]
test iocmd-8.5 {fconfigure command} -returnCodes error -body {
fconfigure stdin -buffering froboz
} -result {bad value for -buffering: must be one of full, line, or none}
test iocmd-8.6 {fconfigure command} -returnCodes error -body {
fconfigure stdin -translation froboz
} -result {bad value for -translation: must be one of auto, binary, cr, lf, crlf, or platform}
test iocmd-8.7 {fconfigure command} -setup {
file delete $path(test1)
} -body {
set f1 [open $path(test1) w]
fconfigure $f1 -translation lf -eofchar {} -encoding unicode
fconfigure $f1
} -cleanup {
catch {close $f1}
} -result {-blocking 1 -buffering full -buffersize 4096 -encoding unicode -eofchar {} -translation lf}
test iocmd-8.8 {fconfigure command} -setup {
file delete $path(test1)
set x {}
} -body {
set f1 [open $path(test1) w]
fconfigure $f1 -translation lf -buffering line -buffersize 3030 \
-eofchar {} -encoding unicode
lappend x [fconfigure $f1 -buffering]
lappend x [fconfigure $f1]
} -cleanup {
catch {close $f1}
} -result {line {-blocking 1 -buffering line -buffersize 3030 -encoding unicode -eofchar {} -translation lf}}
test iocmd-8.9 {fconfigure command} -setup {
file delete $path(test1)
} -body {
set f1 [open $path(test1) w]
fconfigure $f1 -translation binary -buffering none -buffersize 4040 \
-eofchar {} -encoding binary
fconfigure $f1
} -cleanup {
catch {close $f1}
} -result {-blocking 1 -buffering none -buffersize 4040 -encoding binary -eofchar {} -translation lf}
test iocmd-8.10 {fconfigure command} -returnCodes error -body {
fconfigure a b
} -result {can not find channel named "a"}
set path(fconfigure.dummy) [makeFile {} fconfigure.dummy]
test iocmd-8.11 {fconfigure command} -body {
set chan [open $path(fconfigure.dummy) r]
fconfigure $chan -froboz blarfo
} -returnCodes error -cleanup {
catch {close $chan}
} -result [expectedOpts "-froboz" {}]
test iocmd-8.12 {fconfigure command} -body {
set chan [open $path(fconfigure.dummy) r]
fconfigure $chan -b blarfo
} -returnCodes error -cleanup {
catch {close $chan}
} -result [expectedOpts "-b" {}]
test iocmd-8.13 {fconfigure command} -body {
set chan [open $path(fconfigure.dummy) r]
fconfigure $chan -buffer blarfo
} -returnCodes error -cleanup {
catch {close $chan}
} -result [expectedOpts "-buffer" {}]
removeFile fconfigure.dummy
test iocmd-8.14 {fconfigure command} {
fconfigure stdin -buffers
} 4096
test iocmd-8.15.1 {fconfigure command / tcp channel} -constraints {socket unixOrPc} -setup {
set srv [socket -server iocmdSRV -myaddr 127.0.0.1 0]
set port [lindex [fconfigure $srv -sockname] 2]
proc iocmdSRV {sock ip port} {close $sock}
set cli [socket 127.0.0.1 $port]
} -body {
fconfigure $cli -blah
} -cleanup {
close $cli
close $srv
unset cli srv port
rename iocmdSRV {}
} -returnCodes error -result [expectedOpts "-blah" {-connecting -peername -sockname}]
test iocmd-8.16 {fconfigure command / tcp channel} -constraints socket -setup {
set srv [socket -server iocmdSRV -myaddr 127.0.0.1 0]
set port [lindex [fconfigure $srv -sockname] 2]
proc iocmdSRV {sock ip port} {close $sock}
set cli [socket 127.0.0.1 $port]
} -body {
expr {[lindex [fconfigure $cli -peername] 2] == $port}
|
| ︙ | ︙ | |||
333 334 335 336 337 338 339 |
# might fail if /dev/ttya is unavailable
set tty [open /dev/ttya]
fconfigure $tty -blah blih
} -cleanup {
if {$tty ne ""} {
close $tty
}
| | > > > > > > | | 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 |
# might fail if /dev/ttya is unavailable
set tty [open /dev/ttya]
fconfigure $tty -blah blih
} -cleanup {
if {$tty ne ""} {
close $tty
}
} -returnCodes error -result [expectedOpts "-blah" {-closemode -inputmode -mode -queue -ttystatus -xchar}]
test iocmd-8.19 {fconfigure command / win tty channel} -constraints {nonPortable win} -setup {
set tty ""
} -body {
# might fail early if com1 is unavailable
set tty [open com1]
fconfigure $tty -blah blih
} -cleanup {
if {$tty ne ""} {
close $tty
}
} -returnCodes error -result [expectedOpts "-blah" {-closemode -mode -handshake -pollinterval -sysbuffer -timeout -ttycontrol -xchar}]
test iocmd-8.20 {fconfigure command / win console channel} -constraints {nonPortable win} -setup {
# I don't know how else to open the console, but this is non-portable
set console stdin
} -body {
fconfigure $console -blah blih
} -returnCodes error -result [expectedOpts "-blah" {-inputmode}]
# TODO: Test parsing of serial channel options (nonPortable, since requires an
# open channel to work with).
test iocmd-9.1 {eof command} {
list [catch {eof} msg] $msg $::errorCode
} {1 {wrong # args: should be "eof channelId"} {TCL WRONGARGS}}
test iocmd-9.2 {eof command} {
|
| ︙ | ︙ | |||
908 909 910 911 912 913 914 915 916 917 918 919 920 921 |
return -code return $args
}
proc onfinal {} {
upvar args hargs
if {[lindex $hargs 0] ne "finalize"} {return}
return -code return ""
}
}
# Set everything up in the main thread.
eval $helperscript
# --- --- --- --------- --------- ---------
# method finalize
| > > > > > > > > > > > | 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 |
return -code return $args
}
proc onfinal {} {
upvar args hargs
if {[lindex $hargs 0] ne "finalize"} {return}
return -code return ""
}
proc onwatch {} {
upvar args hargs
lassign $hargs watch chan eventspec
if {$watch ne "watch"} return
foreach spec $eventspec {
chan postevent $chan $spec
}
return
}
}
# Set everything up in the main thread.
eval $helperscript
# --- --- --- --------- --------- ---------
# method finalize
|
| ︙ | ︙ | |||
1980 1981 1982 1983 1984 1985 1986 |
rename foo {}
set res
} -result {{unmatched open brace in list}}
test iocmd-31.6 {chan postevent, posted events do happen} -match glob -body {
set res {}
proc foo {args} {oninit; onfinal; track; return}
set c [chan create {r w} foo]
| > | | | | | | | | > > > > > > > > > > > > > > > > > > > > > > > > > | 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 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 |
rename foo {}
set res
} -result {{unmatched open brace in list}}
test iocmd-31.6 {chan postevent, posted events do happen} -match glob -body {
set res {}
proc foo {args} {oninit; onfinal; track; return}
set c [chan create {r w} foo]
set tock {}
note [fileevent $c readable {lappend res TOCK; set tock 1}]
set stop [after 10000 {lappend res TIMEOUT; set tock 1}]
after 1000 {note [chan postevent $c r]}
vwait ::tock
catch {after cancel $stop}
close $c
rename foo {}
set res
} -result {{watch rc* read} {} {} TOCK {watch rc* {}}}
test iocmd-31.7 {chan postevent, posted events do happen} -match glob -body {
set res {}
proc foo {args} {oninit; onfinal; track; return}
set c [chan create {r w} foo]
note [fileevent $c writable {lappend res TOCK; set tock 1}]
set stop [after 10000 {lappend res TIMEOUT; set tock 1}]
after 1000 {note [chan postevent $c w]}
vwait ::tock
catch {after cancel $stop}
close $c
rename foo {}
set res
} -result {{watch rc* write} {} {} TOCK {watch rc* {}}}
test iocmd-31.8 {chan postevent after close throws error} -match glob -setup {
proc foo {args} {oninit; onfinal; track; return}
proc dummy args { return }
set c [chan create {r w} foo]
fileevent $c readable dummy
} -body {
close $c
chan postevent $c read
} -cleanup {
rename foo {}
rename dummy {}
} -returnCodes error -result {can not find reflected channel named "rc*"}
test iocmd-31.9 {
chan postevent
call to current coroutine
see 67a5eabbd3d1
} -match glob -body {
set res {}
proc foo {args} {oninit; onwatch; onfinal; track; return}
set c [chan create {r w} foo]
after 0 [list ::apply [list c {
coroutine c1 ::apply [list c {
chan event $c readable [list [info coroutine]]
yield
set ::done READING
} [namespace current]] $c
} [namespace current]] $c]
set stop [after 10000 {set done TIMEOUT}]
vwait ::done
catch {after cancel $stop}
lappend res $done
close $c
rename foo {}
set res
} -result {{watch rc* read} READING {watch rc* {}}}
# --- === *** ###########################
# 'Pull the rug' tests. Create channel in a interpreter A, move to
# other interpreter B, destroy the origin interpreter (A) before or
# during access from B. Must not crash, must return proper errors.
test iocmd-32.0 {origin interpreter of moved channel gone} -match glob -body {
|
| ︙ | ︙ |
Changes to tests/link.test.
| ︙ | ︙ | |||
16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 |
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testlink [llength [info commands testlink]]
foreach i {int real bool string} {
unset -nocomplain $i
}
test link-1.1 {reading C variables from Tcl} -constraints {testlink} -setup {
testlink delete
} -body {
testlink set 43 1.23 4 - 12341234 64 250 30000 60000 0xbeefbabe 12321 32123 3.25 1231231234
testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1
list $int $real $bool $string $wide
| > > > > > > > > > > > | 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 |
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testlink [llength [info commands testlink]]
testConstraint testlinkarray [llength [info commands testlinkarray]]
foreach i {int real bool string} {
unset -nocomplain $i
}
test link-0.1 {leak test} {testlink} {
interp create i
load {} Tcltest i
i eval {
testlink create 1 0 0 0 0 0 0 0 0 0 0 0 0 0
namespace delete ::
}
interp delete i
} {}
test link-1.1 {reading C variables from Tcl} -constraints {testlink} -setup {
testlink delete
} -body {
testlink set 43 1.23 4 - 12341234 64 250 30000 60000 0xbeefbabe 12321 32123 3.25 1231231234
testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1
list $int $real $bool $string $wide
|
| ︙ | ︙ | |||
84 85 86 87 88 89 90 |
} -result {1 {can't set "bool": variable must have boolean value} 1}
test link-2.5 {writing bad values into variables} -setup {
testlink delete
} -constraints {testlink} -body {
testlink set 43 1.23 4 - 56785678 64 250 30000 60000 0xbeefbabe 12321 32123 3.25 1231231234
testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1
list [catch {set wide gorp} msg] $msg $bool
| | | 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 |
} -result {1 {can't set "bool": variable must have boolean value} 1}
test link-2.5 {writing bad values into variables} -setup {
testlink delete
} -constraints {testlink} -body {
testlink set 43 1.23 4 - 56785678 64 250 30000 60000 0xbeefbabe 12321 32123 3.25 1231231234
testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1
list [catch {set wide gorp} msg] $msg $bool
} -result {1 {can't set "wide": variable must have wide integer value} 1}
test link-2.6 {writing C variables from Tcl} -constraints {testlink} -setup {
testlink delete
} -body {
testlink set 43 1.21 4 - 56785678 64 250 30000 60000 0xbaadbeef 12321 32123 3.25 1231231234
testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1
set int "+"
set real "+"
|
| ︙ | ︙ | |||
359 360 361 362 363 364 365 |
proc x {} {
upvar wide y
set y abc
}
testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1
testlink set -4 16.3 1 {} 778899 {} {} {} {} {} {} {} {} {}
list [catch x msg] $msg $wide
| | | 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 |
proc x {} {
upvar wide y
set y abc
}
testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1
testlink set -4 16.3 1 {} 778899 {} {} {} {} {} {} {} {} {}
list [catch x msg] $msg $wide
} -result {1 {can't set "y": variable must have wide integer value} 778899}
test link-8.1 {Tcl_UpdateLinkedVar procedure} {testlink} {
proc x args {
global x int real bool string wide
lappend x $args $int $real $bool $string $wide
}
set x {}
|
| ︙ | ︙ | |||
394 395 396 397 398 399 400 401 402 403 404 405 406 407 |
} {}
test link-8.3 {Tcl_UpdateLinkedVar procedure, read-only variable} {testlink} {
testlink create 0 0 0 0 0 0 0 0 0 0 0 0 0 0
list [catch {
testlink update 47 {} {} {} {} {} {} {} {} {} {} {} {} {}
} msg] $msg $int
} {0 {} 47}
catch {testlink set 0 0 0 - 0 0 0 0 0 0 0 0 0 0}
catch {testlink delete}
foreach i {int real bool string wide} {
unset -nocomplain $i
}
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 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 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 |
} {}
test link-8.3 {Tcl_UpdateLinkedVar procedure, read-only variable} {testlink} {
testlink create 0 0 0 0 0 0 0 0 0 0 0 0 0 0
list [catch {
testlink update 47 {} {} {} {} {} {} {} {} {} {} {} {} {}
} msg] $msg $int
} {0 {} 47}
test link-9.1 {linkarray usage messages} -returnCodes error -body {
testlinkarray
} -result {wrong # args: should be "testlinkarray option args"}
test link-9.2 {linkarray usage messages} -returnCodes error -body {
testlinkarray x
} -result {bad option "x": must be update, remove, or create}
test link-9.3 {linkarray usage messages} -body {
testlinkarray update
} -result {}
test link-9.4 {linkarray usage messages} -body {
testlinkarray remove
} -result {}
test link-9.5 {linkarray usage messages} -returnCodes error -body {
testlinkarray create
} -result {wrong # args: should be "testlinkarray create ?-readonly? type size name ?address?"}
test link-9.6 {linkarray usage messages} -returnCodes error -body {
testlinkarray create xx 1 my
} -result {bad type "xx": must be char, uchar, short, ushort, int, uint, long, ulong, wide, uwide, float, double, string, char*, or binary}
test link-9.7 {linkarray usage messages} -returnCodes error -body {
testlinkarray create char* 0 my
} -result {wrong array size given}
test link-10.1 {linkarray char*} -setup {
set mylist [list]
} -body {
testlinkarray create char* 1 ::my(var)
lappend mylist [set ::my(var) ""]
catch {set ::my(var) x} msg
lappend mylist $msg
} -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain my
} -result {{} {can't set "::my(var)": wrong size of char* value}}
test link-10.2 {linkarray char*} -body {
testlinkarray create char* 4 ::my(var)
set ::my(var) x
catch {set ::my(var) xyzz} msg
return $msg
} -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain my
} -result {can't set "::my(var)": wrong size of char* value}
test link-10.3 {linkarray char*} -body {
testlinkarray create -r char* 4 ::my(var)
catch {set ::my(var) x} msg
return $msg
} -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain my
} -result {can't set "::my(var)": linked variable is read-only}
test link-11.1 {linkarray char} -setup {
set mylist [list]
} -body {
testlinkarray create char 1 ::my(var)
catch {set ::my(var) x} msg
lappend mylist $msg
lappend mylist [set ::my(var) 120]
catch {set ::my(var) 1234} msg
lappend mylist $msg
} -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain my
} -result {{can't set "::my(var)": variable must have char value} 120 {can't set "::my(var)": variable must have char value}}
test link-11.2 {linkarray char} -setup {
set mylist [list]
} -body {
testlinkarray create char 4 ::my(var)
catch {set ::my(var) {1 2 3}} msg
lappend mylist $msg
set ::my(var) {1 2 3 4}
lappend mylist $my(var)
} -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain my
} -result {{can't set "::my(var)": wrong dimension} {1 2 3 4}}
test link-11.3 {linkarray char} -body {
testlinkarray create -r char 2 ::my(var)
catch {set ::my(var) {1 2}} msg
return $msg
} -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain my
} -result {can't set "::my(var)": linked variable is read-only}
test link-12.1 {linkarray unsigned char} -setup {
set mylist [list]
} -body {
testlinkarray create uchar 1 ::my(var)
catch {set ::my(var) x} msg
lappend mylist $msg
lappend mylist [set ::my(var) 120]
catch {set ::my(var) 1234} msg
lappend mylist $msg
catch {set ::my(var) -1} msg
lappend mylist $msg
} -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain my
} -result {{can't set "::my(var)": variable must have unsigned char value} 120 {can't set "::my(var)": variable must have unsigned char value} {can't set "::my(var)": variable must have unsigned char value}}
test link-12.2 {linkarray unsigned char} -setup {
set mylist [list]
} -body {
testlinkarray create uchar 4 ::my(var)
catch {set ::my(var) {1 2 3}} msg
lappend mylist $msg
set ::my(var) {1 2 3 4}
lappend mylist $my(var)
} -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain my
} -result {{can't set "::my(var)": wrong dimension} {1 2 3 4}}
test link-12.3 {linkarray unsigned char} -body {
testlinkarray create -r uchar 2 ::my(var)
catch {set ::my(var) {1 2}} msg
return $msg
} -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain my
} -result {can't set "::my(var)": linked variable is read-only}
test link-13.1 {linkarray short} -setup {
set mylist [list]
} -body {
testlinkarray create short 1 ::my(var)
catch {set ::my(var) x} msg
lappend mylist $msg
lappend mylist [set ::my(var) 120]
catch {set ::my(var) 123456} msg
lappend mylist $msg
} -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain my
} -result {{can't set "::my(var)": variable must have short value} 120 {can't set "::my(var)": variable must have short value}}
test link-13.2 {linkarray short} -setup {
set mylist [list]
} -body {
testlinkarray create short 4 ::my(var)
catch {set ::my(var) {1 2 3}} msg
lappend mylist $msg
set ::my(var) {1 2 3 4}
lappend mylist $my(var)
} -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain my
} -result {{can't set "::my(var)": wrong dimension} {1 2 3 4}}
test link-13.3 {linkarray short} -body {
testlinkarray create -r short 2 ::my(var)
catch {set ::my(var) {1 2}} msg
return $msg
} -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain my
} -result {can't set "::my(var)": linked variable is read-only}
test link-14.1 {linkarray unsigned short} -setup {
set mylist [list]
} -body {
testlinkarray create ushort 1 ::my(var)
catch {set ::my(var) x} msg
lappend mylist $msg
lappend mylist [set ::my(var) 120]
catch {set ::my(var) 123456} msg
lappend mylist $msg
catch {set ::my(var) -1} msg
lappend mylist $msg
} -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain my
} -result {{can't set "::my(var)": variable must have unsigned short value} 120 {can't set "::my(var)": variable must have unsigned short value} {can't set "::my(var)": variable must have unsigned short value}}
test link-14.2 {linkarray unsigned short} -setup {
set mylist [list]
} -body {
testlinkarray create ushort 4 ::my(var)
catch {set ::my(var) {1 2 3}} msg
lappend mylist $msg
set ::my(var) {1 2 3 4}
lappend mylist $my(var)
} -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain my
} -result {{can't set "::my(var)": wrong dimension} {1 2 3 4}}
test link-14.3 {linkarray unsigned short} -body {
testlinkarray create -r ushort 2 ::my(var)
catch {set ::my(var) {1 2}} msg
return $msg
} -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain my
} -result {can't set "::my(var)": linked variable is read-only}
test link-15.1 {linkarray int} -setup {
set mylist [list]
} -body {
testlinkarray create int 1 ::my(var)
catch {set ::my(var) x} msg
lappend mylist $msg
lappend mylist [set ::my(var) 120]
catch {set ::my(var) 1e3} msg
lappend mylist $msg
} -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain my
} -result {{can't set "::my(var)": variable must have integer value} 120 {can't set "::my(var)": variable must have integer value}}
test link-15.2 {linkarray int} -setup {
set mylist [list]
} -body {
testlinkarray create int 4 ::my(var)
catch {set ::my(var) {1 2 3}} msg
lappend mylist $msg
set ::my(var) {1 2 3 4}
lappend mylist $my(var)
} -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain my
} -result {{can't set "::my(var)": wrong dimension} {1 2 3 4}}
test link-15.3 {linkarray int} -body {
testlinkarray create -r int 2 ::my(var)
catch {set ::my(var) {1 2}} msg
return $msg
} -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain my
} -result {can't set "::my(var)": linked variable is read-only}
test link-16.1 {linkarray unsigned int} -setup {
set mylist [list]
} -body {
testlinkarray create uint 1 ::my(var)
catch {set ::my(var) x} msg
lappend mylist $msg
lappend mylist [set ::my(var) 120]
catch {set ::my(var) 1e33} msg
lappend mylist $msg
catch {set ::my(var) -1} msg
lappend mylist $msg
} -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain ::my
} -result {{can't set "::my(var)": variable must have unsigned int value} 120 {can't set "::my(var)": variable must have unsigned int value} {can't set "::my(var)": variable must have unsigned int value}}
test link-16.2 {linkarray unsigned int} -setup {
set mylist [list]
} -body {
testlinkarray create uint 4 ::my(var)
catch {set ::my(var) {1 2 3}} msg
lappend mylist $msg
set ::my(var) {1 2 3 4}
lappend mylist $my(var)
} -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain ::my
} -result {{can't set "::my(var)": wrong dimension} {1 2 3 4}}
test link-16.3 {linkarray unsigned int} -body {
testlinkarray create -r uint 2 ::my(var)
catch {set ::my(var) {1 2}} msg
return $msg
} -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain my
} -result {can't set "::my(var)": linked variable is read-only}
test link-17.1 {linkarray long} -setup {
set mylist [list]
} -body {
testlinkarray create long 1 ::my(var)
catch {set ::my(var) x} msg
lappend mylist $msg
lappend mylist [set ::my(var) 120]
catch {set ::my(var) 1e33} msg
lappend mylist $msg
} -match glob -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain my
} -result {{can't set "::my(var)": variable must have * value} 120 {can't set "::my(var)": variable must have * value}}
test link-17.2 {linkarray long} -setup {
set mylist [list]
} -body {
testlinkarray create long 4 ::my(var)
catch {set ::my(var) {1 2 3}} msg
lappend mylist $msg
set ::my(var) {1 2 3 4}
lappend mylist $my(var)
} -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain my
} -result {{can't set "::my(var)": wrong dimension} {1 2 3 4}}
test link-17.3 {linkarray long} -body {
testlinkarray create -r long 2 ::my(var)
catch {set ::my(var) {1 2}} msg
return $msg
} -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain my
} -result {can't set "::my(var)": linked variable is read-only}
test link-18.1 {linkarray unsigned long} -setup {
set mylist [list]
} -body {
testlinkarray create ulong 1 ::my(var)
catch {set ::my(var) x} msg
lappend mylist $msg
lappend mylist [set ::my(var) 120]
catch {set ::my(var) 1e33} msg
lappend mylist $msg
} -match glob -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain my
} -result {{can't set "::my(var)": variable must have unsigned * value} 120 {can't set "::my(var)": variable must have unsigned * value}}
test link-18.2 {linkarray unsigned long} -body {
testlinkarray create ulong 1 ::my(var)
set ::my(var) 120
catch {set ::my(var) -1} msg
return $msg
} -match glob -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain my
} -result {can't set "::my(var)": variable must have unsigned * value}
test link-18.3 {linkarray unsigned long} -setup {
set mylist [list]
} -body {
testlinkarray create ulong 4 ::my(var)
catch {set ::my(var) {1 2 3}} msg
lappend mylist $msg
set ::my(var) {1 2 3 4}
lappend mylist $my(var)
} -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain my
} -result {{can't set "::my(var)": wrong dimension} {1 2 3 4}}
test link-18.4 {linkarray unsigned long} -body {
testlinkarray create -r ulong 2 ::my(var)
catch {set ::my(var) {1 2}} msg
return $msg
} -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain my
} -result {can't set "::my(var)": linked variable is read-only}
test link-19.1 {linkarray wide} -setup {
set mylist [list]
} -body {
testlinkarray create wide 1 ::my(var)
catch {set ::my(var) x} msg
lappend mylist $msg
lappend mylist [set ::my(var) 120]
catch {set ::my(var) 1e33} msg
lappend mylist $msg
} -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain my
} -result {{can't set "::my(var)": variable must have wide integer value} 120 {can't set "::my(var)": variable must have wide integer value}}
test link-19.2 {linkarray wide} -setup {
set mylist [list]
} -body {
testlinkarray create wide 4 ::my(var)
catch {set ::my(var) {1 2 3}} msg
lappend mylist $msg
set ::my(var) {1 2 3 4}
lappend mylist $my(var)
} -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain my
} -result {{can't set "::my(var)": wrong dimension} {1 2 3 4}}
test link-19.3 {linkarray wide} -body {
testlinkarray create -r wide 2 ::my(var)
catch {set ::my(var) {1 2}} msg
return $msg
} -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain my
} -result {can't set "::my(var)": linked variable is read-only}
test link-20.1 {linkarray unsigned wide} -setup {
set mylist [list]
} -body {
testlinkarray create uwide 1 ::my(var)
catch {set ::my(var) x} msg
lappend mylist $msg
lappend mylist [set ::my(var) 120]
catch {set ::my(var) 1e33} msg
lappend mylist $msg
lappend mylist [set ::my(var) 0xbabed00dbabed00d]
} -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain my
} -result {{can't set "::my(var)": variable must have unsigned wide int value} 120 {can't set "::my(var)": variable must have unsigned wide int value} 0xbabed00dbabed00d}
test link-20.2 {linkarray unsigned wide} -body {
testlinkarray create uwide 1 ::my(var)
set ::my(var) 120
catch {set ::my(var) -1} msg
return $msg
} -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain my
} -result {can't set "::my(var)": variable must have unsigned wide int value}
test link-20.3 {linkarray unsigned wide} -setup {
set mylist [list]
} -body {
testlinkarray create uwide 4 ::my(var)
catch {set ::my(var) {1 2 3}} msg
lappend mylist $msg
set ::my(var) {1 2 3 4}
lappend mylist $my(var)
} -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain my
} -result {{can't set "::my(var)": wrong dimension} {1 2 3 4}}
test link-20.4 {linkarray unsigned wide} -body {
testlinkarray create -r uwide 2 ::my(var)
catch {set ::my(var) {1 2}} msg
return $msg
} -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain my
} -result {can't set "::my(var)": linked variable is read-only}
test link-21.1 {linkarray string} -setup {
set mylist [list]
} -body {
testlinkarray create string 1 ::my(var)
lappend mylist [set ::my(var) ""]
lappend mylist [set ::my(var) "xyz"]
lappend mylist $::my(var)
} -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain my
} -result {{} xyz xyz}
test link-21.2 {linkarray string} -body {
testlinkarray create -r string 4 ::my(var)
catch {set ::my(var) x} msg
return $msg
} -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain my
} -result {can't set "::my(var)": linked variable is read-only}
test link-22.1 {linkarray binary} -setup {
set mylist [list]
} -body {
testlinkarray create binary 1 ::my(var)
set ::my(var) x
catch {set ::my(var) xy} msg
lappend mylist $msg
lappend mylist $::my(var)
} -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain my
} -result {{can't set "::my(var)": wrong size of binary value} x}
test link-22.2 {linkarray binary} -setup {
set mylist [list]
} -body {
testlinkarray create binary 4 ::my(var)
catch {set ::my(var) abc} msg
lappend mylist $msg
catch {set ::my(var) abcde} msg
lappend mylist $msg
set ::my(var) abcd
lappend mylist $::my(var)
} -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain my
} -result {{can't set "::my(var)": wrong size of binary value} {can't set "::my(var)": wrong size of binary value} abcd}
test link-22.3 {linkarray binary} -body {
testlinkarray create -r binary 4 ::my(var)
catch {set ::my(var) xyzv} msg
return $msg
} -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain my
} -result {can't set "::my(var)": linked variable is read-only}
catch {testlink set 0 0 0 - 0 0 0 0 0 0 0 0 0 0}
catch {testlink delete}
foreach i {int real bool string wide} {
unset -nocomplain $i
}
|
| ︙ | ︙ |
Changes to tests/oo.test.
| ︙ | ︙ | |||
1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 |
oo::define B deletemethod b
lappend result [C a] [C b] [C c] -
oo::define B renamemethod a b
lappend result [C a] [C b] [C c] -
oo::define B deletemethod b c
lappend result [C a] [C b] [C c]
} -result {A.a,B.a A.b,B.b A.c,B.c - A.a,B.a A.b A.c,B.c - A.a A.b,B.a A.c,B.c - A.a A.b A.c}
test oo-11.1 {OO: cleanup} {
oo::object create foo
set result [list [catch {oo::object create foo} msg] $msg]
lappend result [foo destroy] [oo::object create foo] [foo destroy]
} {1 {can't create object "foo": command already exists with that name} {} ::foo {}}
test oo-11.2 {OO: cleanup} {
| > > > > > > > > > > > > > > > > > > > > > > > > | 1545 1546 1547 1548 1549 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 1576 1577 1578 1579 1580 1581 1582 |
oo::define B deletemethod b
lappend result [C a] [C b] [C c] -
oo::define B renamemethod a b
lappend result [C a] [C b] [C c] -
oo::define B deletemethod b c
lappend result [C a] [C b] [C c]
} -result {A.a,B.a A.b,B.b A.c,B.c - A.a,B.a A.b A.c,B.c - A.a A.b,B.a A.c,B.c - A.a A.b A.c}
test oo-10.4 {OO: invoke and modify} -setup {
oo::class create A {
method a {} {return A.a}
method b {} {return A.b}
method c {} {return A.c}
}
A create B
oo::objdefine B {
method a {} {return [next],B.a}
method b {} {return [next],B.b}
method c {} {return [next],B.c}
}
set result {}
} -cleanup {
A destroy
} -body {
lappend result [B a] [B b] [B c] -
oo::objdefine B deletemethod b
lappend result [B a] [B b] [B c] -
oo::objdefine B renamemethod a b
lappend result [B a] [B b] [B c] -
oo::objdefine B deletemethod b c
lappend result [B a] [B b] [B c]
} -result {A.a,B.a A.b,B.b A.c,B.c - A.a,B.a A.b A.c,B.c - A.a A.b,B.a A.c,B.c - A.a A.b A.c}
test oo-11.1 {OO: cleanup} {
oo::object create foo
set result [list [catch {oo::object create foo} msg] $msg]
lappend result [foo destroy] [oo::object create foo] [foo destroy]
} {1 {can't create object "foo": command already exists with that name} {} ::foo {}}
test oo-11.2 {OO: cleanup} {
|
| ︙ | ︙ | |||
2521 2522 2523 2524 2525 2526 2527 |
} -result {^(\d+) \1$} -match regexp
test oo-16.17 {OO: object introspection: creationid #500} -body {
info object creationid nosuchobject
} -returnCodes error -result {nosuchobject does not refer to an object}
test oo-16.18 {OO: object introspection: creationid #500} -body {
info object creationid
} -returnCodes error -result {wrong # args: should be "info object creationid objName"}
| | | 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 |
} -result {^(\d+) \1$} -match regexp
test oo-16.17 {OO: object introspection: creationid #500} -body {
info object creationid nosuchobject
} -returnCodes error -result {nosuchobject does not refer to an object}
test oo-16.18 {OO: object introspection: creationid #500} -body {
info object creationid
} -returnCodes error -result {wrong # args: should be "info object creationid objName"}
test oo-16.18.1 {OO: object introspection: creationid #500} -body {
info object creationid oo::object gorp
} -returnCodes error -result {wrong # args: should be "info object creationid objName"}
test oo-16.19 {OO: object introspection: creationid #500} -setup {
oo::class create cls
} -body {
set id1 [info object creationid [set o1 [cls new]]]
set id2 [info object creationid [set o2 [cls new]]]
|
| ︙ | ︙ | |||
4067 4068 4069 4070 4071 4072 4073 |
SampleSlot create sampleSlot
}] -body {
list [info level] [sampleSlot -prepend g h i] \
[sampleSlot contents] [sampleSlot ops]
} -cleanup [SampleSlotCleanup {
rename sampleSlot {}
}] -result {0 {} {g h i a b c} {1 Resolve g 1 Resolve h 1 Resolve i 1 Get 1 Set {g h i a b c}}}
| | | 4091 4092 4093 4094 4095 4096 4097 4098 4099 4100 4101 4102 4103 4104 4105 |
SampleSlot create sampleSlot
}] -body {
list [info level] [sampleSlot -prepend g h i] \
[sampleSlot contents] [sampleSlot ops]
} -cleanup [SampleSlotCleanup {
rename sampleSlot {}
}] -result {0 {} {g h i a b c} {1 Resolve g 1 Resolve h 1 Resolve i 1 Get 1 Set {g h i a b c}}}
test oo-32.7 {TIP 516: slots - class test} -setup [SampleSlotSetup {
SampleSlot create sampleSlot
}] -body {
list [info level] [sampleSlot -remove c a] \
[sampleSlot contents] [sampleSlot ops]
} -cleanup [SampleSlotCleanup {
rename sampleSlot {}
}] -result {0 {} b {1 Resolve c 1 Resolve a 1 Get 1 Set b}}
|
| ︙ | ︙ |
Changes to tests/process.test.
| ︙ | ︙ | |||
328 329 330 331 332 333 334 335 336 337 338 |
set pid [exec [interpreter] $path(exit) -1 &]
lindex [tcl::process status -wait $pid] 1
} -match glob -result {1 {child killed: unknown signal} {CHILDKILLED * {unknown signal} {unknown signal}}} -cleanup {
tcl::process purge
tcl::process autopurge 1
}
rename wait_for_file {}
rename signal_exit {}
::tcltest::cleanupTests
return
| > > > | 328 329 330 331 332 333 334 335 336 337 338 339 340 341 |
set pid [exec [interpreter] $path(exit) -1 &]
lindex [tcl::process status -wait $pid] 1
} -match glob -result {1 {child killed: unknown signal} {CHILDKILLED * {unknown signal} {unknown signal}}} -cleanup {
tcl::process purge
tcl::process autopurge 1
}
removeFile $path(exit)
removeFile $path(sleep)
rename wait_for_file {}
rename signal_exit {}
::tcltest::cleanupTests
return
|
Changes to tests/socket.test.
| ︙ | ︙ | |||
125 126 127 128 129 130 131 |
# additional [after]s in some tests that are not needed on systems that fail
# immediately.
set t1 [clock milliseconds]
catch {socket 127.0.0.1 [randport]}
set t2 [clock milliseconds]
set lat2 [expr {($t2-$t1)*3}]
| | | | 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 |
# additional [after]s in some tests that are not needed on systems that fail
# immediately.
set t1 [clock milliseconds]
catch {socket 127.0.0.1 [randport]}
set t2 [clock milliseconds]
set lat2 [expr {($t2-$t1)*3}]
# Use the maximum of the two latency calculations, but at least 200ms
set latency [expr {$lat1 > $lat2 ? $lat1 : $lat2}]
set latency [expr {$latency > 200 ? $latency : 200}]
unset t1 t2 s1 s2 lat1 lat2 server
# If remoteServerIP or remoteServerPort are not set, check in the environment
# variables for externally set values.
#
if {![info exists remoteServerIP]} {
|
| ︙ | ︙ | |||
668 669 670 671 672 673 674 |
set s [socket -server accept 0]
set sock ""
} -body {
set s2 [socket $localhost [lindex [fconfigure $s -sockname] 2]]
vwait sock
puts $s2 one
flush $s2
| | | 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 |
set s [socket -server accept 0]
set sock ""
} -body {
set s2 [socket $localhost [lindex [fconfigure $s -sockname] 2]]
vwait sock
puts $s2 one
flush $s2
after $latency {set x 1}; # Spurious failures in Travis CI, if we do [after idle]
vwait x
fconfigure $sock -blocking 0
set result a:[gets $sock]
lappend result b:[gets $sock]
fconfigure $sock -blocking 1
puts $s2 two
flush $s2
|
| ︙ | ︙ |
Changes to tests/string.test.
| ︙ | ︙ | |||
69 70 71 72 73 74 75 |
interp alias {} run {} try
set constraints {}
}
test string-1.1.$noComp {error conditions} {
list [catch {run {string gorp a b}} msg] $msg
| | | 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 |
interp alias {} run {} try
set constraints {}
}
test string-1.1.$noComp {error conditions} {
list [catch {run {string gorp a b}} msg] $msg
} {1 {unknown or ambiguous subcommand "gorp": must be bytelength, cat, compare, equal, first, index, insert, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}}
test string-1.2.$noComp {error conditions} {
list [catch {run {string}} msg] $msg
} {1 {wrong # args: should be "string subcommand ?arg ...?"}}
test stringComp-1.3.$noComp {error condition - undefined method during compile} {
# We don't want this to complain about 'never' because it may never
# be called, or string may get redefined. This must compile OK.
proc foo {str i} {
|
| ︙ | ︙ | |||
1796 1797 1798 1799 1800 1801 1802 |
} \u1361ABC
test string-20.1.$noComp {string trimright errors} {
list [catch {run {string trimright}} msg] $msg
} {1 {wrong # args: should be "string trimright string ?chars?"}}
test string-20.2.$noComp {string trimright errors} {
list [catch {run {string trimg a}} msg] $msg
| | | 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 |
} \u1361ABC
test string-20.1.$noComp {string trimright errors} {
list [catch {run {string trimright}} msg] $msg
} {1 {wrong # args: should be "string trimright string ?chars?"}}
test string-20.2.$noComp {string trimright errors} {
list [catch {run {string trimg a}} msg] $msg
} {1 {unknown or ambiguous subcommand "trimg": must be bytelength, cat, compare, equal, first, index, insert, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}}
test string-20.3.$noComp {string trimright} {
run {string trimright " XYZ "}
} { XYZ}
test string-20.4.$noComp {string trimright} {
run {string trimright " "}
} {}
test string-20.5.$noComp {string trimright} {
|
| ︙ | ︙ | |||
1855 1856 1857 1858 1859 1860 1861 |
} 3
test string-21.14.$noComp {string wordend, unicode} {
run {string wordend "\uc700\uc700 abc" 8}
} 6
test string-22.1.$noComp {string wordstart} {
list [catch {run {string word a}} msg] $msg
| | | 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 |
} 3
test string-21.14.$noComp {string wordend, unicode} {
run {string wordend "\uc700\uc700 abc" 8}
} 6
test string-22.1.$noComp {string wordstart} {
list [catch {run {string word a}} msg] $msg
} {1 {unknown or ambiguous subcommand "word": must be bytelength, cat, compare, equal, first, index, insert, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}}
test string-22.2.$noComp {string wordstart} {
list [catch {run {string wordstart a}} msg] $msg
} {1 {wrong # args: should be "string wordstart string index"}}
test string-22.3.$noComp {string wordstart} {
list [catch {run {string wordstart a b c}} msg] $msg
} {1 {wrong # args: should be "string wordstart string index"}}
test string-22.4.$noComp {string wordstart} {
|
| ︙ | ︙ | |||
2328 2329 2330 2331 2332 2333 2334 |
test string-30.1.1.$noComp {[Bug ba921a8d98]: string cat} {
run {string cat [set data [binary format a* hello]] [encoding convertto $data] [unset data]}
} hellohello
test string-30.1.2.$noComp {[Bug ba921a8d98]: inplace cat by subst (compiled to "strcat" instruction)} {
run {set x "[set data [binary format a* hello]][encoding convertto $data][unset data]"}
} hellohello
| > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | | | | | | | | | | | | | | | | | | 2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 2355 2356 2357 2358 2359 2360 2361 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 2401 2402 2403 2404 2405 2406 2407 2408 2409 2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 2425 2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 2491 2492 2493 |
test string-30.1.1.$noComp {[Bug ba921a8d98]: string cat} {
run {string cat [set data [binary format a* hello]] [encoding convertto $data] [unset data]}
} hellohello
test string-30.1.2.$noComp {[Bug ba921a8d98]: inplace cat by subst (compiled to "strcat" instruction)} {
run {set x "[set data [binary format a* hello]][encoding convertto $data][unset data]"}
} hellohello
# Note: string-31.* tests use [tcl::string::insert] rather than [string insert]
# to dodge ticket [3397978fff] which would cause all arguments to be shared,
# thereby preventing the optimizations from being tested.
test string-31.1.$noComp {string insert, start of string} {
run {tcl::string::insert 0123 0 _}
} _0123
test string-31.2.$noComp {string insert, middle of string} {
run {tcl::string::insert 0123 2 _}
} 01_23
test string-31.3.$noComp {string insert, end of string} {
run {tcl::string::insert 0123 4 _}
} 0123_
test string-31.4.$noComp {string insert, start of string, end-relative} {
run {tcl::string::insert 0123 end-4 _}
} _0123
test string-31.5.$noComp {string insert, middle of string, end-relative} {
run {tcl::string::insert 0123 end-2 _}
} 01_23
test string-31.6.$noComp {string insert, end of string, end-relative} {
run {tcl::string::insert 0123 end _}
} 0123_
test string-31.7.$noComp {string insert, empty target string} {
run {tcl::string::insert {} 0 _}
} _
test string-31.8.$noComp {string insert, empty insert string} {
run {tcl::string::insert 0123 0 {}}
} 0123
test string-31.9.$noComp {string insert, empty strings} {
run {tcl::string::insert {} 0 {}}
} {}
test string-31.10.$noComp {string insert, negative index} {
run {tcl::string::insert 0123 -1 _}
} _0123
test string-31.11.$noComp {string insert, index beyond end} {
run {tcl::string::insert 0123 5 _}
} 0123_
test string-31.12.$noComp {string insert, start of string, pure byte array} {
run {tcl::string::insert [makeByteArray 0123] 0 [makeByteArray _]}
} _0123
test string-31.13.$noComp {string insert, middle of string, pure byte array} {
run {tcl::string::insert [makeByteArray 0123] 2 [makeByteArray _]}
} 01_23
test string-31.14.$noComp {string insert, end of string, pure byte array} {
run {tcl::string::insert [makeByteArray 0123] 4 [makeByteArray _]}
} 0123_
test string-31.15.$noComp {string insert, pure byte array, neither shared} {
run {tcl::string::insert [makeByteArray 0123] 2 [makeByteArray _]}
} 01_23
test string-31.16.$noComp {string insert, pure byte array, first shared} {
run {tcl::string::insert [makeShared [makeByteArray 0123]] 2\
[makeByteArray _]}
} 01_23
test string-31.17.$noComp {string insert, pure byte array, second shared} {
run {tcl::string::insert [makeByteArray 0123] 2\
[makeShared [makeByteArray _]]}
} 01_23
test string-31.18.$noComp {string insert, pure byte array, both shared} {
run {tcl::string::insert [makeShared [makeByteArray 0123]] 2\
[makeShared [makeByteArray _]]}
} 01_23
test string-31.19.$noComp {string insert, start of string, pure Unicode} {
run {tcl::string::insert [makeUnicode 0123] 0 [makeUnicode _]}
} _0123
test string-31.20.$noComp {string insert, middle of string, pure Unicode} {
run {tcl::string::insert [makeUnicode 0123] 2 [makeUnicode _]}
} 01_23
test string-31.21.$noComp {string insert, end of string, pure Unicode} {
run {tcl::string::insert [makeUnicode 0123] 4 [makeUnicode _]}
} 0123_
test string-31.22.$noComp {string insert, str start, pure Uni, first shared} {
run {tcl::string::insert [makeShared [makeUnicode 0123]] 0 [makeUnicode _]}
} _0123
test string-31.23.$noComp {string insert, string mid, pure Uni, 2nd shared} {
run {tcl::string::insert [makeUnicode 0123] 2 [makeShared [makeUnicode _]]}
} 01_23
test string-31.24.$noComp {string insert, string end, pure Uni, both shared} {
run {tcl::string::insert [makeShared [makeUnicode 0123]] 4\
[makeShared [makeUnicode _]]}
} 0123_
test string-31.25.$noComp {string insert, neither byte array nor Unicode} {
run {tcl::string::insert [makeList a b c] 1 zzzzzz}
} {azzzzzz b c}
test string-32.1.$noComp {string is dict} {
string is dict {a b c d}
} 1
test string-32.1a.$noComp {string is dict} {
string is dict {a b c}
} 0
test string-32.2.$noComp {string is dict} {
string is dict "a \{b c"
} 0
test string-32.3.$noComp {string is dict} {
string is dict {a {b c}d e}
} 0
test string-32.4.$noComp {string is dict} {
string is dict {}
} 1
test string-32.5.$noComp {string is dict} {
string is dict -strict {a b c d}
} 1
test string-32.5a.$noComp {string is dict} {
string is dict -strict {a b c}
} 0
test string-32.6.$noComp {string is dict} {
string is dict -strict "a \{b c"
} 0
test string-32.7.$noComp {string is dict} {
string is dict -strict {a {b c}d e}
} 0
test string-32.8.$noComp {string is dict} {
string is dict -strict {}
} 1
test string-32.9.$noComp {string is dict} {
set x {}
list [string is dict -failindex x {a b c d}] $x
} {1 {}}
test string-32.9a.$noComp {string is dict} {
set x {}
list [string is dict -failindex x {a b c}] $x
} {0 -1}
test string-32.10.$noComp {string is dict} {
set x {}
list [string is dict -failindex x "a \{b c d"] $x
} {0 2}
test string-32.10a.$noComp {string is dict} {
set x {}
list [string is dict -failindex x "a \{b c"] $x
} {0 2}
test string-32.11.$noComp {string is dict} {
set x {}
list [string is dict -failindex x {a b {b c}d e}] $x
} {0 4}
test string-32.12.$noComp {string is dict} {
set x {}
list [string is dict -failindex x {}] $x
} {1 {}}
test string-32.13.$noComp {string is dict} {
set x {}
list [string is dict -failindex x { {b c}d e}] $x
} {0 2}
test string-32.14.$noComp {string is dict} {
set x {}
list [string is dict -failindex x "\uabcd {b c}d e"] $x
} {0 2}
test string-32.15.$noComp {string is dict, valid dict} {
string is dict {a b c d e f}
} 1
test string-32.16.$noComp {string is dict, invalid dict} {
string is dict a
} 0
test string-32.17.$noComp {string is dict, valid dict packed in invalid dict} {
string is dict {{a b c d e f g h}}
} 0
}; # foreach noComp {0 1}
# cleanup
rename MemStress {}
|
| ︙ | ︙ |
Changes to tests/upvar.test.
| ︙ | ︙ | |||
352 353 354 355 356 357 358 359 360 361 362 363 364 365 |
array set upvarArray {}
upvar 0 upvarArray(elem) upvarArrayElemAlias(elem)
} -returnCodes 1 -match glob -result *
test upvar-9.1 {Tcl_UpVar2 procedure} testupvar {
list [catch {testupvar xyz a {} x global} msg] $msg
} {1 {bad level "xyz"}}
test upvar-9.2 {Tcl_UpVar2 procedure} testupvar {
catch {unset a}
catch {unset x}
set a 44
list [catch "testupvar #0 a 1 x global" msg] $msg
} {1 {can't access "a(1)": variable isn't array}}
test upvar-9.3 {Tcl_UpVar2 procedure} testupvar {
| > > > > | 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 |
array set upvarArray {}
upvar 0 upvarArray(elem) upvarArrayElemAlias(elem)
} -returnCodes 1 -match glob -result *
test upvar-9.1 {Tcl_UpVar2 procedure} testupvar {
list [catch {testupvar xyz a {} x global} msg] $msg
} {1 {bad level "xyz"}}
test upvar-9.1.1 {TclGetFrame, via Tcl_UpVar2} testupvar {
apply {{} {testupvar xyz a {} x local; set x foo}}
set a
} foo
test upvar-9.2 {Tcl_UpVar2 procedure} testupvar {
catch {unset a}
catch {unset x}
set a 44
list [catch "testupvar #0 a 1 x global" msg] $msg
} {1 {can't access "a(1)": variable isn't array}}
test upvar-9.3 {Tcl_UpVar2 procedure} testupvar {
|
| ︙ | ︙ |
Changes to tests/utf.test.
| ︙ | ︙ | |||
157 158 159 160 161 162 163 |
} {c}
test utf-8.4 {Tcl_UniCharAtIndex: index > 0} {
string index \u4e4e\u25a\xff\u543 2
} "\uff"
test utf-8.5 {Tcl_UniCharAtIndex: high surrogate} {
string index \ud842 0
} "\ud842"
| | | 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 |
} {c}
test utf-8.4 {Tcl_UniCharAtIndex: index > 0} {
string index \u4e4e\u25a\xff\u543 2
} "\uff"
test utf-8.5 {Tcl_UniCharAtIndex: high surrogate} {
string index \ud842 0
} "\ud842"
test utf-8.6 {Tcl_UniCharAtIndex: low surrogate} {
string index \udc42 0
} "\udc42"
test utf-9.1 {Tcl_UtfAtIndex: index = 0} {
string range abcd 0 2
} {abc}
test utf-9.2 {Tcl_UtfAtIndex: index > 0} {
|
| ︙ | ︙ | |||
188 189 190 191 192 193 194 |
} 1
test utf-10.5 {Tcl_UtfBackslash: stops after 4 hex chars} testbytestring {
expr {"\u4e216" eq "[testbytestring \xe4\xb8\xa1]6"}
} 1
test utf-10.6 {Tcl_UtfBackslash: stops after 5 hex chars} testbytestring {
expr {"\U1e2165" eq "[testbytestring \xf0\x9e\x88\x96]5"}
} 1
| | | | 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 |
} 1
test utf-10.5 {Tcl_UtfBackslash: stops after 4 hex chars} testbytestring {
expr {"\u4e216" eq "[testbytestring \xe4\xb8\xa1]6"}
} 1
test utf-10.6 {Tcl_UtfBackslash: stops after 5 hex chars} testbytestring {
expr {"\U1e2165" eq "[testbytestring \xf0\x9e\x88\x96]5"}
} 1
test utf-10.7 {Tcl_UtfBackslash: stops after 6 hex chars} testbytestring {
expr {"\U10e2165" eq "[testbytestring \xf4\x8e\x88\x96]5"}
} 1
proc bsCheck {char num} {
global errNum
test utf-10.$errNum {backslash substitution} {
scan $char %c value
set value
} $num
incr errNum
}
set errNum 8
bsCheck \b 8
bsCheck \e 101
bsCheck \f 12
bsCheck \n 10
bsCheck \r 13
bsCheck \t 9
bsCheck \v 11
|
| ︙ | ︙ |
Changes to unix/configure.
| ︙ | ︙ | |||
9451 9452 9453 9454 9455 9456 9457 |
else
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $langinfo_ok" >&5
$as_echo "$langinfo_ok" >&6; }
fi
#--------------------------------------------------------------------
| | | | 9451 9452 9453 9454 9455 9456 9457 9458 9459 9460 9461 9462 9463 9464 9465 9466 9467 9468 |
else
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $langinfo_ok" >&5
$as_echo "$langinfo_ok" >&6; }
fi
#--------------------------------------------------------------------
# Check for support of cfmakeraw, chflags and mkstemps functions
#--------------------------------------------------------------------
for ac_func in cfmakeraw chflags mkstemps
do :
as_ac_var=`$as_echo "ac_cv_func_$ac_func" | $as_tr_sh`
ac_fn_c_check_func "$LINENO" "$ac_func" "$as_ac_var"
if eval test \"x\$"$as_ac_var"\" = x"yes"; then :
cat >>confdefs.h <<_ACEOF
#define `$as_echo "HAVE_$ac_func" | $as_tr_cpp` 1
_ACEOF
|
| ︙ | ︙ |
Changes to unix/configure.ac.
| ︙ | ︙ | |||
549 550 551 552 553 554 555 | #-------------------------------------------------------------------- # Check for support of nl_langinfo function #-------------------------------------------------------------------- SC_ENABLE_LANGINFO #-------------------------------------------------------------------- | | | | 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 |
#--------------------------------------------------------------------
# Check for support of nl_langinfo function
#--------------------------------------------------------------------
SC_ENABLE_LANGINFO
#--------------------------------------------------------------------
# Check for support of cfmakeraw, chflags and mkstemps functions
#--------------------------------------------------------------------
AC_CHECK_FUNCS(cfmakeraw chflags mkstemps)
#--------------------------------------------------------------------
# Check for support of isnan() function or macro
#--------------------------------------------------------------------
AC_CACHE_CHECK([isnan], tcl_cv_isnan, [
AC_TRY_LINK([#include <math.h>], [
|
| ︙ | ︙ |
Changes to unix/dltest/Makefile.in.
| ︙ | ︙ | |||
13 14 15 16 17 18 19 | DLTEST_SUFFIX = @DLTEST_SUFFIX@ SRC_DIR = @TCL_SRC_DIR@/unix/dltest BUILD_DIR = @builddir@ TCL_VERSION= @TCL_VERSION@ CFLAGS_DEBUG = @CFLAGS_DEBUG@ CFLAGS_OPTIMIZE = @CFLAGS_OPTIMIZE@ | | | 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 |
DLTEST_SUFFIX = @DLTEST_SUFFIX@
SRC_DIR = @TCL_SRC_DIR@/unix/dltest
BUILD_DIR = @builddir@
TCL_VERSION= @TCL_VERSION@
CFLAGS_DEBUG = @CFLAGS_DEBUG@
CFLAGS_OPTIMIZE = @CFLAGS_OPTIMIZE@
CFLAGS = @CFLAGS_DEFAULT@ @CFLAGS@ -DTCL_NO_DEPRECATED=1
LDFLAGS_DEBUG = @LDFLAGS_DEBUG@
LDFLAGS_OPTIMIZE = @LDFLAGS_OPTIMIZE@
LDFLAGS = @LDFLAGS_DEFAULT@ @LDFLAGS@
CC_SWITCHES = $(CFLAGS) -I${SRC_DIR}/../../generic -DTCL_MEM_DEBUG \
${SHLIB_CFLAGS} -DUSE_TCL_STUBS ${AC_FLAGS}
|
| ︙ | ︙ |
Changes to unix/tclUnixChan.c.
| ︙ | ︙ | |||
44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 | # endif /* !CRTSCTS&CNEW_RTSCTS */ # if !defined(PAREXT) && defined(CMSPAR) # define PAREXT CMSPAR # endif /* !PAREXT&&CMSPAR */ #endif /* HAVE_TERMIOS_H */ /* * Helper macros to make parts of this file clearer. The macros do exactly * what they say on the tin. :-) They also only ever refer to their arguments * once, and so can be used without regard to side effects. */ #define SET_BITS(var, bits) ((var) |= (bits)) #define CLEAR_BITS(var, bits) ((var) &= ~(bits)) /* | > > > > > > > > > > | > > > > > > > > > > > > > | | 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 |
# endif /* !CRTSCTS&CNEW_RTSCTS */
# if !defined(PAREXT) && defined(CMSPAR)
# define PAREXT CMSPAR
# endif /* !PAREXT&&CMSPAR */
#endif /* HAVE_TERMIOS_H */
/*
* The bits supported for describing the closeMode field of TtyState.
*/
enum CloseModeBits {
CLOSE_DEFAULT,
CLOSE_DRAIN,
CLOSE_DISCARD
};
/*
* Helper macros to make parts of this file clearer. The macros do exactly
* what they say on the tin. :-) They also only ever refer to their arguments
* once, and so can be used without regard to side effects.
*/
#define SET_BITS(var, bits) ((var) |= (bits))
#define CLEAR_BITS(var, bits) ((var) &= ~(bits))
/*
* These structures describe per-instance state of file-based and serial-based
* channels.
*/
typedef struct {
Tcl_Channel channel; /* Channel associated with this file. */
int fd; /* File handle. */
int validMask; /* OR'ed combination of TCL_READABLE,
* TCL_WRITABLE, or TCL_EXCEPTION: indicates
* which operations are valid on the file. */
} FileState;
typedef struct {
FileState fileState;
#ifdef SUPPORTS_TTY
int closeMode; /* One of CLOSE_DEFAULT, CLOSE_DRAIN or
* CLOSE_DISCARD. */
int doReset; /* Whether we should do a terminal reset on
* close. */
struct termios initState; /* The state of the terminal when it was
* opened. */
#endif /* SUPPORTS_TTY */
} TtyState;
#ifdef SUPPORTS_TTY
/*
* The following structure is used to set or get the serial port attributes in
* a platform-independant manner.
*/
typedef struct {
int baud;
int parity;
int data;
int stop;
} TtyAttrs;
#endif /* SUPPORTS_TTY */
#define UNSUPPORTED_OPTION(detail) \
if (interp) { \
Tcl_SetObjResult(interp, Tcl_ObjPrintf( \
"%s not supported for this platform", (detail))); \
Tcl_SetErrorCode(interp, "TCL", "UNSUPPORTED", NULL); \
}
|
| ︙ | ︙ | |||
109 110 111 112 113 114 115 116 117 118 119 120 121 122 | int mode, int *errorCode); static int FileTruncateProc(ClientData instanceData, Tcl_WideInt length); static Tcl_WideInt FileWideSeekProc(ClientData instanceData, Tcl_WideInt offset, int mode, int *errorCode); static void FileWatchProc(ClientData instanceData, int mask); #ifdef SUPPORTS_TTY static void TtyGetAttributes(int fd, TtyAttrs *ttyPtr); static int TtyGetOptionProc(ClientData instanceData, Tcl_Interp *interp, const char *optionName, Tcl_DString *dsPtr); static int TtyGetBaud(speed_t speed); static speed_t TtyGetSpeed(int baud); static void TtyInit(int fd); | > > | 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 | int mode, int *errorCode); static int FileTruncateProc(ClientData instanceData, Tcl_WideInt length); static Tcl_WideInt FileWideSeekProc(ClientData instanceData, Tcl_WideInt offset, int mode, int *errorCode); static void FileWatchProc(ClientData instanceData, int mask); #ifdef SUPPORTS_TTY static int TtyCloseProc(ClientData instanceData, Tcl_Interp *interp); static void TtyGetAttributes(int fd, TtyAttrs *ttyPtr); static int TtyGetOptionProc(ClientData instanceData, Tcl_Interp *interp, const char *optionName, Tcl_DString *dsPtr); static int TtyGetBaud(speed_t speed); static speed_t TtyGetSpeed(int baud); static void TtyInit(int fd); |
| ︙ | ︙ | |||
158 159 160 161 162 163 164 |
* This structure describes the channel type structure for serial IO.
* Note that this type is a subclass of the "file" type.
*/
static const Tcl_ChannelType ttyChannelType = {
"tty", /* Type name. */
TCL_CHANNEL_VERSION_5, /* v5 channel */
| | | 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 |
* This structure describes the channel type structure for serial IO.
* Note that this type is a subclass of the "file" type.
*/
static const Tcl_ChannelType ttyChannelType = {
"tty", /* Type name. */
TCL_CHANNEL_VERSION_5, /* v5 channel */
TtyCloseProc, /* Close proc. */
FileInputProc, /* Input proc. */
FileOutputProc, /* Output proc. */
NULL, /* Seek proc. */
TtySetOptionProc, /* Set option proc. */
TtyGetOptionProc, /* Get option proc. */
FileWatchProc, /* Initialize notifier. */
FileGetHandleProc, /* Get OS handles out of channel. */
|
| ︙ | ︙ | |||
306 307 308 309 310 311 312 |
*errorCodePtr = errno;
return -1;
}
/*
*----------------------------------------------------------------------
*
| | | | > | 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 |
*errorCodePtr = errno;
return -1;
}
/*
*----------------------------------------------------------------------
*
* FileCloseProc, TtyCloseProc --
*
* These functions are called from the generic IO level to perform
* channel-type-specific cleanup when a file- or tty-based channel is
* closed.
*
* Results:
* 0 if successful, errno if failed.
*
* Side effects:
* Closes the device of the channel.
*
|
| ︙ | ︙ | |||
343 344 345 346 347 348 349 350 351 352 353 354 355 356 |
if (close(fsPtr->fd) < 0) {
errorCode = errno;
}
}
Tcl_Free(fsPtr);
return errorCode;
}
/*
*----------------------------------------------------------------------
*
* FileSeekProc --
*
* This function is called by the generic IO level to move the access
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
if (close(fsPtr->fd) < 0) {
errorCode = errno;
}
}
Tcl_Free(fsPtr);
return errorCode;
}
#ifdef SUPPORTS_TTY
static int
TtyCloseProc(
ClientData instanceData,
Tcl_Interp *interp)
{
TtyState *ttyPtr = instanceData;
/*
* If we've been asked by the user to drain or flush, do so now.
*/
switch (ttyPtr->closeMode) {
case CLOSE_DRAIN:
tcdrain(ttyPtr->fileState.fd);
break;
case CLOSE_DISCARD:
tcflush(ttyPtr->fileState.fd, TCIOFLUSH);
break;
default:
/* Do nothing */
break;
}
/*
* If we've had our state changed from the default, reset now.
*/
if (ttyPtr->doReset) {
tcsetattr(ttyPtr->fileState.fd, TCSANOW, &ttyPtr->initState);
}
/*
* Delegate to close for files.
*/
return FileCloseProc(instanceData, interp);
}
#endif /* SUPPORTS_TTY */
/*
*----------------------------------------------------------------------
*
* FileSeekProc --
*
* This function is called by the generic IO level to move the access
|
| ︙ | ︙ | |||
574 575 576 577 578 579 580 |
static int
TtySetOptionProc(
ClientData instanceData, /* File state. */
Tcl_Interp *interp, /* For error reporting - can be NULL. */
const char *optionName, /* Which option to set? */
const char *value) /* New value for option. */
{
| | | 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 |
static int
TtySetOptionProc(
ClientData instanceData, /* File state. */
Tcl_Interp *interp, /* For error reporting - can be NULL. */
const char *optionName, /* Which option to set? */
const char *value) /* New value for option. */
{
TtyState *fsPtr = instanceData;
size_t len, vlen;
TtyAttrs tty;
int argc;
const char **argv;
struct termios iostate;
len = strlen(optionName);
|
| ︙ | ︙ | |||
597 598 599 600 601 602 603 | return TCL_ERROR; } /* * system calls results should be checked there. - dl */ | | | | 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 |
return TCL_ERROR;
}
/*
* system calls results should be checked there. - dl
*/
TtySetAttributes(fsPtr->fileState.fd, &tty);
return TCL_OK;
}
/*
* Option -handshake none|xonxoff|rtscts|dtrdsr
*/
if ((len > 1) && (strncmp(optionName, "-handshake", len) == 0)) {
/*
* Reset all handshake options. DTR and RTS are ON by default.
*/
tcgetattr(fsPtr->fileState.fd, &iostate);
CLEAR_BITS(iostate.c_iflag, IXON | IXOFF | IXANY);
#ifdef CRTSCTS
CLEAR_BITS(iostate.c_cflag, CRTSCTS);
#endif /* CRTSCTS */
if (Tcl_UtfNcasecmp(value, "NONE", vlen) == 0) {
/*
* Leave all handshake options disabled.
|
| ︙ | ︙ | |||
641 642 643 644 645 646 647 | "bad value for -handshake: must be one of" " xonxoff, rtscts, dtrdsr or none", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE", "VALUE", NULL); } return TCL_ERROR; } | | | 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 |
"bad value for -handshake: must be one of"
" xonxoff, rtscts, dtrdsr or none", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE",
"VALUE", NULL);
}
return TCL_ERROR;
}
tcsetattr(fsPtr->fileState.fd, TCSADRAIN, &iostate);
return TCL_OK;
}
/*
* Option -xchar {\x11 \x13}
*/
|
| ︙ | ︙ | |||
664 665 666 667 668 669 670 | " two elements with each a single 8-bit character", -1)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "XCHAR", NULL); } Tcl_Free(argv); return TCL_ERROR; } | | | | | | 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 |
" two elements with each a single 8-bit character", -1));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "XCHAR", NULL);
}
Tcl_Free(argv);
return TCL_ERROR;
}
tcgetattr(fsPtr->fileState.fd, &iostate);
iostate.c_cc[VSTART] = argv[0][0];
iostate.c_cc[VSTOP] = argv[1][0];
if (argv[0][0] & 0x80 || argv[1][0] & 0x80) {
Tcl_UniChar character = 0;
int charLen;
charLen = Tcl_UtfToUniChar(argv[0], &character);
if ((character > 0xFF) || argv[0][charLen]) {
goto badXchar;
}
iostate.c_cc[VSTART] = character;
charLen = Tcl_UtfToUniChar(argv[1], &character);
if ((character > 0xFF) || argv[1][charLen]) {
goto badXchar;
}
iostate.c_cc[VSTOP] = character;
}
Tcl_Free(argv);
tcsetattr(fsPtr->fileState.fd, TCSADRAIN, &iostate);
return TCL_OK;
}
/*
* Option -timeout msec
*/
if ((len > 2) && (strncmp(optionName, "-timeout", len) == 0)) {
int msec;
tcgetattr(fsPtr->fileState.fd, &iostate);
if (Tcl_GetInt(interp, value, &msec) != TCL_OK) {
return TCL_ERROR;
}
iostate.c_cc[VMIN] = 0;
iostate.c_cc[VTIME] = (msec==0) ? 0 : (msec<100) ? 1 : (msec+50)/100;
tcsetattr(fsPtr->fileState.fd, TCSADRAIN, &iostate);
return TCL_OK;
}
/*
* Option -ttycontrol {DTR 1 RTS 0 BREAK 0}
*/
|
| ︙ | ︙ | |||
729 730 731 732 733 734 735 | Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE", "VALUE", NULL); } Tcl_Free(argv); return TCL_ERROR; } | | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | 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 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 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 |
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE",
"VALUE", NULL);
}
Tcl_Free(argv);
return TCL_ERROR;
}
ioctl(fsPtr->fileState.fd, TIOCMGET, &control);
for (i = 0; i < argc-1; i += 2) {
if (Tcl_GetBoolean(interp, argv[i+1], &flag) == TCL_ERROR) {
Tcl_Free(argv);
return TCL_ERROR;
}
if (Tcl_UtfNcasecmp(argv[i], "DTR", strlen(argv[i])) == 0) {
if (flag) {
SET_BITS(control, TIOCM_DTR);
} else {
CLEAR_BITS(control, TIOCM_DTR);
}
} else if (Tcl_UtfNcasecmp(argv[i], "RTS", strlen(argv[i])) == 0) {
if (flag) {
SET_BITS(control, TIOCM_RTS);
} else {
CLEAR_BITS(control, TIOCM_RTS);
}
} else if (Tcl_UtfNcasecmp(argv[i], "BREAK", strlen(argv[i])) == 0) {
#if defined(TIOCSBRK) && defined(TIOCCBRK)
if (flag) {
ioctl(fsPtr->fileState.fd, TIOCSBRK, NULL);
} else {
ioctl(fsPtr->fileState.fd, TIOCCBRK, NULL);
}
#else /* TIOCSBRK & TIOCCBRK */
UNSUPPORTED_OPTION("-ttycontrol BREAK");
Tcl_Free(argv);
return TCL_ERROR;
#endif /* TIOCSBRK & TIOCCBRK */
} else {
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad signal \"%s\" for -ttycontrol: must be"
" DTR, RTS or BREAK", argv[i]));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE",
"VALUE", NULL);
}
Tcl_Free(argv);
return TCL_ERROR;
}
} /* -ttycontrol options loop */
ioctl(fsPtr->fileState.fd, TIOCMSET, &control);
Tcl_Free(argv);
return TCL_OK;
#else /* TIOCMGET&TIOCMSET */
UNSUPPORTED_OPTION("-ttycontrol");
#endif /* TIOCMGET&TIOCMSET */
}
/*
* Option -closemode drain|discard
*/
if ((len > 2) && (strncmp(optionName, "-closemode", len) == 0)) {
if (Tcl_UtfNcasecmp(value, "DEFAULT", vlen) == 0) {
fsPtr->closeMode = CLOSE_DEFAULT;
} else if (Tcl_UtfNcasecmp(value, "DRAIN", vlen) == 0) {
fsPtr->closeMode = CLOSE_DRAIN;
} else if (Tcl_UtfNcasecmp(value, "DISCARD", vlen) == 0) {
fsPtr->closeMode = CLOSE_DISCARD;
} else {
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad mode \"%s\" for -closemode: must be"
" default, discard, or drain", value));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE",
"VALUE", NULL);
}
return TCL_ERROR;
}
return TCL_OK;
}
/*
* Option -inputmode normal|password|raw
*/
if ((len > 2) && (strncmp(optionName, "-inputmode", len) == 0)) {
if (tcgetattr(fsPtr->fileState.fd, &iostate) < 0) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't read serial terminal control state: %s",
Tcl_PosixError(interp)));
}
return TCL_ERROR;
}
if (Tcl_UtfNcasecmp(value, "NORMAL", vlen) == 0) {
SET_BITS(iostate.c_iflag, BRKINT | IGNPAR | ISTRIP | ICRNL | IXON);
SET_BITS(iostate.c_oflag, OPOST);
SET_BITS(iostate.c_lflag, ECHO | ECHONL | ICANON | ISIG);
} else if (Tcl_UtfNcasecmp(value, "PASSWORD", vlen) == 0) {
SET_BITS(iostate.c_iflag, BRKINT | IGNPAR | ISTRIP | ICRNL | IXON);
SET_BITS(iostate.c_oflag, OPOST);
CLEAR_BITS(iostate.c_lflag, ECHO);
/*
* Note: password input turns out to be best if you echo the
* newline that the user types. Theoretically we could get users
* to do the processing of this in their scripts, but it always
* feels highly unnatural to do so in practice.
*/
SET_BITS(iostate.c_lflag, ECHONL | ICANON | ISIG);
} else if (Tcl_UtfNcasecmp(value, "RAW", vlen) == 0) {
#ifdef HAVE_CFMAKERAW
cfmakeraw(&iostate);
#else /* !HAVE_CFMAKERAW */
CLEAR_BITS(iostate.c_iflag, IGNBRK | BRKINT | PARMRK | ISTRIP
| INLCR | IGNCR | ICRNL | IXON);
CLEAR_BITS(iostate.c_oflag, OPOST);
CLEAR_BITS(iostate.c_lflag, ECHO | ECHONL | ICANON | ISIG | IEXTEN);
CLEAR_BITS(iostate.c_cflag, CSIZE | PARENB);
SET_BITS(iostate.c_cflag, CS8);
#endif /* HAVE_CFMAKERAW */
} else if (Tcl_UtfNcasecmp(value, "RESET", vlen) == 0) {
/*
* Reset to the initial state, whatever that is.
*/
memcpy(&iostate, &fsPtr->initState, sizeof(struct termios));
} else {
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad mode \"%s\" for -inputmode: must be"
" normal, password, raw, or reset", value));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE",
"VALUE", NULL);
}
return TCL_ERROR;
}
if (tcsetattr(fsPtr->fileState.fd, TCSADRAIN, &iostate) < 0) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't update serial terminal control state: %s",
Tcl_PosixError(interp)));
}
return TCL_ERROR;
}
/*
* If we've changed the state from default, schedule a reset later.
* Note that this specifically does not detect changes made by calling
* an external stty program; that is deliberate, as it maintains
* compatibility with existing code!
*
* This mechanism in Tcl is not intended to be a full replacement for
* what stty does; it just handles a few common cases and tries not to
* leave things in a broken state.
*/
fsPtr->doReset = (memcmp(&iostate, &fsPtr->initState,
sizeof(struct termios)) != 0);
return TCL_OK;
}
return Tcl_BadChannelOption(interp, optionName,
"closemode inputmode mode handshake timeout ttycontrol xchar");
}
/*
*----------------------------------------------------------------------
*
* TtyGetOptionProc --
*
|
| ︙ | ︙ | |||
809 810 811 812 813 814 815 |
static int
TtyGetOptionProc(
ClientData instanceData, /* File state. */
Tcl_Interp *interp, /* For error reporting - can be NULL. */
const char *optionName, /* Option to get. */
Tcl_DString *dsPtr) /* Where to store value(s). */
{
| | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | < | | 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 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 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 |
static int
TtyGetOptionProc(
ClientData instanceData, /* File state. */
Tcl_Interp *interp, /* For error reporting - can be NULL. */
const char *optionName, /* Option to get. */
Tcl_DString *dsPtr) /* Where to store value(s). */
{
TtyState *fsPtr = instanceData;
size_t len;
char buf[3*TCL_INTEGER_SPACE + 16];
int valid = 0; /* Flag if valid option parsed. */
struct termios iostate;
if (optionName == NULL) {
len = 0;
} else {
len = strlen(optionName);
}
/*
* Get option -closemode
*/
if (len == 0) {
Tcl_DStringAppendElement(dsPtr, "-closemode");
}
if (len==0 || (len>1 && strncmp(optionName, "-closemode", len)==0)) {
switch (fsPtr->closeMode) {
case CLOSE_DRAIN:
Tcl_DStringAppendElement(dsPtr, "drain");
break;
case CLOSE_DISCARD:
Tcl_DStringAppendElement(dsPtr, "discard");
break;
default:
Tcl_DStringAppendElement(dsPtr, "default");
break;
}
}
/*
* Get option -inputmode
*
* This is a great simplification of the underlying reality, but actually
* represents what almost all scripts really want to know.
*/
if (len == 0) {
Tcl_DStringAppendElement(dsPtr, "-inputmode");
}
if (len==0 || (len>1 && strncmp(optionName, "-inputmode", len)==0)) {
valid = 1;
if (tcgetattr(fsPtr->fileState.fd, &iostate) < 0) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't read serial terminal control state: %s",
Tcl_PosixError(interp)));
}
return TCL_ERROR;
}
if (iostate.c_lflag & ICANON) {
if (iostate.c_lflag & ECHO) {
Tcl_DStringAppendElement(dsPtr, "normal");
} else {
Tcl_DStringAppendElement(dsPtr, "password");
}
} else {
Tcl_DStringAppendElement(dsPtr, "raw");
}
}
/*
* Get option -mode
*/
if (len == 0) {
Tcl_DStringAppendElement(dsPtr, "-mode");
}
if (len==0 || (len>2 && strncmp(optionName, "-mode", len)==0)) {
TtyAttrs tty;
valid = 1;
TtyGetAttributes(fsPtr->fileState.fd, &tty);
sprintf(buf, "%d,%c,%d,%d", tty.baud, tty.parity, tty.data, tty.stop);
Tcl_DStringAppendElement(dsPtr, buf);
}
/*
* Get option -xchar
*/
if (len == 0) {
Tcl_DStringAppendElement(dsPtr, "-xchar");
Tcl_DStringStartSublist(dsPtr);
}
if (len==0 || (len>1 && strncmp(optionName, "-xchar", len)==0)) {
Tcl_DString ds;
valid = 1;
tcgetattr(fsPtr->fileState.fd, &iostate);
Tcl_DStringInit(&ds);
Tcl_ExternalToUtfDString(NULL, (char *) &iostate.c_cc[VSTART], 1, &ds);
Tcl_DStringAppendElement(dsPtr, Tcl_DStringValue(&ds));
TclDStringClear(&ds);
Tcl_ExternalToUtfDString(NULL, (char *) &iostate.c_cc[VSTOP], 1, &ds);
|
| ︙ | ︙ | |||
869 870 871 872 873 874 875 |
* returned by unnamed [fconfigure chan].
*/
if ((len > 1) && (strncmp(optionName, "-queue", len) == 0)) {
int inQueue=0, outQueue=0, inBuffered, outBuffered;
valid = 1;
| | | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > | | 1096 1097 1098 1099 1100 1101 1102 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 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 |
* returned by unnamed [fconfigure chan].
*/
if ((len > 1) && (strncmp(optionName, "-queue", len) == 0)) {
int inQueue=0, outQueue=0, inBuffered, outBuffered;
valid = 1;
GETREADQUEUE(fsPtr->fileState.fd, inQueue);
GETWRITEQUEUE(fsPtr->fileState.fd, outQueue);
inBuffered = Tcl_InputBuffered(fsPtr->fileState.channel);
outBuffered = Tcl_OutputBuffered(fsPtr->fileState.channel);
sprintf(buf, "%d", inBuffered+inQueue);
Tcl_DStringAppendElement(dsPtr, buf);
sprintf(buf, "%d", outBuffered+outQueue);
Tcl_DStringAppendElement(dsPtr, buf);
}
#if defined(TIOCMGET)
/*
* Get option -ttystatus
* Option is readonly and returned by [fconfigure chan -ttystatus] but not
* returned by unnamed [fconfigure chan].
*/
if ((len > 4) && (strncmp(optionName, "-ttystatus", len) == 0)) {
int status;
valid = 1;
ioctl(fsPtr->fileState.fd, TIOCMGET, &status);
TtyModemStatusStr(status, dsPtr);
}
#endif /* TIOCMGET */
#if defined(TIOCGWINSZ)
/*
* Get option -winsize
* Option is readonly and returned by [fconfigure chan -winsize] but not
* returned by [fconfigure chan] without explicit option name.
*/
if ((len > 1) && (strncmp(optionName, "-winsize", len) == 0)) {
struct winsize ws;
valid = 1;
if (ioctl(fsPtr->fileState.fd, TIOCGWINSZ, &ws) < 0) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't read terminal size: %s",
Tcl_PosixError(interp)));
}
return TCL_ERROR;
}
sprintf(buf, "%d", ws.ws_col);
Tcl_DStringAppendElement(dsPtr, buf);
sprintf(buf, "%d", ws.ws_row);
Tcl_DStringAppendElement(dsPtr, buf);
}
#endif /* TIOCGWINSZ */
if (valid) {
return TCL_OK;
}
return Tcl_BadChannelOption(interp, optionName,
"closemode inputmode mode queue ttystatus winsize xchar");
}
static const struct {int baud; speed_t speed;} speeds[] = {
#ifdef B0
{0, B0},
#endif
#ifdef B50
|
| ︙ | ︙ | |||
1371 1372 1373 1374 1375 1376 1377 |
* NULL. */
Tcl_Obj *pathPtr, /* Name of file to open. */
int mode, /* POSIX open mode. */
int permissions) /* If the open involves creating a file, with
* what modes to create it? */
{
int fd, channelPermissions;
| | | 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 |
* NULL. */
Tcl_Obj *pathPtr, /* Name of file to open. */
int mode, /* POSIX open mode. */
int permissions) /* If the open involves creating a file, with
* what modes to create it? */
{
int fd, channelPermissions;
TtyState *fsPtr;
const char *native, *translation;
char channelName[16 + TCL_INTEGER_SPACE];
const Tcl_ChannelType *channelTypePtr;
switch (mode & (O_RDONLY | O_WRONLY | O_RDWR)) {
case O_RDONLY:
channelPermissions = TCL_READABLE;
|
| ︙ | ︙ | |||
1427 1428 1429 1430 1431 1432 1433 |
/*
* Set close-on-exec flag on the fd so that child processes will not
* inherit this fd.
*/
fcntl(fd, F_SETFD, FD_CLOEXEC);
| < < > > | | | > > > > > | > > | | | | | | 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 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 |
/*
* Set close-on-exec flag on the fd so that child processes will not
* inherit this fd.
*/
fcntl(fd, F_SETFD, FD_CLOEXEC);
#ifdef SUPPORTS_TTY
if (strcmp(native, "/dev/tty") != 0 && isatty(fd)) {
/*
* Initialize the serial port to a set of sane parameters. Especially
* important if the remote device is set to echo and the serial port
* driver was also set to echo -- as soon as a char were sent to the
* serial port, the remote device would echo it, then the serial
* driver would echo it back to the device, etc.
*
* Note that we do not do this if we're dealing with /dev/tty itself,
* as that tends to cause Bad Things To Happen when you're working
* interactively. Strictly a better check would be to see if the FD
* being set up is a device and has the same major/minor as the
* initial std FDs (beware reopening!) but that's nearly as messy.
*/
translation = "auto crlf";
channelTypePtr = &ttyChannelType;
TtyInit(fd);
sprintf(channelName, "serial%d", fd);
} else
#endif /* SUPPORTS_TTY */
{
translation = NULL;
channelTypePtr = &fileChannelType;
sprintf(channelName, "file%d", fd);
}
fsPtr = Tcl_Alloc(sizeof(TtyState));
fsPtr->fileState.validMask = channelPermissions | TCL_EXCEPTION;
fsPtr->fileState.fd = fd;
#ifdef SUPPORTS_TTY
if (channelTypePtr == &ttyChannelType) {
fsPtr->closeMode = CLOSE_DEFAULT;
fsPtr->doReset = 0;
tcgetattr(fsPtr->fileState.fd, &fsPtr->initState);
}
#endif /* SUPPORTS_TTY */
fsPtr->fileState.channel = Tcl_CreateChannel(channelTypePtr, channelName,
fsPtr, channelPermissions);
if (translation != NULL) {
/*
* Gotcha. Most modems need a "\r" at the end of the command sequence.
* If you just send "at\n", the modem will not respond with "OK"
* because it never got a "\r" to actually invoke the command. So, by
* default, newlines are translated to "\r\n" on output to avoid "bug"
* reports that the serial port isn't working.
*/
if (Tcl_SetChannelOption(interp, fsPtr->fileState.channel,
"-translation", translation) != TCL_OK) {
Tcl_Close(NULL, fsPtr->fileState.channel);
return NULL;
}
}
return fsPtr->fileState.channel;
}
/*
*----------------------------------------------------------------------
*
* Tcl_MakeFileChannel --
*
|
| ︙ | ︙ | |||
1503 1504 1505 1506 1507 1508 1509 |
Tcl_Channel
Tcl_MakeFileChannel(
ClientData handle, /* OS level handle. */
int mode) /* ORed combination of TCL_READABLE and
* TCL_WRITABLE to indicate file mode. */
{
| | > | | > > | | | | | > | | | | > > > > > | > > | | 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 |
Tcl_Channel
Tcl_MakeFileChannel(
ClientData handle, /* OS level handle. */
int mode) /* ORed combination of TCL_READABLE and
* TCL_WRITABLE to indicate file mode. */
{
TtyState *fsPtr;
char channelName[16 + TCL_INTEGER_SPACE];
int fd = PTR2INT(handle);
const Tcl_ChannelType *channelTypePtr;
struct stat buf;
if (mode == 0) {
return NULL;
}
#ifdef SUPPORTS_TTY
if (isatty(fd)) {
channelTypePtr = &ttyChannelType;
sprintf(channelName, "serial%d", fd);
} else
#endif /* SUPPORTS_TTY */
if (fstat(fd, &buf) == 0 && S_ISSOCK(buf.st_mode)) {
struct sockaddr sockaddr;
socklen_t sockaddrLen = sizeof(sockaddr);
sockaddr.sa_family = AF_UNSPEC;
if ((getsockname(fd, (struct sockaddr *)&sockaddr, &sockaddrLen) == 0)
&& (sockaddrLen > 0)
&& (sockaddr.sa_family == AF_INET
|| sockaddr.sa_family == AF_INET6)) {
return TclpMakeTcpClientChannelMode(INT2PTR(fd), mode);
}
goto normalChannelAfterAll;
} else {
normalChannelAfterAll:
channelTypePtr = &fileChannelType;
sprintf(channelName, "file%d", fd);
}
fsPtr = Tcl_Alloc(sizeof(TtyState));
fsPtr->fileState.fd = fd;
fsPtr->fileState.validMask = mode | TCL_EXCEPTION;
fsPtr->fileState.channel = Tcl_CreateChannel(channelTypePtr, channelName,
fsPtr, mode);
#ifdef SUPPORTS_TTY
if (channelTypePtr == &ttyChannelType) {
fsPtr->closeMode = CLOSE_DEFAULT;
fsPtr->doReset = 0;
tcgetattr(fsPtr->fileState.fd, &fsPtr->initState);
}
#endif /* SUPPORTS_TTY */
return fsPtr->fileState.channel;
}
/*
*----------------------------------------------------------------------
*
* TclpGetDefaultStdChannel --
*
|
| ︙ | ︙ |
Changes to win/tclWinConsole.c.
| ︙ | ︙ | |||
27 28 29 30 31 32 33 | TCL_DECLARE_MUTEX(consoleMutex) /* * Bit masks used in the flags field of the ConsoleInfo structure below. */ | | | > > | 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 | TCL_DECLARE_MUTEX(consoleMutex) /* * Bit masks used in the flags field of the ConsoleInfo structure below. */ #define CONSOLE_PENDING (1<<0) /* Message is pending in the queue. */ #define CONSOLE_ASYNC (1<<1) /* Channel is non-blocking. */ #define CONSOLE_READ_OPS (1<<4) /* Channel supports read-related ops. */ #define CONSOLE_RESET (1<<5) /* Console mode needs to be reset. */ /* * Bit masks used in the sharedFlags field of the ConsoleInfo structure below. */ #define CONSOLE_EOF (1<<2) /* Console has reached EOF. */ #define CONSOLE_BUFFERED (1<<3) /* Data was read into a buffer by the reader |
| ︙ | ︙ | |||
98 99 100 101 102 103 104 105 106 107 108 109 110 111 |
int toWrite; /* Current amount to be written. Access is
* synchronized with the writable object. */
int readFlags; /* Flags that are shared with the reader
* thread. Access is synchronized with the
* readable object. */
int bytesRead; /* Number of bytes in the buffer. */
int offset; /* Number of bytes read out of the buffer. */
char buffer[CONSOLE_BUFFER_SIZE];
/* Data consumed by reader thread. */
} ConsoleInfo;
typedef struct {
/*
* The following pointer refers to the head of the list of consoles that
| > | 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 |
int toWrite; /* Current amount to be written. Access is
* synchronized with the writable object. */
int readFlags; /* Flags that are shared with the reader
* thread. Access is synchronized with the
* readable object. */
int bytesRead; /* Number of bytes in the buffer. */
int offset; /* Number of bytes read out of the buffer. */
DWORD initMode; /* Initial console mode. */
char buffer[CONSOLE_BUFFER_SIZE];
/* Data consumed by reader thread. */
} ConsoleInfo;
typedef struct {
/*
* The following pointer refers to the head of the list of consoles that
|
| ︙ | ︙ | |||
140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 | static void ConsoleCheckProc(ClientData clientData, int flags); static int ConsoleCloseProc(ClientData instanceData, Tcl_Interp *interp); static int ConsoleEventProc(Tcl_Event *evPtr, int flags); static void ConsoleExitHandler(ClientData clientData); static int ConsoleGetHandleProc(ClientData instanceData, int direction, ClientData *handlePtr); static void ConsoleInit(void); static int ConsoleInputProc(ClientData instanceData, char *buf, int toRead, int *errorCode); static int ConsoleOutputProc(ClientData instanceData, const char *buf, int toWrite, int *errorCode); static DWORD WINAPI ConsoleReaderThread(LPVOID arg); static void ConsoleSetupProc(ClientData clientData, int flags); static void ConsoleWatchProc(ClientData instanceData, int mask); static DWORD WINAPI ConsoleWriterThread(LPVOID arg); static void ProcExitHandler(ClientData clientData); static int WaitForRead(ConsoleInfo *infoPtr, int blocking); static void ConsoleThreadActionProc(ClientData instanceData, int action); | > > > > > > | 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 | static void ConsoleCheckProc(ClientData clientData, int flags); static int ConsoleCloseProc(ClientData instanceData, Tcl_Interp *interp); static int ConsoleEventProc(Tcl_Event *evPtr, int flags); static void ConsoleExitHandler(ClientData clientData); static int ConsoleGetHandleProc(ClientData instanceData, int direction, ClientData *handlePtr); static int ConsoleGetOptionProc(ClientData instanceData, Tcl_Interp *interp, const char *optionName, Tcl_DString *dsPtr); static void ConsoleInit(void); static int ConsoleInputProc(ClientData instanceData, char *buf, int toRead, int *errorCode); static int ConsoleOutputProc(ClientData instanceData, const char *buf, int toWrite, int *errorCode); static DWORD WINAPI ConsoleReaderThread(LPVOID arg); static int ConsoleSetOptionProc(ClientData instanceData, Tcl_Interp *interp, const char *optionName, const char *value); static void ConsoleSetupProc(ClientData clientData, int flags); static void ConsoleWatchProc(ClientData instanceData, int mask); static DWORD WINAPI ConsoleWriterThread(LPVOID arg); static void ProcExitHandler(ClientData clientData); static int WaitForRead(ConsoleInfo *infoPtr, int blocking); static void ConsoleThreadActionProc(ClientData instanceData, int action); |
| ︙ | ︙ | |||
171 172 173 174 175 176 177 |
static const Tcl_ChannelType consoleChannelType = {
"console", /* Type name. */
TCL_CHANNEL_VERSION_5, /* v5 channel */
ConsoleCloseProc, /* Close proc. */
ConsoleInputProc, /* Input proc. */
ConsoleOutputProc, /* Output proc. */
NULL, /* Seek proc. */
| | | | 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 |
static const Tcl_ChannelType consoleChannelType = {
"console", /* Type name. */
TCL_CHANNEL_VERSION_5, /* v5 channel */
ConsoleCloseProc, /* Close proc. */
ConsoleInputProc, /* Input proc. */
ConsoleOutputProc, /* Output proc. */
NULL, /* Seek proc. */
ConsoleSetOptionProc, /* Set option proc. */
ConsoleGetOptionProc, /* Get option proc. */
ConsoleWatchProc, /* Set up notifier to watch the channel. */
ConsoleGetHandleProc, /* Get an OS handle from channel. */
NULL, /* close2proc. */
ConsoleBlockModeProc, /* Set blocking or non-blocking mode. */
NULL, /* Flush proc. */
NULL, /* Handler proc. */
NULL, /* Wide seek proc. */
|
| ︙ | ︙ | |||
563 564 565 566 567 568 569 570 571 572 573 574 575 576 |
TclPipeThreadStop(&consolePtr->writer.TI, consolePtr->writer.thread);
CloseHandle(consolePtr->writer.thread);
CloseHandle(consolePtr->writer.readyEvent);
consolePtr->writer.thread = NULL;
}
consolePtr->validMask &= ~TCL_WRITABLE;
/*
* Don't close the Win32 handle if the handle is a standard channel during
* the thread exit process. Otherwise, one thread may kill the stdio of
* another.
*/
| > > > > > > > > > > > | 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 |
TclPipeThreadStop(&consolePtr->writer.TI, consolePtr->writer.thread);
CloseHandle(consolePtr->writer.thread);
CloseHandle(consolePtr->writer.readyEvent);
consolePtr->writer.thread = NULL;
}
consolePtr->validMask &= ~TCL_WRITABLE;
/*
* If the user has been tinkering with the mode, reset it now. We ignore
* any errors from this; we're quite possibly about to close or exit
* anyway.
*/
if ((consolePtr->flags & CONSOLE_READ_OPS) &&
(consolePtr->flags & CONSOLE_RESET)) {
SetConsoleMode(consolePtr->handle, consolePtr->initMode);
}
/*
* Don't close the Win32 handle if the handle is a standard channel during
* the thread exit process. Otherwise, one thread may kill the stdio of
* another.
*/
|
| ︙ | ︙ | |||
586 587 588 589 590 591 592 |
consolePtr->watchMask &= consolePtr->validMask;
/*
* Remove the file from the list of watched files.
*/
| | | 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 |
consolePtr->watchMask &= consolePtr->validMask;
/*
* Remove the file from the list of watched files.
*/
for (nextPtrPtr = &tsdPtr->firstConsolePtr, infoPtr = *nextPtrPtr;
infoPtr != NULL;
nextPtrPtr = &infoPtr->nextPtr, infoPtr = *nextPtrPtr) {
if (infoPtr == (ConsoleInfo *) consolePtr) {
*nextPtrPtr = infoPtr->nextPtr;
break;
}
}
|
| ︙ | ︙ | |||
1328 1329 1330 1331 1332 1333 1334 |
if (permissions & TCL_READABLE) {
/*
* Make sure the console input buffer is ready for only character
* input notifications and the buffer is set for line buffering. IOW,
* we only want to catch when complete lines are ready for reading.
*/
| > | > | 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 |
if (permissions & TCL_READABLE) {
/*
* Make sure the console input buffer is ready for only character
* input notifications and the buffer is set for line buffering. IOW,
* we only want to catch when complete lines are ready for reading.
*/
infoPtr->flags |= CONSOLE_READ_OPS;
GetConsoleMode(infoPtr->handle, &infoPtr->initMode);
modes = infoPtr->initMode;
modes &= ~(ENABLE_WINDOW_INPUT | ENABLE_MOUSE_INPUT);
modes |= ENABLE_LINE_INPUT;
SetConsoleMode(infoPtr->handle, modes);
infoPtr->reader.readyEvent = CreateEvent(NULL, TRUE, TRUE, NULL);
infoPtr->reader.thread = CreateThread(NULL, 256, ConsoleReaderThread,
TclPipeThreadCreateTI(&infoPtr->reader.TI, infoPtr,
|
| ︙ | ︙ | |||
1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 |
infoPtr->threadId = Tcl_GetChannelThread(infoPtr->channel);
}
} else {
infoPtr->threadId = NULL;
}
Tcl_MutexUnlock(&consoleMutex);
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 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 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 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 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 1646 1647 1648 1649 1650 1651 1652 |
infoPtr->threadId = Tcl_GetChannelThread(infoPtr->channel);
}
} else {
infoPtr->threadId = NULL;
}
Tcl_MutexUnlock(&consoleMutex);
}
/*
*----------------------------------------------------------------------
*
* ConsoleSetOptionProc --
*
* Sets an option on a channel.
*
* Results:
* A standard Tcl result. Also sets the interp's result on error if
* interp is not NULL.
*
* Side effects:
* May modify an option on a console. Sets Error message if needed (by
* calling Tcl_BadChannelOption).
*
*----------------------------------------------------------------------
*/
static int
ConsoleSetOptionProc(
ClientData instanceData, /* File state. */
Tcl_Interp *interp, /* For error reporting - can be NULL. */
const char *optionName, /* Which option to set? */
const char *value) /* New value for option. */
{
ConsoleInfo *infoPtr = instanceData;
int len = strlen(optionName);
int vlen = strlen(value);
/*
* Option -inputmode normal|password|raw
*/
if ((infoPtr->flags & CONSOLE_READ_OPS) && (len > 1) &&
(strncmp(optionName, "-inputmode", len) == 0)) {
DWORD mode;
if (GetConsoleMode(infoPtr->handle, &mode) == 0) {
TclWinConvertError(GetLastError());
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't read console mode: %s",
Tcl_PosixError(interp)));
}
return TCL_ERROR;
}
if (Tcl_UtfNcasecmp(value, "NORMAL", vlen) == 0) {
mode |= ENABLE_ECHO_INPUT | ENABLE_LINE_INPUT;
} else if (Tcl_UtfNcasecmp(value, "PASSWORD", vlen) == 0) {
mode |= ENABLE_LINE_INPUT;
mode &= ~ENABLE_ECHO_INPUT;
} else if (Tcl_UtfNcasecmp(value, "RAW", vlen) == 0) {
mode &= ~(ENABLE_ECHO_INPUT | ENABLE_LINE_INPUT);
} else if (Tcl_UtfNcasecmp(value, "RESET", vlen) == 0) {
/*
* Reset to the initial mode, whatever that is.
*/
mode = infoPtr->initMode;
} else {
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad mode \"%s\" for -inputmode: must be"
" normal, password, raw, or reset", value));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE",
"VALUE", NULL);
}
return TCL_ERROR;
}
if (SetConsoleMode(infoPtr->handle, mode) == 0) {
TclWinConvertError(GetLastError());
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't set console mode: %s",
Tcl_PosixError(interp)));
}
return TCL_ERROR;
}
/*
* If we've changed the mode from default, schedule a reset later.
*/
if (mode == infoPtr->initMode) {
infoPtr->flags &= ~CONSOLE_RESET;
} else {
infoPtr->flags |= CONSOLE_RESET;
}
return TCL_OK;
}
if (infoPtr->flags & CONSOLE_READ_OPS) {
return Tcl_BadChannelOption(interp, optionName, "inputmode");
} else {
return Tcl_BadChannelOption(interp, optionName, "");
}
}
/*
*----------------------------------------------------------------------
*
* ConsoleGetOptionProc --
*
* Gets a mode associated with an IO channel. If the optionName arg is
* non-NULL, retrieves the value of that option. If the optionName arg is
* NULL, retrieves a list of alternating option names and values for the
* given channel.
*
* Results:
* A standard Tcl result. Also sets the supplied DString to the string
* value of the option(s) returned. Sets error message if needed
* (by calling Tcl_BadChannelOption).
*
*----------------------------------------------------------------------
*/
static int
ConsoleGetOptionProc(
ClientData instanceData, /* File state. */
Tcl_Interp *interp, /* For error reporting - can be NULL. */
const char *optionName, /* Option to get. */
Tcl_DString *dsPtr) /* Where to store value(s). */
{
ConsoleInfo *infoPtr = instanceData;
int valid = 0; /* Flag if valid option parsed. */
unsigned int len;
char buf[TCL_INTEGER_SPACE];
if (optionName == NULL) {
len = 0;
} else {
len = strlen(optionName);
}
/*
* Get option -inputmode
*
* This is a great simplification of the underlying reality, but actually
* represents what almost all scripts really want to know.
*/
if (infoPtr->flags & CONSOLE_READ_OPS) {
if (len == 0) {
Tcl_DStringAppendElement(dsPtr, "-inputmode");
}
if (len==0 || (len>1 && strncmp(optionName, "-inputmode", len)==0)) {
DWORD mode;
valid = 1;
if (GetConsoleMode(infoPtr->handle, &mode) == 0) {
TclWinConvertError(GetLastError());
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't read console mode: %s",
Tcl_PosixError(interp)));
}
return TCL_ERROR;
}
if (mode & ENABLE_LINE_INPUT) {
if (mode & ENABLE_ECHO_INPUT) {
Tcl_DStringAppendElement(dsPtr, "normal");
} else {
Tcl_DStringAppendElement(dsPtr, "password");
}
} else {
Tcl_DStringAppendElement(dsPtr, "raw");
}
}
}
/*
* Get option -winsize
* Option is readonly and returned by [fconfigure chan -winsize] but not
* returned by [fconfigure chan] without explicit option name.
*/
if ((len > 1) && (strncmp(optionName, "-winsize", len) == 0)) {
CONSOLE_SCREEN_BUFFER_INFO consoleInfo;
valid = 1;
if (!GetConsoleScreenBufferInfo(infoPtr->handle, &consoleInfo)) {
TclWinConvertError(GetLastError());
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't read console size: %s",
Tcl_PosixError(interp)));
}
return TCL_ERROR;
}
sprintf(buf, "%d",
consoleInfo.srWindow.Right - consoleInfo.srWindow.Left + 1);
Tcl_DStringAppendElement(dsPtr, buf);
sprintf(buf, "%d",
consoleInfo.srWindow.Bottom - consoleInfo.srWindow.Top + 1);
Tcl_DStringAppendElement(dsPtr, buf);
}
if (valid) {
return TCL_OK;
}
if (infoPtr->flags & CONSOLE_READ_OPS) {
return Tcl_BadChannelOption(interp, optionName, "inputmode winsize");
} else {
return Tcl_BadChannelOption(interp, optionName, "");
}
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to win/tclWinFile.c.
| ︙ | ︙ | |||
676 677 678 679 680 681 682 |
const WCHAR *linkDirPath, /* The junction to read */
REPARSE_DATA_BUFFER *buffer,/* Pointer to buffer. Cannot be NULL */
DWORD desiredAccess)
{
HANDLE hFile;
DWORD returnedLength;
| | > | 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 |
const WCHAR *linkDirPath, /* The junction to read */
REPARSE_DATA_BUFFER *buffer,/* Pointer to buffer. Cannot be NULL */
DWORD desiredAccess)
{
HANDLE hFile;
DWORD returnedLength;
hFile = CreateFile(linkDirPath, desiredAccess, FILE_SHARE_READ, NULL,
OPEN_EXISTING,
FILE_FLAG_OPEN_REPARSE_POINT | FILE_FLAG_BACKUP_SEMANTICS, NULL);
if (hFile == INVALID_HANDLE_VALUE) {
/*
* Error creating directory.
*/
|
| ︙ | ︙ | |||
828 829 830 831 832 833 834 |
OutputDebugStringW(msgString);
} else {
MessageBeep(MB_ICONEXCLAMATION);
MessageBoxW(NULL, msgString, L"Fatal Error",
MB_ICONSTOP | MB_OK | MB_TASKMODAL | MB_SETFOREGROUND);
}
}
| | | 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 |
OutputDebugStringW(msgString);
} else {
MessageBeep(MB_ICONEXCLAMATION);
MessageBoxW(NULL, msgString, L"Fatal Error",
MB_ICONSTOP | MB_OK | MB_TASKMODAL | MB_SETFOREGROUND);
}
}
/*
*---------------------------------------------------------------------------
*
* TclpFindExecutable --
*
* This function computes the absolute path name of the current
* application.
|
| ︙ | ︙ | |||
1426 1427 1428 1429 1430 1431 1432 |
Tcl_DStringInit(bufferPtr);
wDomain = NULL;
domain = Tcl_UtfFindFirst(name, '@');
if (domain == NULL) {
const char *ptr;
| > | > > | | < > | > > | | > | > > > > | > > | > > > > > > | > > | | > > | 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 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 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 |
Tcl_DStringInit(bufferPtr);
wDomain = NULL;
domain = Tcl_UtfFindFirst(name, '@');
if (domain == NULL) {
const char *ptr;
/*
* No domain. Firstly check it's the current user
*/
ptr = TclpGetUserName(&ds);
if (ptr != NULL && strcasecmp(name, ptr) == 0) {
/*
* Try safest and fastest way to get current user home
*/
ptr = TclGetEnv("HOME", &ds);
if (ptr != NULL) {
Tcl_JoinPath(1, &ptr, bufferPtr);
rc = 1;
result = Tcl_DStringValue(bufferPtr);
}
}
Tcl_DStringFree(&ds);
} else {
Tcl_DStringInit(&ds);
wName = TclUtfToWCharDString(domain + 1, -1, &ds);
rc = NetGetDCName(NULL, wName, (LPBYTE *) &wDomain);
Tcl_DStringFree(&ds);
nameLen = domain - name;
}
if (rc == 0) {
Tcl_DStringInit(&ds);
wName = TclUtfToWCharDString(name, nameLen, &ds);
while (NetUserGetInfo(wDomain, wName, 1, (LPBYTE *) &uiPtr) != 0) {
/*
* User does not exist; if domain was not specified, try again
* using current domain.
*/
rc = 1;
if (domain != NULL) {
break;
}
/*
* Get current domain
*/
rc = NetGetDCName(NULL, NULL, (LPBYTE *) &wDomain);
if (rc != 0) {
break;
}
domain = INT2PTR(-1); /* repeat once */
}
if (rc == 0) {
DWORD i, size = MAX_PATH;
wHomeDir = uiPtr->usri1_home_dir;
if ((wHomeDir != NULL) && (wHomeDir[0] != L'\0')) {
size = lstrlenW(wHomeDir);
TclWCharToUtfDString(wHomeDir, size, bufferPtr);
} else {
/*
* User exists but has no home dir. Return
* "{GetProfilesDirectory}/<user>".
*/
GetProfilesDirectoryW(buf, &size);
TclWCharToUtfDString(buf, size-1, bufferPtr);
Tcl_DStringAppend(bufferPtr, "/", 1);
Tcl_DStringAppend(bufferPtr, name, nameLen);
}
result = Tcl_DStringValue(bufferPtr);
/*
* Be sure we return normalized path
*/
for (i = 0; i < size; ++i) {
if (result[i] == '\\') {
result[i] = '/';
}
}
NetApiBufferFree((void *) uiPtr);
}
Tcl_DStringFree(&ds);
}
if (wDomain != NULL) {
NetApiBufferFree((void *) wDomain);
|
| ︙ | ︙ | |||
1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 |
return 0;
}
/*
* If it's not a directory (assume file), do several fast checks:
*/
if (!(attr & FILE_ATTRIBUTE_DIRECTORY)) {
/*
* If the attributes say this is not writable at all. The file is a
* regular file (i.e., not a directory), then the file is not
| > | | | > > | > > > > | > > > | > > | > > | > | > | | > > | > > > > | > > | 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 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 |
return 0;
}
/*
* If it's not a directory (assume file), do several fast checks:
*/
if (!(attr & FILE_ATTRIBUTE_DIRECTORY)) {
/*
* If the attributes say this is not writable at all. The file is a
* regular file (i.e., not a directory), then the file is not
* writable, full stop. For directories, the read-only bit is
* (mostly) ignored by Windows, so we can't ascertain anything about
* directory access from the attrib data. However, if we have the
* advanced 'getFileSecurityProc', then more robust ACL checks will be
* done below.
*/
if ((mode & W_OK) && (attr & FILE_ATTRIBUTE_READONLY)) {
Tcl_SetErrno(EACCES);
return -1;
}
/*
* If doesn't have the correct extension, it can't be executable
*/
if ((mode & X_OK) && !NativeIsExec(nativePath)) {
Tcl_SetErrno(EACCES);
return -1;
}
/*
* Special case for read/write/executable check on file
*/
if ((mode & (R_OK|W_OK|X_OK)) && !(mode & ~(R_OK|W_OK|X_OK))) {
DWORD mask = 0;
HANDLE hFile;
if (mode & R_OK) {
mask |= GENERIC_READ;
}
if (mode & W_OK) {
mask |= GENERIC_WRITE;
}
if (mode & X_OK) {
mask |= GENERIC_EXECUTE;
}
hFile = CreateFile(nativePath, mask,
FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE,
NULL, OPEN_EXISTING, FILE_FLAG_NO_BUFFERING, NULL);
if (hFile != INVALID_HANDLE_VALUE) {
CloseHandle(hFile);
return 0;
}
/*
* Fast exit if access was denied
*/
if (GetLastError() == ERROR_ACCESS_DENIED) {
Tcl_SetErrno(EACCES);
return -1;
}
}
/*
* We cannnot verify the access fast, check it below using security
* info.
*/
}
/*
* It looks as if the permissions are ok, but if we are on NT, 2000 or XP,
* we have a more complex permissions structure so we try to check that.
* The code below is remarkably complex for such a simple thing as finding
* what permissions the OS has set for a file.
|
| ︙ | ︙ | |||
1984 1985 1986 1987 1988 1989 1990 |
/*
* If we can use 'createFile' on this, then we can use the resulting
* fileHandle to read more information (nlink, ino) than we can get from
* other attributes reading APIs. If not, then we try to fall back on the
* 'getFileAttributesExProc', and if that isn't available, then on even
* simpler routines.
*
| | | | | | | < > > | > > | 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 |
/*
* If we can use 'createFile' on this, then we can use the resulting
* fileHandle to read more information (nlink, ino) than we can get from
* other attributes reading APIs. If not, then we try to fall back on the
* 'getFileAttributesExProc', and if that isn't available, then on even
* simpler routines.
*
* Special consideration must be given to Windows hardcoded names like
* CON, NULL, COM1, LPT1 etc. For these, we still need to do the
* CreateFile as some may not exist (e.g. there is no CON in wish by
* default). However the subsequent GetFileInformationByHandle will
* fail. We do a WinIsReserved to see if it is one of the special names,
* and if successful, mock up a BY_HANDLE_FILE_INFORMATION structure.
*/
fileHandle = CreateFile(nativePath, GENERIC_READ,
FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE,
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);
|
| ︙ | ︙ | |||
2291 2292 2293 2294 2295 2296 2297 |
if (GetCurrentDirectory(MAX_PATH, buffer) == 0) {
TclWinConvertError(GetLastError());
return NULL;
}
if (clientData != NULL) {
| | | 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 2355 |
if (GetCurrentDirectory(MAX_PATH, buffer) == 0) {
TclWinConvertError(GetLastError());
return NULL;
}
if (clientData != NULL) {
if (wcscmp((const WCHAR *) clientData, buffer) == 0) {
return clientData;
}
}
return TclNativeDupInternalRep(buffer);
}
|
| ︙ | ︙ | |||
2519 2520 2521 2522 2523 2524 2525 |
}
}
Tcl_DStringAppend(&dsNorm,
(const char *)nativePath,
(int)(sizeof(WCHAR) * len));
lastValidPathEnd = currentPathEndPosition;
} else if (nextCheckpoint == 0) {
| > | | | > | | | | | < | | | 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 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 |
}
}
Tcl_DStringAppend(&dsNorm,
(const char *)nativePath,
(int)(sizeof(WCHAR) * len));
lastValidPathEnd = currentPathEndPosition;
} else if (nextCheckpoint == 0) {
/*
* Path starts with a drive designation that's not
* actually on the system. We still must normalize up
* past the first separator. [Bug 3603434]
*/
currentPathEndPosition++;
}
}
Tcl_DStringFree(&ds);
break;
}
/*
* File 'nativePath' does exist if we get here. We now want to
* check if it is a symlink and otherwise continue with the
* rest of the path.
*/
/*
* Check for symlinks, except at last component of path (we don't
* follow final symlinks). Also a drive (C:/) for example, may
* sometimes have the reparse flag set for some reason I don't
* understand. We therefore don't perform this check for drives.
*/
if (cur != 0 && !isDrive &&
data.dwFileAttributes & FILE_ATTRIBUTE_REPARSE_POINT){
Tcl_Obj *to = WinReadLinkDirectory(nativePath);
if (to != NULL) {
/*
* Read the reparse point ok. Now, reparse points need not
* be normalized, otherwise we could use:
*
* Tcl_GetStringFromObj(to, &pathLen);
* nextCheckpoint = pathLen;
*
* So, instead we have to start from the beginning.
*/
|
| ︙ | ︙ | |||
2591 2592 2593 2594 2595 2596 2597 | Tcl_DStringFree(&ds); continue; } } #ifndef TclNORM_LONG_PATH /* | | | | | 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 |
Tcl_DStringFree(&ds);
continue;
}
}
#ifndef TclNORM_LONG_PATH
/*
* Now we convert the tail of the current path to its 'long form',
* and append it to 'dsNorm' which holds the current normalized
* path
*/
if (isDrive) {
WCHAR drive = ((WCHAR *) nativePath)[0];
if (drive >= L'a') {
drive -= (L'a' - L'A');
|
| ︙ | ︙ | |||
2622 2623 2624 2625 2626 2627 2628 |
checkDots++;
}
}
if (checkDots != NULL) {
int dotLen = currentPathEndPosition-lastValidPathEnd;
/*
| | | | | | < | 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 |
checkDots++;
}
}
if (checkDots != NULL) {
int dotLen = currentPathEndPosition-lastValidPathEnd;
/*
* Path is just dots. We shouldn't really ever see a path
* like that. However, to be nice we at least don't mangle
* the path - we just add the dots as a path segment and
* continue.
*/
Tcl_DStringAppend(&dsNorm, ((const char *)nativePath)
+ Tcl_DStringLength(&ds)
- (dotLen * sizeof(WCHAR)),
dotLen * sizeof(WCHAR));
} else {
/*
* Normal path.
*/
WIN32_FIND_DATAW fData;
HANDLE handle;
handle = FindFirstFileW((WCHAR *) nativePath, &fData);
if (handle == INVALID_HANDLE_VALUE) {
/*
* This is usually the '/' in 'c:/' at end of string.
*/
Tcl_DStringAppend(&dsNorm, (const char *) L"/",
sizeof(WCHAR));
} else {
WCHAR *nativeName;
|
| ︙ | ︙ | |||
2674 2675 2676 2677 2678 2679 2680 |
Tcl_DStringFree(&ds);
lastValidPathEnd = currentPathEndPosition;
if (cur == 0) {
break;
}
/*
| | | | 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734 2735 2736 2737 2738 2739 |
Tcl_DStringFree(&ds);
lastValidPathEnd = currentPathEndPosition;
if (cur == 0) {
break;
}
/*
* If we get here, we've got past one directory delimiter, so we
* know it is no longer a drive.
*/
isDrive = 0;
}
currentPathEndPosition++;
#ifdef TclNORM_LONG_PATH
|
| ︙ | ︙ | |||
2969 2970 2971 2972 2973 2974 2975 |
* shorter so the utf-to-external conversion will be somewhat faster).
*/
validPathPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr);
if (validPathPtr == NULL) {
return NULL;
}
| > > | > > > > | > > > > | > > > > | > > > | | > > > > | > > | | > > | | | | > | > | | < | | | | > | | > | | > | | > | | | | | > | | | > < | 3019 3020 3021 3022 3023 3024 3025 3026 3027 3028 3029 3030 3031 3032 3033 3034 3035 3036 3037 3038 3039 3040 3041 3042 3043 3044 3045 3046 3047 3048 3049 3050 3051 3052 3053 3054 3055 3056 3057 3058 3059 3060 3061 3062 3063 3064 3065 3066 3067 3068 3069 3070 3071 3072 3073 3074 3075 3076 3077 3078 3079 3080 3081 3082 3083 3084 3085 3086 3087 3088 3089 3090 3091 3092 3093 3094 3095 3096 3097 3098 3099 3100 3101 3102 3103 3104 3105 3106 3107 3108 3109 3110 3111 3112 3113 3114 3115 3116 3117 3118 3119 3120 3121 3122 3123 3124 3125 3126 3127 3128 3129 3130 3131 3132 3133 3134 3135 3136 3137 3138 3139 3140 3141 3142 3143 3144 3145 3146 3147 3148 3149 3150 |
* shorter so the utf-to-external conversion will be somewhat faster).
*/
validPathPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr);
if (validPathPtr == NULL) {
return NULL;
}
/*
* refCount of validPathPtr was already incremented in
* Tcl_FSGetTranslatedPath
*/
} else {
/*
* Make sure the normalized path is set.
*/
validPathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr);
if (validPathPtr == NULL) {
return NULL;
}
/*
* validPathPtr returned from Tcl_FSGetNormalizedPath is owned by Tcl,
* so incr refCount here
*/
Tcl_IncrRefCount(validPathPtr);
}
str = TclGetStringFromObj(validPathPtr, &len);
if (strlen(str) != len) {
/*
* String contains NUL-bytes. This is invalid.
*/
goto done;
}
/*
* For a reserved device, strip a possible postfix ':'
*/
len = WinIsReserved(str);
if (len == 0) {
/*
* Let MultiByteToWideChar check for other invalid sequences, like
* 0xC0 0x80 (== overlong NUL). See bug [3118489]: NUL in filenames
*/
len = MultiByteToWideChar(CP_UTF8, MB_ERR_INVALID_CHARS, str, -1, 0, 0);
if (len==0) {
goto done;
}
}
/*
* Overallocate 6 chars, making some room for extended paths
*/
wp = nativePathPtr = Tcl_Alloc((len + 6) * sizeof(WCHAR));
if (nativePathPtr==0) {
goto done;
}
MultiByteToWideChar(CP_UTF8, MB_ERR_INVALID_CHARS, str, -1, nativePathPtr,
len + 1);
/*
* If path starts with "//?/" or "\\?\" (extended path), translate any
* slashes to backslashes but leave the '?' intact
*/
if ((str[0] == '\\' || str[0] == '/') && (str[1] == '\\' || str[1] == '/')
&& str[2] == '?' && (str[3] == '\\' || str[3] == '/')) {
wp[0] = wp[1] = wp[3] = '\\';
str += 4;
wp += 4;
}
/*
* If there is no "\\?\" prefix but there is a drive or UNC path prefix
* and the path is larger than MAX_PATH chars, no Win32 API function can
* handle that unless it is prefixed with the extended path prefix. See:
* <http://msdn.microsoft.com/en-us/library/aa365247(VS.85).aspx#maxpath>
*/
if (((str[0] >= 'A' && str[0] <= 'Z') || (str[0] >= 'a' && str[0] <= 'z'))
&& str[1] == ':') {
if (wp == nativePathPtr && len > MAX_PATH
&& (str[2] == '\\' || str[2] == '/')) {
memmove(wp + 4, wp, len * sizeof(WCHAR));
memcpy(wp, L"\\\\?\\", 4 * sizeof(WCHAR));
wp += 4;
}
/*
* If (remainder of) path starts with "<drive>:", leave the ':'
* intact.
*/
wp += 2;
} else if (wp == nativePathPtr && len > MAX_PATH
&& (str[0] == '\\' || str[0] == '/')
&& (str[1] == '\\' || str[1] == '/') && str[2] != '?') {
memmove(wp + 6, wp, len * sizeof(WCHAR));
memcpy(wp, L"\\\\?\\UNC", 7 * sizeof(WCHAR));
wp += 7;
}
/*
* In the remainder of the path, translate invalid characters to
* characters in the Unicode private use area.
*/
while (*wp != '\0') {
if ((*wp < ' ') || wcschr(L"\"*:<>?|", *wp)) {
*wp |= 0xF000;
} else if (*wp == '/') {
*wp = '\\';
}
++wp;
}
done:
TclDecrRefCount(validPathPtr);
return nativePathPtr;
}
/*
*---------------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
3181 3182 3183 3184 3185 3186 3187 |
LPBYTE buf = NULL;
DWORD bufsz;
int owned = 0;
native = Tcl_FSGetNativePath(pathPtr);
if (GetNamedSecurityInfo((LPTSTR) native, SE_FILE_OBJECT,
| | | > | | > > | | | | > > | > > > | > > | > | > | | 3262 3263 3264 3265 3266 3267 3268 3269 3270 3271 3272 3273 3274 3275 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 |
LPBYTE buf = NULL;
DWORD bufsz;
int owned = 0;
native = Tcl_FSGetNativePath(pathPtr);
if (GetNamedSecurityInfo((LPTSTR) 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 = 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/tclWinPipe.c.
| ︙ | ︙ | |||
120 121 122 123 124 125 126 |
HANDLE readable; /* Manual-reset event to signal when the
* reader thread has finished waiting for
* input. */
DWORD writeError; /* An error caused by the last background
* write. Set to 0 if no error has been
* detected. This word is shared with the
* writer thread so access must be
| | < | 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 |
HANDLE readable; /* Manual-reset event to signal when the
* reader thread has finished waiting for
* input. */
DWORD writeError; /* An error caused by the last background
* write. Set to 0 if no error has been
* detected. This word is shared with the
* writer thread so access must be
* synchronized with the writable object. */
char *writeBuf; /* Current background output buffer. Access is
* synchronized with the writable object. */
int writeBufLen; /* Size of write buffer. Access is
* synchronized with the writable object. */
int toWrite; /* Current amount to be written. Access is
* synchronized with the writable object. */
int readFlags; /* Flags that are shared with the reader
|
| ︙ | ︙ | |||
214 215 216 217 218 219 220 |
PipeGetHandleProc, /* Get an OS handle from channel. */
PipeClose2Proc, /* close2proc */
PipeBlockModeProc, /* Set blocking or non-blocking mode.*/
NULL, /* flush proc. */
NULL, /* handler proc. */
NULL, /* wide seek proc */
PipeThreadActionProc, /* thread action proc */
| | | 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 |
PipeGetHandleProc, /* Get an OS handle from channel. */
PipeClose2Proc, /* close2proc */
PipeBlockModeProc, /* Set blocking or non-blocking mode.*/
NULL, /* flush proc. */
NULL, /* handler proc. */
NULL, /* wide seek proc */
PipeThreadActionProc, /* thread action proc */
NULL /* truncate */
};
/*
*----------------------------------------------------------------------
*
* PipeInit --
*
|
| ︙ | ︙ | |||
1424 1425 1426 1427 1428 1429 1430 |
*
*----------------------------------------------------------------------
*/
static const char *
BuildCmdLineBypassBS(
const char *current,
| | < > > | > > | < > | | | < > > | > > > | > > > | | | | > > > | > > | > > > | > > > | > > > | | > | | < | > | | 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 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 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 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 |
*
*----------------------------------------------------------------------
*/
static const char *
BuildCmdLineBypassBS(
const char *current,
const char **bspos)
{
/*
* Mark first backslash position.
*/
if (!*bspos) {
*bspos = current;
}
do {
current++;
} while (*current == '\\');
return current;
}
static void
QuoteCmdLineBackslash(
Tcl_DString *dsPtr,
const char *start,
const char *current,
const char *bspos)
{
if (!bspos) {
if (current > start) { /* part before current (special) */
Tcl_DStringAppend(dsPtr, start, (int) (current - start));
}
} else {
if (bspos > start) { /* part before first backslash */
Tcl_DStringAppend(dsPtr, start, (int) (bspos - start));
}
while (bspos++ < current) { /* each backslash twice */
TclDStringAppendLiteral(dsPtr, "\\\\");
}
}
}
static const char *
QuoteCmdLinePart(
Tcl_DString *dsPtr,
const char *start,
const char *special,
const char *specMetaChars,
const char **bspos)
{
if (!*bspos) {
/*
* Rest before special (before quote).
*/
QuoteCmdLineBackslash(dsPtr, start, special, NULL);
start = special;
} else {
/*
* Rest before first backslash and backslashes into new quoted block.
*/
QuoteCmdLineBackslash(dsPtr, start, *bspos, NULL);
start = *bspos;
}
/*
* escape all special chars enclosed in quotes like `"..."`, note that
* here we don't must escape `\` (with `\`), because it's outside of the
* main quotes, so `\` remains `\`, but important - not at end of part,
* because results as before the quote, so `%\%\` should be escaped as
* `"%\%"\\`).
*/
TclDStringAppendLiteral(dsPtr, "\""); /* opening escape quote-char */
do {
*bspos = NULL;
special++;
if (*special == '\\') {
/*
* Bypass backslashes (and mark first backslash position).
*/
special = BuildCmdLineBypassBS(special, bspos);
if (*special == '\0') {
break;
}
}
} while (*special && strchr(specMetaChars, *special));
if (!*bspos) {
/*
* Unescaped rest before quote.
*/
QuoteCmdLineBackslash(dsPtr, start, special, NULL);
} else {
/*
* Unescaped rest before first backslash (rather belongs to the main
* block).
*/
QuoteCmdLineBackslash(dsPtr, start, *bspos, NULL);
}
TclDStringAppendLiteral(dsPtr, "\""); /* closing escape quote-char */
return special;
}
static void
BuildCommandLine(
const char *executable, /* Full path of executable (including
* extension). Replacement for argv[0]. */
int argc, /* Number of arguments. */
const char **argv, /* Argument strings in UTF. */
Tcl_DString *linePtr) /* Initialized Tcl_DString that receives the
* command line (WCHAR). */
{
const char *arg, *start, *special, *bspos;
int quote = 0, i;
Tcl_DString ds;
static const char specMetaChars[] = "&|^<>!()%";
/* Characters to enclose in quotes if unpaired
* quote flag set. */
static const char specMetaChars2[] = "%";
/* Character to enclose in quotes in any case
* (regardless of unpaired-flag). */
/*
* Quote flags:
* CL_ESCAPE - escape argument;
* CL_QUOTE - enclose in quotes;
* CL_UNPAIRED - previous arguments chain contains unpaired quote-char;
*/
enum {CL_ESCAPE = 1, CL_QUOTE = 2, CL_UNPAIRED = 4};
Tcl_DStringInit(&ds);
|
| ︙ | ︙ | |||
1551 1552 1553 1554 1555 1556 1557 |
quote &= ~(CL_ESCAPE|CL_QUOTE); /* reset escape flags */
bspos = NULL;
if (arg[0] == '\0') {
quote = CL_QUOTE;
} else {
for (start = arg;
| | | | < | > > | | | | | > | > > > | > > > | > > > > | > > | > > > > > > | > > | > > > > | > > > > | > > > | > > > | > > > > | > > > | > > > | > > > > | > > | > > > | > > > | > | > > | 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 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 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 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 |
quote &= ~(CL_ESCAPE|CL_QUOTE); /* reset escape flags */
bspos = NULL;
if (arg[0] == '\0') {
quote = CL_QUOTE;
} else {
for (start = arg;
*start != '\0' &&
(quote & (CL_ESCAPE|CL_QUOTE)) != (CL_ESCAPE|CL_QUOTE);
start++) {
if (*start & 0x80) {
continue;
}
if (TclIsSpaceProc(*start)) {
quote |= CL_QUOTE; /* quote only */
if (bspos) { /* if backslash found, escape & quote */
quote |= CL_ESCAPE;
break;
}
continue;
}
if (strchr(specMetaChars, *start)) {
quote |= (CL_ESCAPE|CL_QUOTE); /* escape & quote */
break;
}
if (*start == '"') {
quote |= CL_ESCAPE; /* escape only */
continue;
}
if (*start == '\\') {
bspos = start;
if (quote & CL_QUOTE) { /* if quote, escape & quote */
quote |= CL_ESCAPE;
break;
}
continue;
}
}
bspos = NULL;
}
if (quote & CL_QUOTE) {
/*
* Start of argument (main opening quote-char).
*/
TclDStringAppendLiteral(&ds, "\"");
}
if (!(quote & CL_ESCAPE)) {
/*
* Nothing to escape.
*/
Tcl_DStringAppend(&ds, arg, -1);
} else {
start = arg;
for (special = arg; *special != '\0'; ) {
/*
* Position of `\` is important before quote or at end (equal
* `\"` because quoted).
*/
if (*special == '\\') {
/*
* Bypass backslashes (and mark first backslash position)
*/
special = BuildCmdLineBypassBS(special, &bspos);
if (*special == '\0') {
break;
}
}
/* ["] */
if (*special == '"') {
/*
* Invert the unpaired flag - observe unpaired quotes
*/
quote ^= CL_UNPAIRED;
/*
* Add part before (and escape backslashes before quote).
*/
QuoteCmdLineBackslash(&ds, start, special, bspos);
bspos = NULL;
/*
* Escape using backslash
*/
TclDStringAppendLiteral(&ds, "\\\"");
start = ++special;
continue;
}
/*
* Unpaired (escaped) quote causes special handling on
* meta-chars
*/
if ((quote & CL_UNPAIRED) && strchr(specMetaChars, *special)) {
special = QuoteCmdLinePart(&ds, start, special,
specMetaChars, &bspos);
/*
* Start to current or first backslash
*/
start = !bspos ? special : bspos;
continue;
}
/*
* Special case for % - should be enclosed always (paired
* also)
*/
if (strchr(specMetaChars2, *special)) {
special = QuoteCmdLinePart(&ds, start, special,
specMetaChars2, &bspos);
/*
* Start to current or first backslash.
*/
start = !bspos ? special : bspos;
continue;
}
/*
* Other not special (and not meta) character
*/
bspos = NULL; /* reset last backslash position (not
* interesting) */
special++;
}
/*
* Rest of argument (and escape backslashes before closing main
* quote)
*/
QuoteCmdLineBackslash(&ds, start, special,
(quote & CL_QUOTE) ? bspos : NULL);
}
if (quote & CL_QUOTE) {
/*
* End of argument (main closing quote-char)
*/
TclDStringAppendLiteral(&ds, "\"");
}
}
Tcl_DStringFree(linePtr);
Tcl_WinUtfToTChar(Tcl_DStringValue(&ds), Tcl_DStringLength(&ds), linePtr);
Tcl_DStringFree(&ds);
}
|
| ︙ | ︙ | |||
2171 2172 2173 2174 2175 2176 2177 |
PipeInfo *infoPtr = (PipeInfo *) instanceData;
WinFile *filePtr = (WinFile*) infoPtr->writeFile;
DWORD bytesWritten, timeout;
*errorCode = 0;
/* avoid blocking if pipe-thread exited */
| | > | | 2256 2257 2258 2259 2260 2261 2262 2263 2264 2265 2266 2267 2268 2269 2270 2271 2272 |
PipeInfo *infoPtr = (PipeInfo *) instanceData;
WinFile *filePtr = (WinFile*) infoPtr->writeFile;
DWORD bytesWritten, timeout;
*errorCode = 0;
/* avoid blocking if pipe-thread exited */
timeout = ((infoPtr->flags & PIPE_ASYNC)
|| !TclPipeThreadIsAlive(&infoPtr->writeTI)
|| TclInExit() || TclInThreadExit()) ? 0 : INFINITE;
if (WaitForSingleObject(infoPtr->writable, timeout) == WAIT_TIMEOUT) {
/*
* The writer thread is blocked waiting for a write to complete and
* the channel is in non-blocking mode.
*/
errno = EWOULDBLOCK;
|
| ︙ | ︙ | |||
2358 2359 2360 2361 2362 2363 2364 2365 2366 2367 2368 2369 2370 2371 |
* Since most of the work is handled by the background threads, we just
* need to update the watchMask and then force the notifier to poll once.
*/
infoPtr->watchMask = mask & infoPtr->validMask;
if (infoPtr->watchMask) {
Tcl_Time blockTime = { 0, 0 };
if (!oldMask) {
infoPtr->nextPtr = tsdPtr->firstPipePtr;
tsdPtr->firstPipePtr = infoPtr;
}
Tcl_SetMaxBlockTime(&blockTime);
} else {
if (oldMask) {
| > | 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 |
* Since most of the work is handled by the background threads, we just
* need to update the watchMask and then force the notifier to poll once.
*/
infoPtr->watchMask = mask & infoPtr->validMask;
if (infoPtr->watchMask) {
Tcl_Time blockTime = { 0, 0 };
if (!oldMask) {
infoPtr->nextPtr = tsdPtr->firstPipePtr;
tsdPtr->firstPipePtr = infoPtr;
}
Tcl_SetMaxBlockTime(&blockTime);
} else {
if (oldMask) {
|
| ︙ | ︙ | |||
2827 2828 2829 2830 2831 2832 2833 |
*----------------------------------------------------------------------
*/
static DWORD WINAPI
PipeReaderThread(
LPVOID arg)
{
| | > | | 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 2940 2941 2942 2943 2944 2945 2946 |
*----------------------------------------------------------------------
*/
static DWORD WINAPI
PipeReaderThread(
LPVOID arg)
{
TclPipeThreadInfo *pipeTI = (TclPipeThreadInfo *) arg;
PipeInfo *infoPtr = NULL; /* access info only after success init/wait */
HANDLE handle = NULL;
DWORD count, err;
int done = 0;
while (!done) {
/*
* Wait for the main thread to signal before attempting to wait on the
* pipe becoming readable.
*/
if (!TclPipeThreadWaitForSignal(&pipeTI)) {
/* exit */
break;
}
if (!infoPtr) {
infoPtr = (PipeInfo *) pipeTI->clientData;
handle = ((WinFile *) infoPtr->readFile)->handle;
}
/*
* Try waiting for 0 bytes. This will block until some data is
* available on NT, but will return immediately on Win 95. So, if no
* data is available after the first read, we block until we can read
|
| ︙ | ︙ | |||
3191 3192 3193 3194 3195 3196 3197 |
HANDLE wakeEvent)
{
TclPipeThreadInfo *pipeTI;
#ifndef _PTI_USE_CKALLOC
pipeTI = malloc(sizeof(TclPipeThreadInfo));
#else
pipeTI = Tcl_Alloc(sizeof(TclPipeThreadInfo));
| | | 3279 3280 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 3291 3292 3293 |
HANDLE wakeEvent)
{
TclPipeThreadInfo *pipeTI;
#ifndef _PTI_USE_CKALLOC
pipeTI = malloc(sizeof(TclPipeThreadInfo));
#else
pipeTI = Tcl_Alloc(sizeof(TclPipeThreadInfo));
#endif /* !_PTI_USE_CKALLOC */
pipeTI->evControl = CreateEvent(NULL, FALSE, FALSE, NULL);
pipeTI->state = PTI_STATE_IDLE;
pipeTI->clientData = clientData;
pipeTI->evWakeUp = wakeEvent;
return (*pipeTIPtr = pipeTI);
}
|
| ︙ | ︙ | |||
3230 3231 3232 3233 3234 3235 3236 3237 3238 3239 3240 |
HANDLE wakeEvent;
if (!pipeTI) {
return 0;
}
wakeEvent = pipeTI->evWakeUp;
/*
* Wait for the main thread to signal before attempting to do the work.
*/
| > > | > > | > | > | > > > > | < > > < > > | > > | > | > | > > > | > > | > | > > | 3318 3319 3320 3321 3322 3323 3324 3325 3326 3327 3328 3329 3330 3331 3332 3333 3334 3335 3336 3337 3338 3339 3340 3341 3342 3343 3344 3345 3346 3347 3348 3349 3350 3351 3352 3353 3354 3355 3356 3357 3358 3359 3360 3361 3362 3363 3364 3365 3366 3367 3368 3369 3370 3371 3372 3373 3374 3375 3376 3377 3378 3379 3380 3381 3382 3383 3384 3385 3386 3387 3388 3389 |
HANDLE wakeEvent;
if (!pipeTI) {
return 0;
}
wakeEvent = pipeTI->evWakeUp;
/*
* Wait for the main thread to signal before attempting to do the work.
*/
/*
* Reset work state of thread (idle/waiting)
*/
state = InterlockedCompareExchange(&pipeTI->state, PTI_STATE_IDLE,
PTI_STATE_WORK);
if (state & (PTI_STATE_STOP|PTI_STATE_END)) {
/*
* End of work, check the owner of structure.
*/
goto end;
}
/*
* Entering wait
*/
waitResult = WaitForSingleObject(pipeTI->evControl, INFINITE);
if (waitResult != WAIT_OBJECT_0) {
/*
* The control event was not signaled, so end of work (unexpected
* behaviour, main thread can be dead?).
*/
goto end;
}
/*
* Try to set work state of thread
*/
state = InterlockedCompareExchange(&pipeTI->state, PTI_STATE_WORK,
PTI_STATE_IDLE);
if (state & (PTI_STATE_STOP|PTI_STATE_END)) {
/*
* End of work
*/
goto end;
}
/*
* Signaled to work.
*/
return 1;
end:
/*
* End of work, check the owner of the TI structure.
*/
if (state != PTI_STATE_STOP) {
*pipeTIPtr = NULL;
} else {
pipeTI->evWakeUp = NULL;
}
if (wakeEvent) {
SetEvent(wakeEvent);
|
| ︙ | ︙ | |||
3293 3294 3295 3296 3297 3298 3299 | * 1 if signaled (or pipe-thread is down), 0 if pipe thread still working. * *---------------------------------------------------------------------- */ int TclPipeThreadStopSignal( | | > < | | | < | | | < > > | < | < | | | | > | > | | 3405 3406 3407 3408 3409 3410 3411 3412 3413 3414 3415 3416 3417 3418 3419 3420 3421 3422 3423 3424 3425 3426 3427 3428 3429 3430 3431 3432 3433 3434 3435 3436 3437 3438 3439 3440 3441 3442 3443 3444 3445 3446 3447 3448 3449 3450 3451 |
* 1 if signaled (or pipe-thread is down), 0 if pipe thread still working.
*
*----------------------------------------------------------------------
*/
int
TclPipeThreadStopSignal(
TclPipeThreadInfo **pipeTIPtr,
HANDLE wakeEvent)
{
TclPipeThreadInfo *pipeTI = *pipeTIPtr;
HANDLE evControl;
int state;
if (!pipeTI) {
return 1;
}
evControl = pipeTI->evControl;
pipeTI->evWakeUp = wakeEvent;
state = InterlockedCompareExchange(&pipeTI->state, PTI_STATE_STOP,
PTI_STATE_IDLE);
switch (state) {
case PTI_STATE_IDLE:
/*
* Thread was idle/waiting, notify it goes teardown
*/
SetEvent(evControl);
*pipeTIPtr = NULL;
case PTI_STATE_DOWN:
return 1;
default:
/*
* Thread works currently, we should try to end it, own the TI
* structure (because of possible sharing the joint structures with
* thread)
*/
InterlockedExchange(&pipeTI->state, PTI_STATE_END);
break;
}
return 0;
}
/*
|
| ︙ | ︙ | |||
3368 3369 3370 3371 3372 3373 3374 3375 3376 3377 |
if (!pipeTI) {
return;
}
pipeTI = *pipeTIPtr;
evControl = pipeTI->evControl;
pipeTI->evWakeUp = NULL;
/*
* Try to sane stop the pipe worker, corresponding its current state
*/
| > | | | | < | | | > > | > | > > > | | > | > > | | > | > > | > | | | | | > | > | | | > | > | < > < > > | | > | < > > | | | | | < | | | | | > | | | > | | | > | | > | > | | | < > | > > > < > | | | | 3480 3481 3482 3483 3484 3485 3486 3487 3488 3489 3490 3491 3492 3493 3494 3495 3496 3497 3498 3499 3500 3501 3502 3503 3504 3505 3506 3507 3508 3509 3510 3511 3512 3513 3514 3515 3516 3517 3518 3519 3520 3521 3522 3523 3524 3525 3526 3527 3528 3529 3530 3531 3532 3533 3534 3535 3536 3537 3538 3539 3540 3541 3542 3543 3544 3545 3546 3547 3548 3549 3550 3551 3552 3553 3554 3555 3556 3557 3558 3559 3560 3561 3562 3563 3564 3565 3566 3567 3568 3569 3570 3571 3572 3573 3574 3575 3576 3577 3578 3579 3580 3581 3582 3583 3584 3585 3586 3587 3588 3589 3590 3591 3592 3593 3594 3595 3596 3597 3598 3599 3600 3601 3602 3603 3604 3605 3606 3607 3608 3609 3610 3611 3612 3613 3614 3615 3616 3617 3618 3619 3620 3621 3622 3623 3624 3625 3626 3627 3628 3629 3630 3631 3632 3633 3634 3635 3636 3637 3638 3639 3640 3641 3642 3643 3644 3645 3646 3647 3648 3649 3650 3651 3652 3653 3654 3655 |
if (!pipeTI) {
return;
}
pipeTI = *pipeTIPtr;
evControl = pipeTI->evControl;
pipeTI->evWakeUp = NULL;
/*
* Try to sane stop the pipe worker, corresponding its current state
*/
state = InterlockedCompareExchange(&pipeTI->state, PTI_STATE_STOP,
PTI_STATE_IDLE);
switch (state) {
case PTI_STATE_IDLE:
/*
* Thread was idle/waiting, notify it goes teardown
*/
SetEvent(evControl);
/*
* We don't need to wait for it at all, thread frees himself (owns the
* TI structure)
*/
pipeTI = NULL;
break;
case PTI_STATE_STOP:
/*
* Already stopped, thread frees himself (owns the TI structure)
*/
pipeTI = NULL;
break;
case PTI_STATE_DOWN:
/*
* Thread already down (?), do nothing
*/
/*
* We don't need to wait for it, but we should free pipeTI
*/
hThread = NULL;
break;
/* case PTI_STATE_WORK: */
default:
/*
* Thread works currently, we should try to end it, own the TI
* structure (because of possible sharing the joint structures with
* thread)
*/
state = InterlockedCompareExchange(&pipeTI->state, PTI_STATE_END,
PTI_STATE_WORK);
if (state == PTI_STATE_DOWN) {
/*
* We don't need to wait for it, but we should free pipeTI
*/
hThread = NULL;
}
break;
}
if (pipeTI && hThread) {
DWORD exitCode;
/*
* The thread may already have closed on its own. Check its exit
* code.
*/
GetExitCodeThread(hThread, &exitCode);
if (exitCode == STILL_ACTIVE) {
int inExit = (TclInExit() || TclInThreadExit());
/*
* Set the stop event so that if the pipe thread is blocked
* somewhere, it may hereafter sane exit cleanly.
*/
SetEvent(evControl);
/*
* Cancel all sync-IO of this thread (may be blocked there).
*/
if (tclWinProcs.cancelSynchronousIo) {
tclWinProcs.cancelSynchronousIo(hThread);
}
/*
* Wait at most 20 milliseconds for the reader thread to close
* (regarding TIP#398-fast-exit).
*/
/*
* If we want TIP#398-fast-exit.
*/
if (WaitForSingleObject(hThread, inExit ? 0 : 20) == WAIT_TIMEOUT) {
/*
* The thread must be blocked waiting for the pipe to become
* readable in ReadFile(). There isn't a clean way to exit the
* thread from this condition. We should terminate the child
* process instead to get the reader thread to fall out of
* ReadFile with a FALSE. (below) is not the correct way to do
* this, but will stay here until a better solution is found.
*
* Note that we need to guard against terminating the thread
* while it is in the middle of Tcl_ThreadAlert because it
* won't be able to release the notifier lock.
*
* Also note that terminating threads during their
* initialization or teardown phase may result in ntdll.dll's
* LoaderLock to remain locked indefinitely. This causes
* ntdll.dll's LdrpInitializeThread() to deadlock trying to
* acquire LoaderLock. LdrpInitializeThread() is executed
* within new threads to perform initialization and to execute
* DllMain() of all loaded dlls. As a result, all new threads
* are deadlocked in their initialization phase and never
* execute, even though CreateThread() reports successful
* thread creation. This results in a very weird process-wide
* behavior, which is extremely hard to debug.
*
* THREADS SHOULD NEVER BE TERMINATED. Period.
*
* But for now, check if thread is exiting, and if so, let it
* die peacefully.
*
* Also don't terminate if in exit (otherwise deadlocked in
* ntdll.dll's).
*/
if (pipeTI->state != PTI_STATE_DOWN
&& WaitForSingleObject(hThread,
inExit ? 50 : 5000) != WAIT_OBJECT_0) {
/* BUG: this leaks memory */
if (inExit || !TerminateThread(hThread, 0)) {
/*
* in exit or terminate fails, just give thread a
* chance to exit
*/
if (InterlockedExchange(&pipeTI->state,
PTI_STATE_STOP) != PTI_STATE_DOWN) {
pipeTI = NULL;
}
}
}
}
}
}
*pipeTIPtr = NULL;
if (pipeTI) {
if (pipeTI->evWakeUp) {
SetEvent(pipeTI->evWakeUp);
}
CloseHandle(pipeTI->evControl);
#ifndef _PTI_USE_CKALLOC
free(pipeTI);
#else
Tcl_Free(pipeTI);
#endif /* !_PTI_USE_CKALLOC */
}
}
/*
*----------------------------------------------------------------------
*
* TclPipeThreadExit --
|
| ︙ | ︙ | |||
3531 3532 3533 3534 3535 3536 3537 3538 3539 3540 3541 3542 3543 3544 3545 3546 |
void
TclPipeThreadExit(
TclPipeThreadInfo **pipeTIPtr)
{
LONG state;
TclPipeThreadInfo *pipeTI = *pipeTIPtr;
/*
* If state of thread was set to stop (exactly), we can sane free its info
* structure, otherwise it is shared with main thread, so main thread will
* own it.
*/
if (!pipeTI) {
return;
}
*pipeTIPtr = NULL;
| > > | | | | | | 3670 3671 3672 3673 3674 3675 3676 3677 3678 3679 3680 3681 3682 3683 3684 3685 3686 3687 3688 3689 3690 3691 3692 3693 3694 3695 3696 3697 3698 3699 3700 3701 3702 3703 3704 3705 3706 3707 3708 3709 3710 |
void
TclPipeThreadExit(
TclPipeThreadInfo **pipeTIPtr)
{
LONG state;
TclPipeThreadInfo *pipeTI = *pipeTIPtr;
/*
* If state of thread was set to stop (exactly), we can sane free its info
* structure, otherwise it is shared with main thread, so main thread will
* own it.
*/
if (!pipeTI) {
return;
}
*pipeTIPtr = NULL;
state = InterlockedExchange(&pipeTI->state, PTI_STATE_DOWN);
if (state == PTI_STATE_STOP) {
CloseHandle(pipeTI->evControl);
if (pipeTI->evWakeUp) {
SetEvent(pipeTI->evWakeUp);
}
#ifndef _PTI_USE_CKALLOC
free(pipeTI);
#else
Tcl_Free(pipeTI);
/* be sure all subsystems used are finalized */
Tcl_FinalizeThread();
#endif /* !_PTI_USE_CKALLOC */
}
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to win/tclWinSerial.c.
| ︙ | ︙ | |||
39 40 41 42 43 44 45 46 47 48 49 50 51 52 | /* * Bit masks used in the sharedFlags field of the SerialInfo structure below. */ #define SERIAL_EOF (1<<2) /* Serial has reached EOF. */ #define SERIAL_ERROR (1<<4) /* * Default time to block between checking status on the serial port. */ #define SERIAL_DEFAULT_BLOCKTIME 10 /* 10 msec */ /* | > > > > > > > > > | 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 | /* * Bit masks used in the sharedFlags field of the SerialInfo structure below. */ #define SERIAL_EOF (1<<2) /* Serial has reached EOF. */ #define SERIAL_ERROR (1<<4) /* * Bit masks used for noting whether to drain or discard output on close. They * are disjoint from each other; at most one may be set at a time. */ #define SERIAL_CLOSE_DRAIN (1<<6) /* Drain all output on close. */ #define SERIAL_CLOSE_DISCARD (1<<7) /* Discard all output on close. */ #define SERIAL_CLOSE_MASK (3<<6) /* Both two bits above. */ /* * Default time to block between checking status on the serial port. */ #define SERIAL_DEFAULT_BLOCKTIME 10 /* 10 msec */ /* |
| ︙ | ︙ | |||
600 601 602 603 604 605 606 |
if (serialPtr->validMask & TCL_READABLE) {
PurgeComm(serialPtr->handle, PURGE_RXABORT | PURGE_RXCLEAR);
CloseHandle(serialPtr->osRead.hEvent);
}
serialPtr->validMask &= ~TCL_READABLE;
if (serialPtr->writeThread) {
| < | 609 610 611 612 613 614 615 616 617 618 619 620 621 622 |
if (serialPtr->validMask & TCL_READABLE) {
PurgeComm(serialPtr->handle, PURGE_RXABORT | PURGE_RXCLEAR);
CloseHandle(serialPtr->osRead.hEvent);
}
serialPtr->validMask &= ~TCL_READABLE;
if (serialPtr->writeThread) {
TclPipeThreadStop(&serialPtr->writeTI, serialPtr->writeThread);
CloseHandle(serialPtr->osWrite.hEvent);
CloseHandle(serialPtr->evWritable);
CloseHandle(serialPtr->writeThread);
serialPtr->writeThread = NULL;
|
| ︙ | ︙ | |||
1274 1275 1276 1277 1278 1279 1280 |
/*
* Wait for the main thread to signal before attempting to write.
*/
if (!TclPipeThreadWaitForSignal(&pipeTI)) {
/* exit */
break;
}
| | | 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 |
/*
* Wait for the main thread to signal before attempting to write.
*/
if (!TclPipeThreadWaitForSignal(&pipeTI)) {
/* exit */
break;
}
infoPtr = (SerialInfo *) pipeTI->clientData;
buf = infoPtr->writeBuf;
toWrite = infoPtr->toWrite;
myWrite.hEvent = CreateEvent(NULL, TRUE, FALSE, NULL);
/*
|
| ︙ | ︙ | |||
1338 1339 1340 1341 1342 1343 1344 |
*/
Tcl_ThreadAlert(infoPtr->threadId);
}
Tcl_MutexUnlock(&serialMutex);
}
| > > > > > > > > > > > > > > > > | > > | 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 |
*/
Tcl_ThreadAlert(infoPtr->threadId);
}
Tcl_MutexUnlock(&serialMutex);
}
/*
* We're about to close, so do any drain or discard required.
*/
if (infoPtr) {
switch (infoPtr->flags & SERIAL_CLOSE_MASK) {
case SERIAL_CLOSE_DRAIN:
FlushFileBuffers(infoPtr->handle);
break;
case SERIAL_CLOSE_DISCARD:
PurgeComm(infoPtr->handle, PURGE_TXABORT | PURGE_TXCLEAR);
break;
}
}
/*
* Worker exit, so inform the main thread or free TI-structure (if owned).
*/
TclPipeThreadExit(&pipeTI);
return 0;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 |
/*
* Parse options. This would be far easier if we had Tcl_Objs to work with
* as that would let us use Tcl_GetIndexFromObj()...
*/
len = strlen(optionName);
vlen = strlen(value);
/*
* Option -mode baud,parity,databits,stopbits
*/
if ((len > 2) && (strncmp(optionName, "-mode", len) == 0)) {
if (!GetCommState(infoPtr->handle, &dcb)) {
| > > > > > > > > > > > > > > > > > > > > > > > > > > | 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 |
/*
* Parse options. This would be far easier if we had Tcl_Objs to work with
* as that would let us use Tcl_GetIndexFromObj()...
*/
len = strlen(optionName);
vlen = strlen(value);
/*
* Option -closemode drain|discard|default
*/
if ((len > 2) && (strncmp(optionName, "-closemode", len) == 0)) {
if (Tcl_UtfNcasecmp(value, "DEFAULT", vlen) == 0) {
infoPtr->flags &= ~SERIAL_CLOSE_MASK;
} else if (Tcl_UtfNcasecmp(value, "DRAIN", vlen) == 0) {
infoPtr->flags &= ~SERIAL_CLOSE_MASK;
infoPtr->flags |= SERIAL_CLOSE_DRAIN;
} else if (Tcl_UtfNcasecmp(value, "DISCARD", vlen) == 0) {
infoPtr->flags &= ~SERIAL_CLOSE_MASK;
infoPtr->flags |= SERIAL_CLOSE_DISCARD;
} else {
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad mode \"%s\" for -closemode: must be"
" default, discard, or drain", value));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE",
"VALUE", NULL);
}
return TCL_ERROR;
}
return TCL_OK;
}
/*
* Option -mode baud,parity,databits,stopbits
*/
if ((len > 2) && (strncmp(optionName, "-mode", len) == 0)) {
if (!GetCommState(infoPtr->handle, &dcb)) {
|
| ︙ | ︙ | |||
1934 1935 1936 1937 1938 1939 1940 |
return TCL_ERROR;
}
return TCL_OK;
}
return Tcl_BadChannelOption(interp, optionName,
| | > | 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 |
return TCL_ERROR;
}
return TCL_OK;
}
return Tcl_BadChannelOption(interp, optionName,
"closemode mode handshake pollinterval sysbuffer timeout "
"ttycontrol xchar");
getStateFailed:
if (interp != NULL) {
TclWinConvertError(GetLastError());
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't get comm state: %s", Tcl_PosixError(interp)));
}
|
| ︙ | ︙ | |||
1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 |
infoPtr = (SerialInfo *) instanceData;
if (optionName == NULL) {
len = 0;
} else {
len = strlen(optionName);
}
/*
* Get option -mode
*/
if (len == 0) {
Tcl_DStringAppendElement(dsPtr, "-mode");
| > > > > > > > > > > > > > > > > > > > > > | 2046 2047 2048 2049 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 |
infoPtr = (SerialInfo *) instanceData;
if (optionName == NULL) {
len = 0;
} else {
len = strlen(optionName);
}
/*
* Get option -closemode
*/
if (len == 0) {
Tcl_DStringAppendElement(dsPtr, "-closemode");
}
if (len==0 || (len>1 && strncmp(optionName, "-closemode", len)==0)) {
switch (infoPtr->flags & SERIAL_CLOSE_MASK) {
case SERIAL_CLOSE_DRAIN:
Tcl_DStringAppendElement(dsPtr, "drain");
break;
case SERIAL_CLOSE_DISCARD:
Tcl_DStringAppendElement(dsPtr, "discard");
break;
default:
Tcl_DStringAppendElement(dsPtr, "default");
break;
}
}
/*
* Get option -mode
*/
if (len == 0) {
Tcl_DStringAppendElement(dsPtr, "-mode");
|
| ︙ | ︙ | |||
2170 2171 2172 2173 2174 2175 2176 |
SerialModemStatusStr(status, dsPtr);
}
if (valid) {
return TCL_OK;
}
return Tcl_BadChannelOption(interp, optionName,
| | > | 2244 2245 2246 2247 2248 2249 2250 2251 2252 2253 2254 2255 2256 2257 2258 2259 |
SerialModemStatusStr(status, dsPtr);
}
if (valid) {
return TCL_OK;
}
return Tcl_BadChannelOption(interp, optionName,
"closemode mode pollinterval lasterror queue sysbuffer ttystatus "
"xchar");
}
/*
*----------------------------------------------------------------------
*
* SerialThreadActionProc --
*
|
| ︙ | ︙ |