Many hyperlinks are disabled.
Use anonymous login
to enable hyperlinks.
Changes In Branch tip-671 Excluding Merge-Ins
This is equivalent to a diff from 0797156bae to bfb5c2d0d3
2024-01-04
| ||
20:58 | Merge 9.0 Leaf check-in: bfb5c2d0d3 user: jan.nijtmans tags: tip-671 | |
20:52 | Merge-mark check-in: b74b1e3bb8 user: jan.nijtmans tags: trunk, main | |
2023-11-13
| ||
10:20 | TIP #657: Make "-profile strict" the default in Tcl 9.0 check-in: e9d398b2aa user: jan.nijtmans tags: trunk, main | |
2023-11-10
| ||
13:12 | Rebase to latest 9.0 Closed-Leaf check-in: 0797156bae user: jan.nijtmans tags: tip-657 | |
11:01 | exec.n documentation: add chapter about MS-Windows quoting. check-in: f048af6d62 user: oehhar tags: trunk, main | |
2023-11-02
| ||
17:00 | Merge main check-in: e85a6745f5 user: oehhar tags: tip-657 | |
2023-09-12
| ||
14:23 | Rebase to tip-657 check-in: 0e7c7d2154 user: jan.nijtmans tags: tip-671 | |
Changes to .github/workflows/linux-build.yml.
︙ | ︙ | |||
10 11 12 13 14 15 16 | permissions: contents: read jobs: gcc: runs-on: ubuntu-22.04 strategy: matrix: | | > > > > > > > > | | | 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 | permissions: contents: read jobs: gcc: runs-on: ubuntu-22.04 strategy: matrix: config: - "" - "CFLAGS=-DTCL_NO_DEPRECATED=1" - "--disable-shared" - "--disable-zipfs" - "--enable-symbols" - "--enable-symbols=mem" - "--enable-symbols=all" - "CFLAGS=-ftrapv" # Duplicated below - "CFLAGS=-m32 CPPFLAGS=-m32 LDFLAGS=-m32 --disable-64bit" defaults: run: shell: bash working-directory: unix steps: - name: Checkout uses: actions/checkout@v4 timeout-minutes: 5 - name: Install 32-bit dependencies if needed # Duplicated from above if: ${{ matrix.config == 'CFLAGS=-m32 CPPFLAGS=-m32 LDFLAGS=-m32 --disable-64bit' }} run: | sudo apt-get update sudo apt-get install gcc-multilib libc6-dev-i386 - name: Prepare run: | touch tclStubInit.c tclOOStubInit.c tclOOScript.h working-directory: generic - name: Configure ${{ matrix.config }} run: | mkdir "${HOME}/install dir" ./configure ${CFGOPT} "--prefix=$HOME/install dir" || (cat config.log && exit 1) env: CFGOPT: ${{ matrix.config }} timeout-minutes: 5 - name: Build run: | make all timeout-minutes: 5 - name: Build Test Harness run: | |
︙ | ︙ |
Changes to .github/workflows/mac-build.yml.
︙ | ︙ | |||
35 36 37 38 39 40 41 | ERROR_ON_FAILURES: 1 MAC_CI: 1 timeout-minutes: 15 clang: runs-on: macos-11 strategy: matrix: | | | | | 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 | ERROR_ON_FAILURES: 1 MAC_CI: 1 timeout-minutes: 15 clang: runs-on: macos-11 strategy: matrix: config: - "" - "--disable-shared" - "--disable-zipfs" - "--enable-symbols" - "--enable-symbols=mem" - "--enable-symbols=all" defaults: run: shell: bash working-directory: unix steps: - name: Checkout uses: actions/checkout@v4 timeout-minutes: 5 - name: Prepare run: | touch tclStubInit.c tclOOStubInit.c tclOOScript.h mkdir "$HOME/install dir" working-directory: generic - name: Configure ${{ matrix.config }} # Note that macOS is always a 64 bit platform run: ./configure --enable-dtrace --enable-framework ${CFGOPT} "--prefix=$HOME/install" || (cat config.log && exit 1) env: CFLAGS: -arch x86_64 -arch arm64 CFGOPT: ${{ matrix.config }} timeout-minutes: 5 - name: Build run: | make all tcltest env: CFLAGS: -arch x86_64 -arch arm64 timeout-minutes: 15 |
︙ | ︙ |
Changes to .github/workflows/onefiledist.yml.
︙ | ︙ | |||
37 38 39 40 41 42 43 | - name: Package run: | cp ../unix/tclsh tclsh${TCL_PATCHLEVEL}_snapshot chmod +x tclsh${TCL_PATCHLEVEL}_snapshot tar -cf tclsh${TCL_PATCHLEVEL}_snapshot.tar tclsh${TCL_PATCHLEVEL}_snapshot working-directory: 1dist - name: Upload | | | 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 | - name: Package run: | cp ../unix/tclsh tclsh${TCL_PATCHLEVEL}_snapshot chmod +x tclsh${TCL_PATCHLEVEL}_snapshot tar -cf tclsh${TCL_PATCHLEVEL}_snapshot.tar tclsh${TCL_PATCHLEVEL}_snapshot working-directory: 1dist - name: Upload uses: actions/upload-artifact@v4 with: name: Tclsh ${{ env.TCL_PATCHLEVEL }} Linux single-file build (snapshot) path: 1dist/*.tar macos: name: macOS runs-on: macos-11 defaults: |
︙ | ︙ | |||
100 101 102 103 104 105 106 | --volname "Tcl $TCL_PATCHLEVEL (snapshot)" \ --window-pos 200 120 \ --window-size 800 400 \ "Tcl-$TCL_PATCHLEVEL-(snapshot).dmg" \ "contents/" working-directory: 1dist - name: Upload | | | 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 | --volname "Tcl $TCL_PATCHLEVEL (snapshot)" \ --window-pos 200 120 \ --window-size 800 400 \ "Tcl-$TCL_PATCHLEVEL-(snapshot).dmg" \ "contents/" working-directory: 1dist - name: Upload uses: actions/upload-artifact@v4 with: name: Tclsh ${{ env.TCL_PATCHLEVEL }} macOS single-file build (snapshot) path: 1dist/*.dmg win: name: Windows runs-on: windows-2019 defaults: |
︙ | ︙ | |||
145 146 147 148 149 150 151 | ./tclsh*.exe $VER_PATH $GITHUB_ENV working-directory: win - name: Set Executable Name run: | cp ../win/tclsh*.exe tclsh${TCL_PATCHLEVEL}_snapshot.exe working-directory: 1dist - name: Upload | | | 145 146 147 148 149 150 151 152 153 154 155 | ./tclsh*.exe $VER_PATH $GITHUB_ENV working-directory: win - name: Set Executable Name run: | cp ../win/tclsh*.exe tclsh${TCL_PATCHLEVEL}_snapshot.exe working-directory: 1dist - name: Upload uses: actions/upload-artifact@v4 with: name: Tclsh ${{ env.TCL_PATCHLEVEL }} Windows single-file build (snapshot) path: '1dist/*_snapshot.exe' |
Changes to .github/workflows/win-build.yml.
︙ | ︙ | |||
16 17 18 19 20 21 22 | runs-on: windows-2022 defaults: run: shell: powershell working-directory: win strategy: matrix: | | | | | | | | | | 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 | runs-on: windows-2022 defaults: run: shell: powershell working-directory: win strategy: matrix: config: - "" - "CHECKS=nodep" - "OPTS=static" - "OPTS=noembed" - "OPTS=symbols" - "OPTS=symbols STATS=compdbg,memdbg" # Using powershell means we need to explicitly stop on failure steps: - name: Checkout uses: actions/checkout@v4 timeout-minutes: 5 - name: Init MSVC uses: ilammy/msvc-dev-cmd@v1 timeout-minutes: 5 - name: Build ${{ matrix.config }} run: | &nmake -f makefile.vc ${{ matrix.config }} all if ($lastexitcode -ne 0) { throw "nmake exit code: $lastexitcode" } timeout-minutes: 5 - name: Build Test Harness ${{ matrix.config }} run: | &nmake -f makefile.vc ${{ matrix.config }} tcltest if ($lastexitcode -ne 0) { throw "nmake exit code: $lastexitcode" } timeout-minutes: 5 - name: Run Tests ${{ matrix.config }} run: | &nmake -f makefile.vc ${{ matrix.config }} test if ($lastexitcode -ne 0) { throw "nmake exit code: $lastexitcode" } timeout-minutes: 30 gcc: runs-on: windows-2022 defaults: run: shell: msys2 {0} working-directory: win strategy: matrix: config: - "" - "CFLAGS=-DTCL_NO_DEPRECATED=1" - "--disable-shared" - "--disable-zipfs" - "--enable-symbols" - "--enable-symbols=mem" - "--enable-symbols=all" |
︙ | ︙ | |||
84 85 86 87 88 89 90 | uses: actions/checkout@v4 timeout-minutes: 5 - name: Prepare run: | touch tclStubInit.c tclOOStubInit.c tclOOScript.h mkdir "${HOME}/install dir" working-directory: generic | | | | 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 | uses: actions/checkout@v4 timeout-minutes: 5 - name: Prepare run: | touch tclStubInit.c tclOOStubInit.c tclOOScript.h mkdir "${HOME}/install dir" working-directory: generic - name: Configure ${{ matrix.config }} run: | ./configure ${CFGOPT} "--prefix=$HOME/install dir" || (cat config.log && exit 1) env: CFGOPT: --enable-64bit ${{ matrix.config }} timeout-minutes: 5 - name: Build run: make all timeout-minutes: 5 - name: Build Test Harness run: make tcltest timeout-minutes: 5 - name: Run Tests run: make test timeout-minutes: 30 # If you add builds with Wine, be sure to define the environment variable # CI_USING_WINE when running them so that broken tests know not to run. |
Changes to doc/AddErrInfo.3.
︙ | ︙ | |||
24 25 26 27 28 29 30 | .sp \fBTcl_AppendObjToErrorInfo\fR(\fIinterp, objPtr\fR) .sp \fBTcl_AddObjErrorInfo\fR(\fIinterp, message, length\fR) .sp \fBTcl_SetObjErrorCode\fR(\fIinterp, errorObjPtr\fR) .sp | | | 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 | .sp \fBTcl_AppendObjToErrorInfo\fR(\fIinterp, objPtr\fR) .sp \fBTcl_AddObjErrorInfo\fR(\fIinterp, message, length\fR) .sp \fBTcl_SetObjErrorCode\fR(\fIinterp, errorObjPtr\fR) .sp \fBTcl_SetErrorCode\fR(\fIinterp, element, element, ... \fB(char *)NULL\fR) .sp \fBTcl_GetErrorLine\fR(\fIinterp\fR) .sp \fBTcl_SetErrorLine\fR(\fIinterp, lineNum\fR) .sp const char * \fBTcl_PosixError\fR(\fIinterp\fR) |
︙ | ︙ |
Changes to doc/ByteArrObj.3.
︙ | ︙ | |||
41 42 43 44 45 46 47 | overwritten by a byte-array value. For \fBTcl_GetBytesFromObj\fR, \fBTcl_GetByteArrayFromObj\fR and \fBTcl_SetByteArrayLength\fR, this points to the value from which to extract an array of bytes. .AP Tcl_Interp *interp in Interpreter to use for error reporting. .AP "Tcl_Size \&| int" *numBytesPtr out Points to space where the number of bytes in the array may be written. | | > > > > < | 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 | overwritten by a byte-array value. For \fBTcl_GetBytesFromObj\fR, \fBTcl_GetByteArrayFromObj\fR and \fBTcl_SetByteArrayLength\fR, this points to the value from which to extract an array of bytes. .AP Tcl_Interp *interp in Interpreter to use for error reporting. .AP "Tcl_Size \&| int" *numBytesPtr out Points to space where the number of bytes in the array may be written. May be (Tcl_Size *)NULL when not used. If it points to a variable which type is not \fBTcl_Size\fR, a compiler warning will be generated. If your extensions is compiled with -DTCL_8_API, this function will return NULL for byte arrays larger than INT_MAX (which should trigger proper error-handling), otherwise expect it to crash. .BE .SH DESCRIPTION .PP These routines are used to create, modify, store, transfer, and retrieve arbitrary binary data in Tcl values. Specifically, data that can be represented as a sequence of arbitrary byte values is supported. This includes data read from binary channels, values created by the \fBbinary\fR command, encrypted data, or other information representable as |
︙ | ︙ |
Changes to doc/DictObj.3.
︙ | ︙ | |||
69 70 71 72 73 74 75 76 77 78 79 80 81 82 | Points to a variable that will have the value from a key/value pair placed within it. For \fBTcl_DictObjFirst\fR and \fBTcl_DictObjNext\fR, this may be NULL to indicate that the caller is not interested in the value. .AP "Tcl_Size \&| int" *sizePtr out Points to a variable that will have the number of key/value pairs contained within the dictionary placed within it. .AP Tcl_DictSearch *searchPtr in/out Pointer to record to use to keep track of progress in enumerating all key/value pairs in a dictionary. The contents of the record will be initialized by the call to \fBTcl_DictObjFirst\fR. If the enumerating is to be terminated before all values in the dictionary have been returned, the search record \fImust\fR be passed to \fBTcl_DictObjDone\fR to enable the internal locks to be released. | > > > > > | 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 | Points to a variable that will have the value from a key/value pair placed within it. For \fBTcl_DictObjFirst\fR and \fBTcl_DictObjNext\fR, this may be NULL to indicate that the caller is not interested in the value. .AP "Tcl_Size \&| int" *sizePtr out Points to a variable that will have the number of key/value pairs contained within the dictionary placed within it. May be (Tcl_Size *)NULL when not used. If it points to a variable which type is not \fBTcl_Size\fR, a compiler warning will be generated. If your extensions is compiled with -DTCL_8_API, this function will return NULL for dictionaries larger than INT_MAX (which should trigger proper error-handling), otherwise expect it to crash. .AP Tcl_DictSearch *searchPtr in/out Pointer to record to use to keep track of progress in enumerating all key/value pairs in a dictionary. The contents of the record will be initialized by the call to \fBTcl_DictObjFirst\fR. If the enumerating is to be terminated before all values in the dictionary have been returned, the search record \fImust\fR be passed to \fBTcl_DictObjDone\fR to enable the internal locks to be released. |
︙ | ︙ |
Changes to doc/Eval.3.
︙ | ︙ | |||
33 34 35 36 37 38 39 | int \fBTcl_GlobalEval\fR(\fIinterp, script\fR) .sp int \fBTcl_GlobalEvalObj\fR(\fIinterp, objPtr\fR) .sp int | | | 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 | int \fBTcl_GlobalEval\fR(\fIinterp, script\fR) .sp int \fBTcl_GlobalEvalObj\fR(\fIinterp, objPtr\fR) .sp int \fBTcl_VarEval\fR(\fIinterp, part, part, ... \fB(char *)NULL\fR) .SH ARGUMENTS .AS Tcl_Interp **termPtr .AP Tcl_Interp *interp in Interpreter in which to execute the script. The interpreter's result is modified to hold the result or error message from the script. .AP Tcl_Obj *objPtr in A Tcl value containing the script to execute. |
︙ | ︙ |
Changes to doc/FileSystem.3.
︙ | ︙ | |||
266 267 268 269 270 271 272 | .AP "const char" *modeString in Specifies how the file is to be accessed. May have any of the values allowed for the \fImode\fR argument to the Tcl \fBopen\fR command. .AP int permissions in POSIX-style permission flags such as 0644. If a new file is created, these permissions will be set on the created file. .AP "Tcl_Size \&| int" *lenPtr out | | > > > > > | 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 | .AP "const char" *modeString in Specifies how the file is to be accessed. May have any of the values allowed for the \fImode\fR argument to the Tcl \fBopen\fR command. .AP int permissions in POSIX-style permission flags such as 0644. If a new file is created, these permissions will be set on the created file. .AP "Tcl_Size \&| int" *lenPtr out Filled with the number of elements in the split path. May be (Tcl_Size *)NULL when not used. If it points to a variable which type is not \fBTcl_Size\fR, a compiler warning will be generated. If your extensions is compiled with -DTCL_8_API, this function will return NULL for paths having more than INT_MAX elements (which should trigger proper error-handling), otherwise expect it to crash. .AP Tcl_Obj *basePtr in The base path on to which to join the given elements. May be NULL. .AP Tcl_Size objc in The number of elements in \fIobjv\fR. .AP "Tcl_Obj *const" objv[] in The elements to join to the given base path. .AP Tcl_Obj *linkNamePtr in |
︙ | ︙ |
Changes to doc/ListObj.3.
︙ | ︙ | |||
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 | points to the Tcl value that will be appended to \fIlistPtr\fR. For \fBTcl_SetListObj\fR, this points to the Tcl value that will be converted to a list value containing the \fIobjc\fR elements of the array referenced by \fIobjv\fR. .AP "Tcl_Size \&| int" *objcPtr in Points to location where \fBTcl_ListObjGetElements\fR stores the number of element values in \fIlistPtr\fR. .AP Tcl_Obj ***objvPtr out A location where \fBTcl_ListObjGetElements\fR stores a pointer to an array of pointers to the element values of \fIlistPtr\fR. .AP Tcl_Size objc in The number of Tcl values that \fBTcl_NewListObj\fR will insert into a new list value, and \fBTcl_ListObjReplace\fR will insert into \fIlistPtr\fR. For \fBTcl_SetListObj\fR, the number of Tcl values to insert into \fIobjPtr\fR. .AP "Tcl_Obj *const" objv[] in An array of pointers to values. \fBTcl_NewListObj\fR will insert these values into a new list value and \fBTcl_ListObjReplace\fR will insert them into an existing \fIlistPtr\fR. Each value will become a separate list element. .AP "Tcl_Size \&| int" *lengthPtr out Points to location where \fBTcl_ListObjLength\fR stores the length of the list. .AP Tcl_Size index in Index of the list element that \fBTcl_ListObjIndex\fR is to return. The first element has index 0. .AP Tcl_Obj **objPtrPtr out Points to place where \fBTcl_ListObjIndex\fR is to store a pointer to the resulting list element value. | > > > > > > > > > > | 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 | points to the Tcl value that will be appended to \fIlistPtr\fR. For \fBTcl_SetListObj\fR, this points to the Tcl value that will be converted to a list value containing the \fIobjc\fR elements of the array referenced by \fIobjv\fR. .AP "Tcl_Size \&| int" *objcPtr in Points to location where \fBTcl_ListObjGetElements\fR stores the number of element values in \fIlistPtr\fR. May be (Tcl_Size *)NULL when not used. If it points to a variable which type is not \fBTcl_Size\fR, a compiler warning will be generated. If your extensions is compiled with -DTCL_8_API, this function will return NULL for lists with more than INT_MAX elements (which should trigger proper error-handling), otherwise expect it to crash. .AP Tcl_Obj ***objvPtr out A location where \fBTcl_ListObjGetElements\fR stores a pointer to an array of pointers to the element values of \fIlistPtr\fR. .AP Tcl_Size objc in The number of Tcl values that \fBTcl_NewListObj\fR will insert into a new list value, and \fBTcl_ListObjReplace\fR will insert into \fIlistPtr\fR. For \fBTcl_SetListObj\fR, the number of Tcl values to insert into \fIobjPtr\fR. .AP "Tcl_Obj *const" objv[] in An array of pointers to values. \fBTcl_NewListObj\fR will insert these values into a new list value and \fBTcl_ListObjReplace\fR will insert them into an existing \fIlistPtr\fR. Each value will become a separate list element. .AP "Tcl_Size \&| int" *lengthPtr out Points to location where \fBTcl_ListObjLength\fR stores the length of the list. May be (Tcl_Size *)NULL when not used. If it points to a variable which type is not \fBTcl_Size\fR, a compiler warning will be generated. If your extensions is compiled with -DTCL_8_API, this function will return TCL_ERROR for lists with more than INT_MAX elements (which should trigger proper error-handling), otherwise expect it to crash. .AP Tcl_Size index in Index of the list element that \fBTcl_ListObjIndex\fR is to return. The first element has index 0. .AP Tcl_Obj **objPtrPtr out Points to place where \fBTcl_ListObjIndex\fR is to store a pointer to the resulting list element value. |
︙ | ︙ | |||
160 161 162 163 164 165 166 | will attempt to convert it to one; if the conversion fails, it returns \fBTCL_ERROR\fR and leaves an error message in the interpreter's result value if \fIinterp\fR is not NULL. Otherwise it returns \fBTCL_OK\fR after storing the count and array pointer. .PP \fBTcl_ListObjLength\fR returns the number of elements in the list value referenced by \fIlistPtr\fR. | < < < | 170 171 172 173 174 175 176 177 178 179 180 181 182 183 | will attempt to convert it to one; if the conversion fails, it returns \fBTCL_ERROR\fR and leaves an error message in the interpreter's result value if \fIinterp\fR is not NULL. Otherwise it returns \fBTCL_OK\fR after storing the count and array pointer. .PP \fBTcl_ListObjLength\fR returns the number of elements in the list value referenced by \fIlistPtr\fR. If the value is not already a list value, \fBTcl_ListObjLength\fR will attempt to convert it to one; if the conversion fails, it returns \fBTCL_ERROR\fR and leaves an error message in the interpreter's result value if \fIinterp\fR is not NULL. Otherwise it returns \fBTCL_OK\fR after storing the list's length. .PP |
︙ | ︙ |
Changes to doc/ParseArgs.3.
︙ | ︙ | |||
21 22 23 24 25 26 27 28 29 30 31 32 33 34 | Where to store error messages. .AP "const Tcl_ArgvInfo" *argTable in Pointer to array of option descriptors. .AP "Tcl_Size \&| int" *objcPtr in/out A pointer to variable holding number of arguments in \fIobjv\fR. Will be modified to hold number of arguments left in the unprocessed argument list stored in \fIremObjv\fR. .AP "Tcl_Obj *const" *objv in The array of arguments to be parsed. .AP Tcl_Obj ***remObjv out Pointer to a variable that will hold the array of unprocessed arguments. Should be NULL if no return of unprocessed arguments is required. If \fIobjcPtr\fR is updated to a non-zero value, the array returned through this must be deallocated using \fBTcl_Free\fR. | > > > > > | 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 | Where to store error messages. .AP "const Tcl_ArgvInfo" *argTable in Pointer to array of option descriptors. .AP "Tcl_Size \&| int" *objcPtr in/out A pointer to variable holding number of arguments in \fIobjv\fR. Will be modified to hold number of arguments left in the unprocessed argument list stored in \fIremObjv\fR. May be (Tcl_Size *)NULL when not used. If it points to a variable which type is not \fBTcl_Size\fR, a compiler warning will be generated. If your extensions is compiled with -DTCL_8_API, this function will return NULL for argument lists with more than INT_MAX elements (which should trigger proper error-handling), otherwise expect it to crash. .AP "Tcl_Obj *const" *objv in The array of arguments to be parsed. .AP Tcl_Obj ***remObjv out Pointer to a variable that will hold the array of unprocessed arguments. Should be NULL if no return of unprocessed arguments is required. If \fIobjcPtr\fR is updated to a non-zero value, the array returned through this must be deallocated using \fBTcl_Free\fR. |
︙ | ︙ |
Changes to doc/SetResult.3.
︙ | ︙ | |||
20 21 22 23 24 25 26 | \fBTcl_GetObjResult\fR(\fIinterp\fR) .sp \fBTcl_SetResult\fR(\fIinterp, result, freeProc\fR) .sp const char * \fBTcl_GetStringResult\fR(\fIinterp\fR) .sp | | | 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 | \fBTcl_GetObjResult\fR(\fIinterp\fR) .sp \fBTcl_SetResult\fR(\fIinterp, result, freeProc\fR) .sp const char * \fBTcl_GetStringResult\fR(\fIinterp\fR) .sp \fBTcl_AppendResult\fR(\fIinterp, result, result, ... , \fB(char *)NULL\fR) .sp \fBTcl_ResetResult\fR(\fIinterp\fR) .sp \fBTcl_TransferResult\fR(\fIsourceInterp, code, targetInterp\fR) .sp \fBTcl_AppendElement\fR(\fIinterp, element\fR) .SH ARGUMENTS |
︙ | ︙ |
Changes to doc/SplitList.3.
︙ | ︙ | |||
36 37 38 39 40 41 42 43 44 45 46 47 48 49 | .AP Tcl_Interp *interp out Interpreter to use for error reporting. If NULL, then no error message is left. .AP "const char" *list in Pointer to a string with proper list structure. .AP "Tcl_Size \&| int" *argcPtr out Filled in with number of elements in \fIlist\fR. .AP "const char" ***argvPtr out \fI*argvPtr\fR will be filled in with the address of an array of pointers to the strings that are the extracted elements of \fIlist\fR. There will be \fI*argcPtr\fR valid entries in the array, followed by a NULL entry. .AP Tcl_Size argc in Number of elements in \fIargv\fR. | > > > > > | 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 | .AP Tcl_Interp *interp out Interpreter to use for error reporting. If NULL, then no error message is left. .AP "const char" *list in Pointer to a string with proper list structure. .AP "Tcl_Size \&| int" *argcPtr out Filled in with number of elements in \fIlist\fR. May be (Tcl_Size *)NULL when not used. If it points to a variable which type is not \fBTcl_Size\fR, a compiler warning will be generated. If your extensions is compiled with -DTCL_8_API, this function will return TCL_ERROR for lists with more than INT_MAX elements (which should trigger proper error-handling), otherwise expect it to crash. .AP "const char" ***argvPtr out \fI*argvPtr\fR will be filled in with the address of an array of pointers to the strings that are the extracted elements of \fIlist\fR. There will be \fI*argcPtr\fR valid entries in the array, followed by a NULL entry. .AP Tcl_Size argc in Number of elements in \fIargv\fR. |
︙ | ︙ |
Changes to doc/SplitPath.3.
︙ | ︙ | |||
23 24 25 26 27 28 29 30 31 32 33 34 35 36 | .SH ARGUMENTS .AS "const char *const" ***argvPtr in/out .AP "const char" *path in File path in a form appropriate for the current platform (see the \fBfilename\fR manual entry for acceptable forms for path names). .AP "Tcl_Size \&| int" *argcPtr out Filled in with number of path elements in \fIpath\fR. .AP "const char" ***argvPtr out \fI*argvPtr\fR will be filled in with the address of an array of pointers to the strings that are the extracted elements of \fIpath\fR. There will be \fI*argcPtr\fR valid entries in the array, followed by a NULL entry. .AP Tcl_Size argc in Number of elements in \fIargv\fR. | > > > > > | 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 | .SH ARGUMENTS .AS "const char *const" ***argvPtr in/out .AP "const char" *path in File path in a form appropriate for the current platform (see the \fBfilename\fR manual entry for acceptable forms for path names). .AP "Tcl_Size \&| int" *argcPtr out Filled in with number of path elements in \fIpath\fR. May be (Tcl_Size *)NULL when not used. If it points to a variable which type is not \fBTcl_Size\fR, a compiler warning will be generated. If your extensions is compiled with -DTCL_8_API, argcPtr will be filled with -1 for paths with more than INT_MAX elements (which should trigger proper error-handling), otherwise expect it to crash. .AP "const char" ***argvPtr out \fI*argvPtr\fR will be filled in with the address of an array of pointers to the strings that are the extracted elements of \fIpath\fR. There will be \fI*argcPtr\fR valid entries in the array, followed by a NULL entry. .AP Tcl_Size argc in Number of elements in \fIargv\fR. |
︙ | ︙ |
Changes to doc/StringObj.3.
︙ | ︙ | |||
52 53 54 55 56 57 58 | void \fBTcl_AppendUnicodeToObj\fR(\fIobjPtr, unicode, numChars\fR) .sp void \fBTcl_AppendObjToObj\fR(\fIobjPtr, appendObjPtr\fR) .sp void | | | 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 | void \fBTcl_AppendUnicodeToObj\fR(\fIobjPtr, unicode, numChars\fR) .sp void \fBTcl_AppendObjToObj\fR(\fIobjPtr, appendObjPtr\fR) .sp void \fBTcl_AppendStringsToObj\fR(\fIobjPtr, string, string, ... \fB(char *)NULL\fR) .sp void \fBTcl_AppendLimitedToObj\fR(\fIobjPtr, bytes, length, limit, ellipsis\fR) .sp Tcl_Obj * \fBTcl_Format\fR(\fIinterp, format, objc, objv\fR) .sp |
︙ | ︙ | |||
116 117 118 119 120 121 122 | the last one available. .AP Tcl_Obj *objPtr in/out A pointer to a value to read, or to an unshared value to modify. .AP Tcl_Obj *appendObjPtr in The value to append to \fIobjPtr\fR in \fBTcl_AppendObjToObj\fR. .AP "Tcl_Size \&| int" *lengthPtr out The location where \fBTcl_GetStringFromObj\fR will store the length | | > > > > | 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 | the last one available. .AP Tcl_Obj *objPtr in/out A pointer to a value to read, or to an unshared value to modify. .AP Tcl_Obj *appendObjPtr in The value to append to \fIobjPtr\fR in \fBTcl_AppendObjToObj\fR. .AP "Tcl_Size \&| int" *lengthPtr out The location where \fBTcl_GetStringFromObj\fR will store the length of a value's string representation. May be (Tcl_Size *)NULL when not used. If it points to a variable which type is not \fBTcl_Size\fR, a compiler warning will be generated. If your extensions is compiled with -DTCL_8_API, this function will panic for strings with more than INT_MAX bytes/characters, otherwise expect it to crash. .AP "const char" *string in Null-terminated string value to append to \fIobjPtr\fR. .AP Tcl_Size limit in Maximum number of bytes to be appended. .AP "const char" *ellipsis in Suffix to append when the limit leads to string truncation. If NULL is passed then the suffix |
︙ | ︙ | |||
181 182 183 184 185 186 187 | limited purpose, the pointer returned by \fBTcl_GetStringFromObj\fR or \fBTcl_GetString\fR should be treated as read-only. It is recommended that this pointer be assigned to a (const char *) variable. Even in the limited situations where writing to this pointer is acceptable, one should take care to respect the copy-on-write semantics required by \fBTcl_Obj\fR's, with appropriate calls to \fBTcl_IsShared\fR and \fBTcl_DuplicateObj\fR prior to any | | < < | < | | | 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 | limited purpose, the pointer returned by \fBTcl_GetStringFromObj\fR or \fBTcl_GetString\fR should be treated as read-only. It is recommended that this pointer be assigned to a (const char *) variable. Even in the limited situations where writing to this pointer is acceptable, one should take care to respect the copy-on-write semantics required by \fBTcl_Obj\fR's, with appropriate calls to \fBTcl_IsShared\fR and \fBTcl_DuplicateObj\fR prior to any in-place modification of the string representation. The procedure \fBTcl_GetString\fR is used in the common case where the caller does not need the length of the string representation. .PP \fBTcl_GetUnicodeFromObj\fR and \fBTcl_GetUnicode\fR return a value's value as a Unicode string. This is given by the returned pointer and (for \fBTcl_GetUnicodeFromObj\fR) length, which is stored in \fIlengthPtr\fR if it is non-NULL. The storage referenced by the returned byte pointer is owned by the value manager and should not be modified by the caller. The procedure \fBTcl_GetUnicode\fR is used in the common case where the caller does not need the length of the unicode string representation. .PP \fBTcl_GetUniChar\fR returns the \fIindex\fR'th character in the value's Unicode representation. If the index is out of range it returns -1; .PP \fBTcl_GetRange\fR returns a newly created value comprised of the characters between \fIfirst\fR and \fIlast\fR (inclusive) in the value's Unicode representation. If the value's Unicode representation is invalid, the Unicode representation is regenerated from the value's string representation. If \fIfirst\fR is negative, then the returned string starts at the beginning of the value. If \fIlast\fR negative, |
︙ | ︙ |
Changes to doc/Utf.3.
︙ | ︙ | |||
301 302 303 304 305 306 307 | byte \fIsrc[0]\fR nor the byte \fIstart[-1]\fR nor the byte \fIsrc[-5]\fR. .PP \fBTcl_UniCharAtIndex\fR corresponds to a C string array dereference or the Pascal Ord() function. It returns the Unicode character represented at the specified character (not byte) \fIindex\fR in the UTF-8 string \fIsrc\fR. The source string must contain at least \fIindex\fR | | < | 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 | byte \fIsrc[0]\fR nor the byte \fIstart[-1]\fR nor the byte \fIsrc[-5]\fR. .PP \fBTcl_UniCharAtIndex\fR corresponds to a C string array dereference or the Pascal Ord() function. It returns the Unicode character represented at the specified character (not byte) \fIindex\fR in the UTF-8 string \fIsrc\fR. The source string must contain at least \fIindex\fR characters. If \fIindex\fR is negative it returns -1. .PP \fBTcl_UtfAtIndex\fR returns a pointer to the specified character (not byte) \fIindex\fR in the UTF-8 string \fIsrc\fR. The source string must contain at least \fIindex\fR characters. This is equivalent to calling \fBTcl_UtfToUniChar\fR \fIindex\fR times. If \fIindex\fR is negative, the return pointer points to the first character in the source string. .PP |
︙ | ︙ |
Changes to doc/chan.n.
︙ | ︙ | |||
392 393 394 395 396 397 398 | \fBchan eof \fIchannelName\fR . Returns 1 if the last read on the channel failed because the end of the data was already reached, and 0 otherwise. .TP \fBchan event \fIchannelName event\fR ?\fIscript\fR? . | | | 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 | \fBchan eof \fIchannelName\fR . Returns 1 if the last read on the channel failed because the end of the data was already reached, and 0 otherwise. .TP \fBchan event \fIchannelName event\fR ?\fIscript\fR? . Arranges for the given script, called a \fBchannel event handler\fR, to be called whenever the given event, one of .QW \fBreadable\fR or .QW \fBwritable\fR occurs on the given channel, replacing any script that was previously set. If \fIscript\fR is the empty string the current handler is deleted. It is also deleted when the channel is closed. If \fIscript\fR is omitted, either the |
︙ | ︙ |
Added doc/const.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 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 | '\" '\" Copyright (c) 2023 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 const n 9.0 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME const \- create and initialize a constant .SH SYNOPSIS \fBconst \fIvarName value\fR .BE .SH DESCRIPTION .PP This command is normally used within a procedure body (or method body, or lambda term) to create a constant within that procedure, or within a \fBnamespace eval\fR body to create a constant within that namespace. The constant is an unmodifiable variable, called \fIvarName\fR, that is initialized with \fIvalue\fR. The result of \fBconst\fR is always the empty string on success. .PP If a variable \fIvarName\fR does not exist, it is created with its value set to \fIvalue\fR and marked as a constant; this means that no other command (e.g., \fBset\fR, \fBappend\fR, \fBincr\fR, \fBunset\fR) may modify or remove the variable; variables are checked for whether they are constants before any traces are called. If a variable \fIvarName\fR already exists, it is an error unless that variable is marked as a constant (in which case \fBconst\fR is a no-op). .PP The \fIvarName\fR may not be a qualified name or reference an element of an array by any means. If the variable exists and is an array, that is an error. .PP Constants are normally only removed by their containing procedure exiting or their namespace being deleted. .SH EXAMPLES .PP Create a constant in a procedure: .PP .CS proc foo {a b} { \fBconst\fR BAR 12345 return [expr {$a + $b + $BAR}] } .CE .PP Create a constant in a namespace to factor out a regular expression: .PP .CS namespace eval someNS { \fBconst\fR FOO_MATCHER {(?i)}\emfoo\eM} proc findFoos str { variable FOO_MATCHER regexp -all $FOO_MATCHER $str } proc findFooIndices str { variable FOO_MATCHER regexp -all -indices $FOO_MATCHER $str } } .CE .PP Making a constant in a loop doesn't error: .PP .CS proc foo {n} { set result {} for {set i 0} {$i < $n} {incr i} { \fBconst\fR X 123 lappend result [expr {$X + $i**2}] } } .CE .SH "SEE ALSO" proc(n), namespace(n), set(n), unset(n) .SH KEYWORDS namespace, procedure, variable, constant .\" Local variables: .\" mode: nroff .\" fill-column: 78 .\" End: |
Changes to doc/coroutine.n.
︙ | ︙ | |||
115 116 117 118 119 120 121 | multiple injected commands, the result of one becomes the resumption value processed by the next. .PP The injection is a one-off. It is not retained once it has been executed. It may \fByield\fR or \fByieldto\fR as part of its execution. .PP Note that running coroutines may be neither probed nor injected; the | | > > > | 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 | multiple injected commands, the result of one becomes the resumption value processed by the next. .PP The injection is a one-off. It is not retained once it has been executed. It may \fByield\fR or \fByieldto\fR as part of its execution. .PP Note that running coroutines may be neither probed nor injected; the operations may only be applied to coroutines that are suspended. (If a coroutine is running then any introspection code would be merely inspecting the state of where it is currently running; \fBcoroinject\fR/\fBcoroprobe\fR are unnecessary in that case.) .VE "8.7, TIP383" .SH EXAMPLES .PP This example shows a coroutine that will produce an infinite sequence of even values, and a loop that consumes the first ten of them. .PP .CS |
︙ | ︙ |
Changes to doc/exec.n.
︙ | ︙ | |||
250 251 252 253 254 255 256 | % exec my-echo.cmd {test&whoami} test mylogin % exec my-echo.cmd "ENV X:%X%" ENV X: CONTENT OF X .CE The following formatting is automatically performed on any | < < | < < < < < < < | < > | 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 | % exec my-echo.cmd {test&whoami} test mylogin % exec my-echo.cmd "ENV X:%X%" ENV X: CONTENT OF X .CE The following formatting is automatically performed on any argument item to avoid subprogram execution: Any special character argument containing a special character (\fB&\fR, \fB|\fR, \fB^\fR, \fB<\fR, \fB>\fR, \fB!\fR, \fB(\fR, \fB)\fR, \fB(\fR, \fB%\fR) is automatically enclosed in quotes (\fB"\fR). Any data quote is escaped by insertion of backslash characters. .PP The automatic resolving of environment variables using "\fB%var%\fR" is critical, but has more use than danger and is not escaped. .RE .PP The Tk console text widget does not provide real standard IO capabilities. Under Tk, when redirecting from standard input, all applications will see an immediate end-of-file; information redirected to standard output or standard error will be discarded. .PP |
︙ | ︙ |
Changes to doc/fcopy.n.
︙ | ︙ | |||
13 14 15 16 17 18 19 | fcopy \- Copy data from one channel to another .SH SYNOPSIS \fBfcopy \fIinputChan\fR \fIoutputChan\fR ?\fB\-size \fIsize\fR? ?\fB\-command \fIcallback\fR? .BE .SH DESCRIPTION .PP | | < | | > | > > > > > > > > > > > > > > > | < > > > | > | > > | | | | > > > | > | < < < > | > | > | | < | < > > | < > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | fcopy \- Copy data from one channel to another .SH SYNOPSIS \fBfcopy \fIinputChan\fR \fIoutputChan\fR ?\fB\-size \fIsize\fR? ?\fB\-command \fIcallback\fR? .BE .SH DESCRIPTION .PP The \fBfcopy\fR command copies data from one I/O channel, \fIinchan\fR to another I/O channel, \fIoutchan\fR. The \fBfcopy\fR command leverages the buffering in the Tcl I/O system to avoid extra copies and to avoid buffering too much data in main memory when copying large files to destinations like network sockets. . .SS "DATA QUANTITY" All data until \fIEOF\fR is copied. In addition, the quantity of copied data may be specified by the option \fB-size\fR. The given size is in bytes, if the input channel is in binary mode. Otherwise, it is in characters. .PP Depreciated feature: the transfer is treated as a binary transfer, if the encoding profile is set to .QW tcl8 and the input encoding matches the output encoding. In this case, eventual encoding errors are not handled. An eventually given size is in bytes in this case. . .SS "BLOCKING OPERATION MODE" Without the \fB\-command\fR option, \fBfcopy\fR blocks until the copy is complete and returns the number of bytes or characters (using the same rules as for the \fB\-size\fR option) written to \fIoutchan\fR. . .SS "BACKGROUND OPERATION MODE" The \fB\-command\fR argument makes \fBfcopy\fR work in the background. In this case it returns immediately and the \fIcallback\fR is invoked later when the copy completes. The \fIcallback\fR is called with one or two additional arguments that indicates how many bytes were written to \fIoutchan\fR. If an error occurred during the background copy, the second argument is the error string associated with the error. With a background copy, it is not necessary to put \fIinchan\fR or \fIoutchan\fR into non-blocking mode; the \fBfcopy\fR command takes care of that automatically. However, it is necessary to enter the event loop by using the \fBvwait\fR command or by using Tk. .PP You are not allowed to do other input operations with \fIinchan\fR, or output operations with \fIoutchan\fR, during a background \fBfcopy\fR. The converse is entirely legitimate, as exhibited by the bidirectional fcopy example below. .PP If either \fIinchan\fR or \fIoutchan\fR get closed while the copy is in progress, the current copy is stopped and the command callback is \fInot\fR made. If \fIinchan\fR is closed, then all data already queued for \fIoutchan\fR is written out. .PP Note that \fIinchan\fR can become readable during a background copy. You should turn off any \fBfileevent\fR handlers during a background copy so those handlers do not interfere with the copy. Any wrong-sided I/O attempted (by a \fBfileevent\fR handler or otherwise) will get a .QW "channel busy" error. . .SS "CHANNEL TRANSLATION OPTIONS" \fBFcopy\fR translates end-of-line sequences in \fIinchan\fR and \fIoutchan\fR according to the \fB\-translation\fR option for these channels. See the manual entry for \fBfconfigure\fR for details on the \fB\-translation\fR option. The translations mean that the number of bytes read from \fIinchan\fR can be different than the number of bytes written to \fIoutchan\fR. Only the number of bytes written to \fIoutchan\fR is reported, either as the return value of a synchronous \fBfcopy\fR or as the argument to the callback for an asynchronous \fBfcopy\fR. .SS "CHANNEL ENCODING OPTIONS" \fBFcopy\fR obeys the encodings, profiles and character translations configured for the channels. This means that the incoming characters are converted internally first UTF-8 and then into the encoding of the channel \fBfcopy\fR writes to. See the manual entry for \fBfconfigure\fR for details on the \fB\-encoding\fR and \fB\-profile\fR options. No conversion is done if both channels are set to encoding .QW binary and have matching translations. If only the output channel is set to encoding .QW binary the system will write the internal UTF-8 representation of the incoming characters. If only the input channel is set to encoding .QW binary the system will assume that the incoming bytes are valid UTF-8 characters and convert them according to the output encoding. The behaviour of the system for bytes which are not valid UTF-8 characters is undefined in this case. .PP \fBFcopy\fR may throw encoding errors (error code \fBEILSEQ\fR), if input or output channel is configured to the .QW strict encoding profile. .PP If an encoding error arises on the input channel, any data before the error byte is written to the output channel. The input file pointer is located just before the values causing the encoding error. Error inspection or recovery is possible by changing the encoding parameters and invoking a file command (\fBread\fR, \fBfcopy\fR). .PP If an encoding error arises on the output channel, the errorneous data is lost. To make the difference between the input error case and the output error case, only the error message may be inspected (read or write), as both throw the error code \fIEILSEQ\fR. .SH EXAMPLES .PP The first example transfers the contents of one channel exactly to another. Note that when copying one file to another, it is better to use \fBfile copy\fR which also copies file metadata (e.g. the file access permissions) where possible. .PP |
︙ | ︙ | |||
94 95 96 97 98 99 100 | incr total $bytes if {([string length $error] != 0) || [eof $in]} { set done $total close $in close $out } else { \fBfcopy\fR $in $out -size $chunk \e | | | | 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 | incr total $bytes if {([string length $error] != 0) || [eof $in]} { set done $total close $in close $out } else { \fBfcopy\fR $in $out -size $chunk \e -command [list CopyMore $in $out $chunk] } } set in [open $file1] set out [socket $server $port] set chunk 1024 set total 0 \fBfcopy\fR $in $out -size $chunk \e -command [list CopyMore $in $out $chunk] vwait done .CE .PP The fourth example starts an asynchronous, bidirectional fcopy between two sockets. Those could also be pipes from two [open "|hal 9000" r+] (though their conversation would remain secret to the script, since all four fileevent slots are busy). |
︙ | ︙ |
Changes to doc/http.n.
︙ | ︙ | |||
54 55 56 57 58 59 60 | .sp \fB::http::responseHeaderValue\fR \fItoken\fR \fIheaderName\fR .sp \fB::http::responseInfo\fR \fItoken\fR .sp \fB::http::responseBody\fR \fItoken\fR .sp | | | | 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 | .sp \fB::http::responseHeaderValue\fR \fItoken\fR \fIheaderName\fR .sp \fB::http::responseInfo\fR \fItoken\fR .sp \fB::http::responseBody\fR \fItoken\fR .sp \fB::http::register \fIproto port command\fR ?\fIsocketCmdVarName\fR? ?\fIuseSockThread\fR? ?\fIendToEndProxy\fR? .sp \fB::http::registerError \fIsock\fR ?\fImessage\fR? .sp \fB::http::unregister \fIproto\fR .sp \fB::http::code \fItoken\fR .sp \fB::http::data \fItoken\fR .sp |
︙ | ︙ | |||
785 786 787 788 789 790 791 | .PP Other terms for "entity", with varying precision, include "representation of resource", "resource", "response body after decoding", "payload", "message body after decoding", "content(s)", and "file". .RE .TP | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > | | < | | | 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 | .PP Other terms for "entity", with varying precision, include "representation of resource", "resource", "response body after decoding", "payload", "message body after decoding", "content(s)", and "file". .RE .TP \fB::http::register\fR \fIproto port command\fR ?\fIsocketCmdVarName\fR? ?\fIuseSockThread\fR? ?\fIendToEndProxy\fR? . This procedure allows one to provide custom HTTP transport types such as HTTPS, by registering a prefix, the default port, and the command to execute to create the Tcl \fBchannel\fR. The optional arguments configure how \fBhttp\fR uses the custom transport, and have default values that are compatible with older versions of \fBhttp\fR in which \fB::http::register\fR has no optional arguments. .RS .PP Argument \fIsocketCmdVarName\fR is the name of a variable provided by the transport, whose value is the command used by the transport to open a socket. Its default value is set by the transport and is "::socket", but if the name of the variable is supplied to \fB::http::register\fR, then \fBhttp\fR will set a new value in order to make optional facilities available. These facilities are enabled by the optional arguments \fIuseSockThread\fR, \fIendToEndProxy\fR, which take boolean values with default value \fIfalse\fR. .PP Iff argument \fIuseSockThread\fR is supplied and is boolean \fItrue\fR, then iff permitted by the value [\fBhttp::config\fR \fI-threadlevel\fR] and by the availability of package \fBThread\fR, sockets created for the transport will be opened in a different thread so that a slow DNS lookup will not cause the script to block. .PP Iff argument \fIendToEndProxy\fR is supplied and is boolean \fItrue\fR, then when \fBhttp::geturl\fR accesses a server via a proxy, it will open a channel by sending a CONNECT request to the proxy, and it will then make its request over this channel. This allows end-to-end encryption for HTTPS requests made through a proxy. .PP For example, .RS .PP .CS package require http package require tls ::http::register https 443 ::tls::socket ::tls::socketCmd 1 1 set token [::http::geturl https://my.secure.site/] .CE .RE .RE .TP \fB::http::registerError\fR \fIsock\fR ?\fImessage\fR? . This procedure allows a registered protocol handler to deliver an error message for use by \fBhttp\fR. Calling this command does not raise an error. The command is useful when a registered protocol detects an problem (for example, an invalid TLS certificate) that will cause an error to propagate to \fBhttp\fR. The command allows \fBhttp\fR to provide a precise error message rather than a general one. The command returns the value provided by the last call with argument \fImessage\fR, or the empty string if no such call has been made. .TP \fB::http::unregister\fR \fIproto\fR . This procedure unregisters a protocol handler that was previously registered via \fB::http::register\fR, returning a six-item list of the values that were previously supplied to \fB::http::register\fR if there was such a handler, and an error if there was no such handler. .TP \fB::http::code\fR \fItoken\fR . An alternative name for the command \fB::http::responseLine\fR .TP \fB::http::data\fR \fItoken\fR . |
︙ | ︙ |
Changes to doc/info.n.
︙ | ︙ | |||
80 81 82 83 84 85 86 87 88 89 90 91 92 93 | \fBnamespace\fR(n) documentation. .TP \fBinfo complete \fIcommand\fR . Returns 1 if \fIcommand\fR is a complete command, and \fB0\fR otherwise. Typically used in line-oriented input environments to allow users to type in commands that span multiple lines. .TP \fBinfo coroutine\fR . Returns the name of the current \fBcoroutine\fR, or the empty string if there is no current coroutine or the current coroutine has been deleted. .TP | > > > > > > > > > > > > > | 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 | \fBnamespace\fR(n) documentation. .TP \fBinfo complete \fIcommand\fR . Returns 1 if \fIcommand\fR is a complete command, and \fB0\fR otherwise. Typically used in line-oriented input environments to allow users to type in commands that span multiple lines. .TP \fBinfo constant \fIvarName\fR .VS "TIP 677" Returns 1 if \fIvarName\fR is a constant variable (see \fBconst\fR) and 0 otherwise. .VE "TIP 677" .TP \fBinfo consts\fR ?\fIpattern\fR? .VS "TIP 677" Returns the list of constant variables (see \fBconst\fR) in the current scope, or the list of constant variables matching \fIpattern\fR (if that is provided) in a manner similar to \fBinfo vars\fR. .VE "TIP 677" .TP \fBinfo coroutine\fR . Returns the name of the current \fBcoroutine\fR, or the empty string if there is no current coroutine or the current coroutine has been deleted. .TP |
︙ | ︙ |
Changes to doc/library.n.
︙ | ︙ | |||
21 22 23 24 25 26 27 28 29 30 31 32 33 34 | \fBtcl_findLibrary \fIbasename version patch initScript enVarName varName\fR \fBparray \fIarrayName\fR ?\fIpattern\fR? \fBtcl_endOfWord \fIstr start\fR \fBtcl_startOfNextWord \fIstr start\fR \fBtcl_startOfPreviousWord \fIstr start\fR \fBtcl_wordBreakAfter \fIstr start\fR \fBtcl_wordBreakBefore \fIstr start\fR .BE .SH INTRODUCTION .PP Tcl includes a library of Tcl procedures for commonly-needed functions. The procedures defined in the Tcl library are generic ones suitable for use by many different applications. The location of the Tcl library is returned by the \fBinfo library\fR | > > > > > | 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 | \fBtcl_findLibrary \fIbasename version patch initScript enVarName varName\fR \fBparray \fIarrayName\fR ?\fIpattern\fR? \fBtcl_endOfWord \fIstr start\fR \fBtcl_startOfNextWord \fIstr start\fR \fBtcl_startOfPreviousWord \fIstr start\fR \fBtcl_wordBreakAfter \fIstr start\fR \fBtcl_wordBreakBefore \fIstr start\fR .VS "Tcl 8.7, TIP 670" \fBforeachLine \fIfilename varName body\fR \fBreadFile \fIfilename\fR ?\fBtext\fR|\fBbinary\fR? \fBwriteFile \fIfilename\fR ?\fBtext\fR|\fBbinary\fR? \fIcontents\fR .VE "Tcl 8.7, TIP 670" .BE .SH INTRODUCTION .PP Tcl includes a library of Tcl procedures for commonly-needed functions. The procedures defined in the Tcl library are generic ones suitable for use by many different applications. The location of the Tcl library is returned by the \fBinfo library\fR |
︙ | ︙ | |||
302 303 304 305 306 307 308 309 310 311 312 313 314 315 | \fBtcl_wordBreakBefore \fIstr start\fR . Returns the index of the first word boundary before the starting index \fIstart\fR in the string \fIstr\fR. Returns \-1 if there are no more boundaries before the starting point in the given string. The index returned refers to the second character of the pair that comprises a boundary. .SH "VARIABLES" .PP The following global variables are defined or used by the procedures in the Tcl library. They fall into two broad classes, handling unknown commands and packages, and determining what are words. .SS "AUTOLOADING AND PACKAGE MANAGEMENT VARIABLES" .TP | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | \fBtcl_wordBreakBefore \fIstr start\fR . Returns the index of the first word boundary before the starting index \fIstart\fR in the string \fIstr\fR. Returns \-1 if there are no more boundaries before the starting point in the given string. The index returned refers to the second character of the pair that comprises a boundary. .TP \fBforeachLine \fIvarName filename body\fR .VS "Tcl 8.7, TIP 670" This reads in the text file named \fIfilename\fR one line at a time (using system defaults for reading text files). It writes that line to the variable named by \fIvarName\fR and then executes \fIbody\fR for that line. The result value of \fIbody\fR is ignored, but \fBerror\fR, \fBreturn\fR, \fBbreak\fR and \fBcontinue\fR may be used within it to produce an error, return from the calling context, stop the loop, or go to the next line respectively. The overall result of \fBforeachLine\fR is the empty string (assuming no errors from I/O or from evaluating the body of the loop); the file will be closed prior to the procedure returning. .VE "Tcl 8.7, TIP 670" .TP \fBreadFile \fIfilename\fR ?\fBtext\fR|\fBbinary\fR? .VS "Tcl 8.7, TIP 670" Reads in the file named in \fIfilename\fR and returns its contents. The second argument says how to read in the file, either as \fBtext\fR (using the system defaults for reading text files) or as \fBbinary\fR (as uninterpreted bytes). The default is \fBtext\fR. When read as text, this will include any trailing newline. The file will be closed prior to the procedure returning. .VE "Tcl 8.7, TIP 670" .TP \fBwriteFile \fIfilename\fR ?\fBtext\fR|\fBbinary\fR? \fIcontents\fR .VS "Tcl 8.7, TIP 670" Writes the \fIcontents\fR to the file named in \fIfilename\fR. The optional second argument says how to write to the file, either as \fBtext\fR (using the system defaults for writing text files) or as \fBbinary\fR (as uninterpreted bytes). The default is \fBtext\fR. If a trailing newline is required, it will need to be provided in \fIcontents\fR. The result of this command is the empty string; the file will be closed prior to the procedure returning. .VE "Tcl 8.7, TIP 670" .SH "VARIABLES" .PP The following global variables are defined or used by the procedures in the Tcl library. They fall into two broad classes, handling unknown commands and packages, and determining what are words. .SS "AUTOLOADING AND PACKAGE MANAGEMENT VARIABLES" .TP |
︙ | ︙ |
Changes to doc/namespace.n.
︙ | ︙ | |||
10 11 12 13 14 15 16 | .TH namespace n 8.5 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME namespace \- create and manipulate contexts for commands and variables .SH SYNOPSIS | | | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 | .TH namespace n 8.5 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME namespace \- create and manipulate contexts for commands and variables .SH SYNOPSIS \fBnamespace \fR\fIsubcommand\fR ?\fIarg ...\fR? .BE .SH DESCRIPTION .PP The \fBnamespace\fR command lets you create, access, and destroy separate contexts for commands and variables. See the section \fBWHAT IS A NAMESPACE?\fR below for a brief overview of namespaces. |
︙ | ︙ |
Changes to doc/read.n.
︙ | ︙ | |||
57 58 59 60 61 62 63 | possible by changing to an encoding (or encoding profile), which accepts the data. An encoding error is reported by the POSIX error code \fBEILSEQ\fR. .PP In blocking mode, the error is directly thrown, even, if there is a leading decodable data portion. The file pointer is advanced just before the encoding error. | | < | > > > | > > > > > | 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 | possible by changing to an encoding (or encoding profile), which accepts the data. An encoding error is reported by the POSIX error code \fBEILSEQ\fR. .PP In blocking mode, the error is directly thrown, even, if there is a leading decodable data portion. The file pointer is advanced just before the encoding error. An eventual well decoded data chunk before the encoding error is returned in the error option dictionary key \fB-data\fR. The value of the key contains the empty string, if the error arises at the first data position. .PP In non blocking mode, first, any data without encoding error is returned (without error state). In the next call, no data is returned and the \fBEILSEQ\fR error state is set. The key \fB-data\fR is not present. .PP Here is an example with an encoding error in UTF-8 encoding, which is then introspected by a switch to the binary encoding. The test file contains a not continued multi-byte sequence at position 1 (\fBA \\xC3 B\fR): .PP File creation for examples . .CS % set f [open test_A_195_B.txt wb]; puts -nonewline $f A\\xC3B; close $f .CE Blocking example . .CS % set f [open test_A_195_B.txt r] file35a65a0 % fconfigure $f -encoding utf-8 -profile strict -blocking 1 % catch {read $f} e d 1 % set d -data A -code 1 -level 0 -errorstack {INNER {invokeStk1 read file35a65a0}} -errorcode {POSIX EILSEQ {invalid or incomplete multibyte or wide character}} -errorinfo {...} -errorline 1 % tell $f 1 % fconfigure $f -encoding binary -profile strict % read $f ÃB % close $f .CE The already decoded data "A" is returned in the error options dictionary key \fB-data\fR. The file position is advanced on the encoding error position 1. The data at the error position is thus recovered by the next \fBread\fR command. .PP Non blocking example . .CS % set f [open test_A_195_B.txt r] file35a65a0 % fconfigure $f -encoding utf-8 -profile strict -blocking 0 % read $f |
︙ | ︙ |
Changes to doc/string.n.
︙ | ︙ | |||
170 171 172 173 174 175 176 177 178 179 180 181 182 183 | .IP \fBspace\fR 12 Any Unicode whitespace character, mongolian vowel separator (U+180e), zero width space (U+200b), word joiner (U+2060) or zero width no-break space (U+feff) (=BOM). .IP \fBtrue\fR 12 Any of the forms allowed to \fBTcl_GetBoolean\fR where the value is true. .IP \fBupper\fR 12 Any upper case alphabet character in the Unicode character set. .IP \fBwideinteger\fR 12 Any of the valid forms for a wide integer in Tcl, with optional surrounding whitespace. In case of overflow in the value, 0 is returned and the \fIvarname\fR will contain \-1. .IP \fBwordchar\fR 12 | > > | 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 | .IP \fBspace\fR 12 Any Unicode whitespace character, mongolian vowel separator (U+180e), zero width space (U+200b), word joiner (U+2060) or zero width no-break space (U+feff) (=BOM). .IP \fBtrue\fR 12 Any of the forms allowed to \fBTcl_GetBoolean\fR where the value is true. .IP \fBunicode\fR 12 Any Unicode character, except surrogates and noncharacters .IP \fBupper\fR 12 Any upper case alphabet character in the Unicode character set. .IP \fBwideinteger\fR 12 Any of the valid forms for a wide integer in Tcl, with optional surrounding whitespace. In case of overflow in the value, 0 is returned and the \fIvarname\fR will contain \-1. .IP \fBwordchar\fR 12 |
︙ | ︙ |
Changes to generic/regc_lex.c.
︙ | ︙ | |||
839 840 841 842 843 844 845 | RETV(PLAIN, c); break; case CHR('U'): i = lexdigits(v, 16, 1, 8); if (ISERR()) { FAILW(REG_EESCAPE); } | < < < < < | 839 840 841 842 843 844 845 846 847 848 849 850 851 852 | RETV(PLAIN, c); break; case CHR('U'): i = lexdigits(v, 16, 1, 8); if (ISERR()) { FAILW(REG_EESCAPE); } RETV(PLAIN, (uchr) i); break; case CHR('v'): RETV(PLAIN, CHR('\v')); break; case CHR('w'): NOTE(REG_ULOCALE); |
︙ | ︙ |
Changes to generic/tcl.h.
︙ | ︙ | |||
554 555 556 557 558 559 560 | int argc, const char *argv[]); typedef void (Tcl_CmdTraceProc) (void *clientData, Tcl_Interp *interp, int level, char *command, Tcl_CmdProc *proc, void *cmdClientData, int argc, const char *argv[]); typedef int (Tcl_CmdObjTraceProc) (void *clientData, Tcl_Interp *interp, int level, const char *command, Tcl_Command commandInfo, int objc, struct Tcl_Obj *const *objv); | < < < < < < < | | | < > > > > > > > > > > | 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 | int argc, const char *argv[]); typedef void (Tcl_CmdTraceProc) (void *clientData, Tcl_Interp *interp, int level, char *command, Tcl_CmdProc *proc, void *cmdClientData, int argc, const char *argv[]); typedef int (Tcl_CmdObjTraceProc) (void *clientData, Tcl_Interp *interp, int level, const char *command, Tcl_Command commandInfo, int objc, struct Tcl_Obj *const *objv); typedef void (Tcl_CmdObjTraceDeleteProc) (void *clientData); typedef void (Tcl_DupInternalRepProc) (struct Tcl_Obj *srcPtr, struct Tcl_Obj *dupPtr); typedef int (Tcl_EncodingConvertProc) (void *clientData, const char *src, int srcLen, int flags, Tcl_EncodingState *statePtr, char *dst, int dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr); typedef void (Tcl_EncodingFreeProc) (void *clientData); typedef int (Tcl_EventProc) (Tcl_Event *evPtr, int flags); typedef void (Tcl_EventCheckProc) (void *clientData, int flags); typedef int (Tcl_EventDeleteProc) (Tcl_Event *evPtr, void *clientData); typedef void (Tcl_EventSetupProc) (void *clientData, int flags); typedef void (Tcl_ExitProc) (void *clientData); typedef void (Tcl_FileProc) (void *clientData, int mask); typedef void (Tcl_FileFreeProc) (void *clientData); typedef void (Tcl_FreeInternalRepProc) (struct Tcl_Obj *objPtr); typedef void (Tcl_IdleProc) (void *clientData); typedef void (Tcl_InterpDeleteProc) (void *clientData, Tcl_Interp *interp); typedef void (Tcl_NamespaceDeleteProc) (void *clientData); typedef int (Tcl_ObjCmdProc) (void *clientData, Tcl_Interp *interp, int objc, struct Tcl_Obj *const *objv); #if TCL_MAJOR_VERSION > 8 typedef int (Tcl_ObjCmdProc2) (void *clientData, Tcl_Interp *interp, Tcl_Size objc, struct Tcl_Obj *const *objv); typedef int (Tcl_CmdObjTraceProc2) (void *clientData, Tcl_Interp *interp, Tcl_Size level, const char *command, Tcl_Command commandInfo, Tcl_Size objc, struct Tcl_Obj *const *objv); typedef void (Tcl_FreeProc) (void *blockPtr); #define Tcl_ExitProc Tcl_FreeProc #define Tcl_FileFreeProc Tcl_FreeProc #define Tcl_FileFreeProc Tcl_FreeProc #define Tcl_EncodingFreeProc Tcl_FreeProc #else #define Tcl_ObjCmdProc2 Tcl_ObjCmdProc #define Tcl_CmdObjTraceProc2 Tcl_CmdObjTraceProc typedef void (Tcl_FreeProc) (char *blockPtr); #endif typedef int (Tcl_LibraryInitProc) (Tcl_Interp *interp); typedef int (Tcl_LibraryUnloadProc) (Tcl_Interp *interp, int flags); typedef void (Tcl_PanicProc) (const char *format, ...); typedef void (Tcl_TcpAcceptProc) (void *callbackData, Tcl_Channel chan, char *address, int port); typedef void (Tcl_TimerProc) (void *clientData); |
︙ | ︙ | |||
746 747 748 749 750 751 752 753 754 755 756 757 758 759 | const Tcl_ObjType *typePtr; /* Denotes the object's type. Always * corresponds to the type of the object's * internal rep. NULL indicates the object has * no internal rep (has no type). */ Tcl_ObjInternalRep internalRep; /* The internal representation: */ } Tcl_Obj; /* *---------------------------------------------------------------------------- * The following definitions support Tcl's namespace facility. Note: the first * five fields must match exactly the fields in a Namespace structure (see * tclInt.h). */ | > | 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 | const Tcl_ObjType *typePtr; /* Denotes the object's type. Always * corresponds to the type of the object's * internal rep. NULL indicates the object has * no internal rep (has no type). */ Tcl_ObjInternalRep internalRep; /* The internal representation: */ } Tcl_Obj; /* *---------------------------------------------------------------------------- * The following definitions support Tcl's namespace facility. Note: the first * five fields must match exactly the fields in a Namespace structure (see * tclInt.h). */ |
︙ | ︙ | |||
1029 1030 1031 1032 1033 1034 1035 | #define TCL_LINK_STRING 4 #define TCL_LINK_WIDE_INT 5 #define TCL_LINK_CHAR 6 #define TCL_LINK_UCHAR 7 #define TCL_LINK_SHORT 8 #define TCL_LINK_USHORT 9 #define TCL_LINK_UINT 10 | < < < < < | 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 | #define TCL_LINK_STRING 4 #define TCL_LINK_WIDE_INT 5 #define TCL_LINK_CHAR 6 #define TCL_LINK_UCHAR 7 #define TCL_LINK_SHORT 8 #define TCL_LINK_USHORT 9 #define TCL_LINK_UINT 10 #define TCL_LINK_LONG ((sizeof(long) != sizeof(int)) ? TCL_LINK_WIDE_INT : TCL_LINK_INT) #define TCL_LINK_ULONG ((sizeof(long) != sizeof(int)) ? TCL_LINK_WIDE_UINT : TCL_LINK_UINT) #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 /* |
︙ | ︙ | |||
1425 1426 1427 1428 1429 1430 1431 | typedef struct Tcl_ChannelType { const char *typeName; /* The name of the channel type in Tcl * commands. This storage is owned by channel * type. */ Tcl_ChannelTypeVersion version; /* Version of the channel type. */ | | < | < | 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 | typedef struct Tcl_ChannelType { const char *typeName; /* The name of the channel type in Tcl * commands. This storage is owned by channel * type. */ Tcl_ChannelTypeVersion version; /* Version of the channel type. */ void *closeProc; /* Not used any more. */ Tcl_DriverInputProc *inputProc; /* Function to call for input on channel. */ Tcl_DriverOutputProc *outputProc; /* Function to call for output on channel. */ void *seekProc; /* Not used any more. */ Tcl_DriverSetOptionProc *setOptionProc; /* Set an option on a channel. */ Tcl_DriverGetOptionProc *getOptionProc; /* Get an option from a channel. */ Tcl_DriverWatchProc *watchProc; /* Set up the notifier to watch for events on * this channel. */ |
︙ | ︙ | |||
2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 | * Reserve top byte for profile values (disjoint, not a mask). In case of * changes, ensure ENCODING_PROFILE_* macros in tclInt.h are modified if * necessary. */ #define TCL_ENCODING_PROFILE_STRICT TCL_ENCODING_STOPONERROR #define TCL_ENCODING_PROFILE_TCL8 0x01000000 #define TCL_ENCODING_PROFILE_REPLACE 0x02000000 /* * The following definitions are the error codes returned by the conversion * routines: * * TCL_OK - All characters were converted. * TCL_CONVERT_NOSPACE - The output buffer would not have been large | > | 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 | * Reserve top byte for profile values (disjoint, not a mask). In case of * changes, ensure ENCODING_PROFILE_* macros in tclInt.h are modified if * necessary. */ #define TCL_ENCODING_PROFILE_STRICT TCL_ENCODING_STOPONERROR #define TCL_ENCODING_PROFILE_TCL8 0x01000000 #define TCL_ENCODING_PROFILE_REPLACE 0x02000000 #define TCL_ENCODING_PROFILE_LOSSLESS 0x03000000 /* * The following definitions are the error codes returned by the conversion * routines: * * TCL_OK - All characters were converted. * TCL_CONVERT_NOSPACE - The output buffer would not have been large |
︙ | ︙ |
Changes to generic/tclBasic.c.
︙ | ︙ | |||
312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 | */ {"append", Tcl_AppendObjCmd, TclCompileAppendCmd, NULL, CMD_IS_SAFE}, {"apply", Tcl_ApplyObjCmd, NULL, TclNRApplyObjCmd, CMD_IS_SAFE}, {"break", Tcl_BreakObjCmd, TclCompileBreakCmd, NULL, CMD_IS_SAFE}, {"catch", Tcl_CatchObjCmd, TclCompileCatchCmd, TclNRCatchObjCmd, CMD_IS_SAFE}, {"concat", Tcl_ConcatObjCmd, TclCompileConcatCmd, NULL, CMD_IS_SAFE}, {"continue", Tcl_ContinueObjCmd, TclCompileContinueCmd, NULL, CMD_IS_SAFE}, {"coroinject", NULL, NULL, TclNRCoroInjectObjCmd, CMD_IS_SAFE}, {"coroprobe", NULL, NULL, TclNRCoroProbeObjCmd, CMD_IS_SAFE}, {"coroutine", NULL, NULL, TclNRCoroutineObjCmd, CMD_IS_SAFE}, {"error", Tcl_ErrorObjCmd, TclCompileErrorCmd, NULL, CMD_IS_SAFE}, {"eval", Tcl_EvalObjCmd, NULL, TclNREvalObjCmd, CMD_IS_SAFE}, {"expr", Tcl_ExprObjCmd, TclCompileExprCmd, TclNRExprObjCmd, CMD_IS_SAFE}, {"for", Tcl_ForObjCmd, TclCompileForCmd, TclNRForObjCmd, CMD_IS_SAFE}, {"foreach", Tcl_ForeachObjCmd, TclCompileForeachCmd, TclNRForeachCmd, CMD_IS_SAFE}, {"format", Tcl_FormatObjCmd, TclCompileFormatCmd, NULL, CMD_IS_SAFE}, {"fpclassify", FloatClassifyObjCmd, NULL, NULL, CMD_IS_SAFE}, {"global", Tcl_GlobalObjCmd, TclCompileGlobalCmd, NULL, CMD_IS_SAFE}, {"if", Tcl_IfObjCmd, TclCompileIfCmd, TclNRIfObjCmd, CMD_IS_SAFE}, {"incr", Tcl_IncrObjCmd, TclCompileIncrCmd, NULL, CMD_IS_SAFE}, {"join", Tcl_JoinObjCmd, NULL, NULL, CMD_IS_SAFE}, {"lappend", Tcl_LappendObjCmd, TclCompileLappendCmd, NULL, CMD_IS_SAFE}, {"lassign", Tcl_LassignObjCmd, TclCompileLassignCmd, NULL, CMD_IS_SAFE}, | > | | 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 | */ {"append", Tcl_AppendObjCmd, TclCompileAppendCmd, NULL, CMD_IS_SAFE}, {"apply", Tcl_ApplyObjCmd, NULL, TclNRApplyObjCmd, CMD_IS_SAFE}, {"break", Tcl_BreakObjCmd, TclCompileBreakCmd, NULL, CMD_IS_SAFE}, {"catch", Tcl_CatchObjCmd, TclCompileCatchCmd, TclNRCatchObjCmd, CMD_IS_SAFE}, {"concat", Tcl_ConcatObjCmd, TclCompileConcatCmd, NULL, CMD_IS_SAFE}, {"const", Tcl_ConstObjCmd, TclCompileConstCmd, NULL, CMD_IS_SAFE}, {"continue", Tcl_ContinueObjCmd, TclCompileContinueCmd, NULL, CMD_IS_SAFE}, {"coroinject", NULL, NULL, TclNRCoroInjectObjCmd, CMD_IS_SAFE}, {"coroprobe", NULL, NULL, TclNRCoroProbeObjCmd, CMD_IS_SAFE}, {"coroutine", NULL, NULL, TclNRCoroutineObjCmd, CMD_IS_SAFE}, {"error", Tcl_ErrorObjCmd, TclCompileErrorCmd, NULL, CMD_IS_SAFE}, {"eval", Tcl_EvalObjCmd, NULL, TclNREvalObjCmd, CMD_IS_SAFE}, {"expr", Tcl_ExprObjCmd, TclCompileExprCmd, TclNRExprObjCmd, CMD_IS_SAFE}, {"for", Tcl_ForObjCmd, TclCompileForCmd, TclNRForObjCmd, CMD_IS_SAFE}, {"foreach", Tcl_ForeachObjCmd, TclCompileForeachCmd, TclNRForeachCmd, CMD_IS_SAFE}, {"format", Tcl_FormatObjCmd, TclCompileFormatCmd, NULL, CMD_IS_SAFE}, {"fpclassify", FloatClassifyObjCmd, NULL, NULL, CMD_IS_SAFE}, {"global", Tcl_GlobalObjCmd, TclCompileGlobalCmd, NULL, CMD_IS_SAFE}, {"if", Tcl_IfObjCmd, TclCompileIfCmd, TclNRIfObjCmd, CMD_IS_SAFE}, {"incr", Tcl_IncrObjCmd, TclCompileIncrCmd, NULL, CMD_IS_SAFE}, {"join", Tcl_JoinObjCmd, NULL, NULL, CMD_IS_SAFE}, {"lappend", Tcl_LappendObjCmd, TclCompileLappendCmd, NULL, CMD_IS_SAFE}, {"lassign", Tcl_LassignObjCmd, TclCompileLassignCmd, NULL, CMD_IS_SAFE}, {"ledit", Tcl_LeditObjCmd, NULL, NULL, CMD_IS_SAFE}, {"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}, |
︙ | ︙ | |||
4555 4556 4557 4558 4559 4560 4561 | Dispatch( void *data[], Tcl_Interp *interp, TCL_UNUSED(int) /*result*/) { Tcl_ObjCmdProc *objProc = (Tcl_ObjCmdProc *)data[0]; void *clientData = data[1]; | | | | | 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 | Dispatch( void *data[], Tcl_Interp *interp, TCL_UNUSED(int) /*result*/) { Tcl_ObjCmdProc *objProc = (Tcl_ObjCmdProc *)data[0]; void *clientData = data[1]; Tcl_Size objc = PTR2INT(data[2]); Tcl_Obj **objv = (Tcl_Obj **)data[3]; Interp *iPtr = (Interp *) interp; #ifdef USE_DTRACE if (TCL_DTRACE_CMD_ARGS_ENABLED()) { const char *a[10]; Tcl_Size i = 0; while (i < 10) { a[i] = i < objc ? TclGetString(objv[i]) : NULL; i++; } TCL_DTRACE_CMD_ARGS(a[0], a[1], a[2], a[3], a[4], a[5], a[6], a[7], a[8], a[9]); } if (TCL_DTRACE_CMD_INFO_ENABLED() && iPtr->cmdFramePtr) { Tcl_Obj *info = TclInfoFrame(interp, iPtr->cmdFramePtr); const char *a[6]; Tcl_Size i[2]; TclDTraceInfo(info, a, i); TCL_DTRACE_CMD_INFO(a[0], a[1], a[2], a[3], i[0], i[1], a[4], a[5]); TclDecrRefCount(info); } if ((TCL_DTRACE_CMD_RETURN_ENABLED() || TCL_DTRACE_CMD_RESULT_ENABLED()) && objc) { |
︙ | ︙ | |||
6894 6895 6896 6897 6898 6899 6900 | *---------------------------------------------------------------------- */ Tcl_Size Tcl_SetRecursionLimit( Tcl_Interp *interp, /* Interpreter whose nesting limit is to be * set. */ | | | 6895 6896 6897 6898 6899 6900 6901 6902 6903 6904 6905 6906 6907 6908 6909 | *---------------------------------------------------------------------- */ Tcl_Size Tcl_SetRecursionLimit( Tcl_Interp *interp, /* Interpreter whose nesting limit is to be * set. */ Tcl_Size depth) /* New value for maximum depth. */ { Interp *iPtr = (Interp *) interp; Tcl_Size old; old = iPtr->maxNestingDepth; if (depth > 0) { iPtr->maxNestingDepth = depth; |
︙ | ︙ | |||
8342 8343 8344 8345 8346 8347 8348 | *---------------------------------------------------------------------- */ void TclDTraceInfo( Tcl_Obj *info, const char **args, | | | 8343 8344 8345 8346 8347 8348 8349 8350 8351 8352 8353 8354 8355 8356 8357 | *---------------------------------------------------------------------- */ void TclDTraceInfo( Tcl_Obj *info, const char **args, Tcl_Size *argsi) { static Tcl_Obj *keys[10] = { NULL }; Tcl_Obj **k = keys, *val; int i = 0; if (!*k) { #define kini(s) TclNewLiteralStringObj(keys[i], s); i++ |
︙ | ︙ | |||
8382 8383 8384 8385 8386 8387 8388 | 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); if (val) { | | | 8383 8384 8385 8386 8387 8388 8389 8390 8391 8392 8393 8394 8395 8396 8397 | 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); if (val) { Tcl_GetSizeIntFromObj(NULL, val, &argsi[i]); } else { argsi[i] = 0; } } } /* |
︙ | ︙ |
Changes to generic/tclBinary.c.
︙ | ︙ | |||
2605 2606 2607 2608 2609 2610 2611 | TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { Tcl_Obj *resultObj; unsigned char *data, *limit; | | | | 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 | TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { Tcl_Obj *resultObj; unsigned char *data, *limit; Tcl_WideInt maxlen = 0; const char *wrapchar = "\n"; Tcl_Size wrapcharlen = 1; int index, purewrap = 1; Tcl_Size i, offset, size, outindex = 0, count = 0; enum { OPT_MAXLEN, OPT_WRAPCHAR }; static const char *const optStrings[] = { "-maxlen", "-wrapchar", NULL }; if (objc < 2 || objc % 2 != 0) { Tcl_WrongNumArgs(interp, 1, objv, "?-maxlen len? ?-wrapchar char? data"); return TCL_ERROR; } for (i = 1; i < objc - 1; i += 2) { if (Tcl_GetIndexFromObj(interp, objv[i], optStrings, "option", TCL_EXACT, &index) != TCL_OK) { return TCL_ERROR; } switch (index) { case OPT_MAXLEN: if (TclGetWideIntFromObj(interp, objv[i + 1], &maxlen) != TCL_OK) { return TCL_ERROR; } if (maxlen < 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "line length out of range", -1)); Tcl_SetErrorCode(interp, "TCL", "BINARY", "ENCODE", "LINE_LENGTH", (void *)NULL); |
︙ | ︙ |
Changes to generic/tclCkalloc.c.
︙ | ︙ | |||
833 834 835 836 837 838 839 | return TCL_OK; } if (strcmp(TclGetString(objv[1]),"break_on_malloc") == 0) { Tcl_WideInt value; if (objc != 3) { goto argError; } | | | 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 | return TCL_OK; } if (strcmp(TclGetString(objv[1]),"break_on_malloc") == 0) { Tcl_WideInt value; if (objc != 3) { goto argError; } if (TclGetWideIntFromObj(interp, objv[2], &value) != TCL_OK) { return TCL_ERROR; } break_on_malloc = value; return TCL_OK; } if (strcmp(TclGetString(objv[1]),"info") == 0) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( |
︙ | ︙ | |||
918 919 920 921 922 923 924 | } if (strcmp(TclGetString(objv[1]),"trace_on_at_malloc") == 0) { Tcl_WideInt value; if (objc != 3) { goto argError; } | | | 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 | } if (strcmp(TclGetString(objv[1]),"trace_on_at_malloc") == 0) { Tcl_WideInt value; if (objc != 3) { goto argError; } if (TclGetWideIntFromObj(interp, objv[2], &value) != TCL_OK) { return TCL_ERROR; } trace_on_at_malloc = value; return TCL_OK; } if (strcmp(TclGetString(objv[1]),"validate") == 0) { if (objc != 3) { |
︙ | ︙ |
Changes to generic/tclClock.c.
︙ | ︙ | |||
890 891 892 893 894 895 896 | * platforms, so seize a mutex before attempting this. */ TzsetIfNecessary(); Tcl_MutexLock(&clockMutex); errno = 0; fields->seconds = (Tcl_WideInt) mktime(&timeVal); | | | 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 | * platforms, so seize a mutex before attempting this. */ TzsetIfNecessary(); Tcl_MutexLock(&clockMutex); errno = 0; fields->seconds = (Tcl_WideInt) mktime(&timeVal); localErrno = (fields->seconds == -1) ? errno : 0; Tcl_MutexUnlock(&clockMutex); /* * If conversion fails, report an error. */ if (localErrno != 0 |
︙ | ︙ |
Changes to generic/tclCmdIL.c.
︙ | ︙ | |||
156 157 158 159 160 161 162 163 164 165 166 167 168 169 | static const EnsembleImplMap defaultInfoMap[] = { {"args", InfoArgsCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, {"body", InfoBodyCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, {"cmdcount", InfoCmdCountCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0}, {"cmdtype", InfoCmdTypeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1}, {"commands", InfoCommandsCmd, TclCompileInfoCommandsCmd, NULL, NULL, 0}, {"complete", InfoCompleteCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, {"coroutine", TclInfoCoroutineCmd, TclCompileInfoCoroutineCmd, NULL, NULL, 0}, {"default", InfoDefaultCmd, TclCompileBasic3ArgCmd, NULL, NULL, 0}, {"errorstack", InfoErrorStackCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, {"exists", TclInfoExistsCmd, TclCompileInfoExistsCmd, NULL, NULL, 0}, {"frame", InfoFrameCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, {"functions", InfoFunctionsCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, {"globals", TclInfoGlobalsCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, | > > | 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 | static const EnsembleImplMap defaultInfoMap[] = { {"args", InfoArgsCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, {"body", InfoBodyCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, {"cmdcount", InfoCmdCountCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0}, {"cmdtype", InfoCmdTypeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1}, {"commands", InfoCommandsCmd, TclCompileInfoCommandsCmd, NULL, NULL, 0}, {"complete", InfoCompleteCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, {"constant", TclInfoConstantCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, {"consts", TclInfoConstsCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, {"coroutine", TclInfoCoroutineCmd, TclCompileInfoCoroutineCmd, NULL, NULL, 0}, {"default", InfoDefaultCmd, TclCompileBasic3ArgCmd, NULL, NULL, 0}, {"errorstack", InfoErrorStackCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, {"exists", TclInfoExistsCmd, TclCompileInfoExistsCmd, NULL, NULL, 0}, {"frame", InfoFrameCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, {"functions", InfoFunctionsCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, {"globals", TclInfoGlobalsCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, |
︙ | ︙ | |||
3464 3465 3466 3467 3468 3469 3470 | Tcl_SetObjResult(interp, Tcl_NewStringObj( "\"-stride\" option must be " "followed by stride length", -1)); Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", (void *)NULL); result = TCL_ERROR; goto done; } | | | 3466 3467 3468 3469 3470 3471 3472 3473 3474 3475 3476 3477 3478 3479 3480 | Tcl_SetObjResult(interp, Tcl_NewStringObj( "\"-stride\" option must be " "followed by stride length", -1)); Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", (void *)NULL); result = TCL_ERROR; goto done; } if (TclGetWideIntFromObj(interp, objv[i+1], &wide) != TCL_OK) { result = TCL_ERROR; goto done; } if (wide < 1) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "stride length must be at least 1", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSEARCH", |
︙ | ︙ | |||
4464 4465 4466 4467 4468 4469 4470 | * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_LsetObjCmd( | | | 4466 4467 4468 4469 4470 4471 4472 4473 4474 4475 4476 4477 4478 4479 4480 | * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_LsetObjCmd( TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument values. */ { Tcl_Obj *listPtr; /* Pointer to the list being altered. */ Tcl_Obj *finalValuePtr; /* Value finally assigned to the variable. */ |
︙ | ︙ | |||
4718 4719 4720 4721 4722 4723 4724 | Tcl_SetObjResult(interp, Tcl_NewStringObj( "\"-stride\" option must be " "followed by stride length", -1)); Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", (void *)NULL); sortInfo.resultCode = TCL_ERROR; goto done; } | | | 4720 4721 4722 4723 4724 4725 4726 4727 4728 4729 4730 4731 4732 4733 4734 | Tcl_SetObjResult(interp, Tcl_NewStringObj( "\"-stride\" option must be " "followed by stride length", -1)); Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", (void *)NULL); sortInfo.resultCode = TCL_ERROR; goto done; } if (TclGetWideIntFromObj(interp, objv[i+1], &wide) != TCL_OK) { sortInfo.resultCode = TCL_ERROR; goto done; } if (wide < 2) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "stride length must be at least 2", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSORT", |
︙ | ︙ |
Changes to generic/tclCmdMZ.c.
︙ | ︙ | |||
2068 2069 2070 2071 2072 2073 2074 | * Empty input string, just stop now. */ goto done; } end = ustring1 + length1; | | | 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 | * Empty input string, just stop now. */ goto done; } end = ustring1 + length1; strCmpFn = nocase ? TclUniCharNcasecmp : TclUniCharNcmp; /* * Force result to be Unicode */ resultPtr = Tcl_NewUnicodeObj(ustring1, 0); |
︙ | ︙ | |||
2638 2639 2640 2641 2642 2643 2644 | * Remember to keep code here in some sync with the byte-compiled versions * in tclExecute.c (INST_STR_EQ, INST_STR_NEQ and INST_STR_CMP as well as * the expr string comparison in INST_EQ/INST_NEQ/INST_LT/...). */ const char *string2; int i, match, nocase = 0; | | > | > > > | 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 | * Remember to keep code here in some sync with the byte-compiled versions * in tclExecute.c (INST_STR_EQ, INST_STR_NEQ and INST_STR_CMP as well as * the expr string comparison in INST_EQ/INST_NEQ/INST_LT/...). */ const char *string2; int i, match, nocase = 0; Tcl_Size length; Tcl_WideInt reqlength = -1; if (objc < 3 || objc > 6) { str_cmp_args: Tcl_WrongNumArgs(interp, 1, objv, "?-nocase? ?-length int? string1 string2"); return TCL_ERROR; } for (i = 1; i < objc-2; i++) { string2 = Tcl_GetStringFromObj(objv[i], &length); if ((length > 1) && !strncmp(string2, "-nocase", length)) { nocase = 1; } else if ((length > 1) && !strncmp(string2, "-length", length)) { if (i+1 >= objc-2) { goto str_cmp_args; } i++; if (TclGetWideIntFromObj(interp, objv[i], &reqlength) != TCL_OK) { return TCL_ERROR; } if ((Tcl_WideUInt)reqlength > TCL_SIZE_MAX) { reqlength = -1; } } else { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad option \"%s\": must be -nocase or -length", string2)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "option", string2, (void *)NULL); |
︙ | ︙ | |||
2737 2738 2739 2740 2741 2742 2743 2744 | Tcl_Obj *const objv[], /* Argument objects. */ int *nocase, Tcl_Size *reqlength) { int i; Tcl_Size length; const char *string; | > < | > > > > > | 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 | Tcl_Obj *const objv[], /* Argument objects. */ int *nocase, Tcl_Size *reqlength) { int i; Tcl_Size length; const char *string; Tcl_WideInt wreqlength = -1; *nocase = 0; if (objc < 3 || objc > 6) { str_cmp_args: Tcl_WrongNumArgs(interp, 1, objv, "?-nocase? ?-length int? string1 string2"); return TCL_ERROR; } for (i = 1; i < objc-2; i++) { string = Tcl_GetStringFromObj(objv[i], &length); if ((length > 1) && !strncmp(string, "-nocase", length)) { *nocase = 1; } else if ((length > 1) && !strncmp(string, "-length", length)) { if (i+1 >= objc-2) { goto str_cmp_args; } i++; if (TclGetWideIntFromObj(interp, objv[i], &wreqlength) != TCL_OK) { return TCL_ERROR; } if ((Tcl_WideUInt)wreqlength > TCL_SIZE_MAX) { *reqlength = -1; } else { *reqlength = wreqlength; } } else { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad option \"%s\": must be -nocase or -length", string)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "option", string, (void *)NULL); |
︙ | ︙ | |||
4189 4190 4191 4192 4193 4194 4195 | Tcl_WrongNumArgs(interp, 1, objv, "?-direct? ?-calibrate? ?-overhead double? " "command ?time ?max-count??"); return TCL_ERROR; } objPtr = objv[i++]; if (i < objc) { /* max-time */ | | > | | 4198 4199 4200 4201 4202 4203 4204 4205 4206 4207 4208 4209 4210 4211 4212 4213 4214 4215 4216 4217 4218 4219 4220 | 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 = TclGetWideIntFromObj(interp, objv[i], &maxms); i++; // Keep this separate from TclGetWideIntFromObj macro above! if (result != TCL_OK) { return result; } if (i < objc) { /* max-count*/ Tcl_WideInt v; result = TclGetWideIntFromObj(interp, objv[i], &v); if (result != TCL_OK) { return result; } maxcnt = (v > 0) ? v : 0; } } |
︙ | ︙ |
Changes to generic/tclCompCmds.c.
︙ | ︙ | |||
911 912 913 914 915 916 917 918 919 920 921 922 923 924 | CompileWord(envPtr, tokenPtr, interp, i); } TclEmitInstInt4( INST_CONCAT_STK, i-1, envPtr); return TCL_OK; } /* *---------------------------------------------------------------------- * * TclCompileContinueCmd -- * * Procedure called to compile the "continue" command. | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | CompileWord(envPtr, tokenPtr, interp, i); } TclEmitInstInt4( INST_CONCAT_STK, i-1, envPtr); return TCL_OK; } /* *---------------------------------------------------------------------- * * TclCompileConstCmd -- * * Procedure called to compile the "const" command. * * Results: * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer * evaluation to runtime. * * Side effects: * Instructions are added to envPtr to execute the "const" command at * runtime. * *---------------------------------------------------------------------- */ int TclCompileConstCmd( Tcl_Interp *interp, /* The interpreter. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ TCL_UNUSED(Command *), CompileEnv *envPtr) /* Holds resulting instructions. */ { DefineLineInformation; /* TIP #280 */ Tcl_Token *varTokenPtr, *valueTokenPtr; int isScalar, localIndex; /* * Need exactly two arguments. */ if (parsePtr->numWords != 3) { return TCL_ERROR; } /* * Decide if we can use a frame slot for the var/array name or if we need * to emit code to compute and push the name at runtime. We use a frame * slot (entry in the array of local vars) if we are compiling a procedure * body and if the name is simple text that does not include namespace * qualifiers. */ varTokenPtr = TokenAfter(parsePtr->tokenPtr); PushVarNameWord(interp, varTokenPtr, envPtr, 0, &localIndex, &isScalar, 1); /* * If the user specified an array element, we don't bother handling * that. */ if (!isScalar) { return TCL_ERROR; } /* * We are doing an assignment to set the value of the constant. This will * need to be extended to push a value for each argument. */ valueTokenPtr = TokenAfter(varTokenPtr); CompileWord(envPtr, valueTokenPtr, interp, 2); if (localIndex < 0) { TclEmitOpcode(INST_CONST_STK, envPtr); } else { TclEmitInstInt4(INST_CONST_IMM, localIndex, envPtr); } /* * The const command's result is an empty string. */ PushStringLiteral(envPtr, ""); return TCL_OK; } /* *---------------------------------------------------------------------- * * TclCompileContinueCmd -- * * Procedure called to compile the "continue" command. |
︙ | ︙ |
Changes to generic/tclCompile.c.
︙ | ︙ | |||
660 661 662 663 664 665 666 667 668 669 670 671 672 673 | {"lreplace4", 6, INT_MIN, 2, {OPERAND_UINT4, OPERAND_UINT1}}, /* Operands: number of arguments, flags * flags: Combination of TCL_LREPLACE4_* flags * Stack: ... listobj index1 ?index2? new1 ... newN => ... newlistobj * where index2 is present only if TCL_LREPLACE_SINGLE_INDEX is not * set in flags. */ {NULL, 0, 0, 0, {OPERAND_NONE}} }; /* * Prototypes for procedures defined later in this file: */ | > > > > > > > | 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 | {"lreplace4", 6, INT_MIN, 2, {OPERAND_UINT4, OPERAND_UINT1}}, /* Operands: number of arguments, flags * flags: Combination of TCL_LREPLACE4_* flags * Stack: ... listobj index1 ?index2? new1 ... newN => ... newlistobj * where index2 is present only if TCL_LREPLACE_SINGLE_INDEX is not * set in flags. */ {"constImm", 5, -1, 1, {OPERAND_LVT4}}, /* Create constant. Index into LVT is immediate, value is on stack. * Stack: ... value => ... */ {"constStk", 1, -2, 0, {OPERAND_NONE}}, /* Create constant. Variable name and value on stack. * Stack: ... varName value => ... */ {NULL, 0, 0, 0, {OPERAND_NONE}} }; /* * Prototypes for procedures defined later in this file: */ |
︙ | ︙ |
Changes to generic/tclCompile.h.
︙ | ︙ | |||
832 833 834 835 836 837 838 839 840 841 842 843 844 845 | /* TIP 461 */ INST_STR_LT, INST_STR_GT, INST_STR_LE, INST_STR_GE, INST_LREPLACE4, /* The last opcode */ LAST_INST_OPCODE }; /* * Table describing the Tcl bytecode instructions: their name (for displaying | > > > > | 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 | /* TIP 461 */ INST_STR_LT, INST_STR_GT, INST_STR_LE, INST_STR_GE, INST_LREPLACE4, /* TIP 667: const */ INST_CONST_IMM, INST_CONST_STK, /* The last opcode */ LAST_INST_OPCODE }; /* * Table describing the Tcl bytecode instructions: their name (for displaying |
︙ | ︙ | |||
1750 1751 1752 1753 1754 1755 1756 | #define TCL_DTRACE_TCL_PROBE_ENABLED() unlikely(TCL_TCL_PROBE_ENABLED()) #define TCL_DTRACE_TCL_PROBE(a0, a1, a2, a3, a4, a5, a6, a7, a8, a9) \ TCL_TCL_PROBE(a0, a1, a2, a3, a4, a5, a6, a7, a8, a9) #define TCL_DTRACE_DEBUG_LOG() MODULE_SCOPE void TclDTraceInfo(Tcl_Obj *info, const char **args, | | | 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 | #define TCL_DTRACE_TCL_PROBE_ENABLED() unlikely(TCL_TCL_PROBE_ENABLED()) #define TCL_DTRACE_TCL_PROBE(a0, a1, a2, a3, a4, a5, a6, a7, a8, a9) \ TCL_TCL_PROBE(a0, a1, a2, a3, a4, a5, a6, a7, a8, a9) #define TCL_DTRACE_DEBUG_LOG() MODULE_SCOPE void TclDTraceInfo(Tcl_Obj *info, const char **args, Tcl_Size *argsi); #else /* USE_DTRACE */ #define TCL_DTRACE_PROC_ENTRY_ENABLED() 0 #define TCL_DTRACE_PROC_RETURN_ENABLED() 0 #define TCL_DTRACE_PROC_RESULT_ENABLED() 0 #define TCL_DTRACE_PROC_ARGS_ENABLED() 0 |
︙ | ︙ | |||
1805 1806 1807 1808 1809 1810 1811 | #undef TCL_DTRACE_DEBUG_INST_PROBES #define TCL_DTRACE_DEBUG_INST_PROBES 0 #endif MODULE_SCOPE int tclDTraceDebugEnabled, tclDTraceDebugIndent; MODULE_SCOPE FILE *tclDTraceDebugLog; MODULE_SCOPE void TclDTraceOpenDebugLog(void); | | | 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 | #undef TCL_DTRACE_DEBUG_INST_PROBES #define TCL_DTRACE_DEBUG_INST_PROBES 0 #endif MODULE_SCOPE int tclDTraceDebugEnabled, tclDTraceDebugIndent; MODULE_SCOPE FILE *tclDTraceDebugLog; MODULE_SCOPE void TclDTraceOpenDebugLog(void); MODULE_SCOPE void TclDTraceInfo(Tcl_Obj *info, const char **args, Tcl_Size *argsi); #define TCL_DTRACE_DEBUG_LOG() \ int tclDTraceDebugEnabled = TCL_DTRACE_DEBUG_LOG_ENABLED; \ int tclDTraceDebugIndent = 0; \ FILE *tclDTraceDebugLog = NULL; \ void TclDTraceOpenDebugLog(void) { \ char n[35]; \ |
︙ | ︙ | |||
1843 1844 1845 1846 1847 1848 1849 | #define TCL_DTRACE_PROC_ENTRY_ENABLED() 1 #define TCL_DTRACE_PROC_RETURN_ENABLED() 1 #define TCL_DTRACE_PROC_RESULT_ENABLED() 1 #define TCL_DTRACE_PROC_ARGS_ENABLED() 1 #define TCL_DTRACE_PROC_INFO_ENABLED() 1 #define TCL_DTRACE_PROC_ENTRY(a0, a1, a2) \ tclDTraceDebugIndent++; \ | | | | | 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 | #define TCL_DTRACE_PROC_ENTRY_ENABLED() 1 #define TCL_DTRACE_PROC_RETURN_ENABLED() 1 #define TCL_DTRACE_PROC_RESULT_ENABLED() 1 #define TCL_DTRACE_PROC_ARGS_ENABLED() 1 #define TCL_DTRACE_PROC_INFO_ENABLED() 1 #define TCL_DTRACE_PROC_ENTRY(a0, a1, a2) \ tclDTraceDebugIndent++; \ TclDTraceDbgMsg("-> proc-entry", "%s %" TCL_SIZE_MODIFIER "d %p", a0, a1, a2) #define TCL_DTRACE_PROC_RETURN(a0, a1) \ TclDTraceDbgMsg("<- proc-return", "%s %d", a0, a1); \ tclDTraceDebugIndent-- #define TCL_DTRACE_PROC_RESULT(a0, a1, a2, a3) \ TclDTraceDbgMsg(" | proc-result", "%s %d %s %p", a0, a1, a2, a3) #define TCL_DTRACE_PROC_ARGS(a0, a1, a2, a3, a4, a5, a6, a7, a8, a9) \ TclDTraceDbgMsg(" | proc-args", "%s %s %s %s %s %s %s %s %s %s", a0, \ a1, a2, a3, a4, a5, a6, a7, a8, a9) #define TCL_DTRACE_PROC_INFO(a0, a1, a2, a3, a4, a5, a6, a7) \ TclDTraceDbgMsg(" | proc-info", "%s %s %s %s %d %d %s %s", a0, a1, \ a2, a3, a4, a5, a6, a7) #define TCL_DTRACE_CMD_ENTRY_ENABLED() 1 #define TCL_DTRACE_CMD_RETURN_ENABLED() 1 #define TCL_DTRACE_CMD_RESULT_ENABLED() 1 #define TCL_DTRACE_CMD_ARGS_ENABLED() 1 #define TCL_DTRACE_CMD_INFO_ENABLED() 1 #define TCL_DTRACE_CMD_ENTRY(a0, a1, a2) \ tclDTraceDebugIndent++; \ TclDTraceDbgMsg("-> cmd-entry", "%s %" TCL_SIZE_MODIFIER "d %p", a0, a1, a2) #define TCL_DTRACE_CMD_RETURN(a0, a1) \ TclDTraceDbgMsg("<- cmd-return", "%s %d", a0, a1); \ tclDTraceDebugIndent-- #define TCL_DTRACE_CMD_RESULT(a0, a1, a2, a3) \ TclDTraceDbgMsg(" | cmd-result", "%s %d %s %p", a0, a1, a2, a3) #define TCL_DTRACE_CMD_ARGS(a0, a1, a2, a3, a4, a5, a6, a7, a8, a9) \ TclDTraceDbgMsg(" | cmd-args", "%s %s %s %s %s %s %s %s %s %s", a0, \ a1, a2, a3, a4, a5, a6, a7, a8, a9) #define TCL_DTRACE_CMD_INFO(a0, a1, a2, a3, a4, a5, a6, a7) \ TclDTraceDbgMsg(" | cmd-info", "%s %s %s %s %" TCL_SIZE_MODIFIER "d %" TCL_SIZE_MODIFIER "d %s %s", a0, a1, \ a2, a3, a4, a5, a6, a7) #define TCL_DTRACE_INST_START_ENABLED() TCL_DTRACE_DEBUG_INST_PROBES #define TCL_DTRACE_INST_DONE_ENABLED() TCL_DTRACE_DEBUG_INST_PROBES #define TCL_DTRACE_INST_START(a0, a1, a2) \ TclDTraceDbgMsg(" | inst-start", "%s %d %p", a0, a1, a2) #define TCL_DTRACE_INST_DONE(a0, a1, a2) \ |
︙ | ︙ |
Changes to generic/tclDTrace.d.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 | /* * tclDTrace.d -- * * Tcl DTrace provider. * * Copyright (c) 2007-2008 Daniel A. Steffen <[email protected]> * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ typedef struct Tcl_Obj Tcl_Obj; /* * Tcl DTrace probes */ provider tcl { /***************************** proc probes *****************************/ /* * tcl*:::proc-entry probe * triggered immediately before proc bytecode execution * arg0: proc name (string) | > > | | | 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 | /* * tclDTrace.d -- * * Tcl DTrace provider. * * Copyright (c) 2007-2008 Daniel A. Steffen <[email protected]> * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ typedef struct Tcl_Obj Tcl_Obj; typedef ptrdiff_t Tcl_Size; /* * Tcl DTrace probes */ provider tcl { /***************************** proc probes *****************************/ /* * tcl*:::proc-entry probe * triggered immediately before proc bytecode execution * arg0: proc name (string) * arg1: number of arguments (Tcl_Size) * arg2: array of proc argument objects (Tcl_Obj**) */ probe proc__entry(const char *name, Tcl_Size objc, struct Tcl_Obj **objv); /* * tcl*:::proc-return probe * triggered immediately after proc bytecode execution * arg0: proc name (string) * arg1: return code (int) */ probe proc__return(const char *name, int code); |
︙ | ︙ | |||
58 59 60 61 62 63 64 | * triggered before proc-entry probe, gives access to TIP 280 * information for the proc invocation (i.e. [info frame 0]) * arg0: TIP 280 cmd (string) * arg1: TIP 280 type (string) * arg2: TIP 280 proc (string) * arg3: TIP 280 file (string) * arg4: TIP 280 line (int) | | | | | | 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 | * triggered before proc-entry probe, gives access to TIP 280 * information for the proc invocation (i.e. [info frame 0]) * arg0: TIP 280 cmd (string) * arg1: TIP 280 type (string) * arg2: TIP 280 proc (string) * arg3: TIP 280 file (string) * arg4: TIP 280 line (int) * arg5: TIP 280 level (Tcl_Size) * arg6: TclOO method (string) * arg7: TclOO class/object (string) */ probe proc__info(const char *cmd, const char *type, const char *proc, const char *file, int line, Tcl_Size level, const char *method, const char *class); /***************************** cmd probes ******************************/ /* * tcl*:::cmd-entry probe * triggered immediately before commmand execution * arg0: command name (string) * arg1: number of arguments (Tcl_Size) * arg2: array of command argument objects (Tcl_Obj**) */ probe cmd__entry(const char *name, Tcl_Size objc, struct Tcl_Obj **objv); /* * tcl*:::cmd-return probe * triggered immediately after commmand execution * arg0: command name (string) * arg1: return code (int) */ probe cmd__return(const char *name, int code); |
︙ | ︙ | |||
117 118 119 120 121 122 123 | * arg3: TIP 280 file (string) * arg4: TIP 280 line (int) * arg5: TIP 280 level (int) * arg6: TclOO method (string) * arg7: TclOO class/object (string) */ probe cmd__info(const char *cmd, const char *type, const char *proc, | | | | | | | 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 | * arg3: TIP 280 file (string) * arg4: TIP 280 line (int) * arg5: TIP 280 level (int) * arg6: TclOO method (string) * arg7: TclOO class/object (string) */ probe cmd__info(const char *cmd, const char *type, const char *proc, const char *file, int line, Tcl_Size level, const char *method, const char *class); /***************************** inst probes *****************************/ /* * tcl*:::inst-start probe * triggered immediately before execution of a bytecode * arg0: bytecode name (string) * arg1: depth of stack (Tcl_Size) * arg2: top of stack (Tcl_Obj**) */ probe inst__start(const char *name, Tcl_Size depth, struct Tcl_Obj **stack); /* * tcl*:::inst-done probe * triggered immediately after execution of a bytecode * arg0: bytecode name (string) * arg1: depth of stack (Tcl_Size) * arg2: top of stack (Tcl_Obj**) */ probe inst__done(const char *name, Tcl_Size depth, struct Tcl_Obj **stack); /***************************** obj probes ******************************/ /* * tcl*:::obj-create probe * triggered immediately after a new Tcl_Obj has been created * arg0: object created (Tcl_Obj*) */ |
︙ | ︙ | |||
174 175 176 177 178 179 180 181 182 183 | typedef struct Tcl_ObjType { const char *name; void *freeIntRepProc; void *dupIntRepProc; void *updateStringProc; void *setFromAnyProc; } Tcl_ObjType; struct Tcl_Obj { | > > > > > > > > > | | | 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 | typedef struct Tcl_ObjType { const char *name; void *freeIntRepProc; void *dupIntRepProc; void *updateStringProc; void *setFromAnyProc; size_t version; void *lengthProc; void *indexProc; void *sliceProc; void *reverseProc; void *getElementsProc; void *setElementProc; void *replaceProc; void *inOperProc; } Tcl_ObjType; struct Tcl_Obj { Tcl_Size refCount; char *bytes; Tcl_Size length; const Tcl_ObjType *typePtr; union { long longValue; double doubleValue; void *otherValuePtr; int64_t wideValue; struct { |
︙ | ︙ |
Changes to generic/tclDate.c.
︙ | ︙ | |||
60 61 62 63 64 65 66 | /* Substitute the variable and function names. */ #define yyparse TclDateparse #define yylex TclDatelex #define yyerror TclDateerror #define yydebug TclDatedebug | < | 60 61 62 63 64 65 66 67 68 69 70 71 72 73 | /* Substitute the variable and function names. */ #define yyparse TclDateparse #define yylex TclDatelex #define yyerror TclDateerror #define yydebug TclDatedebug /* Copy the first part of user declarations. */ /* * tclDate.c -- |
︙ | ︙ | |||
1290 1291 1292 1293 1294 1295 1296 | static YYLTYPE yyloc_default # if defined YYLTYPE_IS_TRIVIAL && YYLTYPE_IS_TRIVIAL = { 1, 1, 1, 1 } # endif ; YYLTYPE yylloc = yyloc_default; | < < < | 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 | static YYLTYPE yyloc_default # if defined YYLTYPE_IS_TRIVIAL && YYLTYPE_IS_TRIVIAL = { 1, 1, 1, 1 } # endif ; YYLTYPE yylloc = yyloc_default; int yystate; /* Number of tokens to shift before error messages enabled. */ int yyerrstatus; /* The stacks and their tools: 'yyss': related to states. 'yyvs': related to semantic values. |
︙ | ︙ | |||
1356 1357 1358 1359 1360 1361 1362 | yylsp = yyls = yylsa; yystacksize = YYINITDEPTH; YYDPRINTF ((stderr, "Starting parse\n")); yystate = 0; yyerrstatus = 0; | < | 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 | yylsp = yyls = yylsa; yystacksize = YYINITDEPTH; YYDPRINTF ((stderr, "Starting parse\n")); yystate = 0; yyerrstatus = 0; yychar = YYEMPTY; /* Cause a token to be read. */ yylsp[0] = yylloc; goto yysetstate; /*------------------------------------------------------------. | yynewstate -- Push a new state, which is found in yystate. | `------------------------------------------------------------*/ |
︙ | ︙ | |||
2094 2095 2096 2097 2098 2099 2100 | /* Make sure we have latest lookahead translation. See comments at user semantic actions for why this is necessary. */ yytoken = yychar == YYEMPTY ? YYEMPTY : YYTRANSLATE (yychar); /* If not already recovering from an error, report this error. */ if (!yyerrstatus) { | < | 2089 2090 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 | /* Make sure we have latest lookahead translation. See comments at user semantic actions for why this is necessary. */ yytoken = yychar == YYEMPTY ? YYEMPTY : YYTRANSLATE (yychar); /* If not already recovering from an error, report this error. */ if (!yyerrstatus) { #if ! YYERROR_VERBOSE yyerror (&yylloc, info, YY_("syntax error")); #else # define YYSYNTAX_ERROR yysyntax_error (&yymsg_alloc, &yymsg, \ yyssp, yytoken) { char const *yymsgp = YY_("syntax error"); |
︙ | ︙ |
Changes to generic/tclDecls.h.
︙ | ︙ | |||
3958 3959 3960 3961 3962 3963 3964 | Tcl_Free((char *)__result); \ } else { \ (*__freeProc)((char *)__result); \ } \ } \ } while(0) | < < < < < < < < < | 3958 3959 3960 3961 3962 3963 3964 3965 3966 3967 3968 3969 3970 3971 | Tcl_Free((char *)__result); \ } else { \ (*__freeProc)((char *)__result); \ } \ } \ } while(0) #if defined(USE_TCL_STUBS) # if defined(_WIN32) && defined(_WIN64) && TCL_MAJOR_VERSION < 9 # undef Tcl_GetTime /* Handle Win64 tk.dll being loaded in Cygwin64 (only needed for Tcl 8). */ # define Tcl_GetTime(t) \ do { \ struct { \ |
︙ | ︙ | |||
4023 4024 4025 4026 4027 4028 4029 4030 4031 4032 4033 4034 | #define Tcl_GetString(objPtr) \ Tcl_GetStringFromObj(objPtr, (Tcl_Size *)NULL) #define Tcl_GetUnicode(objPtr) \ Tcl_GetUnicodeFromObj(objPtr, (Tcl_Size *)NULL) #undef Tcl_GetIndexFromObjStruct #undef Tcl_GetBooleanFromObj #undef Tcl_GetBoolean #if defined(USE_TCL_STUBS) #define Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, indexPtr) \ (tclStubsPtr->tcl_GetIndexFromObjStruct((interp), (objPtr), (tablePtr), (offset), (msg), \ (flags)|(int)(sizeof(*(indexPtr))<<1), (indexPtr))) #define Tcl_GetBooleanFromObj(interp, objPtr, boolPtr) \ | > > > > > > | | | | | 4014 4015 4016 4017 4018 4019 4020 4021 4022 4023 4024 4025 4026 4027 4028 4029 4030 4031 4032 4033 4034 4035 4036 4037 4038 4039 4040 4041 4042 4043 4044 4045 4046 4047 4048 4049 4050 4051 4052 | #define Tcl_GetString(objPtr) \ Tcl_GetStringFromObj(objPtr, (Tcl_Size *)NULL) #define Tcl_GetUnicode(objPtr) \ Tcl_GetUnicodeFromObj(objPtr, (Tcl_Size *)NULL) #undef Tcl_GetIndexFromObjStruct #undef Tcl_GetBooleanFromObj #undef Tcl_GetBoolean #ifdef __GNUC__ /* If this gives: "error: size of array ‘_bool_Var’ is negative", it means that sizeof(*boolPtr)>sizeof(int), which is not allowed */ # define TCLBOOLWARNING(boolPtr) ({__attribute__((unused)) char _bool_Var[sizeof(*(boolPtr)) > sizeof(int) ? -1 : 1];}), #else # define TCLBOOLWARNING(boolPtr) #endif #if defined(USE_TCL_STUBS) #define Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, indexPtr) \ (tclStubsPtr->tcl_GetIndexFromObjStruct((interp), (objPtr), (tablePtr), (offset), (msg), \ (flags)|(int)(sizeof(*(indexPtr))<<1), (indexPtr))) #define Tcl_GetBooleanFromObj(interp, objPtr, boolPtr) \ (TCLBOOLWARNING(boolPtr)(sizeof(*(boolPtr)) >= sizeof(int) && (TCL_MAJOR_VERSION == 8)) ? tclStubsPtr->tcl_GetBooleanFromObj(interp, objPtr, (int *)(boolPtr)) : \ Tcl_GetBoolFromObj(interp, objPtr, (TCL_NULL_OK-2)&(int)sizeof((*(boolPtr))), (char *)(boolPtr))) #define Tcl_GetBoolean(interp, src, boolPtr) \ (TCLBOOLWARNING(boolPtr)(sizeof(*(boolPtr)) >= sizeof(int) && (TCL_MAJOR_VERSION == 8)) ? tclStubsPtr->tcl_GetBoolean(interp, src, (int *)(boolPtr)) : \ Tcl_GetBool(interp, src, (TCL_NULL_OK-2)&(int)sizeof((*(boolPtr))), (char *)(boolPtr))) #else #define Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, indexPtr) \ ((Tcl_GetIndexFromObjStruct)((interp), (objPtr), (tablePtr), (offset), (msg), \ (flags)|(int)(sizeof(*(indexPtr))<<1), (indexPtr))) #define Tcl_GetBooleanFromObj(interp, objPtr, boolPtr) \ (TCLBOOLWARNING(boolPtr)(sizeof(*(boolPtr)) >= sizeof(int) && (TCL_MAJOR_VERSION == 8)) ? Tcl_GetBooleanFromObj(interp, objPtr, (int *)(boolPtr)) : \ Tcl_GetBoolFromObj(interp, objPtr, (TCL_NULL_OK-2)&(int)sizeof((*(boolPtr))), (char *)(boolPtr))) #define Tcl_GetBoolean(interp, src, boolPtr) \ (TCLBOOLWARNING(boolPtr)(sizeof(*(boolPtr)) >= sizeof(int) && (TCL_MAJOR_VERSION == 8)) ? Tcl_GetBoolean(interp, src, (int *)(boolPtr)) : \ Tcl_GetBool(interp, src, (TCL_NULL_OK-2)&(int)sizeof((*(boolPtr))), (char *)(boolPtr))) #endif #ifdef TCL_MEM_DEBUG # undef Tcl_Alloc # define Tcl_Alloc(x) \ (Tcl_DbCkalloc((x), __FILE__, __LINE__)) |
︙ | ︙ | |||
4210 4211 4212 4213 4214 4215 4216 | tclStubsPtr->tclSplitPath((path), (argcPtr), (argvPtr)) # undef Tcl_FSSplitPath # define Tcl_FSSplitPath(pathPtr, lenPtr) \ tclStubsPtr->tclFSSplitPath((pathPtr), (lenPtr)) # undef Tcl_ParseArgsObjv # define Tcl_ParseArgsObjv(interp, argTable, objcPtr, objv, remObjv) \ tclStubsPtr->tclParseArgsObjv((interp), (argTable), (objcPtr), (objv), (remObjv)) | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 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 | tclStubsPtr->tclSplitPath((path), (argcPtr), (argvPtr)) # undef Tcl_FSSplitPath # define Tcl_FSSplitPath(pathPtr, lenPtr) \ tclStubsPtr->tclFSSplitPath((pathPtr), (lenPtr)) # undef Tcl_ParseArgsObjv # define Tcl_ParseArgsObjv(interp, argTable, objcPtr, objv, remObjv) \ tclStubsPtr->tclParseArgsObjv((interp), (argTable), (objcPtr), (objv), (remObjv)) #elif defined(TCL_8_API) # undef Tcl_GetByteArrayFromObj # undef Tcl_GetBytesFromObj # undef Tcl_GetStringFromObj # undef Tcl_GetUnicodeFromObj # undef Tcl_ListObjGetElements # undef Tcl_ListObjLength # undef Tcl_DictObjSize # undef Tcl_SplitList # undef Tcl_SplitPath # undef Tcl_FSSplitPath # undef Tcl_ParseArgsObjv # if !defined(USE_TCL_STUBS) # define Tcl_GetByteArrayFromObj(objPtr, sizePtr) (sizeof(*(sizePtr)) <= sizeof(int) ? \ TclGetBytesFromObj(NULL, (objPtr), (sizePtr)) : \ (Tcl_GetBytesFromObj)(NULL, (objPtr), (Tcl_Size *)(void *)(sizePtr))) # define Tcl_GetBytesFromObj(interp, objPtr, sizePtr) (sizeof(*(sizePtr)) <= sizeof(int) ? \ TclGetBytesFromObj((interp), (objPtr), (sizePtr)) : \ (Tcl_GetBytesFromObj)((interp), (objPtr), (Tcl_Size *)(void *)(sizePtr))) # define Tcl_GetStringFromObj(objPtr, sizePtr) (sizeof(*(sizePtr)) <= sizeof(int) ? \ TclGetStringFromObj((objPtr), (sizePtr)) : \ (Tcl_GetStringFromObj)((objPtr), (Tcl_Size *)(void *)(sizePtr))) # define Tcl_GetUnicodeFromObj(objPtr, sizePtr) (sizeof(*(sizePtr)) <= sizeof(int) ? \ TclGetUnicodeFromObj((objPtr), (sizePtr)) : \ (Tcl_GetUnicodeFromObj)((objPtr), (Tcl_Size *)(void *)(sizePtr))) # define Tcl_ListObjGetElements(interp, listPtr, objcPtr, objvPtr) (sizeof(*(objcPtr)) <= sizeof(int) ? \ TclListObjGetElements((interp), (listPtr), (objcPtr), (objvPtr)) : \ (Tcl_ListObjGetElements)((interp), (listPtr), (Tcl_Size *)(void *)(objcPtr), (objvPtr))) # define Tcl_ListObjLength(interp, listPtr, lengthPtr) (sizeof(*(lengthPtr)) <= sizeof(int) ? \ TclListObjLength((interp), (listPtr), (lengthPtr)) : \ (Tcl_ListObjLength)((interp), (listPtr), (Tcl_Size *)(void *)(lengthPtr))) # define Tcl_DictObjSize(interp, dictPtr, sizePtr) (sizeof(*(sizePtr)) <= sizeof(int) ? \ TclDictObjSize((interp), (dictPtr), (sizePtr)) : \ (Tcl_DictObjSize)((interp), (dictPtr), (Tcl_Size *)(void *)(sizePtr))) # define Tcl_SplitList(interp, listStr, argcPtr, argvPtr) (sizeof(*(argcPtr)) <= sizeof(int) ? \ TclSplitList((interp), (listStr), (argcPtr), (argvPtr)) : \ (Tcl_SplitList)((interp), (listStr), (Tcl_Size *)(void *)(argcPtr), (argvPtr))) # define Tcl_SplitPath(path, argcPtr, argvPtr) (sizeof(*(argcPtr)) <= sizeof(int) ? \ TclSplitPath((path), (argcPtr), (argvPtr)) : \ (Tcl_SplitPath)((path), (Tcl_Size *)(void *)(argcPtr), (argvPtr))) # define Tcl_FSSplitPath(pathPtr, lenPtr) (sizeof(*(lenPtr)) <= sizeof(int) ? \ TclFSSplitPath((pathPtr), (lenPtr)) : \ (Tcl_FSSplitPath)((pathPtr), (Tcl_Size *)(void *)(lenPtr))) # define Tcl_ParseArgsObjv(interp, argTable, objcPtr, objv, remObjv) (sizeof(*(objcPtr)) <= sizeof(int) ? \ TclParseArgsObjv((interp), (argTable), (objcPtr), (objv), (remObjv)) : \ (Tcl_ParseArgsObjv)((interp), (argTable), (Tcl_Size *)(void *)(objcPtr), (objv), (remObjv))) # elif !defined(BUILD_tcl) # define Tcl_GetByteArrayFromObj(objPtr, sizePtr) (sizeof(*(sizePtr)) <= sizeof(int) ? \ tclStubsPtr->tclGetBytesFromObj(NULL, (objPtr), (sizePtr)) : \ tclStubsPtr->tcl_GetBytesFromObj(NULL, (objPtr), (Tcl_Size *)(void *)(sizePtr))) # define Tcl_GetBytesFromObj(interp, objPtr, sizePtr) (sizeof(*(sizePtr)) <= sizeof(int) ? \ tclStubsPtr->tclGetBytesFromObj((interp), (objPtr), (sizePtr)) : \ tclStubsPtr->tcl_GetBytesFromObj((interp), (objPtr), (Tcl_Size *)(void *)(sizePtr))) # define Tcl_GetStringFromObj(objPtr, sizePtr) (sizeof(*(sizePtr)) <= sizeof(int) ? \ tclStubsPtr->tclGetStringFromObj((objPtr), (sizePtr)) : \ tclStubsPtr->tcl_GetStringFromObj((objPtr), (Tcl_Size *)(void *)(sizePtr))) # define Tcl_GetUnicodeFromObj(objPtr, sizePtr) (sizeof(*(sizePtr)) <= sizeof(int) ? \ tclStubsPtr->tclGetUnicodeFromObj((objPtr), (sizePtr)) : \ tclStubsPtr->tcl_GetUnicodeFromObj((objPtr), (Tcl_Size *)(void *)(sizePtr))) # define Tcl_ListObjGetElements(interp, listPtr, objcPtr, objvPtr) (sizeof(*(objcPtr)) <= sizeof(int) ? \ tclStubsPtr->tclListObjGetElements((interp), (listPtr), (objcPtr), (objvPtr)) : \ tclStubsPtr->tcl_ListObjGetElements((interp), (listPtr), (Tcl_Size *)(void *)(objcPtr), (objvPtr))) # define Tcl_ListObjLength(interp, listPtr, lengthPtr) (sizeof(*(lengthPtr)) <= sizeof(int) ? \ tclStubsPtr->tclListObjLength((interp), (listPtr), (lengthPtr)) : \ tclStubsPtr->tcl_ListObjLength((interp), (listPtr), (Tcl_Size *)(void *)(lengthPtr))) # define Tcl_DictObjSize(interp, dictPtr, sizePtr) (sizeof(*(sizePtr)) <= sizeof(int) ? \ tclStubsPtr->tclDictObjSize((interp), (dictPtr), (sizePtr)) : \ tclStubsPtr->tcl_DictObjSize((interp), (dictPtr), (Tcl_Size *)(void *)(sizePtr))) # define Tcl_SplitList(interp, listStr, argcPtr, argvPtr) (sizeof(*(argcPtr)) <= sizeof(int) ? \ tclStubsPtr->tclSplitList((interp), (listStr), (argcPtr), (argvPtr)) : \ tclStubsPtr->tcl_SplitList((interp), (listStr), (Tcl_Size *)(void *)(argcPtr), (argvPtr))) # define Tcl_SplitPath(path, argcPtr, argvPtr) (sizeof(*(argcPtr)) <= sizeof(int) ? \ tclStubsPtr->tclSplitPath((path), (argcPtr), (argvPtr)) : \ tclStubsPtr->tcl_SplitPath((path), (Tcl_Size *)(void *)(argcPtr), (argvPtr))) # define Tcl_FSSplitPath(pathPtr, lenPtr) (sizeof(*(lenPtr)) <= sizeof(int) ? \ tclStubsPtr->tclFSSplitPath((pathPtr), (lenPtr)) : \ tclStubsPtr->tcl_FSSplitPath((pathPtr), (Tcl_Size *)(void *)(lenPtr))) # define Tcl_ParseArgsObjv(interp, argTable, objcPtr, objv, remObjv) (sizeof(*(objcPtr)) <= sizeof(int) ? \ tclStubsPtr->tclParseArgsObjv((interp), (argTable), (objcPtr), (objv), (remObjv)) : \ tclStubsPtr->tcl_ParseArgsObjv((interp), (argTable), (Tcl_Size *)(void *)(objcPtr), (objv), (remObjv))) # endif /* defined(USE_TCL_STUBS) */ #else /* !defined(TCL_8_API) */ # undef Tcl_GetByteArrayFromObj # define Tcl_GetByteArrayFromObj(objPtr, sizePtr) \ Tcl_GetBytesFromObj(NULL, (objPtr), (sizePtr)) #endif /* defined(TCL_8_API) */ #endif /* _TCLDECLS */ |
Changes to generic/tclDisassemble.c.
︙ | ︙ | |||
275 276 277 278 279 280 281 | numCmds = codePtr->numCommands; /* * Print header lines describing the ByteCode. */ Tcl_AppendPrintfToObj(bufferObj, | | | | | | | | 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 | numCmds = codePtr->numCommands; /* * Print header lines describing the ByteCode. */ Tcl_AppendPrintfToObj(bufferObj, "ByteCode %p, refCt %" TCL_SIZE_MODIFIER "d, epoch %" TCL_SIZE_MODIFIER "d, interp %p (epoch %" TCL_SIZE_MODIFIER "d)\n", codePtr, codePtr->refCount, codePtr->compileEpoch, iPtr, iPtr->compileEpoch); Tcl_AppendToObj(bufferObj, " Source ", -1); PrintSourceToObj(bufferObj, codePtr->source, TclMin(codePtr->numSrcBytes, 55)); GetLocationInformation(codePtr->procPtr, &fileObj, &line); if (line >= 0 && fileObj != NULL) { Tcl_AppendPrintfToObj(bufferObj, "\n File \"%s\" Line %d", TclGetString(fileObj), line); } Tcl_AppendPrintfToObj(bufferObj, "\n Cmds %d, src %" TCL_SIZE_MODIFIER "d, inst %" TCL_SIZE_MODIFIER "d, litObjs %" TCL_SIZE_MODIFIER "d, aux %" TCL_SIZE_MODIFIER "d, stkDepth %" TCL_SIZE_MODIFIER "d, code/src %.2f\n", numCmds, codePtr->numSrcBytes, codePtr->numCodeBytes, codePtr->numLitObjects, codePtr->numAuxDataItems, codePtr->maxStackDepth, #ifdef TCL_COMPILE_STATS codePtr->numSrcBytes? codePtr->structureSize/(float)codePtr->numSrcBytes : #endif 0.0); #ifdef TCL_COMPILE_STATS Tcl_AppendPrintfToObj(bufferObj, " Code %" TCL_Z_MODIFIER "u = header %" TCL_Z_MODIFIER "u+inst %" TCL_SIZE_MODIFIER "d+litObj %" TCL_Z_MODIFIER "u+exc %" TCL_Z_MODIFIER "u+aux %" TCL_Z_MODIFIER "u+cmdMap %" TCL_SIZE_MODIFIER "d\n", codePtr->structureSize, offsetof(ByteCode, localCachePtr), codePtr->numCodeBytes, codePtr->numLitObjects * sizeof(Tcl_Obj *), codePtr->numExceptRanges*sizeof(ExceptionRange), codePtr->numAuxDataItems * sizeof(AuxData), codePtr->numCmdLocBytes); #endif /* TCL_COMPILE_STATS */ /* * If the ByteCode is the compiled body of a Tcl procedure, print * information about that procedure. Note that we don't know the * procedure's name since ByteCode's can be shared among procedures. */ if (codePtr->procPtr != NULL) { Proc *procPtr = codePtr->procPtr; Tcl_Size numCompiledLocals = procPtr->numCompiledLocals; Tcl_AppendPrintfToObj(bufferObj, " Proc %p, refCt %" TCL_SIZE_MODIFIER "d, args %" TCL_SIZE_MODIFIER "d, compiled locals %" TCL_SIZE_MODIFIER "d\n", procPtr, procPtr->refCount, procPtr->numArgs, numCompiledLocals); if (numCompiledLocals > 0) { CompiledLocal *localPtr = procPtr->firstLocalPtr; for (i = 0; i < numCompiledLocals; i++) { Tcl_AppendPrintfToObj(bufferObj, " slot %" TCL_SIZE_MODIFIER "d%s%s%s%s%s%s", i, (localPtr->flags & (VAR_ARRAY|VAR_LINK)) ? "" : ", scalar", (localPtr->flags & VAR_ARRAY) ? ", array" : "", (localPtr->flags & VAR_LINK) ? ", link" : "", (localPtr->flags & VAR_ARGUMENT) ? ", arg" : "", (localPtr->flags & VAR_TEMPORARY) ? ", temp" : "", (localPtr->flags & VAR_RESOLVED) ? ", resolved" : ""); if (TclIsVarTemporary(localPtr)) { |
︙ | ︙ | |||
351 352 353 354 355 356 357 | } /* * Print the ExceptionRange array. */ if ((int)codePtr->numExceptRanges > 0) { | | | | | | 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 | } /* * Print the ExceptionRange array. */ if ((int)codePtr->numExceptRanges > 0) { Tcl_AppendPrintfToObj(bufferObj, " Exception ranges %" TCL_SIZE_MODIFIER "d, depth %" TCL_SIZE_MODIFIER "d:\n", codePtr->numExceptRanges, codePtr->maxExceptDepth); for (i = 0; i < (int)codePtr->numExceptRanges; i++) { ExceptionRange *rangePtr = &codePtr->exceptArrayPtr[i]; Tcl_AppendPrintfToObj(bufferObj, " %" TCL_SIZE_MODIFIER "d: level %" TCL_SIZE_MODIFIER "d, %s, pc %" TCL_SIZE_MODIFIER "d-%" TCL_SIZE_MODIFIER "d, ", i, rangePtr->nestingLevel, (rangePtr->type==LOOP_EXCEPTION_RANGE ? "loop" : "catch"), rangePtr->codeOffset, (rangePtr->codeOffset + rangePtr->numCodeBytes - 1)); switch (rangePtr->type) { case LOOP_EXCEPTION_RANGE: Tcl_AppendPrintfToObj(bufferObj, "continue %" TCL_SIZE_MODIFIER "d, break %" TCL_SIZE_MODIFIER "d\n", rangePtr->continueOffset, rangePtr->breakOffset); break; case CATCH_EXCEPTION_RANGE: Tcl_AppendPrintfToObj(bufferObj, "catch %" TCL_SIZE_MODIFIER "d\n", rangePtr->catchOffset); break; default: Tcl_Panic("DisassembleByteCodeObj: bad ExceptionRange type %d", rangePtr->type); } } |
︙ | ︙ | |||
442 443 444 445 446 447 448 | srcLen = TclGetInt4AtPtr(srcLengthNext); srcLengthNext += 4; } else { srcLen = TclGetInt1AtPtr(srcLengthNext); srcLengthNext++; } | | | 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 | srcLen = TclGetInt4AtPtr(srcLengthNext); srcLengthNext += 4; } else { srcLen = TclGetInt1AtPtr(srcLengthNext); srcLengthNext++; } Tcl_AppendPrintfToObj(bufferObj, "%s%4" TCL_SIZE_MODIFIER "d: pc %d-%d, src %d-%d", ((i % 2)? " " : "\n "), (i+1), codeOffset, (codeOffset + codeLen - 1), srcOffset, (srcOffset + srcLen - 1)); } if (numCmds > 0) { Tcl_AppendToObj(bufferObj, "\n", -1); } |
︙ | ︙ | |||
501 502 503 504 505 506 507 | */ while ((pc-codeStart) < codeOffset) { Tcl_AppendToObj(bufferObj, " ", -1); pc += FormatInstruction(codePtr, pc, bufferObj); } | | | 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 | */ while ((pc-codeStart) < codeOffset) { Tcl_AppendToObj(bufferObj, " ", -1); pc += FormatInstruction(codePtr, pc, bufferObj); } Tcl_AppendPrintfToObj(bufferObj, " Command %" TCL_SIZE_MODIFIER "d: ", i+1); PrintSourceToObj(bufferObj, (codePtr->source + srcOffset), TclMin(srcLen, 55)); Tcl_AppendToObj(bufferObj, "\n", -1); } if (pc < codeLimit) { /* * Print instructions after the last command. |
︙ | ︙ | |||
622 623 624 625 626 627 628 | goto printLVTindex; case OPERAND_LVT4: opnd = TclGetUInt4AtPtr(pc+numBytes); numBytes += 4; printLVTindex: if (localPtr != NULL) { if (opnd >= localCt) { | | | 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 | goto printLVTindex; case OPERAND_LVT4: opnd = TclGetUInt4AtPtr(pc+numBytes); numBytes += 4; printLVTindex: if (localPtr != NULL) { if (opnd >= localCt) { Tcl_Panic("FormatInstruction: bad local var index %u (%" TCL_SIZE_MODIFIER "d locals)", opnd, localCt); } for (j = 0; j < opnd; j++) { localPtr = localPtr->nextPtr; } if (TclIsVarTemporary(localPtr)) { snprintf(suffixBuffer, sizeof(suffixBuffer), "temp var %u", opnd); |
︙ | ︙ | |||
1143 1144 1145 1146 1147 1148 1149 | TclNewObj(exn); for (i=0 ; i<(int)codePtr->numExceptRanges ; i++) { ExceptionRange *rangePtr = &codePtr->exceptArrayPtr[i]; switch (rangePtr->type) { case LOOP_EXCEPTION_RANGE: Tcl_ListObjAppendElement(NULL, exn, Tcl_ObjPrintf( | | | | 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 | TclNewObj(exn); for (i=0 ; i<(int)codePtr->numExceptRanges ; i++) { ExceptionRange *rangePtr = &codePtr->exceptArrayPtr[i]; switch (rangePtr->type) { case LOOP_EXCEPTION_RANGE: Tcl_ListObjAppendElement(NULL, exn, Tcl_ObjPrintf( "type %s level %" TCL_SIZE_MODIFIER "d from %" TCL_SIZE_MODIFIER "d to %" TCL_SIZE_MODIFIER "d break %" TCL_SIZE_MODIFIER "d continue %" TCL_SIZE_MODIFIER "d", "loop", rangePtr->nestingLevel, rangePtr->codeOffset, rangePtr->codeOffset + rangePtr->numCodeBytes - 1, rangePtr->breakOffset, rangePtr->continueOffset)); break; case CATCH_EXCEPTION_RANGE: Tcl_ListObjAppendElement(NULL, exn, Tcl_ObjPrintf( "type %s level %" TCL_SIZE_MODIFIER "d from %" TCL_SIZE_MODIFIER "d to %" TCL_SIZE_MODIFIER "d catch %" TCL_SIZE_MODIFIER "d", "catch", rangePtr->nestingLevel, rangePtr->codeOffset, rangePtr->codeOffset + rangePtr->numCodeBytes - 1, rangePtr->catchOffset)); break; } } |
︙ | ︙ |
Changes to generic/tclEncoding.c.
︙ | ︙ | |||
79 80 81 82 83 84 85 86 87 88 89 90 91 92 | /* Two dimensional sparse matrix to map * characters from Unicode to the encoding. * Each element of the fromUnicode array * points to an array of 256 shorts. If there * is no corresponding character the encoding, * the value in the matrix is 0x0000. * malloc'd. */ } TableEncodingData; /* * Each of the following structures is the clientData for a dynamically-loaded * escape-driven encoding that is itself comprised of other simpler encodings. * An example is "iso-2022-jp", which uses escape sequences to switch between * ascii, jis0208, jis0212, gb2312, and ksc5601. Note that "escape-driven" | > > | 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 | /* Two dimensional sparse matrix to map * characters from Unicode to the encoding. * Each element of the fromUnicode array * points to an array of 256 shorts. If there * is no corresponding character the encoding, * the value in the matrix is 0x0000. * malloc'd. */ int flags; /* Miscellaneous flags */ #define ENCODING_ASCII_COMPATIBLE 0x1 } TableEncodingData; /* * Each of the following structures is the clientData for a dynamically-loaded * escape-driven encoding that is itself comprised of other simpler encodings. * An example is "iso-2022-jp", which uses escape sequences to switch between * ascii, jis0208, jis0212, gb2312, and ksc5601. Note that "escape-driven" |
︙ | ︙ | |||
192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 | * Names of encoding profiles and corresponding integer values. * Keep alphabetical order for error messages. */ static struct TclEncodingProfiles { const char *name; int value; } encodingProfiles[] = { {"replace", TCL_ENCODING_PROFILE_REPLACE}, {"strict", TCL_ENCODING_PROFILE_STRICT}, {"tcl8", TCL_ENCODING_PROFILE_TCL8}, }; #define PROFILE_TCL8(flags_) \ (ENCODING_PROFILE_GET(flags_) == TCL_ENCODING_PROFILE_TCL8) #define PROFILE_REPLACE(flags_) \ (ENCODING_PROFILE_GET(flags_) == TCL_ENCODING_PROFILE_REPLACE) #define PROFILE_STRICT(flags_) \ | > > > > | | 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 | * Names of encoding profiles and corresponding integer values. * Keep alphabetical order for error messages. */ static struct TclEncodingProfiles { const char *name; int value; } encodingProfiles[] = { {"lossless", TCL_ENCODING_PROFILE_LOSSLESS}, {"replace", TCL_ENCODING_PROFILE_REPLACE}, {"strict", TCL_ENCODING_PROFILE_STRICT}, {"tcl8", TCL_ENCODING_PROFILE_TCL8}, }; #define PROFILE_TCL8(flags_) \ (ENCODING_PROFILE_GET(flags_) == TCL_ENCODING_PROFILE_TCL8) #define PROFILE_REPLACE(flags_) \ (ENCODING_PROFILE_GET(flags_) == TCL_ENCODING_PROFILE_REPLACE) #define PROFILE_LOSSLESS(flags_) \ (ENCODING_PROFILE_GET(flags_) == TCL_ENCODING_PROFILE_LOSSLESS) #define PROFILE_STRICT(flags_) \ (!PROFILE_TCL8(flags_) && !PROFILE_REPLACE(flags_) && !PROFILE_LOSSLESS(flags_)) #define UNICODE_REPLACE_CHAR ((Tcl_UniChar)0xFFFD) #define SURROGATE(c_) (((c_) & ~0x7FF) == 0xD800) #define HIGH_SURROGATE(c_) (((c_) & ~0x3FF) == 0xD800) #define LOW_SURROGATE(c_) (((c_) & ~0x3FF) == 0xDC00) /* |
︙ | ︙ | |||
253 254 255 256 257 258 259 260 261 262 263 264 265 266 | static Tcl_EncodingConvertProc Utf16ToUtfProc; static Tcl_EncodingConvertProc UtfToUtf16Proc; static Tcl_EncodingConvertProc UtfToUcs2Proc; static Tcl_EncodingConvertProc UtfToUtfProc; static Tcl_EncodingConvertProc Iso88591FromUtfProc; static Tcl_EncodingConvertProc Iso88591ToUtfProc; /* * A Tcl_ObjType for holding a cached Tcl_Encoding in the twoPtrValue.ptr1 field * of the internalrep. This should help the lifetime of encodings be more useful. * See concerns raised in [Bug 1077262]. */ | > > > > > > > > > > > > > > | 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 | static Tcl_EncodingConvertProc Utf16ToUtfProc; static Tcl_EncodingConvertProc UtfToUtf16Proc; static Tcl_EncodingConvertProc UtfToUcs2Proc; static Tcl_EncodingConvertProc UtfToUtfProc; static Tcl_EncodingConvertProc Iso88591FromUtfProc; static Tcl_EncodingConvertProc Iso88591ToUtfProc; /* Return 1/0 if unich is a lossless wrapper */ static inline int IsLosslessWrapper(Tcl_UniChar unich) { return (unich >= 0xDC00 && unich <= 0xDCFF); } /* Convert a byte to internal lossless representation */ static inline Tcl_UniChar ToLossless(char ch) { /* Only encode if non-ASCII for security reasons. See TIP */ return 0x80 & ch ? 0xDC00 + UCHAR(ch) : UNICODE_REPLACE_CHAR; } /* Convert an internal lossless representation to raw byte */ static inline unsigned char FromLossless(Tcl_UniChar unich) { assert(IsLosslessWrapper(unich)); return (unsigned char)(unich - 0xDC00); } /* * A Tcl_ObjType for holding a cached Tcl_Encoding in the twoPtrValue.ptr1 field * of the internalrep. This should help the lifetime of encodings be more useful. * See concerns raised in [Bug 1077262]. */ |
︙ | ︙ | |||
285 286 287 288 289 290 291 292 293 294 295 296 297 298 | do { \ const Tcl_ObjInternalRep *irPtr; \ irPtr = TclFetchInternalRep ((objPtr), &encodingType); \ (encoding) = irPtr ? (Tcl_Encoding)irPtr->twoPtrValue.ptr1 : NULL; \ } while (0) /* *---------------------------------------------------------------------- * * Tcl_GetEncodingFromObj -- * * Writes to (*encodingPtr) the Tcl_Encoding value of (*objPtr), if * possible, and returns TCL_OK. If no such encoding exists, TCL_ERROR is | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | do { \ const Tcl_ObjInternalRep *irPtr; \ irPtr = TclFetchInternalRep ((objPtr), &encodingType); \ (encoding) = irPtr ? (Tcl_Encoding)irPtr->twoPtrValue.ptr1 : NULL; \ } while (0) /* *------------------------------------------------------------------------ * * ToLosslessUtf8 -- * * Converts an entire string of bytes to their lossless utf-8 representation. * Caller has to ensure the entire string is to be treated as invalid encoding. * * Results: * Number of bytes in converted utf-8 output or a negative value if * insufficient space. * * Side effects: * The dst buffer is filled with the utf-8 lossless representation. * *------------------------------------------------------------------------ */ static Tcl_Size ToLosslessUtf8( const char *src, /* Source bytes */ Tcl_Size srcLen, /* Number of source bytes */ char *dst, /* Destination buffer */ Tcl_Size dstLen) /* Size of destination buffer */ { if ((dstLen / 3) < srcLen) { return -1; /* No space */ } const char *srcEnd = src + srcLen; char *dstStart = dst; while (src < srcEnd) { dst += Tcl_UniCharToUtf(ToLossless(UCHAR(*src)), dst); ++src; } return (dst - dstStart); } /* *---------------------------------------------------------------------- * * Tcl_GetEncodingFromObj -- * * Writes to (*encodingPtr) the Tcl_Encoding value of (*objPtr), if * possible, and returns TCL_OK. If no such encoding exists, TCL_ERROR is |
︙ | ︙ | |||
407 408 409 410 411 412 413 | if (TCL_ERROR == TclListObjLengthM(NULL, searchPath, &dummy)) { return TCL_ERROR; } TclSetProcessGlobalValue(&encodingSearchPath, searchPath, NULL); return TCL_OK; } | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 463 464 465 466 467 468 469 470 471 472 473 474 475 476 | if (TCL_ERROR == TclListObjLengthM(NULL, searchPath, &dummy)) { return TCL_ERROR; } TclSetProcessGlobalValue(&encodingSearchPath, searchPath, NULL); return TCL_OK; } /* *--------------------------------------------------------------------------- * * FillEncodingFileMap -- * * Called to update the encoding file map with the current value |
︙ | ︙ | |||
1291 1292 1293 1294 1295 1296 1297 | * wants to know error location. */ *errorLocPtr = result == TCL_OK ? TCL_INDEX_NONE : nBytesProcessed; } else { /* Caller wants error message on failure */ if (result != TCL_OK && interp != NULL) { char buf[TCL_INTEGER_SPACE]; | | | | 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 | * wants to know error location. */ *errorLocPtr = result == TCL_OK ? TCL_INDEX_NONE : nBytesProcessed; } else { /* Caller wants error message on failure */ if (result != TCL_OK && interp != NULL) { char buf[TCL_INTEGER_SPACE]; snprintf(buf, sizeof(buf), "%" TCL_SIZE_MODIFIER "d", nBytesProcessed); Tcl_SetObjResult( interp, Tcl_ObjPrintf("unexpected byte sequence starting at index %" TCL_SIZE_MODIFIER "d: '\\x%02X'", nBytesProcessed, UCHAR(srcStart[nBytesProcessed]))); Tcl_SetErrorCode( interp, "TCL", "ENCODING", "ILLEGALSEQUENCE", buf, (void *)NULL); } } if (result != TCL_OK) { |
︙ | ︙ | |||
1624 1625 1626 1627 1628 1629 1630 | } else { /* Caller wants error message on failure */ if (result != TCL_OK && interp != NULL) { Tcl_Size pos = Tcl_NumUtfChars(srcStart, nBytesProcessed); int ucs4; char buf[TCL_INTEGER_SPACE]; Tcl_UtfToUniChar(&srcStart[nBytesProcessed], &ucs4); | | | 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 | } else { /* Caller wants error message on failure */ if (result != TCL_OK && interp != NULL) { Tcl_Size pos = Tcl_NumUtfChars(srcStart, nBytesProcessed); int ucs4; char buf[TCL_INTEGER_SPACE]; Tcl_UtfToUniChar(&srcStart[nBytesProcessed], &ucs4); snprintf(buf, sizeof(buf), "%" TCL_SIZE_MODIFIER "d", nBytesProcessed); Tcl_SetObjResult( interp, Tcl_ObjPrintf( "unexpected character at index %" TCL_SIZE_MODIFIER "u: 'U+%06X'", pos, ucs4)); |
︙ | ︙ | |||
2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 2118 2119 2120 2121 2122 | pageMemPtr++; p += 4; } } TclDecrRefCount(objPtr); if (type == ENCODING_DOUBLEBYTE) { memset(dataPtr->prefixBytes, 1, sizeof(dataPtr->prefixBytes)); } else { for (hi = 1; hi < 256; hi++) { if (dataPtr->toUnicode[hi] != NULL) { dataPtr->prefixBytes[hi] = 1; } } } /* * Invert the toUnicode array to produce the fromUnicode array. Performs a * single malloc to get the memory for the array and all the pages needed | > > > > > > > > > > > > > > > > > > | 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 | pageMemPtr++; p += 4; } } TclDecrRefCount(objPtr); if (type == ENCODING_DOUBLEBYTE) { /* DBCS never ascii compatible so no need to set dataPtr->flags */ memset(dataPtr->prefixBytes, 1, sizeof(dataPtr->prefixBytes)); } else { int asciiCompatible = 1; for (hi = 1; hi < 256; hi++) { if (dataPtr->toUnicode[hi] != NULL) { dataPtr->prefixBytes[hi] = 1; if (hi < 128) { /* any byte < 128 is a prefix => not ASCII compatible */ asciiCompatible = 0; } } } if (asciiCompatible) { for (lo = 1; lo < 128; ++lo) { if (dataPtr->toUnicode[0][lo] != lo) { /* any byte < 128 does not map to itself => not ASCII compatible */ asciiCompatible = 0; break; } } if (asciiCompatible) { dataPtr->flags |= ENCODING_ASCII_COMPATIBLE; } } } /* * Invert the toUnicode array to produce the fromUnicode array. Performs a * single malloc to get the memory for the array and all the pages needed |
︙ | ︙ | |||
2552 2553 2554 2555 2556 2557 2558 | /* * Copy 7bit characters, but skip null-bytes when we are in input * mode, so that they get converted to \xC0\x80. */ *dst++ = *src++; } else if ((UCHAR(*src) == 0xC0) && (src + 1 < srcEnd) && (UCHAR(src[1]) == 0x80) && | | > > > > > > > > > > > | < | > > | | > > > | | | > > > < | < < | | | > | | | > > | | | | > | < > | > > | > > > > > > > > | > > > > > > | | < | | | | < | < < > | > > | 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 2617 2618 2619 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 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 2721 | /* * Copy 7bit characters, but skip null-bytes when we are in input * mode, so that they get converted to \xC0\x80. */ *dst++ = *src++; } else if ((UCHAR(*src) == 0xC0) && (src + 1 < srcEnd) && (UCHAR(src[1]) == 0x80) && (!(flags & ENCODING_INPUT) || ! PROFILE_TCL8(profile))) { /* * \xC0\x80 is handled specially for either of the following: * 1. We are doing (internal) modified utf-8 to (external) * conformant utf-8. C080 is valid internal utf-8 so we * simply output a \0. Note this overrides case 2. * 2. The profile in use is not TCL8, in which case we have to * to take a profile-dependent action. * Note the remaining case of external->internal with a TCL8 * profile is handled in the default if clause later. (TODO - why not here?) */ if (flags & ENCODING_INPUT) { assert(!PROFILE_TCL8(profile)); if (PROFILE_STRICT(profile)) { result = TCL_CONVERT_SYNTAX; break; } else if (PROFILE_REPLACE(profile)) { dst += Tcl_UniCharToUtf(UNICODE_REPLACE_CHAR, dst); src += 2; } else { assert(PROFILE_LOSSLESS(profile)); Tcl_Size len = ToLosslessUtf8(src, 2, dst, dstLen - (dst - dstStart)); if (len < 0) { result = TCL_CONVERT_NOSPACE; break; } dst += len; src += 2; } } else { /* For output convert 0xC080 to a real null. */ *dst++ = 0; src += 2; } } else if (!Tcl_UtfCharComplete(src, srcEnd - src)) { /* * Incomplete byte sequence. We need to do this check before the * Tcl_UtfToUniChar checks in the next sibling if clause. Not doing * so can cause it run beyond the end of the buffer! If we * happen on such an incomplete char its bytes are made to * represent themselves unless the user has explicitly asked to * be told. */ assert(flags & TCL_ENCODING_END); /* Else break earlier would trigger (srcClose compare) */ if (flags & ENCODING_INPUT) { /* TODO - why is this inside a ENCODING_INPUT check? */ /* Incomplete bytes for modified UTF-8 target */ if (PROFILE_STRICT(profile)) { result = (flags & TCL_ENCODING_CHAR_LIMIT) ? TCL_CONVERT_MULTIBYTE : TCL_CONVERT_SYNTAX; break; } } if (PROFILE_REPLACE(profile)) { ch = UNICODE_REPLACE_CHAR; ++src; dst += Tcl_UniCharToUtf(ch, dst); } else if (PROFILE_TCL8(profile)) { char chbuf[2]; chbuf[0] = UCHAR(*src++); chbuf[1] = 0; Tcl_UtfToUniChar(chbuf, &ch); dst += Tcl_UniCharToUtf(ch, dst); } else { assert(PROFILE_LOSSLESS(profile)); ch = ToLossless(UCHAR(*src)); dst += Tcl_UniCharToUtf(ch, dst); src += 1; } } else { int isInvalid = 0; size_t len = Tcl_UtfToUniChar(src, &ch); if (flags & ENCODING_INPUT) { if ((len < 2) && (ch != 0)) { isInvalid = 1; } else if ((ch > 0xFFFF) && !(flags & ENCODING_UTF)) { isInvalid = 1; } if (isInvalid) { if (PROFILE_STRICT(profile)) { result = TCL_CONVERT_SYNTAX; break; } else if (PROFILE_REPLACE(profile)) { ch = UNICODE_REPLACE_CHAR; } else if (PROFILE_LOSSLESS(profile)) { Tcl_Size n = ToLosslessUtf8( src, len, dst, dstLen - (dst - dstStart)); if (n < 0) { result = TCL_CONVERT_NOSPACE; break; } dst += n; src += len; continue; } /* else PROFILE_TCL8 - treat as normal char below */ } } const char *saveSrc = src; src += len; if (!(flags & ENCODING_UTF) && !(flags & ENCODING_INPUT) && (ch > 0x3FF)) { if (ch > 0xFFFF) { /* CESU-8 6-byte sequence for chars > U+FFFF */ ch -= 0x10000; *dst++ = 0xED; *dst++ = (char) (((ch >> 16) & 0x0F) | 0xA0); *dst++ = (char) (((ch >> 10) & 0x3F) | 0x80); ch = (ch & 0x0CFF) | 0xDC00; } *dst++ = (char) (((ch >> 12) | 0xE0) & 0xEF); *dst++ = (char) (((ch >> 6) | 0x80) & 0xBF); *dst++ = (char) ((ch | 0x80) & 0xBF); continue; } else if (SURROGATE(ch)) { if (PROFILE_STRICT(profile)) { result = (flags & ENCODING_INPUT) ? TCL_CONVERT_SYNTAX : TCL_CONVERT_UNKNOWN; src = saveSrc; break; } else if (PROFILE_LOSSLESS(profile)) { if (IsLosslessWrapper(ch)) { *dst++ = FromLossless(ch); /* Invalid UTF8 by design! */ continue; } } } dst += Tcl_UniCharToUtf(ch, dst); } } *srcReadPtr = src - srcStart; *dstWrotePtr = dst - dstStart; |
︙ | ︙ | |||
2742 2743 2744 2745 2746 2747 2748 | if (PROFILE_STRICT(flags)) { result = TCL_CONVERT_SYNTAX; break; } } else if (PROFILE_STRICT(flags) && SURROGATE(ch)) { result = TCL_CONVERT_SYNTAX; break; | | > | 2804 2805 2806 2807 2808 2809 2810 2811 2812 2813 2814 2815 2816 2817 2818 2819 | if (PROFILE_STRICT(flags)) { result = TCL_CONVERT_SYNTAX; break; } } else if (PROFILE_STRICT(flags) && SURROGATE(ch)) { result = TCL_CONVERT_SYNTAX; break; } else if ((! PROFILE_TCL8(flags)) && SURROGATE(ch)) { /* PROFILE_REPLACE | PROFILE_LOSSLESS */ ch = UNICODE_REPLACE_CHAR; } /* * Special case for 1-byte utf chars for speed. Make sure we work with * unsigned short-size data. */ |
︙ | ︙ | |||
2770 2771 2772 2773 2774 2775 2776 | if ((flags & TCL_ENCODING_END) && (result == TCL_CONVERT_MULTIBYTE)) { if (dst > dstEnd) { result = TCL_CONVERT_NOSPACE; } else { if (PROFILE_STRICT(flags)) { result = TCL_CONVERT_SYNTAX; } else { | | | 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 2847 | if ((flags & TCL_ENCODING_END) && (result == TCL_CONVERT_MULTIBYTE)) { if (dst > dstEnd) { result = TCL_CONVERT_NOSPACE; } else { if (PROFILE_STRICT(flags)) { result = TCL_CONVERT_SYNTAX; } else { /* PROFILE_REPLACE | PROFILE_LOSSLESS | PROFILE_TCL8 */ result = TCL_OK; dst += Tcl_UniCharToUtf(UNICODE_REPLACE_CHAR, dst); numChars++; src += bytesLeft; /* Go past truncated code unit */ } } } |
︙ | ︙ | |||
2859 2860 2861 2862 2863 2864 2865 | break; } len = Tcl_UtfToUniChar(src, &ch); if (SURROGATE(ch)) { if (PROFILE_STRICT(flags)) { result = TCL_CONVERT_UNKNOWN; break; | | | | 2922 2923 2924 2925 2926 2927 2928 2929 2930 2931 2932 2933 2934 2935 2936 2937 | break; } len = Tcl_UtfToUniChar(src, &ch); if (SURROGATE(ch)) { if (PROFILE_STRICT(flags)) { result = TCL_CONVERT_UNKNOWN; break; } else if (! PROFILE_TCL8(flags)) { /* PROFILE_REPLACE | PROFILE_LOSSLESS */ ch = UNICODE_REPLACE_CHAR; } } src += len; if (flags & TCL_ENCODING_LE) { *dst++ = (ch & 0xFF); *dst++ = ((ch >> 8) & 0xFF); |
︙ | ︙ | |||
2979 2980 2981 2982 2983 2984 2985 | if (HIGH_SURROGATE(prev) && !LOW_SURROGATE(ch)) { if (PROFILE_STRICT(flags)) { result = TCL_CONVERT_SYNTAX; src -= 2; /* Go back to beginning of high surrogate */ dst--; /* Also undo writing a single byte too much */ numChars--; break; | | > > > < < < | > > > | > > | | < | > | | | > | | 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 | if (HIGH_SURROGATE(prev) && !LOW_SURROGATE(ch)) { if (PROFILE_STRICT(flags)) { result = TCL_CONVERT_SYNTAX; src -= 2; /* Go back to beginning of high surrogate */ dst--; /* Also undo writing a single byte too much */ numChars--; break; } else if (PROFILE_TCL8(flags)) { /* Bug [10c2c17c32]. Hi surrogate not followed by Lo: finish 3-byte UTF-8 */ dst += Tcl_UniCharToUtf(-1, dst); } else { /* * Previous loop wrote a single byte to mark the high surrogate. * Replace it with the replacement character. Further, restart * current loop iteration since need to recheck destination space * and reset processing of current character. */ ch = UNICODE_REPLACE_CHAR; dst--; dst += Tcl_UniCharToUtf(ch, dst); src -= 2; numChars--; continue; } } /* * Special case for 1-byte utf chars for speed. Make sure we work with * unsigned short-size data. */ if ((unsigned)ch - 1 < 0x7F) { *dst++ = (ch & 0xFF); } else if (HIGH_SURROGATE(prev) || HIGH_SURROGATE(ch)) { dst += Tcl_UniCharToUtf(ch | TCL_COMBINE, dst); } else if (LOW_SURROGATE(ch)) { /* Lo surrogate not preceded by Hi surrogate and not tcl8 profile */ if (PROFILE_STRICT(flags)) { result = TCL_CONVERT_UNKNOWN; break; } else if (PROFILE_TCL8(flags)) { dst += Tcl_UniCharToUtf(ch, dst); } else { /* * PROFILE_REPLACE | PROFILE_LOSSLESS. LOSSLESS treated like * REPLACE for UTF16 - see TIP 671 */ dst += Tcl_UniCharToUtf(UNICODE_REPLACE_CHAR, dst); } } else { dst += Tcl_UniCharToUtf(ch, dst); } } if (HIGH_SURROGATE(ch)) { if (PROFILE_STRICT(flags)) { result = TCL_CONVERT_SYNTAX; src -= 2; dst--; numChars--; } else if (PROFILE_TCL8(flags)) { dst += Tcl_UniCharToUtf(-1, dst); } else { /* PROFILE_REPLACE | PROFILE_LOSSLESS */ dst--; dst += Tcl_UniCharToUtf(UNICODE_REPLACE_CHAR, dst); } } /* * If we had a truncated code unit at the end AND this is the last * fragment AND profile is not "strict", use the appropriate replacement * strategy. */ if ((flags & TCL_ENCODING_END) && (result == TCL_CONVERT_MULTIBYTE)) { if (dst > dstEnd) { result = TCL_CONVERT_NOSPACE; } else { if (PROFILE_STRICT(flags)) { result = TCL_CONVERT_SYNTAX; } else { /* PROFILE_REPLACE | PROFILE_TCL8 | PROFILE_LOSSLESS */ result = TCL_OK; dst += Tcl_UniCharToUtf(UNICODE_REPLACE_CHAR, dst); numChars++; src++; /* Go past truncated code unit */ } } } |
︙ | ︙ | |||
3136 3137 3138 3139 3140 3141 3142 | break; } len = Tcl_UtfToUniChar(src, &ch); if (SURROGATE(ch)) { if (PROFILE_STRICT(flags)) { result = TCL_CONVERT_UNKNOWN; break; | | | | 3205 3206 3207 3208 3209 3210 3211 3212 3213 3214 3215 3216 3217 3218 3219 3220 | break; } len = Tcl_UtfToUniChar(src, &ch); if (SURROGATE(ch)) { if (PROFILE_STRICT(flags)) { result = TCL_CONVERT_UNKNOWN; break; } else if (! PROFILE_TCL8(flags)) { /* PROFILE_REPLACE | PROFILE_LOSSLESS */ ch = UNICODE_REPLACE_CHAR; } } src += len; if (flags & TCL_ENCODING_LE) { if (ch <= 0xFFFF) { *dst++ = (ch & 0xFF); |
︙ | ︙ | |||
3247 3248 3249 3250 3251 3252 3253 | if (ch > 0xFFFF) { if (PROFILE_STRICT(flags)) { result = TCL_CONVERT_UNKNOWN; break; } ch = UNICODE_REPLACE_CHAR; } | > | | | > > > > | 3316 3317 3318 3319 3320 3321 3322 3323 3324 3325 3326 3327 3328 3329 3330 3331 3332 3333 3334 3335 3336 3337 | if (ch > 0xFFFF) { if (PROFILE_STRICT(flags)) { result = TCL_CONVERT_UNKNOWN; break; } ch = UNICODE_REPLACE_CHAR; } if (SURROGATE(ch)) { if (PROFILE_STRICT(flags)) { result = TCL_CONVERT_SYNTAX; break; } else if (!PROFILE_TCL8(flags)) { /* PROFILE_REPLACE | PROFILE_LOSSLESS */ ch = UNICODE_REPLACE_CHAR; } } src += len; /* * Need to handle this in a way that won't cause misalignment by * casting dst to a Tcl_UniChar. [Bug 1122671] |
︙ | ︙ | |||
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 | result = TCL_CONVERT_NOSPACE; break; } byte = *((unsigned char *) src); if (prefixBytes[byte]) { if (src >= srcEnd-1) { /* Prefix byte but nothing after it */ if (!(flags & TCL_ENCODING_END)) { /* More data to come */ result = TCL_CONVERT_MULTIBYTE; break; } else if (PROFILE_STRICT(flags)) { result = TCL_CONVERT_SYNTAX; break; } else if (PROFILE_REPLACE(flags)) { ch = UNICODE_REPLACE_CHAR; } else { ch = (Tcl_UniChar)byte; } } else { ch = toUnicode[byte][*((unsigned char *)++src)]; } } else { ch = pageZero[byte]; } if ((ch == 0) && (byte != 0)) { /* Prefix+suffix pair is invalid */ if (PROFILE_STRICT(flags)) { result = TCL_CONVERT_SYNTAX; break; } if (prefixBytes[byte]) { src--; } if (PROFILE_REPLACE(flags)) { ch = UNICODE_REPLACE_CHAR; } else { ch = (Tcl_UniChar)byte; } } /* * Special case for 1-byte Utf chars for speed. | > > > > > > > > > | 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 3452 3453 3454 3455 3456 3457 3458 3459 3460 3461 3462 3463 3464 3465 3466 3467 3468 3469 3470 | result = TCL_CONVERT_NOSPACE; break; } byte = *((unsigned char *) src); if (prefixBytes[byte]) { if (src >= srcEnd-1) { /* Prefix byte but nothing after it */ /* Truncated sequence ... */ if (!(flags & TCL_ENCODING_END)) { /* More data to come */ result = TCL_CONVERT_MULTIBYTE; break; } else if (PROFILE_STRICT(flags)) { result = TCL_CONVERT_SYNTAX; break; } else if (PROFILE_REPLACE(flags)) { ch = UNICODE_REPLACE_CHAR; } else if (PROFILE_LOSSLESS(flags)) { if (dataPtr->flags & ENCODING_ASCII_COMPATIBLE) { ch = ToLossless(byte); } else { ch = UNICODE_REPLACE_CHAR; } } else { ch = (Tcl_UniChar)byte; } } else { ch = toUnicode[byte][*((unsigned char *)++src)]; } } else { ch = pageZero[byte]; } if ((ch == 0) && (byte != 0)) { /* Prefix+suffix pair is invalid */ if (PROFILE_STRICT(flags)) { result = TCL_CONVERT_SYNTAX; break; } if (prefixBytes[byte]) { src--; } if (PROFILE_REPLACE(flags)) { ch = UNICODE_REPLACE_CHAR; } else if (PROFILE_LOSSLESS(flags)) { ch = ToLossless(byte); } else { ch = (Tcl_UniChar)byte; } } /* * Special case for 1-byte Utf chars for speed. |
︙ | ︙ | |||
3444 3445 3446 3447 3448 3449 3450 3451 3452 3453 3454 3455 3456 3457 | * output buffer. */ { const char *srcStart, *srcEnd, *srcClose; const char *dstStart, *dstEnd, *prefixBytes; Tcl_UniChar ch = 0; int result, len, word, numChars; TableEncodingData *dataPtr = (TableEncodingData *)clientData; const unsigned short *const *fromUnicode; result = TCL_OK; prefixBytes = dataPtr->prefixBytes; fromUnicode = (const unsigned short *const *) dataPtr->fromUnicode; | > | 3527 3528 3529 3530 3531 3532 3533 3534 3535 3536 3537 3538 3539 3540 3541 | * output buffer. */ { const char *srcStart, *srcEnd, *srcClose; const char *dstStart, *dstEnd, *prefixBytes; Tcl_UniChar ch = 0; int result, len, word, numChars; TableEncodingData *dataPtr = (TableEncodingData *)clientData; int asciiCompatible = dataPtr->flags & ENCODING_ASCII_COMPATIBLE; const unsigned short *const *fromUnicode; result = TCL_OK; prefixBytes = dataPtr->prefixBytes; fromUnicode = (const unsigned short *const *) dataPtr->fromUnicode; |
︙ | ︙ | |||
3480 3481 3482 3483 3484 3485 3486 3487 3488 3489 3490 3491 | /* Unicode chars > +U0FFFF cannot be represented in any table encoding */ if (ch & 0xFFFF0000) { word = 0; } else { word = fromUnicode[(ch >> 8)][ch & 0xFF]; } if ((word == 0) && (ch != 0)) { if (PROFILE_STRICT(flags)) { result = TCL_CONVERT_UNKNOWN; break; } | > > > > > > > | | > | | 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 | /* Unicode chars > +U0FFFF cannot be represented in any table encoding */ if (ch & 0xFFFF0000) { word = 0; } else { word = fromUnicode[(ch >> 8)][ch & 0xFF]; } int isWrappedLossless = 0; if ((word == 0) && (ch != 0)) { if (PROFILE_STRICT(flags)) { result = TCL_CONVERT_UNKNOWN; break; } if (PROFILE_LOSSLESS(flags) && IsLosslessWrapper(ch) && asciiCompatible) { word = FromLossless(ch); isWrappedLossless = 1; } else { word = dataPtr->fallback; /* Both profiles REPLACE and TCL8 */ } } if (prefixBytes[(word >> 8)] != 0 && !isWrappedLossless) { if (dst + 1 > dstEnd) { result = TCL_CONVERT_NOSPACE; break; } dst[0] = (char) (word >> 8); dst[1] = (char) word; dst += 2; |
︙ | ︙ | |||
3564 3565 3566 3567 3568 3569 3570 3571 3572 3573 3574 3575 3576 3577 | } srcStart = src; srcEnd = src + srcLen; dstStart = dst; dstEnd = dst + dstLen - TCL_UTF_MAX; result = TCL_OK; for (numChars = 0; src < srcEnd && numChars <= charLimit; numChars++) { Tcl_UniChar ch = 0; if (dst > dstEnd) { result = TCL_CONVERT_NOSPACE; break; | > > > > > > | 3656 3657 3658 3659 3660 3661 3662 3663 3664 3665 3666 3667 3668 3669 3670 3671 3672 3673 3674 3675 | } srcStart = src; srcEnd = src + srcLen; dstStart = dst; dstEnd = dst + dstLen - TCL_UTF_MAX; /* * Note with respect to profiles: all byte values are mapped * to Unicode characters on input so there is no question of invalid * 8859-1 characters. */ result = TCL_OK; for (numChars = 0; src < srcEnd && numChars <= charLimit; numChars++) { Tcl_UniChar ch = 0; if (dst > dstEnd) { result = TCL_CONVERT_NOSPACE; break; |
︙ | ︙ | |||
3669 3670 3671 3672 3673 3674 3675 | */ if (ch > 0xFF) { if (PROFILE_STRICT(flags)) { result = TCL_CONVERT_UNKNOWN; break; } | < > | < | | > | 3767 3768 3769 3770 3771 3772 3773 3774 3775 3776 3777 3778 3779 3780 3781 3782 3783 3784 3785 | */ if (ch > 0xFF) { if (PROFILE_STRICT(flags)) { result = TCL_CONVERT_UNKNOWN; break; } if (PROFILE_LOSSLESS(flags) && IsLosslessWrapper(ch)) { ch = FromLossless(ch); } else { ch = (Tcl_UniChar)'?'; } } if (dst > dstEnd) { result = TCL_CONVERT_NOSPACE; break; } *(dst++) = (char) ch; |
︙ | ︙ | |||
3887 3888 3889 3890 3891 3892 3893 | * We have a split-up or unrecognized escape sequence. If we * checked all the sequences, then it's a syntax error, otherwise * we need more bytes to determine a match. */ if ((checked == dataPtr->numSubTables + 2) || (flags & TCL_ENCODING_END)) { | | > > < | 3985 3986 3987 3988 3989 3990 3991 3992 3993 3994 3995 3996 3997 3998 3999 4000 4001 4002 4003 4004 4005 4006 4007 | * We have a split-up or unrecognized escape sequence. If we * checked all the sequences, then it's a syntax error, otherwise * we need more bytes to determine a match. */ if ((checked == dataPtr->numSubTables + 2) || (flags & TCL_ENCODING_END)) { if (PROFILE_STRICT(flags)) { result = TCL_CONVERT_SYNTAX; } else { unsigned skip = longest > left ? left : longest; /* Unknown escape sequence */ dst += Tcl_UniCharToUtf(UNICODE_REPLACE_CHAR, dst); src += skip; continue; } } else { result = TCL_CONVERT_MULTIBYTE; } break; } if (encodingPtr == NULL) { |
︙ | ︙ | |||
4066 4067 4068 4069 4070 4071 4072 | if (word == 0) { state = oldState; if (PROFILE_STRICT(flags)) { result = TCL_CONVERT_UNKNOWN; break; } encodingPtr = GetTableEncoding(dataPtr, state); | > | | 4165 4166 4167 4168 4169 4170 4171 4172 4173 4174 4175 4176 4177 4178 4179 4180 | if (word == 0) { state = oldState; if (PROFILE_STRICT(flags)) { result = TCL_CONVERT_UNKNOWN; break; } encodingPtr = GetTableEncoding(dataPtr, state); tableDataPtr = (const TableEncodingData *)encodingPtr->clientData; word = tableDataPtr->fallback; } tablePrefixBytes = (const char *) tableDataPtr->prefixBytes; tableFromUnicode = (const unsigned short *const *) tableDataPtr->fromUnicode; |
︙ | ︙ | |||
4323 4324 4325 4326 4327 4328 4329 | Tcl_Size i, numDirs, numBytes; Tcl_Obj *libPathObj, *encodingObj, *searchPathObj; TclNewLiteralStringObj(encodingObj, "encoding"); TclNewObj(searchPathObj); Tcl_IncrRefCount(encodingObj); Tcl_IncrRefCount(searchPathObj); | | | 4423 4424 4425 4426 4427 4428 4429 4430 4431 4432 4433 4434 4435 4436 4437 | Tcl_Size i, numDirs, numBytes; Tcl_Obj *libPathObj, *encodingObj, *searchPathObj; TclNewLiteralStringObj(encodingObj, "encoding"); TclNewObj(searchPathObj); Tcl_IncrRefCount(encodingObj); Tcl_IncrRefCount(searchPathObj); libPathObj = TclGetProcessGlobalValue(&libraryPath); Tcl_IncrRefCount(libPathObj); TclListObjLengthM(NULL, libPathObj, &numDirs); for (i = 0; i < numDirs; i++) { Tcl_Obj *directoryObj, *pathObj; Tcl_StatBuf stat; |
︙ | ︙ | |||
4471 4472 4473 4474 4475 4476 4477 4478 4479 4480 4481 4482 4483 4484 4485 | objPtr = Tcl_NewListObj(n, NULL); for (i = 0; i < n; ++i) { Tcl_ListObjAppendElement( interp, objPtr, Tcl_NewStringObj(encodingProfiles[i].name, TCL_INDEX_NONE)); } Tcl_SetObjResult(interp, objPtr); } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | objPtr = Tcl_NewListObj(n, NULL); for (i = 0; i < n; ++i) { Tcl_ListObjAppendElement( interp, objPtr, Tcl_NewStringObj(encodingProfiles[i].name, TCL_INDEX_NONE)); } Tcl_SetObjResult(interp, objPtr); } /* *------------------------------------------------------------------------ * * TclSystemToInternalEncoding -- * * Converts a string encoded in the system encoding to Tcl's internal UTF8 * using the lossless profile. * * Results: * Tcl_OK / TCL_ERROR * * Side effects: * On success *dsPtr holds the converted string. On error, *dsPtr is * cleared, an error message is stored in interp (if not NULL), and a * POSIX error code stored in errno. * *------------------------------------------------------------------------ */ int TclSystemToInternalEncoding( Tcl_Interp *interp, /* For error messages, may be NULL */ const char *src, /* String in system encoding */ Tcl_Size srcLen, /* Number of bytes passed in */ Tcl_DString *dsPtr) /* Pointer to uninitialized or cleared Tcl_DString. */ { Tcl_Size errorLoc; int ret; ret = Tcl_ExternalToUtfDStringEx(interp, NULL, src, srcLen, TCL_ENCODING_PROFILE_LOSSLESS, dsPtr, &errorLoc); /* On TCL_OK, caller owns *dsPtr. On failure we have to free it. */ if (ret != TCL_OK) { Tcl_DStringFree(dsPtr); ret = TCL_ERROR; /* Map TCL_CONVERT_* to TCL_ERROR */ } return ret; } /* *------------------------------------------------------------------------ * * TclInternalToSystemEncoding -- * * Converts a string to the system encoding using the lossless profile * * Results: * Tcl_OK / TCL_ERROR * * Side effects: * On success *dsPtr holds the converted string. On error, *dsPtr is * cleared, an error message is stored in interp (if not NULL), and a * POSIX error code stored in errno. * *------------------------------------------------------------------------ */ int TclInternalToSystemEncoding( Tcl_Interp *interp, /* For error messages, may be NULL */ const char *src, /* String in system encoding */ Tcl_Size srcLen, /* Number of bytes passed in */ Tcl_DString *dsPtr) /* Pointer to uninitialized or cleared Tcl_DString. */ { Tcl_Size errorLoc; int ret; ret = Tcl_UtfToExternalDStringEx(interp, NULL, src, srcLen, TCL_ENCODING_PROFILE_LOSSLESS, dsPtr, &errorLoc); /* On TCL_OK, caller owns *dsPtr. On failure we have to free it. */ if (ret != TCL_OK) { Tcl_DStringFree(dsPtr); ret = TCL_ERROR; /* Map TCL_CONVERT_* to TCL_ERROR */ } return ret; } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
Changes to generic/tclEnv.c.
︙ | ︙ | |||
15 16 17 18 19 20 21 | #include "tclInt.h" TCL_DECLARE_MUTEX(envMutex) /* To serialize access to environ. */ #if defined(_WIN32) # define tenviron _wenviron | > | | > > | | > | > | > > > | | > > > > > | 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 | #include "tclInt.h" TCL_DECLARE_MUTEX(envMutex) /* To serialize access to environ. */ #if defined(_WIN32) # define tenviron _wenviron static inline char *tenviron2utfdstr(const WCHAR *str, Tcl_DString *dsPtr) { Tcl_DStringInit(dsPtr); return Tcl_Char16ToUtfDString(str, -1, dsPtr); } static inline WCHAR *utf2tenvirondstr(const char *str, Tcl_DString *dsPtr) { Tcl_DStringInit(dsPtr); return Tcl_UtfToChar16DString(str, -1, dsPtr); } # define techar WCHAR # ifdef USE_PUTENV # define putenv(env) _wputenv((const wchar_t *)env) # endif #else # define tenviron environ static inline char *tenviron2utfdstr(const char *str, Tcl_DString *dsPtr) { if (TclSystemToInternalEncoding(NULL,str,-1,dsPtr) == TCL_OK) { return Tcl_DStringValue(dsPtr); } return NULL; } static inline char *utf2tenvirondstr(const char *str, Tcl_DString *dsPtr) { Tcl_DStringInit(dsPtr); if (TclInternalToSystemEncoding(NULL,str,-1,dsPtr) == TCL_OK) { return Tcl_DStringValue(dsPtr); } return NULL; } # define techar char #endif /* MODULE_SCOPE */ size_t TclEnvEpoch = 0; /* Epoch of the tcl environment * (if changed with tcl-env). */ |
︙ | ︙ |
Changes to generic/tclExecute.c.
︙ | ︙ | |||
3921 3922 3923 3924 3925 3926 3927 3928 3929 3930 3931 3932 3933 3934 | TRACE_ERROR(interp); goto gotError; } break; /* * End of INST_UNSET instructions. * ----------------------------------------------------------------- * Start of INST_ARRAY instructions. */ case INST_ARRAY_EXISTS_IMM: opnd = TclGetUInt4AtPtr(pc+1); pcAdjustment = 5; | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 3921 3922 3923 3924 3925 3926 3927 3928 3929 3930 3931 3932 3933 3934 3935 3936 3937 3938 3939 3940 3941 3942 3943 3944 3945 3946 3947 3948 3949 3950 3951 3952 3953 3954 3955 3956 3957 3958 3959 3960 3961 3962 3963 3964 3965 3966 3967 3968 3969 3970 3971 3972 3973 3974 3975 3976 3977 3978 3979 3980 3981 3982 3983 3984 3985 3986 3987 3988 3989 3990 3991 3992 3993 3994 3995 3996 3997 3998 3999 4000 4001 4002 4003 4004 4005 | TRACE_ERROR(interp); goto gotError; } break; /* * End of INST_UNSET instructions. * ----------------------------------------------------------------- * Start of INST_CONST instructions. */ { const char *msgPart; case INST_CONST_IMM: opnd = TclGetUInt4AtPtr(pc+1); pcAdjustment = 5; cleanup = 1; part1Ptr = NULL; objPtr = OBJ_AT_TOS; TRACE(("%u \"%.30s\" => \n", opnd, O2S(objPtr))); varPtr = LOCAL(opnd); arrayPtr = NULL; while (TclIsVarLink(varPtr)) { varPtr = varPtr->value.linkPtr; } goto doConst; case INST_CONST_STK: opnd = -1; pcAdjustment = 1; cleanup = 2; part1Ptr = OBJ_UNDER_TOS; objPtr = OBJ_AT_TOS; TRACE(("\"%.30s\" \"%.30s\" => ", O2S(part1Ptr), O2S(objPtr))); varPtr = TclObjLookupVarEx(interp, part1Ptr, NULL, 0, NULL, /*createPart1*/1, /*createPart2*/0, &arrayPtr); doConst: if (TclIsVarConstant(varPtr)) { TRACE_APPEND(("\n")); NEXT_INST_V(pcAdjustment, cleanup, 0); } if (TclIsVarArray(varPtr)) { msgPart = "variable is array"; goto constError; } else if (TclIsVarArrayElement(varPtr)) { msgPart = "name refers to an element in an array"; goto constError; } else if (!TclIsVarUndefined(varPtr)) { msgPart = "variable already exists"; goto constError; } if (TclIsVarDirectModifyable(varPtr)) { varPtr->value.objPtr = objPtr; Tcl_IncrRefCount(objPtr); } else { Tcl_Obj *resPtr; DECACHE_STACK_INFO(); resPtr = TclPtrSetVarIdx(interp, varPtr, arrayPtr, part1Ptr, NULL, objPtr, TCL_LEAVE_ERR_MSG, opnd); CACHE_STACK_INFO(); if (resPtr == NULL) { TRACE_ERROR(interp); goto gotError; } } TclSetVarConstant(varPtr); TRACE_APPEND(("\n")); NEXT_INST_V(pcAdjustment, cleanup, 0); constError: TclObjVarErrMsg(interp, part1Ptr, NULL, "make constant", msgPart, opnd); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CONST", (void *)NULL); TRACE_ERROR(interp); goto gotError; } /* * End of INST_CONST instructions. * ----------------------------------------------------------------- * Start of INST_ARRAY instructions. */ case INST_ARRAY_EXISTS_IMM: opnd = TclGetUInt4AtPtr(pc+1); pcAdjustment = 5; |
︙ | ︙ | |||
9543 9544 9545 9546 9547 9548 9549 | ByteCodeStats *statsPtr = &iPtr->stats; double totalCodeBytes, currentCodeBytes; double totalLiteralBytes, currentLiteralBytes; double objBytesIfUnshared, strBytesIfUnshared, sharingBytesSaved; double strBytesSharedMultX, strBytesSharedOnce; double numInstructions, currentHeaderBytes; size_t numCurrentByteCodes, numByteCodeLits; | | | | 9614 9615 9616 9617 9618 9619 9620 9621 9622 9623 9624 9625 9626 9627 9628 9629 9630 | ByteCodeStats *statsPtr = &iPtr->stats; double totalCodeBytes, currentCodeBytes; double totalLiteralBytes, currentLiteralBytes; double objBytesIfUnshared, strBytesIfUnshared, sharingBytesSaved; double strBytesSharedMultX, strBytesSharedOnce; double numInstructions, currentHeaderBytes; size_t numCurrentByteCodes, numByteCodeLits; size_t refCountSum, literalMgmtBytes, sum, decadeHigh; size_t numSharedMultX, numSharedOnce, minSizeDecade, maxSizeDecade; Tcl_Size i, length; size_t ui; char *litTableStats; LiteralEntry *entryPtr; Tcl_Obj *objPtr; #define Percent(a,b) ((a) * 100.0 / (b)) |
︙ | ︙ |
Changes to generic/tclGetDate.y.
︙ | ︙ | |||
637 638 639 640 641 642 643 | { "bt", tZONE, -HOUR( 3) }, /* Baghdad, USSR Zone 2 */ { "it", tZONE, -HOUR( 7/2) }, /* Iran */ { "zp4", tZONE, -HOUR( 4) }, /* USSR Zone 3 */ { "zp5", tZONE, -HOUR( 5) }, /* USSR Zone 4 */ { "ist", tZONE, -HOUR(11/2) }, /* Indian Standard */ { "zp6", tZONE, -HOUR( 6) }, /* USSR Zone 5 */ #if 0 | | | 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 | { "bt", tZONE, -HOUR( 3) }, /* Baghdad, USSR Zone 2 */ { "it", tZONE, -HOUR( 7/2) }, /* Iran */ { "zp4", tZONE, -HOUR( 4) }, /* USSR Zone 3 */ { "zp5", tZONE, -HOUR( 5) }, /* USSR Zone 4 */ { "ist", tZONE, -HOUR(11/2) }, /* Indian Standard */ { "zp6", tZONE, -HOUR( 6) }, /* USSR Zone 5 */ #if 0 /* For completeness. NST is also Newfoundland Standard, and SST is * also Swedish Summer. */ { "nst", tZONE, -HOUR(13/2) }, /* North Sumatra */ { "sst", tZONE, -HOUR( 7) }, /* South Sumatra, USSR Zone 6 */ #endif /* 0 */ { "wast", tZONE, -HOUR( 7) }, /* West Australian Standard */ { "wadt", tDAYZONE, -HOUR( 7) }, /* West Australian Daylight */ { "jt", tZONE, -HOUR(15/2) }, /* Java (3pm in Cronusland!) */ |
︙ | ︙ | |||
1094 1095 1096 1097 1098 1099 1100 | Tcl_ListObjAppendElement(interp, resultElement, Tcl_NewIntObj(yyRelDay)); Tcl_ListObjAppendElement(interp, resultElement, Tcl_NewIntObj(yyRelSeconds)); } Tcl_ListObjAppendElement(interp, result, resultElement); | | | 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 | Tcl_ListObjAppendElement(interp, resultElement, Tcl_NewIntObj(yyRelDay)); Tcl_ListObjAppendElement(interp, resultElement, Tcl_NewIntObj(yyRelSeconds)); } Tcl_ListObjAppendElement(interp, result, resultElement); TclNewObj(resultElement); if (yyHaveDay && !yyHaveDate) { Tcl_ListObjAppendElement(interp, resultElement, Tcl_NewIntObj(yyDayOrdinal)); Tcl_ListObjAppendElement(interp, resultElement, Tcl_NewIntObj(yyDayNumber)); } Tcl_ListObjAppendElement(interp, result, resultElement); |
︙ | ︙ |
Changes to generic/tclIO.c.
︙ | ︙ | |||
4688 4689 4690 4691 4692 4693 4694 4695 4696 4697 4698 4699 4700 4701 | skip = 0; eof = NULL; inEofChar = statePtr->inEofChar; ResetFlag(statePtr, CHANNEL_BLOCKED); while (1) { if (dst >= dstEnd) { if (FilterInputBytes(chanPtr, &gs) != 0) { goto restore; } dstEnd = dst + gs.bytesWrote; } /* | > > > > > > | 4688 4689 4690 4691 4692 4693 4694 4695 4696 4697 4698 4699 4700 4701 4702 4703 4704 4705 4706 4707 | skip = 0; eof = NULL; inEofChar = statePtr->inEofChar; ResetFlag(statePtr, CHANNEL_BLOCKED); while (1) { if (dst >= dstEnd) { /* * In case of encoding errors, state gets flag * CHANNEL_ENCODING_ERROR set in the call below. First, the * EOF/EOL condition is checked, as we may have valid data with * EOF/EOL before the encoding error. */ if (FilterInputBytes(chanPtr, &gs) != 0) { goto restore; } dstEnd = dst + gs.bytesWrote; } /* |
︙ | ︙ | |||
4857 4858 4859 4860 4861 4862 4863 | CommonGetsCleanup(chanPtr); copiedTotal = -1; ResetFlag(statePtr, CHANNEL_BLOCKED|INPUT_SAW_CR); goto done; } goto gotEOL; } else if (gs.bytesWrote == 0 | | > > > > | > > > > > | 4863 4864 4865 4866 4867 4868 4869 4870 4871 4872 4873 4874 4875 4876 4877 4878 4879 4880 4881 4882 4883 4884 4885 4886 4887 | CommonGetsCleanup(chanPtr); copiedTotal = -1; ResetFlag(statePtr, CHANNEL_BLOCKED|INPUT_SAW_CR); goto done; } goto gotEOL; } else if (gs.bytesWrote == 0 && GotFlag(statePtr, CHANNEL_ENCODING_ERROR)) { /* Ticket c4eb46a1 Harald Oehlmann 2023-11-12 debugging session. * In non blocking mode we loop indifenitly on a decoding error in * this while-loop. * Removed the following from the upper condition: * "&& !GotFlag(statePtr, CHANNEL_NONBLOCKING)" * In case of an encoding error with leading correct bytes, we pass here * two times, as gs.bytesWrote is not 0 on the first pass. This feels * once to much, as the data is anyway not used. */ /* Set eol to the position that caused the encoding error, and then * continue to gotEOL, which stores the data that was decoded * without error to objPtr. This allows the caller to do something * useful with the data decoded so far, and also results in the * position of the file being the first byte that was not * successfully decoded, allowing further processing at exactly that * point, if desired. |
︙ | ︙ | |||
6240 6241 6242 6243 6244 6245 6246 | * how many characters were produced by the previous pass. */ int factor = *factorPtr; int dstLimit = TCL_UTF_MAX - 1 + toRead * factor / UTF_EXPANSION_FACTOR; (void) Tcl_GetStringFromObj(objPtr, &numBytes); | | | 6255 6256 6257 6258 6259 6260 6261 6262 6263 6264 6265 6266 6267 6268 6269 | * how many characters were produced by the previous pass. */ int factor = *factorPtr; int dstLimit = TCL_UTF_MAX - 1 + toRead * factor / UTF_EXPANSION_FACTOR; (void) Tcl_GetStringFromObj(objPtr, &numBytes); Tcl_SetObjLength(objPtr, numBytes + dstLimit); if (toRead == srcLen) { Tcl_Size size; dst = TclGetStringStorage(objPtr, &size) + numBytes; dstLimit = (size - numBytes) > INT_MAX ? INT_MAX : (size - numBytes); } else { dst = TclGetString(objPtr) + numBytes; |
︙ | ︙ | |||
7527 7528 7529 7530 7531 7532 7533 7534 7535 7536 7537 7538 7539 7540 | if (GotFlag(statePtr, CHANNEL_ENCODING_ERROR)) { return 0; } return GotFlag(statePtr, CHANNEL_EOF) ? 1 : 0; } /* *---------------------------------------------------------------------- * * Tcl_InputBlocked -- * * Returns 1 if input is blocked on this channel, 0 otherwise. * | > > > > > > > > > > > > > > > > > > > > > > > > > > > | 7542 7543 7544 7545 7546 7547 7548 7549 7550 7551 7552 7553 7554 7555 7556 7557 7558 7559 7560 7561 7562 7563 7564 7565 7566 7567 7568 7569 7570 7571 7572 7573 7574 7575 7576 7577 7578 7579 7580 7581 7582 | if (GotFlag(statePtr, CHANNEL_ENCODING_ERROR)) { return 0; } return GotFlag(statePtr, CHANNEL_EOF) ? 1 : 0; } /* *---------------------------------------------------------------------- * * TclChannelGetBlockingMode -- * * Returns 1 if the channel is in blocking mode (default), 0 otherwise. * * Results: * 1 or 0, always. * * Side effects: * None. * *---------------------------------------------------------------------- */ int TclChannelGetBlockingMode( Tcl_Channel chan) { ChannelState *statePtr = ((Channel *) chan)->state; /* State of real channel structure. */ return GotFlag(statePtr, CHANNEL_NONBLOCKING) ? 0 : 1; } /* *---------------------------------------------------------------------- * * Tcl_InputBlocked -- * * Returns 1 if input is blocked on this channel, 0 otherwise. * |
︙ | ︙ | |||
9641 9642 9643 9644 9645 9646 9647 9648 9649 9650 9651 9652 9653 9654 | { Tcl_Interp *interp; Tcl_Obj *cmdPtr, *errObj = NULL, *bufObj = NULL, *msg = NULL; Tcl_Channel inChan, outChan; ChannelState *inStatePtr, *outStatePtr; int result = TCL_OK; Tcl_Size sizeb; Tcl_WideInt total; Tcl_WideInt size; const char *buffer; int moveBytes; int underflow; /* Input underflow */ inChan = (Tcl_Channel) csPtr->readPtr; | > | 9683 9684 9685 9686 9687 9688 9689 9690 9691 9692 9693 9694 9695 9696 9697 | { Tcl_Interp *interp; Tcl_Obj *cmdPtr, *errObj = NULL, *bufObj = NULL, *msg = NULL; Tcl_Channel inChan, outChan; ChannelState *inStatePtr, *outStatePtr; int result = TCL_OK; Tcl_Size sizeb; Tcl_Size sizePart; Tcl_WideInt total; Tcl_WideInt size; const char *buffer; int moveBytes; int underflow; /* Input underflow */ inChan = (Tcl_Channel) csPtr->readPtr; |
︙ | ︙ | |||
9722 9723 9724 9725 9726 9727 9728 9729 9730 9731 9732 9733 9734 9735 | if (moveBytes) { size = DoRead(inStatePtr->topChanPtr, csPtr->buffer, sizeb, !GotFlag(inStatePtr, CHANNEL_NONBLOCKING)); } else { size = DoReadChars(inStatePtr->topChanPtr, bufObj, sizeb, !GotFlag(inStatePtr, CHANNEL_NONBLOCKING) ,0 /* No append */); } underflow = (size >= 0) && (size < sizeb); /* Input underflow */ } if (size < 0) { readError: if (interp) { | > > > > > > > > > > > > > > > > > | 9765 9766 9767 9768 9769 9770 9771 9772 9773 9774 9775 9776 9777 9778 9779 9780 9781 9782 9783 9784 9785 9786 9787 9788 9789 9790 9791 9792 9793 9794 9795 | if (moveBytes) { size = DoRead(inStatePtr->topChanPtr, csPtr->buffer, sizeb, !GotFlag(inStatePtr, CHANNEL_NONBLOCKING)); } else { size = DoReadChars(inStatePtr->topChanPtr, bufObj, sizeb, !GotFlag(inStatePtr, CHANNEL_NONBLOCKING) ,0 /* No append */); /* * In case of a recoverable encoding error, any data before * the error should be written. This data is in the bufObj. * Program flow for this case: * - Check, if there are any remaining bytes to write * - If yes, simulate a successful read to write them out * - Come back here by the outer loop and read again * - Do not enter in the if below, as there are no pending * writes * - Fail below with a read error */ if (size < 0 && Tcl_GetErrno() == EILSEQ) { Tcl_GetStringFromObj(bufObj, &sizePart); if (sizePart > 0) { size = sizePart; } } } underflow = (size >= 0) && (size < sizeb); /* Input underflow */ } if (size < 0) { readError: if (interp) { |
︙ | ︙ |
Changes to generic/tclIOCmd.c.
︙ | ︙ | |||
429 430 431 432 433 434 435 | } } TclNewObj(resultPtr); TclChannelPreserve(chan); charactersRead = Tcl_ReadChars(chan, resultPtr, toRead, 0); if (charactersRead == TCL_IO_FAILURE) { | > > > > > > | > > > > | 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 | } } TclNewObj(resultPtr); TclChannelPreserve(chan); charactersRead = Tcl_ReadChars(chan, resultPtr, toRead, 0); if (charactersRead == TCL_IO_FAILURE) { Tcl_Obj *returnOptsPtr = NULL; if (TclChannelGetBlockingMode(chan)) { returnOptsPtr = Tcl_NewDictObj(); Tcl_DictObjPut(NULL, returnOptsPtr, Tcl_NewStringObj("-data", -1), resultPtr); } else { Tcl_DecrRefCount(resultPtr); } /* * TIP #219. * Capture error messages put by the driver into the bypass area and * put them into the regular interpreter result. Fall back to the * regular message if nothing was found in the bypass. */ if (!TclChanCaughtErrorBypass(interp, chan)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "error reading \"%s\": %s", TclGetString(chanObjPtr), Tcl_PosixError(interp))); } TclChannelRelease(chan); if (returnOptsPtr) { Tcl_SetReturnOptions(interp, returnOptsPtr); } return TCL_ERROR; } /* * If requested, remove the last newline in the channel if at EOF. */ |
︙ | ︙ | |||
506 507 508 509 510 511 512 | if ((objc != 3) && (objc != 4)) { Tcl_WrongNumArgs(interp, 1, objv, "channelId offset ?origin?"); return TCL_ERROR; } if (TclGetChannelFromObj(interp, objv[1], &chan, NULL, 0) != TCL_OK) { return TCL_ERROR; } | | | 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 | if ((objc != 3) && (objc != 4)) { Tcl_WrongNumArgs(interp, 1, objv, "channelId offset ?origin?"); return TCL_ERROR; } if (TclGetChannelFromObj(interp, objv[1], &chan, NULL, 0) != TCL_OK) { return TCL_ERROR; } if (TclGetWideIntFromObj(interp, objv[2], &offset) != TCL_OK) { return TCL_ERROR; } mode = SEEK_SET; if (objc == 4) { if (Tcl_GetIndexFromObj(interp, objv[3], originOptions, "origin", 0, &optionIndex) != TCL_OK) { return TCL_ERROR; |
︙ | ︙ | |||
931 932 933 934 935 936 937 938 939 940 941 942 943 944 | */ TclStackFree(interp, (void *) argv); if (chan == NULL) { return TCL_ERROR; } if (background) { /* * Store the list of PIDs from the pipeline in interp's result and * detach the PIDs (instead of waiting for them). */ | > > > > > | 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 | */ TclStackFree(interp, (void *) argv); if (chan == NULL) { return TCL_ERROR; } /* Bug [0f1ddc0df7] - encoding errors - use replace profile */ if (Tcl_SetChannelOption(NULL, chan, "-profile", "replace") != TCL_OK) { return TCL_ERROR; } if (background) { /* * Store the list of PIDs from the pipeline in interp's result and * detach the PIDs (instead of waiting for them). */ |
︙ | ︙ | |||
1734 1735 1736 1737 1738 1739 1740 | for (i = 3; i < objc; i += 2) { if (Tcl_GetIndexFromObj(interp, objv[i], switches, "option", 0, &index) != TCL_OK) { return TCL_ERROR; } switch (index) { case FcopySize: | | | 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 | for (i = 3; i < objc; i += 2) { if (Tcl_GetIndexFromObj(interp, objv[i], switches, "option", 0, &index) != TCL_OK) { return TCL_ERROR; } switch (index) { case FcopySize: if (TclGetWideIntFromObj(interp, objv[i+1], &toRead) != TCL_OK) { return TCL_ERROR; } if (toRead < 0) { /* * Handle all negative sizes like -1, meaning 'copy all'. By * resetting toRead we avoid changes in the core copying * functions (which explicitly check for -1 and crash on any |
︙ | ︙ | |||
1861 1862 1863 1864 1865 1866 1867 | } if (objc == 3) { /* * User is supplying an explicit length. */ | | | 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 | } if (objc == 3) { /* * User is supplying an explicit length. */ if (TclGetWideIntFromObj(interp, objv[2], &length) != TCL_OK) { return TCL_ERROR; } if (length < 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "cannot truncate to negative length of file", -1)); return TCL_ERROR; } |
︙ | ︙ |
Changes to generic/tclIORChan.c.
︙ | ︙ | |||
1613 1614 1615 1616 1617 1618 1619 | Tcl_IncrRefCount(baseObj); if (InvokeTclMethod(rcPtr, METH_SEEK, offObj, baseObj, &resObj)!=TCL_OK) { Tcl_SetChannelError(rcPtr->chan, resObj); goto invalid; } | | | 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 | Tcl_IncrRefCount(baseObj); if (InvokeTclMethod(rcPtr, METH_SEEK, offObj, baseObj, &resObj)!=TCL_OK) { Tcl_SetChannelError(rcPtr->chan, resObj); goto invalid; } if (TclGetWideIntFromObj(rcPtr->interp, resObj, &newLoc) != TCL_OK) { Tcl_SetChannelError(rcPtr->chan, MarshallError(rcPtr->interp)); goto invalid; } if (newLoc < 0) { SetChannelErrorStr(rcPtr->chan, msg_seek_beforestart); goto invalid; |
︙ | ︙ | |||
2010 2011 2012 2013 2014 2015 2016 | /* * Odd number of elements is wrong. */ Tcl_ResetResult(interp); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "Expected list with even number of " | | | 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 | /* * Odd number of elements is wrong. */ Tcl_ResetResult(interp); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "Expected list with even number of " "elements, got %" TCL_SIZE_MODIFIER "d element%s instead", listc, (listc == 1 ? "" : "s"))); goto error; } else { Tcl_Size len; const char *str = Tcl_GetStringFromObj(resObj, &len); if (len) { |
︙ | ︙ | |||
3208 3209 3210 3211 3212 3213 3214 | /* * Process a regular result. If the type is wrong this may change * into an error. */ Tcl_WideInt newLoc; | | | 3208 3209 3210 3211 3212 3213 3214 3215 3216 3217 3218 3219 3220 3221 3222 | /* * Process a regular result. If the type is wrong this may change * into an error. */ Tcl_WideInt newLoc; if (TclGetWideIntFromObj(interp, resObj, &newLoc) == TCL_OK) { if (newLoc < 0) { ForwardSetStaticError(paramPtr, msg_seek_beforestart); paramPtr->seek.offset = -1; } else { paramPtr->seek.offset = newLoc; } } else { |
︙ | ︙ | |||
3319 3320 3321 3322 3323 3324 3325 | } else if ((listc % 2) == 1) { /* * Odd number of elements is wrong. [x]. */ char *buf = (char *)Tcl_Alloc(200); snprintf(buf, 200, | | | 3319 3320 3321 3322 3323 3324 3325 3326 3327 3328 3329 3330 3331 3332 3333 | } else if ((listc % 2) == 1) { /* * Odd number of elements is wrong. [x]. */ char *buf = (char *)Tcl_Alloc(200); snprintf(buf, 200, "{Expected list with even number of elements, got %" TCL_SIZE_MODIFIER "d %s instead}", listc, (listc == 1 ? "element" : "elements")); ForwardSetDynamicError(paramPtr, buf); } else { Tcl_Size len; const char *str = Tcl_GetStringFromObj(resObj, &len); |
︙ | ︙ |
Changes to generic/tclInt.decls.
︙ | ︙ | |||
377 378 379 380 381 382 383 | declare 150 { int TclRegAbout(Tcl_Interp *interp, Tcl_RegExp re) } declare 151 { void TclRegExpRangeUniChar(Tcl_RegExp re, Tcl_Size index, Tcl_Size *startPtr, Tcl_Size *endPtr) } | < < < < < < | 377 378 379 380 381 382 383 384 385 386 387 388 389 390 | declare 150 { int TclRegAbout(Tcl_Interp *interp, Tcl_RegExp re) } declare 151 { void TclRegExpRangeUniChar(Tcl_RegExp re, Tcl_Size index, Tcl_Size *startPtr, Tcl_Size *endPtr) } declare 156 { void TclRegError(Tcl_Interp *interp, const char *msg, int status) } declare 157 { Var *TclVarTraceExists(Tcl_Interp *interp, const char *varName) } |
︙ | ︙ | |||
443 444 445 446 447 448 449 | # void TclSetStartupScriptPath(Tcl_Obj *pathPtr) #} #declare 168 { # Tcl_Obj *TclGetStartupScriptPath(void) #} # variant of Tcl_UtfNCmp that takes n as bytes, not chars declare 169 { | | | 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 | # void TclSetStartupScriptPath(Tcl_Obj *pathPtr) #} #declare 168 { # Tcl_Obj *TclGetStartupScriptPath(void) #} # variant of Tcl_UtfNCmp that takes n as bytes, not chars declare 169 { int TclpUtfNcmp2(const void *s1, const void *s2, size_t n) } declare 170 { int TclCheckInterpTraces(Tcl_Interp *interp, const char *command, Tcl_Size numChars, Command *cmdPtr, int result, int traceFlags, Tcl_Size objc, Tcl_Obj *const objv[]) } declare 171 { |
︙ | ︙ | |||
755 756 757 758 759 760 761 | declare 6 { TclFile TclpMakeFile(Tcl_Channel channel, int direction) } declare 7 { TclFile TclpOpenFile(const char *fname, int mode) } declare 8 { | | | | 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 | declare 6 { TclFile TclpMakeFile(Tcl_Channel channel, int direction) } declare 7 { TclFile TclpOpenFile(const char *fname, int mode) } declare 8 { Tcl_Size TclpGetPid(Tcl_Pid pid) } declare 9 { TclFile TclpCreateTempFile(const char *contents) } declare 11 { void TclGetAndDetachPids(Tcl_Interp *interp, Tcl_Channel chan) } declare 15 { int TclpCreateProcess(Tcl_Interp *interp, size_t argc, const char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr) } declare 16 { int TclpIsAtty(int fd) } declare 17 { int TclUnixCopyFile(const char *src, const char *dst, const Tcl_StatBuf *statBufPtr, int dontCopyAtts) } declare 20 { void TclWinAddProcess(void *hProcess, Tcl_Size id) } declare 24 { char *TclWinNoBackslash(char *path) } declare 27 { void TclWinFlushDirtyChannels(void) } |
︙ | ︙ |
Changes to generic/tclInt.h.
︙ | ︙ | |||
657 658 659 660 661 662 663 664 665 666 667 668 669 670 | * VAR_LINK - 1 means this Var structure contains a pointer * to another Var structure that either has the * real value or is itself another VAR_LINK * pointer. Variables like this come about * through "upvar" and "global" commands, or * through references to variables in enclosing * namespaces. * * Flags that indicate the type and status of storage; none is set for * compiled local variables (Var structs). * * VAR_IN_HASHTABLE - 1 means this variable is in a hash table and * the Var structure is malloc'ed. 0 if it is a * local variable that was assigned a slot in a | > > > > > | 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 | * VAR_LINK - 1 means this Var structure contains a pointer * to another Var structure that either has the * real value or is itself another VAR_LINK * pointer. Variables like this come about * through "upvar" and "global" commands, or * through references to variables in enclosing * namespaces. * VAR_CONSTANT - 1 means this is a constant "variable", and * cannot be written to by ordinary commands. * Structurally, it's the same as a scalar when * being read, but writes are rejected. Constants * are not supported inside arrays. * * Flags that indicate the type and status of storage; none is set for * compiled local variables (Var structs). * * VAR_IN_HASHTABLE - 1 means this variable is in a hash table and * the Var structure is malloc'ed. 0 if it is a * local variable that was assigned a slot in a |
︙ | ︙ | |||
721 722 723 724 725 726 727 728 729 730 731 732 733 734 | * Keep the flag values for VAR_ARGUMENT and VAR_TEMPORARY so that old values * in precompiled scripts keep working. */ /* Type of value (0 is scalar) */ #define VAR_ARRAY 0x1 #define VAR_LINK 0x2 /* Type of storage (0 is compiled local) */ #define VAR_IN_HASHTABLE 0x4 #define VAR_DEAD_HASH 0x8 #define VAR_ARRAY_ELEMENT 0x1000 #define VAR_NAMESPACE_VAR 0x80 /* KEEP OLD VALUE for Itcl */ | > | 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 | * Keep the flag values for VAR_ARGUMENT and VAR_TEMPORARY so that old values * in precompiled scripts keep working. */ /* Type of value (0 is scalar) */ #define VAR_ARRAY 0x1 #define VAR_LINK 0x2 #define VAR_CONSTANT 0x10000 /* Type of storage (0 is compiled local) */ #define VAR_IN_HASHTABLE 0x4 #define VAR_DEAD_HASH 0x8 #define VAR_ARRAY_ELEMENT 0x1000 #define VAR_NAMESPACE_VAR 0x80 /* KEEP OLD VALUE for Itcl */ |
︙ | ︙ | |||
755 756 757 758 759 760 761 762 763 764 765 766 767 | /* * Macros to ensure that various flag bits are set properly for variables. * The ANSI C "prototypes" for these macros are: * * MODULE_SCOPE void TclSetVarScalar(Var *varPtr); * MODULE_SCOPE void TclSetVarArray(Var *varPtr); * MODULE_SCOPE void TclSetVarLink(Var *varPtr); * MODULE_SCOPE void TclSetVarArrayElement(Var *varPtr); * MODULE_SCOPE void TclSetVarUndefined(Var *varPtr); * MODULE_SCOPE void TclClearVarUndefined(Var *varPtr); */ #define TclSetVarScalar(varPtr) \ | > | > > > | | 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 | /* * Macros to ensure that various flag bits are set properly for variables. * The ANSI C "prototypes" for these macros are: * * MODULE_SCOPE void TclSetVarScalar(Var *varPtr); * MODULE_SCOPE void TclSetVarArray(Var *varPtr); * MODULE_SCOPE void TclSetVarLink(Var *varPtr); * MODULE_SCOPE void TclSetVarConstant(Var *varPtr); * MODULE_SCOPE void TclSetVarArrayElement(Var *varPtr); * MODULE_SCOPE void TclSetVarUndefined(Var *varPtr); * MODULE_SCOPE void TclClearVarUndefined(Var *varPtr); */ #define TclSetVarScalar(varPtr) \ (varPtr)->flags &= ~(VAR_ARRAY|VAR_LINK|VAR_CONSTANT) #define TclSetVarArray(varPtr) \ (varPtr)->flags = ((varPtr)->flags & ~VAR_LINK) | VAR_ARRAY #define TclSetVarLink(varPtr) \ (varPtr)->flags = ((varPtr)->flags & ~VAR_ARRAY) | VAR_LINK #define TclSetVarConstant(varPtr) \ (varPtr)->flags = ((varPtr)->flags & ~(VAR_ARRAY|VAR_LINK)) | VAR_CONSTANT #define TclSetVarArrayElement(varPtr) \ (varPtr)->flags = ((varPtr)->flags & ~VAR_ARRAY) | VAR_ARRAY_ELEMENT #define TclSetVarUndefined(varPtr) \ (varPtr)->flags &= ~(VAR_ARRAY|VAR_LINK|VAR_CONSTANT);\ (varPtr)->value.objPtr = NULL #define TclClearVarUndefined(varPtr) #define TclSetVarTraceActive(varPtr) \ (varPtr)->flags |= VAR_TRACE_ACTIVE |
︙ | ︙ | |||
805 806 807 808 809 810 811 812 813 814 815 816 817 818 | } /* * Macros to read various flag bits of variables. * The ANSI C "prototypes" for these macros are: * * MODULE_SCOPE int TclIsVarScalar(Var *varPtr); * MODULE_SCOPE int TclIsVarLink(Var *varPtr); * MODULE_SCOPE int TclIsVarArray(Var *varPtr); * MODULE_SCOPE int TclIsVarUndefined(Var *varPtr); * MODULE_SCOPE int TclIsVarArrayElement(Var *varPtr); * MODULE_SCOPE int TclIsVarTemporary(Var *varPtr); * MODULE_SCOPE int TclIsVarArgument(Var *varPtr); * MODULE_SCOPE int TclIsVarResolved(Var *varPtr); | > | 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 | } /* * Macros to read various flag bits of variables. * The ANSI C "prototypes" for these macros are: * * MODULE_SCOPE int TclIsVarScalar(Var *varPtr); * MODULE_SCOPE int TclIsVarConstant(Var *varPtr); * MODULE_SCOPE int TclIsVarLink(Var *varPtr); * MODULE_SCOPE int TclIsVarArray(Var *varPtr); * MODULE_SCOPE int TclIsVarUndefined(Var *varPtr); * MODULE_SCOPE int TclIsVarArrayElement(Var *varPtr); * MODULE_SCOPE int TclIsVarTemporary(Var *varPtr); * MODULE_SCOPE int TclIsVarArgument(Var *varPtr); * MODULE_SCOPE int TclIsVarResolved(Var *varPtr); |
︙ | ︙ | |||
831 832 833 834 835 836 837 838 839 840 841 842 843 844 | #define TclIsVarLink(varPtr) \ ((varPtr)->flags & VAR_LINK) #define TclIsVarArray(varPtr) \ ((varPtr)->flags & VAR_ARRAY) #define TclIsVarUndefined(varPtr) \ ((varPtr)->value.objPtr == NULL) #define TclIsVarArrayElement(varPtr) \ ((varPtr)->flags & VAR_ARRAY_ELEMENT) #define TclIsVarNamespaceVar(varPtr) \ | > > > > | 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 | #define TclIsVarLink(varPtr) \ ((varPtr)->flags & VAR_LINK) #define TclIsVarArray(varPtr) \ ((varPtr)->flags & VAR_ARRAY) /* Implies scalar as well. */ #define TclIsVarConstant(varPtr) \ ((varPtr)->flags & VAR_CONSTANT) #define TclIsVarUndefined(varPtr) \ ((varPtr)->value.objPtr == NULL) #define TclIsVarArrayElement(varPtr) \ ((varPtr)->flags & VAR_ARRAY_ELEMENT) #define TclIsVarNamespaceVar(varPtr) \ |
︙ | ︙ | |||
890 891 892 893 894 895 896 | && (TclVarParentArray(varPtr)->flags & (trickyFlags)))) #define TclIsVarDirectReadable(varPtr) \ ( (!TclIsVarTricky(varPtr,VAR_TRACED_READ)) \ && (varPtr)->value.objPtr) #define TclIsVarDirectWritable(varPtr) \ | | | | | 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 | && (TclVarParentArray(varPtr)->flags & (trickyFlags)))) #define TclIsVarDirectReadable(varPtr) \ ( (!TclIsVarTricky(varPtr,VAR_TRACED_READ)) \ && (varPtr)->value.objPtr) #define TclIsVarDirectWritable(varPtr) \ (!TclIsVarTricky(varPtr,VAR_TRACED_WRITE|VAR_DEAD_HASH|VAR_CONSTANT)) #define TclIsVarDirectUnsettable(varPtr) \ (!TclIsVarTricky(varPtr,VAR_TRACED_READ|VAR_TRACED_WRITE|VAR_TRACED_UNSET|VAR_DEAD_HASH|VAR_CONSTANT)) #define TclIsVarDirectModifyable(varPtr) \ ( (!TclIsVarTricky(varPtr,VAR_TRACED_READ|VAR_TRACED_WRITE|VAR_CONSTANT)) \ && (varPtr)->value.objPtr) #define TclIsVarDirectReadable2(varPtr, arrayPtr) \ (TclIsVarDirectReadable(varPtr) &&\ (!(arrayPtr) || !((arrayPtr)->flags & VAR_TRACED_READ))) #define TclIsVarDirectWritable2(varPtr, arrayPtr) \ |
︙ | ︙ | |||
3040 3041 3042 3043 3044 3045 3046 3047 3048 3049 3050 3051 3052 3053 | MODULE_SCOPE int TclEncodingProfileNameToId(Tcl_Interp *interp, const char *profileName, int *profilePtr); MODULE_SCOPE const char *TclEncodingProfileIdToName(Tcl_Interp *interp, int profileId); MODULE_SCOPE void TclGetEncodingProfiles(Tcl_Interp *interp); /* * TIP #233 (Virtualized Time) * Data for the time hooks, if any. */ MODULE_SCOPE Tcl_GetTimeProc *tclGetTimeProcPtr; | > > > > | 3055 3056 3057 3058 3059 3060 3061 3062 3063 3064 3065 3066 3067 3068 3069 3070 3071 3072 | MODULE_SCOPE int TclEncodingProfileNameToId(Tcl_Interp *interp, const char *profileName, int *profilePtr); MODULE_SCOPE const char *TclEncodingProfileIdToName(Tcl_Interp *interp, int profileId); MODULE_SCOPE void TclGetEncodingProfiles(Tcl_Interp *interp); MODULE_SCOPE int TclInternalToSystemEncoding(Tcl_Interp *interp, const char *src, Tcl_Size srcLen, Tcl_DString *dsPtr); MODULE_SCOPE int TclSystemToInternalEncoding(Tcl_Interp *interp, const char *src, Tcl_Size srcLen, Tcl_DString *dsPtr); /* * TIP #233 (Virtualized Time) * Data for the time hooks, if any. */ MODULE_SCOPE Tcl_GetTimeProc *tclGetTimeProcPtr; |
︙ | ︙ | |||
3231 3232 3233 3234 3235 3236 3237 3238 3239 3240 3241 3242 3243 3244 | MODULE_SCOPE double TclBignumToDouble(const void *bignum); MODULE_SCOPE int TclByteArrayMatch(const unsigned char *string, Tcl_Size strLen, const unsigned char *pattern, Tcl_Size ptnLen, int flags); MODULE_SCOPE double TclCeil(const void *a); MODULE_SCOPE void TclChannelPreserve(Tcl_Channel chan); MODULE_SCOPE void TclChannelRelease(Tcl_Channel chan); MODULE_SCOPE int TclCheckArrayTraces(Tcl_Interp *interp, Var *varPtr, Var *arrayPtr, Tcl_Obj *name, int index); MODULE_SCOPE int TclCheckEmptyString(Tcl_Obj *objPtr); MODULE_SCOPE int TclChanCaughtErrorBypass(Tcl_Interp *interp, Tcl_Channel chan); MODULE_SCOPE Tcl_ObjCmdProc TclChannelNamesCmd; MODULE_SCOPE Tcl_NRPostProc TclClearRootEnsemble; | > | 3250 3251 3252 3253 3254 3255 3256 3257 3258 3259 3260 3261 3262 3263 3264 | MODULE_SCOPE double TclBignumToDouble(const void *bignum); MODULE_SCOPE int TclByteArrayMatch(const unsigned char *string, Tcl_Size strLen, const unsigned char *pattern, Tcl_Size ptnLen, int flags); MODULE_SCOPE double TclCeil(const void *a); MODULE_SCOPE void TclChannelPreserve(Tcl_Channel chan); MODULE_SCOPE void TclChannelRelease(Tcl_Channel chan); MODULE_SCOPE int TclChannelGetBlockingMode(Tcl_Channel chan); MODULE_SCOPE int TclCheckArrayTraces(Tcl_Interp *interp, Var *varPtr, Var *arrayPtr, Tcl_Obj *name, int index); MODULE_SCOPE int TclCheckEmptyString(Tcl_Obj *objPtr); MODULE_SCOPE int TclChanCaughtErrorBypass(Tcl_Interp *interp, Tcl_Channel chan); MODULE_SCOPE Tcl_ObjCmdProc TclChannelNamesCmd; MODULE_SCOPE Tcl_NRPostProc TclClearRootEnsemble; |
︙ | ︙ | |||
3356 3357 3358 3359 3360 3361 3362 3363 3364 3365 3366 3367 3368 3369 | Tcl_Obj *part2Ptr, Tcl_Obj *incrPtr, int flags); MODULE_SCOPE Tcl_ObjCmdProc TclInfoExistsCmd; MODULE_SCOPE Tcl_ObjCmdProc TclInfoCoroutineCmd; MODULE_SCOPE Tcl_Obj * TclInfoFrame(Tcl_Interp *interp, CmdFrame *framePtr); MODULE_SCOPE Tcl_ObjCmdProc TclInfoGlobalsCmd; MODULE_SCOPE Tcl_ObjCmdProc TclInfoLocalsCmd; MODULE_SCOPE Tcl_ObjCmdProc TclInfoVarsCmd; MODULE_SCOPE void TclInitAlloc(void); MODULE_SCOPE void TclInitDbCkalloc(void); MODULE_SCOPE void TclInitDoubleConversion(void); MODULE_SCOPE void TclInitEmbeddedConfigurationInformation( Tcl_Interp *interp); MODULE_SCOPE void TclInitEncodingSubsystem(void); MODULE_SCOPE void TclInitIOSubsystem(void); | > > | 3376 3377 3378 3379 3380 3381 3382 3383 3384 3385 3386 3387 3388 3389 3390 3391 | Tcl_Obj *part2Ptr, Tcl_Obj *incrPtr, int flags); MODULE_SCOPE Tcl_ObjCmdProc TclInfoExistsCmd; MODULE_SCOPE Tcl_ObjCmdProc TclInfoCoroutineCmd; MODULE_SCOPE Tcl_Obj * TclInfoFrame(Tcl_Interp *interp, CmdFrame *framePtr); MODULE_SCOPE Tcl_ObjCmdProc TclInfoGlobalsCmd; MODULE_SCOPE Tcl_ObjCmdProc TclInfoLocalsCmd; MODULE_SCOPE Tcl_ObjCmdProc TclInfoVarsCmd; MODULE_SCOPE Tcl_ObjCmdProc TclInfoConstsCmd; MODULE_SCOPE Tcl_ObjCmdProc TclInfoConstantCmd; MODULE_SCOPE void TclInitAlloc(void); MODULE_SCOPE void TclInitDbCkalloc(void); MODULE_SCOPE void TclInitDoubleConversion(void); MODULE_SCOPE void TclInitEmbeddedConfigurationInformation( Tcl_Interp *interp); MODULE_SCOPE void TclInitEncodingSubsystem(void); MODULE_SCOPE void TclInitIOSubsystem(void); |
︙ | ︙ | |||
3638 3639 3640 3641 3642 3643 3644 3645 3646 3647 3648 3649 3650 3651 | MODULE_SCOPE Tcl_ObjCmdProc TclChanPostEventObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclChanPopObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclChanPushObjCmd; MODULE_SCOPE void TclClockInit(Tcl_Interp *interp); MODULE_SCOPE Tcl_ObjCmdProc TclClockOldscanObjCmd; MODULE_SCOPE Tcl_ObjCmdProc Tcl_CloseObjCmd; MODULE_SCOPE Tcl_ObjCmdProc Tcl_ConcatObjCmd; MODULE_SCOPE Tcl_ObjCmdProc Tcl_ContinueObjCmd; MODULE_SCOPE Tcl_TimerToken TclCreateAbsoluteTimerHandler( Tcl_Time *timePtr, Tcl_TimerProc *proc, void *clientData); MODULE_SCOPE Tcl_ObjCmdProc TclDefaultBgErrorHandlerObjCmd; MODULE_SCOPE Tcl_Command TclInitDictCmd(Tcl_Interp *interp); MODULE_SCOPE int TclDictWithFinish(Tcl_Interp *interp, Var *varPtr, | > | 3660 3661 3662 3663 3664 3665 3666 3667 3668 3669 3670 3671 3672 3673 3674 | MODULE_SCOPE Tcl_ObjCmdProc TclChanPostEventObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclChanPopObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclChanPushObjCmd; MODULE_SCOPE void TclClockInit(Tcl_Interp *interp); MODULE_SCOPE Tcl_ObjCmdProc TclClockOldscanObjCmd; MODULE_SCOPE Tcl_ObjCmdProc Tcl_CloseObjCmd; MODULE_SCOPE Tcl_ObjCmdProc Tcl_ConcatObjCmd; MODULE_SCOPE Tcl_ObjCmdProc Tcl_ConstObjCmd; MODULE_SCOPE Tcl_ObjCmdProc Tcl_ContinueObjCmd; MODULE_SCOPE Tcl_TimerToken TclCreateAbsoluteTimerHandler( Tcl_Time *timePtr, Tcl_TimerProc *proc, void *clientData); MODULE_SCOPE Tcl_ObjCmdProc TclDefaultBgErrorHandlerObjCmd; MODULE_SCOPE Tcl_Command TclInitDictCmd(Tcl_Interp *interp); MODULE_SCOPE int TclDictWithFinish(Tcl_Interp *interp, Var *varPtr, |
︙ | ︙ | |||
3751 3752 3753 3754 3755 3756 3757 3758 3759 3760 3761 3762 3763 3764 | MODULE_SCOPE CompileProc TclCompileArraySetCmd; MODULE_SCOPE CompileProc TclCompileArrayUnsetCmd; MODULE_SCOPE CompileProc TclCompileBreakCmd; MODULE_SCOPE CompileProc TclCompileCatchCmd; MODULE_SCOPE CompileProc TclCompileClockClicksCmd; MODULE_SCOPE CompileProc TclCompileClockReadingCmd; MODULE_SCOPE CompileProc TclCompileConcatCmd; MODULE_SCOPE CompileProc TclCompileContinueCmd; MODULE_SCOPE CompileProc TclCompileDictAppendCmd; MODULE_SCOPE CompileProc TclCompileDictCreateCmd; MODULE_SCOPE CompileProc TclCompileDictExistsCmd; MODULE_SCOPE CompileProc TclCompileDictForCmd; MODULE_SCOPE CompileProc TclCompileDictGetCmd; MODULE_SCOPE CompileProc TclCompileDictGetWithDefaultCmd; | > | 3774 3775 3776 3777 3778 3779 3780 3781 3782 3783 3784 3785 3786 3787 3788 | MODULE_SCOPE CompileProc TclCompileArraySetCmd; MODULE_SCOPE CompileProc TclCompileArrayUnsetCmd; MODULE_SCOPE CompileProc TclCompileBreakCmd; MODULE_SCOPE CompileProc TclCompileCatchCmd; MODULE_SCOPE CompileProc TclCompileClockClicksCmd; MODULE_SCOPE CompileProc TclCompileClockReadingCmd; MODULE_SCOPE CompileProc TclCompileConcatCmd; MODULE_SCOPE CompileProc TclCompileConstCmd; MODULE_SCOPE CompileProc TclCompileContinueCmd; MODULE_SCOPE CompileProc TclCompileDictAppendCmd; MODULE_SCOPE CompileProc TclCompileDictCreateCmd; MODULE_SCOPE CompileProc TclCompileDictExistsCmd; MODULE_SCOPE CompileProc TclCompileDictForCmd; MODULE_SCOPE CompileProc TclCompileDictGetCmd; MODULE_SCOPE CompileProc TclCompileDictGetWithDefaultCmd; |
︙ | ︙ | |||
4055 4056 4057 4058 4059 4060 4061 | MODULE_SCOPE int TclCommandWordLimitError(Tcl_Interp *interp, Tcl_Size count); #endif /* TCL_MAJOR_VERSION > 8 */ /* Constants used in index value encoding routines. */ #define TCL_INDEX_END ((Tcl_Size)-2) #define TCL_INDEX_START ((Tcl_Size)0) | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 4079 4080 4081 4082 4083 4084 4085 4086 4087 4088 4089 4090 4091 4092 | MODULE_SCOPE int TclCommandWordLimitError(Tcl_Interp *interp, Tcl_Size count); #endif /* TCL_MAJOR_VERSION > 8 */ /* Constants used in index value encoding routines. */ #define TCL_INDEX_END ((Tcl_Size)-2) #define TCL_INDEX_START ((Tcl_Size)0) /* *---------------------------------------------------------------------- * * TclScaleTime -- * * TIP #233 (Virtualized Time): Wrapper around the time virutalisation |
︙ | ︙ | |||
4624 4625 4626 4627 4628 4629 4630 | (((objPtr)->bytes==NULL) && ((objPtr)->typePtr==&tclDictType)) #define TclHasInternalRep(objPtr, type) \ ((objPtr)->typePtr == (type)) #define TclFetchInternalRep(objPtr, type) \ (TclHasInternalRep((objPtr), (type)) ? &((objPtr)->internalRep) : NULL) | < < < < < < < < < < < < < < < < | 4618 4619 4620 4621 4622 4623 4624 4625 4626 4627 4628 4629 4630 4631 | (((objPtr)->bytes==NULL) && ((objPtr)->typePtr==&tclDictType)) #define TclHasInternalRep(objPtr, type) \ ((objPtr)->typePtr == (type)) #define TclFetchInternalRep(objPtr, type) \ (TclHasInternalRep((objPtr), (type)) ? &((objPtr)->internalRep) : NULL) /* *---------------------------------------------------------------- * Macro used by the Tcl core to increment a namespace's export epoch * counter. The ANSI C "prototype" for this macro is: * * MODULE_SCOPE void TclInvalidateNsCmdLookup(Namespace *nsPtr); *---------------------------------------------------------------- |
︙ | ︙ |
Changes to generic/tclIntDecls.h.
︙ | ︙ | |||
316 317 318 319 320 321 322 | /* 149 */ EXTERN void TclHandleRelease(TclHandle handle); /* 150 */ EXTERN int TclRegAbout(Tcl_Interp *interp, Tcl_RegExp re); /* 151 */ EXTERN void TclRegExpRangeUniChar(Tcl_RegExp re, Tcl_Size index, Tcl_Size *startPtr, Tcl_Size *endPtr); | | < | < | 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 | /* 149 */ EXTERN void TclHandleRelease(TclHandle handle); /* 150 */ EXTERN int TclRegAbout(Tcl_Interp *interp, Tcl_RegExp re); /* 151 */ EXTERN void TclRegExpRangeUniChar(Tcl_RegExp re, Tcl_Size index, Tcl_Size *startPtr, Tcl_Size *endPtr); /* Slot 152 is reserved */ /* Slot 153 is reserved */ /* Slot 154 is reserved */ /* Slot 155 is reserved */ /* 156 */ EXTERN void TclRegError(Tcl_Interp *interp, const char *msg, int status); /* 157 */ EXTERN Var * TclVarTraceExists(Tcl_Interp *interp, |
︙ | ︙ | |||
350 351 352 353 354 355 356 | /* 166 */ EXTERN int TclListObjSetElement(Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Size index, Tcl_Obj *valuePtr); /* Slot 167 is reserved */ /* Slot 168 is reserved */ /* 169 */ | | | 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 | /* 166 */ EXTERN int TclListObjSetElement(Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Size index, Tcl_Obj *valuePtr); /* Slot 167 is reserved */ /* Slot 168 is reserved */ /* 169 */ EXTERN int TclpUtfNcmp2(const void *s1, const void *s2, size_t n); /* 170 */ EXTERN int TclCheckInterpTraces(Tcl_Interp *interp, const char *command, Tcl_Size numChars, Command *cmdPtr, int result, int traceFlags, Tcl_Size objc, Tcl_Obj *const objv[]); /* 171 */ |
︙ | ︙ | |||
730 731 732 733 734 735 736 | const struct AuxDataType * (*tclGetAuxDataType) (const char *typeName); /* 145 */ TclHandle (*tclHandleCreate) (void *ptr); /* 146 */ void (*tclHandleFree) (TclHandle handle); /* 147 */ TclHandle (*tclHandlePreserve) (TclHandle handle); /* 148 */ void (*tclHandleRelease) (TclHandle handle); /* 149 */ int (*tclRegAbout) (Tcl_Interp *interp, Tcl_RegExp re); /* 150 */ void (*tclRegExpRangeUniChar) (Tcl_RegExp re, Tcl_Size index, Tcl_Size *startPtr, Tcl_Size *endPtr); /* 151 */ | | | | | 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 | const struct AuxDataType * (*tclGetAuxDataType) (const char *typeName); /* 145 */ TclHandle (*tclHandleCreate) (void *ptr); /* 146 */ void (*tclHandleFree) (TclHandle handle); /* 147 */ TclHandle (*tclHandlePreserve) (TclHandle handle); /* 148 */ void (*tclHandleRelease) (TclHandle handle); /* 149 */ int (*tclRegAbout) (Tcl_Interp *interp, Tcl_RegExp re); /* 150 */ void (*tclRegExpRangeUniChar) (Tcl_RegExp re, Tcl_Size index, Tcl_Size *startPtr, Tcl_Size *endPtr); /* 151 */ void (*reserved152)(void); void (*reserved153)(void); void (*reserved154)(void); void (*reserved155)(void); void (*tclRegError) (Tcl_Interp *interp, const char *msg, int status); /* 156 */ Var * (*tclVarTraceExists) (Tcl_Interp *interp, const char *varName); /* 157 */ void (*reserved158)(void); void (*reserved159)(void); void (*reserved160)(void); int (*tclChannelTransform) (Tcl_Interp *interp, Tcl_Channel chan, Tcl_Obj *cmdObjPtr); /* 161 */ void (*tclChannelEventScriptInvoker) (void *clientData, int flags); /* 162 */ const void * (*tclGetInstructionTable) (void); /* 163 */ void (*tclExpandCodeArray) (void *envPtr); /* 164 */ void (*tclpSetInitialEncodings) (void); /* 165 */ int (*tclListObjSetElement) (Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Size index, Tcl_Obj *valuePtr); /* 166 */ void (*reserved167)(void); void (*reserved168)(void); int (*tclpUtfNcmp2) (const void *s1, const void *s2, size_t n); /* 169 */ int (*tclCheckInterpTraces) (Tcl_Interp *interp, const char *command, Tcl_Size numChars, Command *cmdPtr, int result, int traceFlags, Tcl_Size objc, Tcl_Obj *const objv[]); /* 170 */ int (*tclCheckExecutionTraces) (Tcl_Interp *interp, const char *command, Tcl_Size numChars, Command *cmdPtr, int result, int traceFlags, Tcl_Size objc, Tcl_Obj *const objv[]); /* 171 */ int (*tclInThreadExit) (void); /* 172 */ int (*tclUniCharMatch) (const Tcl_UniChar *string, Tcl_Size strLen, const Tcl_UniChar *pattern, Tcl_Size ptnLen, int flags); /* 173 */ void (*reserved174)(void); int (*tclCallVarTraces) (Interp *iPtr, Var *arrayPtr, Var *varPtr, const char *part1, const char *part2, int flags, int leaveErrMsg); /* 175 */ void (*tclCleanupVar) (Var *varPtr, Var *arrayPtr); /* 176 */ |
︙ | ︙ | |||
1076 1077 1078 1079 1080 1081 1082 | (tclIntStubsPtr->tclHandlePreserve) /* 148 */ #define TclHandleRelease \ (tclIntStubsPtr->tclHandleRelease) /* 149 */ #define TclRegAbout \ (tclIntStubsPtr->tclRegAbout) /* 150 */ #define TclRegExpRangeUniChar \ (tclIntStubsPtr->tclRegExpRangeUniChar) /* 151 */ | < | < | | 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 | (tclIntStubsPtr->tclHandlePreserve) /* 148 */ #define TclHandleRelease \ (tclIntStubsPtr->tclHandleRelease) /* 149 */ #define TclRegAbout \ (tclIntStubsPtr->tclRegAbout) /* 150 */ #define TclRegExpRangeUniChar \ (tclIntStubsPtr->tclRegExpRangeUniChar) /* 151 */ /* Slot 152 is reserved */ /* Slot 153 is reserved */ /* Slot 154 is reserved */ /* Slot 155 is reserved */ #define TclRegError \ (tclIntStubsPtr->tclRegError) /* 156 */ #define TclVarTraceExists \ (tclIntStubsPtr->tclVarTraceExists) /* 157 */ /* Slot 158 is reserved */ |
︙ | ︙ |
Changes to generic/tclIntPlatDecls.h.
︙ | ︙ | |||
53 54 55 56 57 58 59 | /* 3 */ EXTERN int TclpCreatePipe(TclFile *readPipe, TclFile *writePipe); /* 4 */ EXTERN int TclpCreateProcess(Tcl_Interp *interp, int argc, const char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr); | | < | < | < | < | 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 | /* 3 */ EXTERN int TclpCreatePipe(TclFile *readPipe, TclFile *writePipe); /* 4 */ EXTERN int TclpCreateProcess(Tcl_Interp *interp, int argc, const char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr); /* Slot 5 is reserved */ /* 6 */ EXTERN TclFile TclpMakeFile(Tcl_Channel channel, int direction); /* 7 */ EXTERN TclFile TclpOpenFile(const char *fname, int mode); /* 8 */ EXTERN int TclUnixWaitForFile(int fd, int mask, int timeout); /* 9 */ EXTERN TclFile TclpCreateTempFile(const char *contents); /* 10 */ EXTERN Tcl_DirEntry * TclpReaddir(TclDIR *dir); /* Slot 11 is reserved */ /* Slot 12 is reserved */ /* Slot 13 is reserved */ /* 14 */ EXTERN int TclUnixCopyFile(const char *src, const char *dst, const Tcl_StatBuf *statBufPtr, int dontCopyAtts); /* 15 */ EXTERN int TclMacOSXGetFileAttribute(Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, |
︙ | ︙ | |||
97 98 99 100 101 102 103 | Tcl_StatBuf *statBufPtr, Tcl_GlobTypeData *types); /* 19 */ EXTERN void TclMacOSXNotifierAddRunLoopMode( const void *runLoopMode); /* Slot 20 is reserved */ /* Slot 21 is reserved */ | | < | < | < | < < | < < | | < | < < | | < > | 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 | Tcl_StatBuf *statBufPtr, Tcl_GlobTypeData *types); /* 19 */ EXTERN void TclMacOSXNotifierAddRunLoopMode( const void *runLoopMode); /* Slot 20 is reserved */ /* Slot 21 is reserved */ /* Slot 22 is reserved */ /* Slot 23 is reserved */ /* Slot 24 is reserved */ /* Slot 25 is reserved */ /* Slot 26 is reserved */ /* Slot 27 is reserved */ /* Slot 28 is reserved */ /* 29 */ EXTERN int TclWinCPUID(int index, int *regs); /* 30 */ EXTERN int TclUnixOpenTemporaryFile(Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj); #endif /* UNIX */ #if defined(_WIN32) || defined(__CYGWIN__) /* WIN */ /* Slot 0 is reserved */ /* Slot 1 is reserved */ /* Slot 2 is reserved */ /* Slot 3 is reserved */ /* 4 */ EXTERN void * TclWinGetTclInstance(void); /* 5 */ EXTERN int TclUnixWaitForFile(int fd, int mask, int timeout); /* Slot 6 is reserved */ /* Slot 7 is reserved */ /* 8 */ EXTERN Tcl_Size TclpGetPid(Tcl_Pid pid); /* Slot 9 is reserved */ /* Slot 10 is reserved */ /* 11 */ EXTERN void TclGetAndDetachPids(Tcl_Interp *interp, Tcl_Channel chan); /* 12 */ EXTERN int TclpCloseFile(TclFile file); /* 13 */ EXTERN Tcl_Channel TclpCreateCommandChannel(TclFile readFile, |
︙ | ︙ | |||
164 165 166 167 168 169 170 | int dontCopyAtts); /* 18 */ EXTERN TclFile TclpMakeFile(Tcl_Channel channel, int direction); /* 19 */ EXTERN TclFile TclpOpenFile(const char *fname, int mode); /* 20 */ EXTERN void TclWinAddProcess(void *hProcess, Tcl_Size id); | | < | < | < | 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 | int dontCopyAtts); /* 18 */ EXTERN TclFile TclpMakeFile(Tcl_Channel channel, int direction); /* 19 */ EXTERN TclFile TclpOpenFile(const char *fname, int mode); /* 20 */ EXTERN void TclWinAddProcess(void *hProcess, Tcl_Size id); /* Slot 21 is reserved */ /* 22 */ EXTERN TclFile TclpCreateTempFile(const char *contents); /* Slot 23 is reserved */ /* 24 */ EXTERN char * TclWinNoBackslash(char *path); /* Slot 25 is reserved */ /* Slot 26 is reserved */ /* 27 */ EXTERN void TclWinFlushDirtyChannels(void); /* Slot 28 is reserved */ /* 29 */ EXTERN int TclWinCPUID(int index, int *regs); /* 30 */ EXTERN int TclUnixOpenTemporaryFile(Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj); #endif /* WIN */ |
︙ | ︙ | |||
202 203 204 205 206 207 208 | /* 3 */ EXTERN int TclpCreatePipe(TclFile *readPipe, TclFile *writePipe); /* 4 */ EXTERN int TclpCreateProcess(Tcl_Interp *interp, int argc, const char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr); | | < | < < < < < | 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 | /* 3 */ EXTERN int TclpCreatePipe(TclFile *readPipe, TclFile *writePipe); /* 4 */ EXTERN int TclpCreateProcess(Tcl_Interp *interp, int argc, const char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr); /* Slot 5 is reserved */ /* 6 */ EXTERN TclFile TclpMakeFile(Tcl_Channel channel, int direction); /* 7 */ EXTERN TclFile TclpOpenFile(const char *fname, int mode); /* 8 */ EXTERN int TclUnixWaitForFile(int fd, int mask, int timeout); /* 9 */ EXTERN TclFile TclpCreateTempFile(const char *contents); /* 10 */ EXTERN Tcl_DirEntry * TclpReaddir(TclDIR *dir); /* Slot 13 is reserved */ /* 14 */ EXTERN int TclUnixCopyFile(const char *src, const char *dst, const Tcl_StatBuf *statBufPtr, int dontCopyAtts); /* 15 */ EXTERN int TclMacOSXGetFileAttribute(Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, |
︙ | ︙ | |||
246 247 248 249 250 251 252 | Tcl_StatBuf *statBufPtr, Tcl_GlobTypeData *types); /* 19 */ EXTERN void TclMacOSXNotifierAddRunLoopMode( const void *runLoopMode); /* Slot 20 is reserved */ /* Slot 21 is reserved */ | | < | 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 | Tcl_StatBuf *statBufPtr, Tcl_GlobTypeData *types); /* 19 */ EXTERN void TclMacOSXNotifierAddRunLoopMode( const void *runLoopMode); /* Slot 20 is reserved */ /* Slot 21 is reserved */ /* Slot 22 is reserved */ /* Slot 23 is reserved */ /* Slot 24 is reserved */ /* Slot 25 is reserved */ /* Slot 26 is reserved */ /* Slot 27 is reserved */ /* Slot 28 is reserved */ /* 29 */ |
︙ | ︙ | |||
278 279 280 281 282 283 284 | int (*tclpCreateProcess) (Tcl_Interp *interp, int argc, const char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr); /* 4 */ int (*tclUnixWaitForFile_) (int fd, int mask, int timeout); /* 5 */ TclFile (*tclpMakeFile) (Tcl_Channel channel, int direction); /* 6 */ TclFile (*tclpOpenFile) (const char *fname, int mode); /* 7 */ int (*tclUnixWaitForFile) (int fd, int mask, int timeout); /* 8 */ TclFile (*tclpCreateTempFile) (const char *contents); /* 9 */ Tcl_DirEntry * (*tclpReaddir) (TclDIR *dir); /* 10 */ | | | | | | | | | | | | | | | | | | | 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 | int (*tclpCreateProcess) (Tcl_Interp *interp, int argc, const char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr); /* 4 */ int (*tclUnixWaitForFile_) (int fd, int mask, int timeout); /* 5 */ TclFile (*tclpMakeFile) (Tcl_Channel channel, int direction); /* 6 */ TclFile (*tclpOpenFile) (const char *fname, int mode); /* 7 */ int (*tclUnixWaitForFile) (int fd, int mask, int timeout); /* 8 */ TclFile (*tclpCreateTempFile) (const char *contents); /* 9 */ Tcl_DirEntry * (*tclpReaddir) (TclDIR *dir); /* 10 */ void (*reserved11)(void); void (*reserved12)(void); void (*reserved13)(void); int (*tclUnixCopyFile) (const char *src, const char *dst, const Tcl_StatBuf *statBufPtr, int dontCopyAtts); /* 14 */ int (*tclMacOSXGetFileAttribute) (Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj **attributePtrPtr); /* 15 */ int (*tclMacOSXSetFileAttribute) (Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj *attributePtr); /* 16 */ int (*tclMacOSXCopyFileAttributes) (const char *src, const char *dst, const Tcl_StatBuf *statBufPtr); /* 17 */ int (*tclMacOSXMatchType) (Tcl_Interp *interp, const char *pathName, const char *fileName, Tcl_StatBuf *statBufPtr, Tcl_GlobTypeData *types); /* 18 */ void (*tclMacOSXNotifierAddRunLoopMode) (const void *runLoopMode); /* 19 */ void (*reserved20)(void); void (*reserved21)(void); TclFile (*tclpCreateTempFile_) (const char *contents); /* 22 */ void (*reserved23)(void); void (*reserved24)(void); void (*reserved25)(void); void (*reserved26)(void); void (*reserved27)(void); void (*reserved28)(void); int (*tclWinCPUID) (int index, int *regs); /* 29 */ int (*tclUnixOpenTemporaryFile) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj); /* 30 */ #endif /* UNIX */ #if defined(_WIN32) || defined(__CYGWIN__) /* WIN */ void (*reserved0)(void); void (*reserved1)(void); void (*reserved2)(void); void (*reserved3)(void); void * (*tclWinGetTclInstance) (void); /* 4 */ int (*tclUnixWaitForFile) (int fd, int mask, int timeout); /* 5 */ void (*reserved6)(void); void (*reserved7)(void); Tcl_Size (*tclpGetPid) (Tcl_Pid pid); /* 8 */ void (*reserved9)(void); void *(*tclpReaddir) (void *dir); /* 10 */ void (*tclGetAndDetachPids) (Tcl_Interp *interp, Tcl_Channel chan); /* 11 */ int (*tclpCloseFile) (TclFile file); /* 12 */ Tcl_Channel (*tclpCreateCommandChannel) (TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); /* 13 */ int (*tclpCreatePipe) (TclFile *readPipe, TclFile *writePipe); /* 14 */ int (*tclpCreateProcess) (Tcl_Interp *interp, int argc, const char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr); /* 15 */ int (*tclpIsAtty) (int fd); /* 16 */ int (*tclUnixCopyFile) (const char *src, const char *dst, const Tcl_StatBuf *statBufPtr, int dontCopyAtts); /* 17 */ TclFile (*tclpMakeFile) (Tcl_Channel channel, int direction); /* 18 */ TclFile (*tclpOpenFile) (const char *fname, int mode); /* 19 */ void (*tclWinAddProcess) (void *hProcess, Tcl_Size id); /* 20 */ void (*reserved21)(void); TclFile (*tclpCreateTempFile) (const char *contents); /* 22 */ void (*reserved23)(void); char * (*tclWinNoBackslash) (char *path); /* 24 */ void (*reserved25)(void); void (*reserved26)(void); void (*tclWinFlushDirtyChannels) (void); /* 27 */ void (*reserved28)(void); int (*tclWinCPUID) (int index, int *regs); /* 29 */ int (*tclUnixOpenTemporaryFile) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj); /* 30 */ #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ void (*tclGetAndDetachPids) (Tcl_Interp *interp, Tcl_Channel chan); /* 0 */ int (*tclpCloseFile) (TclFile file); /* 1 */ Tcl_Channel (*tclpCreateCommandChannel) (TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); /* 2 */ int (*tclpCreatePipe) (TclFile *readPipe, TclFile *writePipe); /* 3 */ int (*tclpCreateProcess) (Tcl_Interp *interp, int argc, const char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr); /* 4 */ int (*tclUnixWaitForFile_) (int fd, int mask, int timeout); /* 5 */ TclFile (*tclpMakeFile) (Tcl_Channel channel, int direction); /* 6 */ TclFile (*tclpOpenFile) (const char *fname, int mode); /* 7 */ int (*tclUnixWaitForFile) (int fd, int mask, int timeout); /* 8 */ TclFile (*tclpCreateTempFile) (const char *contents); /* 9 */ Tcl_DirEntry * (*tclpReaddir) (TclDIR *dir); /* 10 */ void (*reserved11)(void); void (*reserved12)(void); void (*reserved13)(void); int (*tclUnixCopyFile) (const char *src, const char *dst, const Tcl_StatBuf *statBufPtr, int dontCopyAtts); /* 14 */ int (*tclMacOSXGetFileAttribute) (Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj **attributePtrPtr); /* 15 */ int (*tclMacOSXSetFileAttribute) (Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj *attributePtr); /* 16 */ int (*tclMacOSXCopyFileAttributes) (const char *src, const char *dst, const Tcl_StatBuf *statBufPtr); /* 17 */ int (*tclMacOSXMatchType) (Tcl_Interp *interp, const char *pathName, const char *fileName, Tcl_StatBuf *statBufPtr, Tcl_GlobTypeData *types); /* 18 */ void (*tclMacOSXNotifierAddRunLoopMode) (const void *runLoopMode); /* 19 */ void (*reserved20)(void); |
︙ | ︙ | |||
390 391 392 393 394 395 396 | (tclIntPlatStubsPtr->tclpCloseFile) /* 1 */ #define TclpCreateCommandChannel \ (tclIntPlatStubsPtr->tclpCreateCommandChannel) /* 2 */ #define TclpCreatePipe \ (tclIntPlatStubsPtr->tclpCreatePipe) /* 3 */ #define TclpCreateProcess \ (tclIntPlatStubsPtr->tclpCreateProcess) /* 4 */ | | < | | | < < < | < | | | < | < < < | | < < < < > > | < | < | < | < | | | < < < | < | 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 | (tclIntPlatStubsPtr->tclpCloseFile) /* 1 */ #define TclpCreateCommandChannel \ (tclIntPlatStubsPtr->tclpCreateCommandChannel) /* 2 */ #define TclpCreatePipe \ (tclIntPlatStubsPtr->tclpCreatePipe) /* 3 */ #define TclpCreateProcess \ (tclIntPlatStubsPtr->tclpCreateProcess) /* 4 */ /* Slot 5 is reserved */ #define TclpMakeFile \ (tclIntPlatStubsPtr->tclpMakeFile) /* 6 */ #define TclpOpenFile \ (tclIntPlatStubsPtr->tclpOpenFile) /* 7 */ #define TclUnixWaitForFile \ (tclIntPlatStubsPtr->tclUnixWaitForFile) /* 8 */ #define TclpCreateTempFile \ (tclIntPlatStubsPtr->tclpCreateTempFile) /* 9 */ #define TclpReaddir \ (tclIntPlatStubsPtr->tclpReaddir) /* 10 */ /* Slot 11 is reserved */ /* Slot 12 is reserved */ /* Slot 13 is reserved */ #define TclUnixCopyFile \ (tclIntPlatStubsPtr->tclUnixCopyFile) /* 14 */ #define TclMacOSXGetFileAttribute \ (tclIntPlatStubsPtr->tclMacOSXGetFileAttribute) /* 15 */ #define TclMacOSXSetFileAttribute \ (tclIntPlatStubsPtr->tclMacOSXSetFileAttribute) /* 16 */ #define TclMacOSXCopyFileAttributes \ (tclIntPlatStubsPtr->tclMacOSXCopyFileAttributes) /* 17 */ #define TclMacOSXMatchType \ (tclIntPlatStubsPtr->tclMacOSXMatchType) /* 18 */ #define TclMacOSXNotifierAddRunLoopMode \ (tclIntPlatStubsPtr->tclMacOSXNotifierAddRunLoopMode) /* 19 */ /* Slot 20 is reserved */ /* Slot 21 is reserved */ /* Slot 22 is reserved */ /* Slot 23 is reserved */ /* Slot 24 is reserved */ /* Slot 25 is reserved */ /* Slot 26 is reserved */ /* Slot 27 is reserved */ /* Slot 28 is reserved */ #define TclWinCPUID \ (tclIntPlatStubsPtr->tclWinCPUID) /* 29 */ #define TclUnixOpenTemporaryFile \ (tclIntPlatStubsPtr->tclUnixOpenTemporaryFile) /* 30 */ #endif /* UNIX */ #if defined(_WIN32) || defined(__CYGWIN__) /* WIN */ /* Slot 0 is reserved */ /* Slot 1 is reserved */ /* Slot 2 is reserved */ /* Slot 3 is reserved */ #define TclWinGetTclInstance \ (tclIntPlatStubsPtr->tclWinGetTclInstance) /* 4 */ #define TclUnixWaitForFile \ (tclIntPlatStubsPtr->tclUnixWaitForFile) /* 5 */ /* Slot 6 is reserved */ /* Slot 7 is reserved */ #define TclpGetPid \ (tclIntPlatStubsPtr->tclpGetPid) /* 8 */ /* Slot 9 is reserved */ /* Slot 10 is reserved */ #define TclGetAndDetachPids \ (tclIntPlatStubsPtr->tclGetAndDetachPids) /* 11 */ #define TclpCloseFile \ (tclIntPlatStubsPtr->tclpCloseFile) /* 12 */ #define TclpCreateCommandChannel \ (tclIntPlatStubsPtr->tclpCreateCommandChannel) /* 13 */ #define TclpCreatePipe \ (tclIntPlatStubsPtr->tclpCreatePipe) /* 14 */ #define TclpCreateProcess \ (tclIntPlatStubsPtr->tclpCreateProcess) /* 15 */ #define TclpIsAtty \ (tclIntPlatStubsPtr->tclpIsAtty) /* 16 */ #define TclUnixCopyFile \ (tclIntPlatStubsPtr->tclUnixCopyFile) /* 17 */ #define TclpMakeFile \ (tclIntPlatStubsPtr->tclpMakeFile) /* 18 */ #define TclpOpenFile \ (tclIntPlatStubsPtr->tclpOpenFile) /* 19 */ #define TclWinAddProcess \ (tclIntPlatStubsPtr->tclWinAddProcess) /* 20 */ /* Slot 21 is reserved */ #define TclpCreateTempFile \ (tclIntPlatStubsPtr->tclpCreateTempFile) /* 22 */ /* Slot 23 is reserved */ #define TclWinNoBackslash \ (tclIntPlatStubsPtr->tclWinNoBackslash) /* 24 */ /* Slot 25 is reserved */ /* Slot 26 is reserved */ #define TclWinFlushDirtyChannels \ (tclIntPlatStubsPtr->tclWinFlushDirtyChannels) /* 27 */ /* Slot 28 is reserved */ #define TclWinCPUID \ (tclIntPlatStubsPtr->tclWinCPUID) /* 29 */ #define TclUnixOpenTemporaryFile \ (tclIntPlatStubsPtr->tclUnixOpenTemporaryFile) /* 30 */ #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ #define TclGetAndDetachPids \ (tclIntPlatStubsPtr->tclGetAndDetachPids) /* 0 */ #define TclpCloseFile \ (tclIntPlatStubsPtr->tclpCloseFile) /* 1 */ #define TclpCreateCommandChannel \ (tclIntPlatStubsPtr->tclpCreateCommandChannel) /* 2 */ #define TclpCreatePipe \ (tclIntPlatStubsPtr->tclpCreatePipe) /* 3 */ #define TclpCreateProcess \ (tclIntPlatStubsPtr->tclpCreateProcess) /* 4 */ /* Slot 5 is reserved */ #define TclpMakeFile \ (tclIntPlatStubsPtr->tclpMakeFile) /* 6 */ #define TclpOpenFile \ (tclIntPlatStubsPtr->tclpOpenFile) /* 7 */ #define TclUnixWaitForFile \ (tclIntPlatStubsPtr->tclUnixWaitForFile) /* 8 */ #define TclpCreateTempFile \ (tclIntPlatStubsPtr->tclpCreateTempFile) /* 9 */ #define TclpReaddir \ (tclIntPlatStubsPtr->tclpReaddir) /* 10 */ /* Slot 11 is reserved */ /* Slot 12 is reserved */ /* Slot 13 is reserved */ #define TclUnixCopyFile \ (tclIntPlatStubsPtr->tclUnixCopyFile) /* 14 */ #define TclMacOSXGetFileAttribute \ (tclIntPlatStubsPtr->tclMacOSXGetFileAttribute) /* 15 */ #define TclMacOSXSetFileAttribute \ (tclIntPlatStubsPtr->tclMacOSXSetFileAttribute) /* 16 */ #define TclMacOSXCopyFileAttributes \ (tclIntPlatStubsPtr->tclMacOSXCopyFileAttributes) /* 17 */ #define TclMacOSXMatchType \ (tclIntPlatStubsPtr->tclMacOSXMatchType) /* 18 */ #define TclMacOSXNotifierAddRunLoopMode \ (tclIntPlatStubsPtr->tclMacOSXNotifierAddRunLoopMode) /* 19 */ /* Slot 20 is reserved */ /* Slot 21 is reserved */ /* Slot 22 is reserved */ /* Slot 23 is reserved */ /* Slot 24 is reserved */ /* Slot 25 is reserved */ /* Slot 26 is reserved */ /* Slot 27 is reserved */ /* Slot 28 is reserved */ #define TclWinCPUID \ |
︙ | ︙ | |||
583 584 585 586 587 588 589 | /* 5 */ EXTERN int TclUnixWaitForFile(int fd, int mask, int timeout); /* 6 */ EXTERN TclFile TclpMakeFile(Tcl_Channel channel, int direction); /* 7 */ EXTERN TclFile TclpOpenFile(const char *fname, int mode); /* 8 */ | | | 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 | /* 5 */ EXTERN int TclUnixWaitForFile(int fd, int mask, int timeout); /* 6 */ EXTERN TclFile TclpMakeFile(Tcl_Channel channel, int direction); /* 7 */ EXTERN TclFile TclpOpenFile(const char *fname, int mode); /* 8 */ EXTERN Tcl_Size TclpGetPid(Tcl_Pid pid); /* 9 */ EXTERN TclFile TclpCreateTempFile(const char *contents); /* Slot 10 is reserved */ /* 11 */ EXTERN void TclGetAndDetachPids(Tcl_Interp *interp, Tcl_Channel chan); /* Slot 12 is reserved */ |
︙ | ︙ | |||
607 608 609 610 611 612 613 | /* 17 */ EXTERN int TclUnixCopyFile(const char *src, const char *dst, const Tcl_StatBuf *statBufPtr, int dontCopyAtts); /* Slot 18 is reserved */ /* Slot 19 is reserved */ /* 20 */ | | | 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 | /* 17 */ EXTERN int TclUnixCopyFile(const char *src, const char *dst, const Tcl_StatBuf *statBufPtr, int dontCopyAtts); /* Slot 18 is reserved */ /* Slot 19 is reserved */ /* 20 */ EXTERN void TclWinAddProcess(void *hProcess, Tcl_Size id); /* Slot 21 is reserved */ /* Slot 22 is reserved */ /* Slot 23 is reserved */ /* 24 */ EXTERN char * TclWinNoBackslash(char *path); /* Slot 25 is reserved */ /* Slot 26 is reserved */ |
︙ | ︙ | |||
637 638 639 640 641 642 643 | int (*tclpCloseFile) (TclFile file); /* 1 */ Tcl_Channel (*tclpCreateCommandChannel) (TclFile readFile, TclFile writeFile, TclFile errorFile, size_t numPids, Tcl_Pid *pidPtr); /* 2 */ int (*tclpCreatePipe) (TclFile *readPipe, TclFile *writePipe); /* 3 */ void * (*tclWinGetTclInstance) (void); /* 4 */ int (*tclUnixWaitForFile) (int fd, int mask, int timeout); /* 5 */ TclFile (*tclpMakeFile) (Tcl_Channel channel, int direction); /* 6 */ TclFile (*tclpOpenFile) (const char *fname, int mode); /* 7 */ | | | | 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 | int (*tclpCloseFile) (TclFile file); /* 1 */ Tcl_Channel (*tclpCreateCommandChannel) (TclFile readFile, TclFile writeFile, TclFile errorFile, size_t numPids, Tcl_Pid *pidPtr); /* 2 */ int (*tclpCreatePipe) (TclFile *readPipe, TclFile *writePipe); /* 3 */ void * (*tclWinGetTclInstance) (void); /* 4 */ int (*tclUnixWaitForFile) (int fd, int mask, int timeout); /* 5 */ TclFile (*tclpMakeFile) (Tcl_Channel channel, int direction); /* 6 */ TclFile (*tclpOpenFile) (const char *fname, int mode); /* 7 */ Tcl_Size (*tclpGetPid) (Tcl_Pid pid); /* 8 */ TclFile (*tclpCreateTempFile) (const char *contents); /* 9 */ void (*reserved10)(void); void (*tclGetAndDetachPids) (Tcl_Interp *interp, Tcl_Channel chan); /* 11 */ void (*reserved12)(void); void (*reserved13)(void); void (*reserved14)(void); int (*tclpCreateProcess) (Tcl_Interp *interp, size_t argc, const char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr); /* 15 */ int (*tclpIsAtty) (int fd); /* 16 */ int (*tclUnixCopyFile) (const char *src, const char *dst, const Tcl_StatBuf *statBufPtr, int dontCopyAtts); /* 17 */ void (*reserved18)(void); void (*reserved19)(void); void (*tclWinAddProcess) (void *hProcess, Tcl_Size id); /* 20 */ void (*reserved21)(void); void (*reserved22)(void); void (*reserved23)(void); char * (*tclWinNoBackslash) (char *path); /* 24 */ void (*reserved25)(void); void (*reserved26)(void); void (*tclWinFlushDirtyChannels) (void); /* 27 */ |
︙ | ︙ | |||
731 732 733 734 735 736 737 | #endif /* defined(USE_TCL_STUBS) */ /* !END!: Do not edit above this line. */ #endif /* TCL_MAJOR_VERSION */ #undef TCL_STORAGE_CLASS #define TCL_STORAGE_CLASS DLLIMPORT | < < < < < < < < < < < < < | 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 | #endif /* defined(USE_TCL_STUBS) */ /* !END!: Do not edit above this line. */ #endif /* TCL_MAJOR_VERSION */ #undef TCL_STORAGE_CLASS #define TCL_STORAGE_CLASS DLLIMPORT #ifdef MAC_OSX_TCL /* not accessible on Win32/UNIX */ MODULE_SCOPE int TclMacOSXGetFileAttribute(Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj **attributePtrPtr); /* 16 */ MODULE_SCOPE int TclMacOSXSetFileAttribute(Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, |
︙ | ︙ | |||
771 772 773 774 775 776 777 | #undef TclMacOSXSetFileAttribute /* 16 */ #undef TclMacOSXCopyFileAttributes /* 17 */ #undef TclMacOSXMatchType /* 18 */ #undef TclMacOSXNotifierAddRunLoopMode /* 19 */ #endif #if defined(_WIN32) | < < < < < < < | > > > | | 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 | #undef TclMacOSXSetFileAttribute /* 16 */ #undef TclMacOSXCopyFileAttributes /* 17 */ #undef TclMacOSXMatchType /* 18 */ #undef TclMacOSXNotifierAddRunLoopMode /* 19 */ #endif #if defined(_WIN32) # if !defined(TCL_NO_DEPRECATED) # define TclWinConvertError Tcl_WinConvertError # define TclWinConvertWSAError Tcl_WinConvertError # define TclWinNToHS ntohs # define TclpInetNtoa inet_ntoa # define TclWinGetServByName getservbyname # define TclWinGetSockOpt getsockopt # define TclWinSetSockOpt setsockopt # define TclWinGetPlatformId() (2) /* VER_PLATFORM_WIN32_NT */ # define TclWinResetInterfaces() /* nop */ # define TclWinSetInterfaces(dummy) /* nop */ # endif /* TCL_NO_DEPRECATED */ #else # undef TclpGetPid # define TclpGetPid(pid) ((Tcl_Size)(pid)) #endif #endif /* _TCLINTPLATDECLS */ |
Changes to generic/tclLink.c.
︙ | ︙ | |||
175 176 177 178 179 180 181 | linkPtr = (Link *)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; | < < < < < < < < | 175 176 177 178 179 180 181 182 183 184 185 186 187 188 | linkPtr = (Link *)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 (type & TCL_LINK_READ_ONLY) { linkPtr->flags = LINK_READ_ONLY; } else { linkPtr->flags = 0; } linkPtr->bytes = 0; linkPtr->numElems = 0; |
︙ | ︙ | |||
258 259 260 261 262 263 264 | Tcl_SetObjResult(interp, Tcl_NewStringObj( "wrong array size given", -1)); return TCL_ERROR; } linkPtr = (Link *)Tcl_Alloc(sizeof(Link)); linkPtr->type = type & ~TCL_LINK_READ_ONLY; | < < < < < < < < | 250 251 252 253 254 255 256 257 258 259 260 261 262 263 | Tcl_SetObjResult(interp, Tcl_NewStringObj( "wrong array size given", -1)); return TCL_ERROR; } linkPtr = (Link *)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; } |
︙ | ︙ | |||
302 303 304 305 306 307 308 | break; case TCL_LINK_USHORT: linkPtr->bytes = size * sizeof(unsigned short); break; case TCL_LINK_UINT: linkPtr->bytes = size * sizeof(unsigned int); break; | < < < < < < < < | 286 287 288 289 290 291 292 293 294 295 296 297 298 299 | break; case TCL_LINK_USHORT: linkPtr->bytes = size * sizeof(unsigned short); break; case TCL_LINK_UINT: linkPtr->bytes = size * sizeof(unsigned int); break; 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. */ |
︙ | ︙ | |||
507 508 509 510 511 512 513 | } static inline int GetWide( Tcl_Obj *objPtr, Tcl_WideInt *widePtr) { | | | 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 | } static inline int GetWide( Tcl_Obj *objPtr, Tcl_WideInt *widePtr) { if (TclGetWideIntFromObj(NULL, objPtr, widePtr) != TCL_OK) { int intValue; if (GetInvalidIntFromObj(objPtr, &intValue) != TCL_OK) { return 1; } *widePtr = intValue; } |
︙ | ︙ | |||
795 796 797 798 799 800 801 | 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; | < < < < < < < < | 771 772 773 774 775 776 777 778 779 780 781 782 783 784 | 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; 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; |
︙ | ︙ | |||
1117 1118 1119 1120 1121 1122 1123 | ObjValue(linkPtr), TCL_GLOBAL_ONLY); return (char *) "variable must have unsigned int value"; } LinkedVar(unsigned int) = linkPtr->lastValue.ui = (unsigned int) valueWide; } break; | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 | ObjValue(linkPtr), TCL_GLOBAL_ONLY); return (char *) "variable must have unsigned int value"; } LinkedVar(unsigned int) = linkPtr->lastValue.ui = (unsigned int) valueWide; } break; 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 *) |
︙ | ︙ | |||
1365 1366 1367 1368 1369 1370 1371 | } 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); | < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 | } 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); case TCL_LINK_FLOAT: if (linkPtr->flags & LINK_ALLOC_LAST) { memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); objv = (Tcl_Obj **)Tcl_Alloc(linkPtr->numElems * sizeof(Tcl_Obj *)); for (i=0; i < linkPtr->numElems; i++) { TclNewDoubleObj(objv[i], linkPtr->lastValue.fPtr[i]); } |
︙ | ︙ |
Changes to generic/tclListObj.c.
︙ | ︙ | |||
3165 3166 3167 3168 3169 3170 3171 | elemCount = ListRepLength(&listRep); /* Ensure that the index is in bounds. */ if ((index < 0) || (index >= elemCount)) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( | | | 3165 3166 3167 3168 3169 3170 3171 3172 3173 3174 3175 3176 3177 3178 3179 | elemCount = ListRepLength(&listRep); /* Ensure that the index is in bounds. */ if ((index < 0) || (index >= elemCount)) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "index \"%" TCL_SIZE_MODIFIER "d\" out of range", index)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX", "OUTOFRANGE", (void *)NULL); } return TCL_ERROR; } /* |
︙ | ︙ |
Changes to generic/tclMain.c.
︙ | ︙ | |||
50 51 52 53 54 55 56 | { Tcl_DString ds; #ifdef UNICODE Tcl_DStringInit(&ds); Tcl_WCharToUtfDString(string, -1, &ds); #else | | | 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 | { Tcl_DString ds; #ifdef UNICODE Tcl_DStringInit(&ds); Tcl_WCharToUtfDString(string, -1, &ds); #else (void) TclSystemToInternalEncoding(NULL, string, -1, &ds); #endif return Tcl_DStringToObj(&ds); } /* * Declarations for various library functions and variables (don't want to * include tclPort.h here, because people might copy this file out of the Tcl |
︙ | ︙ |
Changes to generic/tclOO.h.
︙ | ︙ | |||
112 113 114 115 116 117 118 | * data, or NULL if the type-specific data * does not need deleting. */ Tcl_CloneProc *cloneProc; /* How to copy this method's type-specific * data, or NULL if the type-specific data can * be copied directly. */ } Tcl_MethodType2; #else | | | 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 | * data, or NULL if the type-specific data * does not need deleting. */ Tcl_CloneProc *cloneProc; /* How to copy this method's type-specific * data, or NULL if the type-specific data can * be copied directly. */ } Tcl_MethodType2; #else #define Tcl_MethodType2 Tcl_MethodType #endif /* * The correct value for the version field of the Tcl_MethodType structure. * This allows new versions of the structure to be introduced without breaking * binary compatibility. */ |
︙ | ︙ |
Changes to generic/tclOODefineCmds.c.
︙ | ︙ | |||
2492 2493 2494 2495 2496 2497 2498 | Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv) { Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); Tcl_Size mixinc, i; Tcl_Obj **mixinv; | | > > > > > | 2492 2493 2494 2495 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 2509 2510 2511 | Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv) { Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); Tcl_Size mixinc, i; Tcl_Obj **mixinv; Class **mixins; /* The references to the classes to actually * install. */ Tcl_HashTable uniqueCheck; /* Note that this hash table is just used as a * set of class references; it has no payload * values and keys are always pointers. */ int isNew; if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, "mixinList"); return TCL_ERROR; } objv += Tcl_ObjectContextSkippedArgs(context); |
︙ | ︙ | |||
2514 2515 2516 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 | return TCL_ERROR; } else if (TclListObjGetElementsM(interp, objv[0], &mixinc, &mixinv) != TCL_OK) { return TCL_ERROR; } mixins = (Class **)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])) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "may not mix a class into itself", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "SELF_MIXIN", (void *)NULL); goto freeAndError; } } TclOOClassSetMixins(interp, oPtr->classPtr, mixinc, mixins); TclStackFree(interp, mixins); return TCL_OK; freeAndError: TclStackFree(interp, mixins); return TCL_ERROR; } /* * ---------------------------------------------------------------------- * | > > > > > > > > > > | 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 | return TCL_ERROR; } else if (TclListObjGetElementsM(interp, objv[0], &mixinc, &mixinv) != TCL_OK) { return TCL_ERROR; } mixins = (Class **)TclStackAlloc(interp, sizeof(Class *) * mixinc); Tcl_InitHashTable(&uniqueCheck, TCL_ONE_WORD_KEYS); for (i = 0; i < mixinc; i++) { mixins[i] = GetClassInOuterContext(interp, mixinv[i], "may only mix in classes"); if (mixins[i] == NULL) { i--; goto freeAndError; } (void) Tcl_CreateHashEntry(&uniqueCheck, (void *) mixins[i], &isNew); if (!isNew) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "class should only be a direct mixin once", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "REPETITIOUS",NULL); goto freeAndError; } if (TclOOIsReachable(oPtr->classPtr, mixins[i])) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "may not mix a class into itself", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "SELF_MIXIN", (void *)NULL); goto freeAndError; } } TclOOClassSetMixins(interp, oPtr->classPtr, mixinc, mixins); Tcl_DeleteHashTable(&uniqueCheck); TclStackFree(interp, mixins); return TCL_OK; freeAndError: Tcl_DeleteHashTable(&uniqueCheck); TclStackFree(interp, mixins); return TCL_ERROR; } /* * ---------------------------------------------------------------------- * |
︙ | ︙ | |||
2942 2943 2944 2945 2946 2947 2948 | TCL_UNUSED(void *), Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv) { Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); | < | | > > > > > > > > > > | > > | > > > > > > | 2957 2958 2959 2960 2961 2962 2963 2964 2965 2966 2967 2968 2969 2970 2971 2972 2973 2974 2975 2976 2977 2978 2979 2980 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 3009 3010 3011 3012 3013 3014 3015 3016 3017 3018 3019 | TCL_UNUSED(void *), Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv) { Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); Tcl_Size mixinc, i; Tcl_Obj **mixinv; Class **mixins; /* The references to the classes to actually * install. */ Tcl_HashTable uniqueCheck; /* Note that this hash table is just used as a * set of class references; it has no payload * values and keys are always pointers. */ int isNew; 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 (TclListObjGetElementsM(interp, objv[0], &mixinc, &mixinv) != TCL_OK) { return TCL_ERROR; } mixins = (Class **)TclStackAlloc(interp, sizeof(Class *) * mixinc); Tcl_InitHashTable(&uniqueCheck, TCL_ONE_WORD_KEYS); for (i = 0; i < mixinc; i++) { mixins[i] = GetClassInOuterContext(interp, mixinv[i], "may only mix in classes"); if (mixins[i] == NULL) { goto freeAndError; } (void) Tcl_CreateHashEntry(&uniqueCheck, (void *) mixins[i], &isNew); if (!isNew) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "class should only be a direct mixin once", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "REPETITIOUS",NULL); goto freeAndError; } } TclOOObjectSetMixins(oPtr, mixinc, mixins); TclStackFree(interp, mixins); Tcl_DeleteHashTable(&uniqueCheck); return TCL_OK; freeAndError: TclStackFree(interp, mixins); Tcl_DeleteHashTable(&uniqueCheck); return TCL_ERROR; } /* * ---------------------------------------------------------------------- * * ObjectVarsGet, ObjectVarsSet -- * |
︙ | ︙ |
Changes to generic/tclObj.c.
︙ | ︙ | |||
2588 2589 2590 2591 2592 2593 2594 | static int SetIntFromAny( Tcl_Interp *interp, /* Tcl interpreter */ Tcl_Obj *objPtr) /* Pointer to the object to convert */ { Tcl_WideInt w; | | | 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 | static int SetIntFromAny( Tcl_Interp *interp, /* Tcl interpreter */ Tcl_Obj *objPtr) /* Pointer to the object to convert */ { Tcl_WideInt w; return TclGetWideIntFromObj(interp, objPtr, &w); } /* *---------------------------------------------------------------------- * * UpdateStringOfInt -- * |
︙ | ︙ | |||
3143 3144 3145 3146 3147 3148 3149 | */ int Tcl_GetSizeIntFromObj( Tcl_Interp *interp, /* Used for error reporting if not NULL. */ Tcl_Obj *objPtr, /* The object from which to get a int. */ Tcl_Size *sizePtr) /* Place to store resulting int. */ { | > | > > > > > > > > | 3143 3144 3145 3146 3147 3148 3149 3150 3151 3152 3153 3154 3155 3156 3157 3158 3159 3160 3161 3162 3163 3164 3165 3166 | */ int Tcl_GetSizeIntFromObj( Tcl_Interp *interp, /* Used for error reporting if not NULL. */ Tcl_Obj *objPtr, /* The object from which to get a int. */ Tcl_Size *sizePtr) /* Place to store resulting int. */ { if (sizeof(Tcl_Size) == sizeof(int)) { return TclGetIntFromObj(interp, objPtr, (int *)sizePtr); } else { Tcl_WideInt wide; if (TclGetWideIntFromObj(interp, objPtr, &wide) != TCL_OK) { return TCL_ERROR; } *sizePtr = (Tcl_Size)wide; return TCL_OK; } } /* *---------------------------------------------------------------------- * * FreeBignum -- * |
︙ | ︙ |
Changes to generic/tclPipe.c.
︙ | ︙ | |||
971 972 973 974 975 976 977 | } if ((errFilePtr != NULL) && (*errFilePtr != NULL)) { TclpCloseFile(*errFilePtr); *errFilePtr = NULL; } if (pidPtr != NULL) { for (i = 0; i < numPids; i++) { | | | 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 | } if ((errFilePtr != NULL) && (*errFilePtr != NULL)) { TclpCloseFile(*errFilePtr); *errFilePtr = NULL; } if (pidPtr != NULL) { for (i = 0; i < numPids; i++) { if (pidPtr[i] != (Tcl_Pid)-1) { Tcl_DetachPids(1, &pidPtr[i]); } } Tcl_Free(pidPtr); } numPids = -1; goto cleanup; |
︙ | ︙ |
Changes to generic/tclProc.c.
︙ | ︙ | |||
492 493 494 495 496 497 498 | if (result != TCL_OK) { goto procError; } if (precompiled) { if (numArgs > procPtr->numArgs) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( | | | | 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 | if (result != TCL_OK) { goto procError; } if (precompiled) { if (numArgs > procPtr->numArgs) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "procedure \"%s\": arg list contains %" TCL_SIZE_MODIFIER "d entries, " "precompiled header expects %" TCL_SIZE_MODIFIER "d", procName, numArgs, procPtr->numArgs)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", "BYTECODELIES", (void *)NULL); goto procError; } localPtr = procPtr->firstLocalPtr; } else { |
︙ | ︙ | |||
587 588 589 590 591 592 593 | if ((localPtr->nameLength != nameLength) || (memcmp(localPtr->name, argname, nameLength) != 0) || (localPtr->frameIndex != i) || !(localPtr->flags & VAR_ARGUMENT) || (localPtr->defValuePtr == NULL && fieldCount == 2) || (localPtr->defValuePtr != NULL && fieldCount != 2)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( | | | 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 | if ((localPtr->nameLength != nameLength) || (memcmp(localPtr->name, argname, nameLength) != 0) || (localPtr->frameIndex != i) || !(localPtr->flags & VAR_ARGUMENT) || (localPtr->defValuePtr == NULL && fieldCount == 2) || (localPtr->defValuePtr != NULL && fieldCount != 2)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "procedure \"%s\": formal parameter %" TCL_SIZE_MODIFIER "d is " "inconsistent with precompiled body", procName, i)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", "BYTECODELIES", (void *)NULL); goto procError; } /* |
︙ | ︙ | |||
780 781 782 783 784 785 786 | * Check for integer first, since that has potential to spare us * a generation of a stringrep. */ if (objPtr == NULL) { /* Do nothing */ } else if (TCL_OK == Tcl_GetIntFromObj(NULL, objPtr, &level)) { | | | 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 | * Check for integer first, since that has potential to spare us * a generation of a stringrep. */ if (objPtr == NULL) { /* Do nothing */ } else if (TCL_OK == Tcl_GetIntFromObj(NULL, objPtr, &level)) { TclGetWideIntFromObj(NULL, objPtr, &w); if (w < 0 || w > INT_MAX || curLevel > w + INT_MAX) { result = -1; } else { level = curLevel - level; result = 1; } } else if ((irPtr = TclFetchInternalRep(objPtr, &levelReferenceType))) { |
︙ | ︙ | |||
1745 1746 1747 1748 1749 1750 1751 | l++; } TCL_DTRACE_PROC_ARGS(a[0], a[1], a[2], a[3], a[4], a[5], a[6], a[7], a[8], a[9]); } if (TCL_DTRACE_PROC_INFO_ENABLED() && iPtr->cmdFramePtr) { Tcl_Obj *info = TclInfoFrame(interp, iPtr->cmdFramePtr); | | | 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 | l++; } TCL_DTRACE_PROC_ARGS(a[0], a[1], a[2], a[3], a[4], a[5], a[6], a[7], a[8], a[9]); } if (TCL_DTRACE_PROC_INFO_ENABLED() && iPtr->cmdFramePtr) { Tcl_Obj *info = TclInfoFrame(interp, iPtr->cmdFramePtr); const char *a[6]; Tcl_Size i[2]; TclDTraceInfo(info, a, i); TCL_DTRACE_PROC_INFO(a[0], a[1], a[2], a[3], i[0], i[1], a[4], a[5]); TclDecrRefCount(info); } if (TCL_DTRACE_PROC_ENTRY_ENABLED()) { Tcl_Size l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0; |
︙ | ︙ |
Changes to generic/tclProcess.c.
︙ | ︙ | |||
40 41 42 43 44 45 46 | TCL_DECLARE_MUTEX(infoTablesMutex) /* * Prototypes for functions defined later in this file: */ static void InitProcessInfo(ProcessInfo *info, Tcl_Pid pid, | | | | 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 | TCL_DECLARE_MUTEX(infoTablesMutex) /* * Prototypes for functions defined later in this file: */ static void InitProcessInfo(ProcessInfo *info, Tcl_Pid pid, Tcl_Size resolvedPid); static void FreeProcessInfo(ProcessInfo *info); static int RefreshProcessInfo(ProcessInfo *info, int options); static TclProcessWaitStatus WaitProcessStatus(Tcl_Pid pid, Tcl_Size resolvedPid, int options, int *codePtr, Tcl_Obj **msgPtr, Tcl_Obj **errorObjPtr); static Tcl_Obj * BuildProcessStatusObj(ProcessInfo *info); static Tcl_ObjCmdProc ProcessListObjCmd; static Tcl_ObjCmdProc ProcessStatusObjCmd; static Tcl_ObjCmdProc ProcessPurgeObjCmd; static Tcl_ObjCmdProc ProcessAutopurgeObjCmd; |
︙ | ︙ | |||
72 73 74 75 76 77 78 | *---------------------------------------------------------------------- */ void InitProcessInfo( ProcessInfo *info, /* Structure to initialize. */ Tcl_Pid pid, /* Process id. */ | | | 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 | *---------------------------------------------------------------------- */ void InitProcessInfo( ProcessInfo *info, /* Structure to initialize. */ Tcl_Pid pid, /* Process id. */ Tcl_Size resolvedPid) /* Resolved process id. */ { info->pid = pid; info->resolvedPid = resolvedPid; info->purge = 0; info->status = TCL_PROCESS_UNCHANGED; info->code = 0; info->msg = NULL; |
︙ | ︙ | |||
181 182 183 184 185 186 187 | * *---------------------------------------------------------------------- */ TclProcessWaitStatus WaitProcessStatus( Tcl_Pid pid, /* Process id. */ | | | 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 | * *---------------------------------------------------------------------- */ TclProcessWaitStatus WaitProcessStatus( Tcl_Pid pid, /* Process id. */ Tcl_Size resolvedPid, /* Resolved process id. */ int options, /* Options passed to Tcl_WaitPid. */ int *codePtr, /* If non-NULL, will receive either: * - 0 for normal exit. * - errno in case of error. * - non-zero exit code for abormal exit. * - signal number if killed or suspended. * - Tcl_WaitPid status in all other cases. |
︙ | ︙ | |||
785 786 787 788 789 790 791 | *---------------------------------------------------------------------- */ void TclProcessCreated( Tcl_Pid pid) /* Process id. */ { | | | 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 | *---------------------------------------------------------------------- */ void TclProcessCreated( Tcl_Pid pid) /* Process id. */ { Tcl_Size resolvedPid; Tcl_HashEntry *entry, *entry2; int isNew; ProcessInfo *info; /* * Get resolved pid first. */ |
︙ | ︙ |
Changes to generic/tclScan.c.
︙ | ︙ | |||
938 939 940 941 942 943 944 | } string = end; if (flags & SCAN_SUPPRESS) { Tcl_DecrRefCount(objPtr); break; } if (flags & SCAN_LONGER) { | | | 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 | } string = end; if (flags & SCAN_SUPPRESS) { Tcl_DecrRefCount(objPtr); break; } if (flags & SCAN_LONGER) { if (TclGetWideIntFromObj(NULL, objPtr, &wideValue) != TCL_OK) { if (TclGetString(objPtr)[0] == '-') { wideValue = WIDE_MIN; } else { wideValue = WIDE_MAX; } } if ((flags & SCAN_UNSIGNED) && (wideValue < 0)) { |
︙ | ︙ |
Changes to generic/tclStringObj.c.
︙ | ︙ | |||
1844 1845 1846 1847 1848 1849 1850 | * Format string is NUL-terminated. */ while (*format != '\0') { char *end; int gotMinus = 0, gotHash = 0, gotZero = 0, gotSpace = 0, gotPlus = 0; int gotPrecision, sawFlag, useShort = 0, useBig = 0; | | | 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 | * Format string is NUL-terminated. */ while (*format != '\0') { char *end; int gotMinus = 0, gotHash = 0, gotZero = 0, gotSpace = 0, gotPlus = 0; int gotPrecision, sawFlag, useShort = 0, useBig = 0; Tcl_WideInt width, precision; #ifndef TCL_WIDE_INT_IS_LONG int useWide = 0; #endif int newXpg, allocSegment = 0; Tcl_Size numChars, segmentLimit, segmentNumBytes; Tcl_Obj *segment; int step = TclUtfToUniChar(format, &ch); |
︙ | ︙ | |||
1960 1961 1962 1963 1964 1965 1966 | width = 0; if (isdigit(UCHAR(ch))) { /* Note ull will be >= 0 because of isdigit check above */ unsigned long long ull; ull = strtoull(format, &end, 10); /* Comparison is >=, not >, to leave room for nul */ | | | | | 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 1986 1987 1988 | width = 0; if (isdigit(UCHAR(ch))) { /* Note ull will be >= 0 because of isdigit check above */ unsigned long long ull; ull = strtoull(format, &end, 10); /* Comparison is >=, not >, to leave room for nul */ if (ull >= WIDE_MAX) { msg = overflow; errCode = "OVERFLOW"; goto errorMsg; } width = (Tcl_WideInt)ull; format = end; step = TclUtfToUniChar(format, &ch); } else if (ch == '*') { if (objIndex >= objc - 1) { msg = badIndex[gotXpg]; errCode = gotXpg ? "INDEXRANGE" : "FIELDVARMISMATCH"; goto errorMsg; } if (TclGetWideIntFromObj(interp, objv[objIndex], &width) != TCL_OK) { goto error; } if (width < 0) { width = -width; gotMinus = 1; } objIndex++; |
︙ | ︙ | |||
2006 2007 2008 2009 2010 2011 2012 | step = TclUtfToUniChar(format, &ch); } if (isdigit(UCHAR(ch))) { /* Note ull will be >= 0 because of isdigit check above */ unsigned long long ull; ull = strtoull(format, &end, 10); /* Comparison is >=, not >, to leave room for nul */ | | | | | 2006 2007 2008 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 | step = TclUtfToUniChar(format, &ch); } if (isdigit(UCHAR(ch))) { /* Note ull will be >= 0 because of isdigit check above */ unsigned long long ull; ull = strtoull(format, &end, 10); /* Comparison is >=, not >, to leave room for nul */ if (ull >= WIDE_MAX) { msg = overflow; errCode = "OVERFLOW"; goto errorMsg; } precision = (Tcl_WideInt)ull; format = end; step = TclUtfToUniChar(format, &ch); } else if (ch == '*') { if (objIndex >= objc - 1) { msg = badIndex[gotXpg]; errCode = gotXpg ? "INDEXRANGE" : "FIELDVARMISMATCH"; goto errorMsg; } if (TclGetWideIntFromObj(interp, objv[objIndex], &precision) != TCL_OK) { goto error; } /* * TODO: Check this truncation logic. */ |
︙ | ︙ | |||
2467 2468 2469 2470 2471 2472 2473 | if (gotSpace) { *p++ = ' '; } if (gotPlus) { *p++ = '+'; } if (width) { | | < | < | 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 | if (gotSpace) { *p++ = ' '; } if (gotPlus) { *p++ = '+'; } if (width) { p += snprintf(p, TCL_INTEGER_SPACE, "%" TCL_LL_MODIFIER "d", width); if (width > length) { length = width; } } if (gotPrecision) { *p++ = '.'; p += snprintf(p, TCL_INTEGER_SPACE, "%" TCL_LL_MODIFIER "d", precision); if (precision > TCL_SIZE_MAX - length) { msg = overflow; errCode = "OVERFLOW"; goto errorMsg; } length += precision; } |
︙ | ︙ | |||
3466 3467 3468 3469 3470 3471 3472 3473 3474 3475 3476 3477 3478 3479 | * Side effects: * String representations may be generated. Internal representation may * be changed. * *--------------------------------------------------------------------------- */ int TclStringCmp( Tcl_Obj *value1Ptr, Tcl_Obj *value2Ptr, int checkEq, /* comparison is only for equality */ int nocase, /* comparison is not case sensitive */ Tcl_Size reqlength) /* requested length in characters; | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 3464 3465 3466 3467 3468 3469 3470 3471 3472 3473 3474 3475 3476 3477 3478 3479 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 | * Side effects: * String representations may be generated. Internal representation may * be changed. * *--------------------------------------------------------------------------- */ static int UniCharNcasememcmp( const void *ucsPtr, /* Unicode string to compare to uct. */ const void *uctPtr, /* Unicode string ucs is compared to. */ size_t numChars) /* Number of Unichars to compare. */ { const Tcl_UniChar *ucs = (const Tcl_UniChar *)ucsPtr; const Tcl_UniChar *uct = (const Tcl_UniChar *)uctPtr; for ( ; numChars != 0; numChars--, ucs++, uct++) { if (*ucs != *uct) { Tcl_UniChar lcs = Tcl_UniCharToLower(*ucs); Tcl_UniChar lct = Tcl_UniCharToLower(*uct); if (lcs != lct) { return (lcs - lct); } } } return 0; } static int UtfNmemcmp( const void *csPtr, /* UTF string to compare to ct. */ const void *ctPtr, /* UTF string cs is compared to. */ size_t numChars) /* Number of UTF chars to compare. */ { Tcl_UniChar ch1 = 0, ch2 = 0; const char *cs = (const char *)csPtr; const char *ct = (const char *)ctPtr; /* * Cannot use 'memcmp(cs, ct, n);' as byte representation of \u0000 (the * pair of bytes 0xC0,0x80) is larger than byte representation of \u0001 * (the byte 0x01.) */ while (numChars-- > 0) { /* * n must be interpreted as chars, not bytes. This should be called * only when both strings are of at least n chars long (no need for \0 * check) */ cs += TclUtfToUniChar(cs, &ch1); ct += TclUtfToUniChar(ct, &ch2); if (ch1 != ch2) { return (ch1 - ch2); } } return 0; } static int UtfNcasememcmp( const void *csPtr, /* UTF string to compare to ct. */ const void *ctPtr, /* UTF string cs is compared to. */ size_t numChars) /* Number of UTF chars to compare. */ { Tcl_UniChar ch1 = 0, ch2 = 0; const char *cs = (const char *)csPtr; const char *ct = (const char *)ctPtr; while (numChars-- > 0) { /* * n must be interpreted as chars, not bytes. * This should be called only when both strings are of * at least n chars long (no need for \0 check) */ cs += TclUtfToUniChar(cs, &ch1); ct += TclUtfToUniChar(ct, &ch2); if (ch1 != ch2) { ch1 = Tcl_UniCharToLower(ch1); ch2 = Tcl_UniCharToLower(ch2); if (ch1 != ch2) { return (ch1 - ch2); } } } return 0; } static int UniCharNmemcmp( const void *ucsPtr, /* Unicode string to compare to uct. */ const void *uctPtr, /* Unicode string ucs is compared to. */ size_t numChars) /* Number of unichars to compare. */ { const Tcl_UniChar *ucs = (const Tcl_UniChar *)ucsPtr; const Tcl_UniChar *uct = (const Tcl_UniChar *)uctPtr; #if defined(WORDS_BIGENDIAN) /* * We are definitely on a big-endian machine; memcmp() is safe */ return memcmp(ucs, uct, numChars*sizeof(Tcl_UniChar)); #else /* !WORDS_BIGENDIAN */ /* * We can't simply call memcmp() because that is not lexically correct. */ for ( ; numChars != 0; ucs++, uct++, numChars--) { if (*ucs != *uct) { return (*ucs - *uct); } } return 0; #endif /* WORDS_BIGENDIAN */ } int TclStringCmp( Tcl_Obj *value1Ptr, Tcl_Obj *value2Ptr, int checkEq, /* comparison is only for equality */ int nocase, /* comparison is not case sensitive */ Tcl_Size reqlength) /* requested length in characters; |
︙ | ︙ | |||
3511 3512 3513 3514 3515 3516 3517 | * benchmark testing this proved the most efficient check between the * Unicode and string comparison operations. */ if (nocase) { s1 = (char *) Tcl_GetUnicodeFromObj(value1Ptr, &s1len); s2 = (char *) Tcl_GetUnicodeFromObj(value2Ptr, &s2len); | | | 3621 3622 3623 3624 3625 3626 3627 3628 3629 3630 3631 3632 3633 3634 3635 | * benchmark testing this proved the most efficient check between the * Unicode and string comparison operations. */ if (nocase) { s1 = (char *) Tcl_GetUnicodeFromObj(value1Ptr, &s1len); s2 = (char *) Tcl_GetUnicodeFromObj(value2Ptr, &s2len); memCmpFn = UniCharNcasememcmp; } else { s1len = Tcl_GetCharLength(value1Ptr); s2len = Tcl_GetCharLength(value2Ptr); if ((s1len == value1Ptr->length) && (value1Ptr->bytes != NULL) && (s2len == value2Ptr->length) && (value2Ptr->bytes != NULL)) { |
︙ | ︙ | |||
3542 3543 3544 3545 3546 3547 3548 | memCmpFn = memcmp; s1len *= sizeof(Tcl_UniChar); s2len *= sizeof(Tcl_UniChar); if (reqlength > 0) { reqlength *= sizeof(Tcl_UniChar); } } else { | | | 3652 3653 3654 3655 3656 3657 3658 3659 3660 3661 3662 3663 3664 3665 3666 | memCmpFn = memcmp; s1len *= sizeof(Tcl_UniChar); s2len *= sizeof(Tcl_UniChar); if (reqlength > 0) { reqlength *= sizeof(Tcl_UniChar); } } else { memCmpFn = UniCharNmemcmp; } } } } else { empty = TclCheckEmptyString(value1Ptr); if (empty > 0) { switch (TclCheckEmptyString(value2Ptr)) { |
︙ | ︙ | |||
3600 3601 3602 3603 3604 3605 3606 | * memcmp() as that is unsafe with any string containing NUL * (\xC0\x80 in Tcl's utf rep). We can use the more efficient * TclpUtfNcmp2 if we are case-sensitive and no specific * length was requested. */ if ((reqlength < 0) && !nocase) { | | | < | 3710 3711 3712 3713 3714 3715 3716 3717 3718 3719 3720 3721 3722 3723 3724 3725 3726 3727 3728 | * memcmp() as that is unsafe with any string containing NUL * (\xC0\x80 in Tcl's utf rep). We can use the more efficient * TclpUtfNcmp2 if we are case-sensitive and no specific * length was requested. */ if ((reqlength < 0) && !nocase) { memCmpFn = TclpUtfNcmp2; } else { s1len = Tcl_NumUtfChars(s1, s1len); s2len = Tcl_NumUtfChars(s2, s2len); memCmpFn = nocase ? UtfNcasememcmp : UtfNmemcmp; } } } /* At this point s1len, s2len, and reqlength should by now have been * adjusted so that they are all in the units expected by the selected * comparison function. |
︙ | ︙ |
Changes to generic/tclStubCall.c.
︙ | ︙ | |||
35 36 37 38 39 40 41 | * only the first 4 functions in the table can do that. * *---------------------------------------------------------------------- */ /* Table containing which function will be returned, depending on the "arg" */ static const char PROCNAME[][24] = { | | | 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 | * only the first 4 functions in the table can do that. * *---------------------------------------------------------------------- */ /* Table containing which function will be returned, depending on the "arg" */ static const char PROCNAME[][24] = { "_Tcl_SetPanicProc", /* Default, whenever "arg" <= 0 or "arg" > 9 */ "_Tcl_InitSubsystems", /* "arg" == (void *)1 */ "_Tcl_FindExecutable", /* "arg" == (void *)2 */ "_TclZipfs_AppHook", /* "arg" == (void *)3 */ "_Tcl_MainExW", /* "arg" == (void *)4 */ "_Tcl_MainEx", /* "arg" == (void *)5 */ "_Tcl_StaticLibrary", /* "arg" == (void *)6 */ "_Tcl_SetExitProc", /* "arg" == (void *)7 */ |
︙ | ︙ |
Changes to generic/tclStubInit.c.
︙ | ︙ | |||
58 59 60 61 62 63 64 | #undef Tcl_ListObjGetElements #undef Tcl_ListObjLength #undef Tcl_DictObjSize #undef Tcl_SplitList #undef Tcl_SplitPath #undef Tcl_FSSplitPath #undef Tcl_ParseArgsObjv | < < < < < < | 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 | #undef Tcl_ListObjGetElements #undef Tcl_ListObjLength #undef Tcl_DictObjSize #undef Tcl_SplitList #undef Tcl_SplitPath #undef Tcl_FSSplitPath #undef Tcl_ParseArgsObjv #undef TclStaticLibrary #define TclStaticLibrary Tcl_StaticLibrary #undef Tcl_UniCharToUtfDString #undef Tcl_UtfToUniCharDString #undef Tcl_UtfToUniChar #undef Tcl_UniCharLen #undef TclObjInterpProc #if !defined(_WIN32) && !defined(__CYGWIN__) |
︙ | ︙ | |||
290 291 292 293 294 295 296 | #elif defined(__CYGWIN__) # define TclpIsAtty isatty static void doNothing(void) { /* dummy implementation, no need to do anything */ } | | | 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 | #elif defined(__CYGWIN__) # define TclpIsAtty isatty static void doNothing(void) { /* dummy implementation, no need to do anything */ } # define TclWinAddProcess (void (*) (void *, Tcl_Size)) doNothing # define TclWinFlushDirtyChannels doNothing #define TclWinNoBackslash winNoBackslash static char * TclWinNoBackslash(char *path) { char *p; |
︙ | ︙ | |||
315 316 317 318 319 320 321 | { void *hInstance = NULL; GetModuleHandleExW(GET_MODULE_HANDLE_EX_FLAG_FROM_ADDRESS, (const wchar_t *)&TclWinNoBackslash, &hInstance); return hInstance; } | | | | 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 | { void *hInstance = NULL; GetModuleHandleExW(GET_MODULE_HANDLE_EX_FLAG_FROM_ADDRESS, (const wchar_t *)&TclWinNoBackslash, &hInstance); return hInstance; } Tcl_Size TclpGetPid(Tcl_Pid pid) { return (Tcl_Size)PTR2INT(pid); } #if defined(TCL_WIDE_INT_IS_LONG) /* On Cygwin64, long is 64-bit while on Win64 long is 32-bit. Therefore * we have to make sure that all stub entries on Cygwin64 follow the Win64 * signature. Tcl 9 must find a better solution, but that cannot be done * without introducing a binary incompatibility. |
︙ | ︙ | |||
553 554 555 556 557 558 559 | TclGetAuxDataType, /* 145 */ TclHandleCreate, /* 146 */ TclHandleFree, /* 147 */ TclHandlePreserve, /* 148 */ TclHandleRelease, /* 149 */ TclRegAbout, /* 150 */ TclRegExpRangeUniChar, /* 151 */ | | | | 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 | TclGetAuxDataType, /* 145 */ TclHandleCreate, /* 146 */ TclHandleFree, /* 147 */ TclHandlePreserve, /* 148 */ TclHandleRelease, /* 149 */ TclRegAbout, /* 150 */ TclRegExpRangeUniChar, /* 151 */ 0, /* 152 */ 0, /* 153 */ 0, /* 154 */ 0, /* 155 */ TclRegError, /* 156 */ TclVarTraceExists, /* 157 */ 0, /* 158 */ 0, /* 159 */ 0, /* 160 */ |
︙ | ︙ |
Changes to generic/tclTest.c.
︙ | ︙ | |||
11 12 13 14 15 16 17 18 19 20 21 22 23 24 | * Copyright © 1998-2000 Ajuba Solutions. * Copyright © 2003 Kevin B. Kenny. All rights reserved. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #undef BUILD_tcl #undef STATIC_BUILD #ifndef USE_TCL_STUBS # define USE_TCL_STUBS #endif #include "tclInt.h" #ifdef TCL_WITH_EXTERNAL_TOMMATH | > | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 | * Copyright © 1998-2000 Ajuba Solutions. * Copyright © 2003 Kevin B. Kenny. All rights reserved. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #define TCL_8_API #undef BUILD_tcl #undef STATIC_BUILD #ifndef USE_TCL_STUBS # define USE_TCL_STUBS #endif #include "tclInt.h" #ifdef TCL_WITH_EXTERNAL_TOMMATH |
︙ | ︙ | |||
288 289 290 291 292 293 294 | static Tcl_CmdProc TestChannelCmd; static Tcl_CmdProc TestChannelEventCmd; static Tcl_CmdProc TestSocketCmd; static Tcl_ObjCmdProc TestFilesystemObjCmd; static Tcl_ObjCmdProc TestSimpleFilesystemObjCmd; static void TestReport(const char *cmd, Tcl_Obj *arg1, Tcl_Obj *arg2); | < < | 289 290 291 292 293 294 295 296 297 298 299 300 301 302 | static Tcl_CmdProc TestChannelCmd; static Tcl_CmdProc TestChannelEventCmd; static Tcl_CmdProc TestSocketCmd; static Tcl_ObjCmdProc TestFilesystemObjCmd; static Tcl_ObjCmdProc TestSimpleFilesystemObjCmd; static void TestReport(const char *cmd, Tcl_Obj *arg1, Tcl_Obj *arg2); static Tcl_Obj * TestReportGetNativePath(Tcl_Obj *pathPtr); static Tcl_FSStatProc TestReportStat; static Tcl_FSAccessProc TestReportAccess; static Tcl_FSOpenFileChannelProc TestReportOpenFileChannel; static Tcl_FSMatchInDirectoryProc TestReportMatchInDirectory; static Tcl_FSChdirProc TestReportChdir; static Tcl_FSLstatProc TestReportLstat; |
︙ | ︙ | |||
717 718 719 720 721 722 723 | #endif Tcl_CreateObjCommand(interp, "testnreunwind", TestNREUnwind, NULL, NULL); Tcl_CreateObjCommand(interp, "testnrelevels", TestNRELevels, NULL, NULL); Tcl_CreateObjCommand(interp, "testinterpresolver", TestInterpResolverCmd, NULL, NULL); | < < < < | 716 717 718 719 720 721 722 723 724 725 726 727 728 729 | #endif Tcl_CreateObjCommand(interp, "testnreunwind", TestNREUnwind, NULL, NULL); Tcl_CreateObjCommand(interp, "testnrelevels", TestNRELevels, NULL, NULL); Tcl_CreateObjCommand(interp, "testinterpresolver", TestInterpResolverCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testapplylambda", TestApplyLambdaObjCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testlutil", TestLutilCmd, NULL, NULL); if (TclObjTest_Init(interp) != TCL_OK) { return TCL_ERROR; |
︙ | ︙ | |||
2126 2127 2128 2129 2130 2131 2132 | Tcl_Size nflags; static const struct { const char *flagKey; int flag; } flagMap[] = { {"start", TCL_ENCODING_START}, {"end", TCL_ENCODING_END}, | < > | 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 | Tcl_Size nflags; static const struct { const char *flagKey; int flag; } flagMap[] = { {"start", TCL_ENCODING_START}, {"end", TCL_ENCODING_END}, {"noterminate", TCL_ENCODING_NO_TERMINATE}, {"charlimit", TCL_ENCODING_CHAR_LIMIT}, {"profiletcl8", TCL_ENCODING_PROFILE_TCL8}, {"profilestrict", TCL_ENCODING_PROFILE_STRICT}, {"profilereplace", TCL_ENCODING_PROFILE_REPLACE}, {"profilelossless", TCL_ENCODING_PROFILE_LOSSLESS}, {NULL, 0} }; Tcl_Size i; Tcl_WideInt wide; if (objc < 7 || objc > 10) { Tcl_WrongNumArgs(interp, |
︙ | ︙ | |||
3852 3853 3854 3855 3856 3857 3858 | TestlistrepCmd( TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { /* Subcommands supported by this command */ | | | 3847 3848 3849 3850 3851 3852 3853 3854 3855 3856 3857 3858 3859 3860 3861 | TestlistrepCmd( TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { /* Subcommands supported by this command */ static const char *const subcommands[] = { "new", "describe", "config", "validate", NULL }; enum { |
︙ | ︙ | |||
5767 5768 5769 5770 5771 5772 5773 | TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ { struct { #if !defined(TCL_NO_DEPRECATED) | < < < < < < < < < | 5762 5763 5764 5765 5766 5767 5768 5769 5770 5771 5772 5773 5774 5775 5776 5777 5778 5779 5780 5781 5782 5783 5784 5785 5786 5787 5788 5789 5790 5791 5792 | TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ { struct { #if !defined(TCL_NO_DEPRECATED) int n; /* On purpose, not Tcl_Size, in order to demonstrate what happens */ #else Tcl_Size n; #endif int m; /* This variable should not be overwritten */ } x = {0, 1}; const char *p; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "bytearray"); return TCL_ERROR; } p = (const char *)Tcl_GetBytesFromObj(interp, objv[1], &x.n); if (p == NULL) { return TCL_ERROR; } if (x.m != 1) { Tcl_AppendResult(interp, "Tcl_GetBytesFromObj() overwrites variable", (void *)NULL); return TCL_ERROR; } Tcl_SetObjResult(interp, Tcl_NewStringObj(p, x.n)); return TCL_OK; |
︙ | ︙ | |||
8287 8288 8289 8290 8291 8292 8293 | if (result == TCL_OK) { Tcl_ResetResult(interp); } return result; } | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 8273 8274 8275 8276 8277 8278 8279 8280 8281 8282 8283 8284 8285 8286 | if (result == TCL_OK) { Tcl_ResetResult(interp); } return result; } /* *---------------------------------------------------------------------- * * TestparseargsCmd -- * * This procedure implements the "testparseargs" command. It is used to * test that Tcl_ParseArgsObjv does indeed return the right number of |
︙ | ︙ |
Changes to generic/tclTestObj.c.
︙ | ︙ | |||
148 149 150 151 152 153 154 | static int TestbignumobjCmd( TCL_UNUSED(void *), Tcl_Interp *interp, /* Tcl interpreter */ int objc, /* Argument count */ Tcl_Obj *const objv[]) /* Argument vector */ { | | | 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 | static int TestbignumobjCmd( TCL_UNUSED(void *), Tcl_Interp *interp, /* Tcl interpreter */ int objc, /* Argument count */ Tcl_Obj *const objv[]) /* Argument vector */ { static const char *const subcmds[] = { "set", "get", "mult10", "div10", "iseven", "radixsize", NULL }; enum options { BIGNUM_SET, BIGNUM_GET, BIGNUM_MULT10, BIGNUM_DIV10, BIGNUM_ISEVEN, BIGNUM_RADIXSIZE } idx; int index; |
︙ | ︙ | |||
882 883 884 885 886 887 888 | TestlistobjCmd( TCL_UNUSED(void *), Tcl_Interp *interp, /* Tcl interpreter */ int objc, /* Number of arguments */ Tcl_Obj *const objv[]) /* Argument objects */ { /* Subcommands supported by this command */ | | | 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 | TestlistobjCmd( TCL_UNUSED(void *), Tcl_Interp *interp, /* Tcl interpreter */ int objc, /* Number of arguments */ Tcl_Obj *const objv[]) /* Argument objects */ { /* Subcommands supported by this command */ static const char* const subcommands[] = { "set", "get", "replace", "indexmemcheck", "getelementsmemcheck", "index", NULL |
︙ | ︙ | |||
1085 1086 1087 1088 1089 1090 1091 | int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Size varIndex, destIndex; int i; const Tcl_ObjType *targetType; Tcl_Obj **varPtr; | | | 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 | int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Size varIndex, destIndex; int i; const Tcl_ObjType *targetType; Tcl_Obj **varPtr; static const char *const subcommands[] = { "freeallvars", "bug3598580", "buge58d7e19e9", "types", "objtype", "newobj", "set", "assign", "convert", "duplicate", "invalidateStringRep", "refcount", "type", NULL }; enum testobjCmdIndex { |
︙ | ︙ | |||
1616 1617 1618 1619 1620 1621 1622 | "string", "bytearray", "list", "dict", NULL }; enum options { BIGDATA_STRING, BIGDATA_BYTEARRAY, BIGDATA_LIST, BIGDATA_DICT } idx; char *s; unsigned char *p; | | | | | < | | 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 | "string", "bytearray", "list", "dict", NULL }; enum options { BIGDATA_STRING, BIGDATA_BYTEARRAY, BIGDATA_LIST, BIGDATA_DICT } idx; char *s; unsigned char *p; Tcl_Size i, len, split; Tcl_DString ds; Tcl_Obj *objPtr; #define PATTERN_LEN 10 Tcl_Obj *patternObjs[PATTERN_LEN]; if (objc < 2 || objc > 4) { Tcl_WrongNumArgs(interp, 1, objv, "command ?len? ?split?"); return TCL_ERROR; } if (Tcl_GetIndexFromObj(interp, objv[1], subcmds, "option", 0, &idx) != TCL_OK) { return TCL_ERROR; } split = -1; if (objc == 2) { len = PATTERN_LEN; } else { if (Tcl_GetSizeIntFromObj(interp, objv[2], &len) != TCL_OK) { return TCL_ERROR; } if (objc == 4) { if (Tcl_GetSizeIntFromObj(interp, objv[3], &split) != TCL_OK) { return TCL_ERROR; } if (split >= len) { split = len - 1; /* Last position */ } } } /* Need one byte for nul terminator */ Tcl_Size limit = TCL_SIZE_MAX-1; if (len < 0 || len > limit) { Tcl_SetObjResult( interp, Tcl_ObjPrintf( "%s is greater than max permitted length %" TCL_SIZE_MODIFIER "d", Tcl_GetString(objv[2]), limit)); return TCL_ERROR; } switch (idx) { case BIGDATA_STRING: |
︙ | ︙ |
Changes to generic/tclTimer.c.
︙ | ︙ | |||
813 814 815 816 817 818 819 | Tcl_SetAssocData(interp, "tclAfter", AfterCleanupProc, assocPtr); } /* * First lets see if the command was passed a number as the first argument. */ | | | 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 | Tcl_SetAssocData(interp, "tclAfter", AfterCleanupProc, assocPtr); } /* * First lets see if the command was passed a number as the first argument. */ if (TclGetWideIntFromObj(NULL, objv[1], &ms) != TCL_OK) { if (Tcl_GetIndexFromObj(NULL, objv[1], afterSubCmds, "", 0, &index) != TCL_OK) { const char *arg = TclGetString(objv[1]); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad argument \"%s\": must be" " cancel, idle, info, or an integer", arg)); |
︙ | ︙ |
Changes to generic/tclUtf.c.
︙ | ︙ | |||
200 201 202 203 204 205 206 | * * Side effects: * None. * *--------------------------------------------------------------------------- */ | < | | 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 | * * Side effects: * None. * *--------------------------------------------------------------------------- */ Tcl_Size Tcl_UniCharToUtf( int ch, /* The Tcl_UniChar to be stored in the * buffer. Can be or'ed with flag TCL_COMBINE. */ char *buf) /* Buffer in which the UTF-8 representation of * ch is stored. Must be large enough to hold the UTF-8 * character (at most 4 bytes). */ { int flags = ch; |
︙ | ︙ | |||
227 228 229 230 231 232 233 | if (ch >= 0) { if (ch <= 0x7FF) { buf[1] = (char) (0x80 | (0x3F & ch)); buf[0] = (char) (0xC0 | (ch >> 6)); return 2; } if (ch <= 0xFFFF) { | < | | 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 | if (ch >= 0) { if (ch <= 0x7FF) { buf[1] = (char) (0x80 | (0x3F & ch)); buf[0] = (char) (0xC0 | (ch >> 6)); return 2; } if (ch <= 0xFFFF) { if ((flags & TCL_COMBINE) && ((ch & 0xF800) == 0xD800)) { if (ch & 0x0400) { /* Low surrogate */ if ( (0x80 == (0xC0 & buf[0])) && (0 == (0xCF & buf[1]))) { /* Previous Tcl_UniChar was a high surrogate, so combine */ buf[2] = (char) (0x80 | (0x3F & ch)); |
︙ | ︙ | |||
306 307 308 309 310 311 312 | * * Side effects: * None. * *--------------------------------------------------------------------------- */ | < | | 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 | * * Side effects: * None. * *--------------------------------------------------------------------------- */ char * Tcl_UniCharToUtfDString( const int *uniStr, /* Unicode string to convert to UTF-8. */ Tcl_Size uniLength, /* Length of Unicode string. Negative for nul * terminated string */ Tcl_DString *dsPtr) /* UTF-8 representation of string is appended * to this previously initialized DString. */ { const int *w, *wEnd; char *p, *string; Tcl_Size oldLength; |
︙ | ︙ | |||
359 360 361 362 363 364 365 | const unsigned short *uniStr,/* Utf-16 string to convert to UTF-8. */ Tcl_Size uniLength, /* Length of Utf-16 string. */ Tcl_DString *dsPtr) /* UTF-8 representation of string is appended * to this previously initialized DString. */ { const unsigned short *w, *wEnd; char *p, *string; | | | 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 | const unsigned short *uniStr,/* Utf-16 string to convert to UTF-8. */ Tcl_Size uniLength, /* Length of Utf-16 string. */ Tcl_DString *dsPtr) /* UTF-8 representation of string is appended * to this previously initialized DString. */ { const unsigned short *w, *wEnd; char *p, *string; Tcl_Size oldLength; int len = 1; /* * UTF-8 string length in bytes will be <= Utf16 string length * 3. */ if (uniStr == NULL) { |
︙ | ︙ | |||
438 439 440 441 442 443 444 | static const unsigned short cp1252[32] = { 0x20AC, 0x81, 0x201A, 0x0192, 0x201E, 0x2026, 0x2020, 0x2021, 0x02C6, 0x2030, 0x0160, 0x2039, 0x0152, 0x8D, 0x017D, 0x8F, 0x90, 0x2018, 0x2019, 0x201C, 0x201D, 0x2022, 0x2013, 0x2014, 0x2DC, 0x2122, 0x0161, 0x203A, 0x0153, 0x9D, 0x017E, 0x0178 }; | < | 435 436 437 438 439 440 441 442 443 444 445 446 447 448 | static const unsigned short cp1252[32] = { 0x20AC, 0x81, 0x201A, 0x0192, 0x201E, 0x2026, 0x2020, 0x2021, 0x02C6, 0x2030, 0x0160, 0x2039, 0x0152, 0x8D, 0x017D, 0x8F, 0x90, 0x2018, 0x2019, 0x201C, 0x201D, 0x2022, 0x2013, 0x2014, 0x2DC, 0x2122, 0x0161, 0x203A, 0x0153, 0x9D, 0x017E, 0x0178 }; Tcl_Size Tcl_UtfToUniChar( const char *src, /* The UTF-8 string. */ int *chPtr)/* Filled with the Unicode character represented by * the UTF-8 string. */ { int byte; |
︙ | ︙ | |||
639 640 641 642 643 644 645 | * * Side effects: * None. * *--------------------------------------------------------------------------- */ | < | 635 636 637 638 639 640 641 642 643 644 645 646 647 648 | * * Side effects: * None. * *--------------------------------------------------------------------------- */ int * Tcl_UtfToUniCharDString( const char *src, /* UTF-8 string to convert to Unicode. */ Tcl_Size length, /* Length of UTF-8 string in bytes, or -1 for * strlen(). */ Tcl_DString *dsPtr) /* Unicode representation of string is * appended to this previously initialized |
︙ | ︙ | |||
1007 1008 1009 1010 1011 1012 1013 | *--------------------------------------------------------------------------- */ const char * Tcl_UtfNext( const char *src) /* The current location in the string. */ { | | | 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 | *--------------------------------------------------------------------------- */ const char * Tcl_UtfNext( const char *src) /* The current location in the string. */ { int left; const char *next; if (((*src) & 0xC0) == 0x80) { /* Continuation byte, so we start 'inside' a (possible valid) UTF-8 * sequence. Since we are not allowed to access src[-1], we cannot * check if the sequence is actually valid, the best we can do is * just assume it is valid and locate the end. */ |
︙ | ︙ | |||
1218 1219 1220 1221 1222 1223 1224 | */ const char * Tcl_UtfAtIndex( const char *src, /* The UTF-8 string. */ Tcl_Size index) /* The position of the desired character. */ { | | < | < | < | 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 | */ const char * Tcl_UtfAtIndex( const char *src, /* The UTF-8 string. */ Tcl_Size index) /* The position of the desired character. */ { Tcl_UniChar ch = 0; while (index-- > 0) { src += Tcl_UtfToUniChar(src, &ch); } return src; } const char * TclUtfAtIndex( const char *src, /* The UTF-8 string. */ |
︙ | ︙ | |||
1493 1494 1495 1496 1497 1498 1499 | * None. * *---------------------------------------------------------------------- */ int TclpUtfNcmp2( | | | > > | 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 | * None. * *---------------------------------------------------------------------- */ int TclpUtfNcmp2( const void *csPtr, /* UTF string to compare to ct. */ const void *ctPtr, /* UTF string cs is compared to. */ size_t numBytes) /* Number of *bytes* to compare. */ { const char *cs = (const char *)csPtr; const char *ct = (const char *)ctPtr; /* * We can't simply call 'memcmp(cs, ct, numBytes);' because we need to * check for Tcl's \xC0\x80 non-utf-8 null encoding. Otherwise utf-8 lexes * fine in the strcmp manner. */ int result = 0; |
︙ | ︙ | |||
1839 1840 1841 1842 1843 1844 1845 | * * Side effects: * None. * *---------------------------------------------------------------------- */ | < | 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 | * * Side effects: * None. * *---------------------------------------------------------------------- */ Tcl_Size Tcl_UniCharLen( const int *uniStr) /* Unicode string to find length of. */ { Tcl_Size len = 0; while (*uniStr != '\0') { |
︙ | ︙ |
Changes to generic/tclUtil.c.
︙ | ︙ | |||
4233 4234 4235 4236 4237 4238 4239 | */ Tcl_DString native, newValue; Tcl_MutexLock(&pgvPtr->mutex); epoch = ++pgvPtr->epoch; Tcl_UtfToExternalDStringEx(NULL, pgvPtr->encoding, pgvPtr->value, | | | | 4233 4234 4235 4236 4237 4238 4239 4240 4241 4242 4243 4244 4245 4246 4247 4248 4249 | */ Tcl_DString native, newValue; Tcl_MutexLock(&pgvPtr->mutex); epoch = ++pgvPtr->epoch; Tcl_UtfToExternalDStringEx(NULL, pgvPtr->encoding, pgvPtr->value, pgvPtr->numBytes, TCL_ENCODING_PROFILE_LOSSLESS, &native, NULL); Tcl_ExternalToUtfDStringEx(NULL, current, Tcl_DStringValue(&native), Tcl_DStringLength(&native), TCL_ENCODING_PROFILE_LOSSLESS, &newValue, NULL); Tcl_DStringFree(&native); Tcl_Free(pgvPtr->value); pgvPtr->value = (char *)Tcl_Alloc(Tcl_DStringLength(&newValue) + 1); memcpy(pgvPtr->value, Tcl_DStringValue(&newValue), Tcl_DStringLength(&newValue) + 1); Tcl_DStringFree(&newValue); |
︙ | ︙ |
Changes to generic/tclVar.c.
︙ | ︙ | |||
124 125 126 127 128 129 130 131 132 133 134 135 136 137 | "upvar refers to element in deleted array"; static const char DANGLINGVAR[] = "upvar refers to variable in deleted namespace"; static const char BADNAMESPACE[] = "parent namespace doesn't exist"; static const char MISSINGNAME[] = "missing variable name"; static const char ISARRAYELEMENT[] = "name refers to an element in an array"; /* * A test to see if we are in a call frame that has local variables. This is * true if we are inside a procedure body. */ #define HasLocalVars(framePtr) ((framePtr)->isProcCallFrame & FRAME_IS_PROC) | > > | 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 | "upvar refers to element in deleted array"; static const char DANGLINGVAR[] = "upvar refers to variable in deleted namespace"; static const char BADNAMESPACE[] = "parent namespace doesn't exist"; static const char MISSINGNAME[] = "missing variable name"; static const char ISARRAYELEMENT[] = "name refers to an element in an array"; static const char ISCONST[] = "variable is a constant"; static const char EXISTS[] = "variable already exists"; /* * A test to see if we are in a call frame that has local variables. This is * true if we are inside a procedure body. */ #define HasLocalVars(framePtr) ((framePtr)->isProcCallFrame & FRAME_IS_PROC) |
︙ | ︙ | |||
174 175 176 177 178 179 180 | } ArrayVarHashTable; /* * Forward references to functions defined later in this file: */ static void AppendLocals(Tcl_Interp *interp, Tcl_Obj *listPtr, | | > | 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 | } ArrayVarHashTable; /* * Forward references to functions defined later in this file: */ static void AppendLocals(Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Obj *patternPtr, int includeLinks, int justConstants); static void ArrayPopulateSearch(Tcl_Interp *interp, Tcl_Obj *arrayNameObj, Var *varPtr, ArraySearch *searchPtr); static void ArrayDoneSearch(Interp *iPtr, Var *varPtr, ArraySearch *searchPtr); static Tcl_NRPostProc ArrayForLoopCallback; static Tcl_ObjCmdProc ArrayForNRCmd; |
︙ | ︙ | |||
1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 | TclObjVarErrMsg(interp, part1Ptr, part2Ptr, "set", DANGLINGVAR, index); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME", (void *)NULL); } } goto earlyError; } /* * It's an error to try to set an array variable itself. */ if (TclIsVarArray(varPtr)) { if (flags & TCL_LEAVE_ERR_MSG) { | > > > > > > > > > > > | 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 | TclObjVarErrMsg(interp, part1Ptr, part2Ptr, "set", DANGLINGVAR, index); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME", (void *)NULL); } } goto earlyError; } /* * It's an error to try to set a constant. */ if (TclIsVarConstant(varPtr)) { if (flags & TCL_LEAVE_ERR_MSG) { TclObjVarErrMsg(interp, part1Ptr, part2Ptr, "set", ISCONST,index); Tcl_SetErrorCode(interp, "TCL", "WRITE", "CONST", (void *)NULL); } goto earlyError; } /* * It's an error to try to set an array variable itself. */ if (TclIsVarArray(varPtr)) { if (flags & TCL_LEAVE_ERR_MSG) { |
︙ | ︙ | |||
2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 2228 2229 | * TCL_APPEND_VALUE, TCL_LIST_ELEMENT, * TCL_LEAVE_ERR_MSG. */ int index) /* Index into the local variable table of the * variable, or -1. Only used when part1Ptr is * NULL. */ { Tcl_Obj *varValuePtr; if (TclIsVarInHash(varPtr)) { VarHashRefCount(varPtr)++; } varValuePtr = TclPtrGetVarIdx(interp, varPtr, arrayPtr, part1Ptr, part2Ptr, flags, index); if (TclIsVarInHash(varPtr)) { | > > > > > > > > > > > | 2230 2231 2232 2233 2234 2235 2236 2237 2238 2239 2240 2241 2242 2243 2244 2245 2246 2247 2248 2249 2250 2251 2252 2253 2254 | * TCL_APPEND_VALUE, TCL_LIST_ELEMENT, * TCL_LEAVE_ERR_MSG. */ int index) /* Index into the local variable table of the * variable, or -1. Only used when part1Ptr is * NULL. */ { Tcl_Obj *varValuePtr; /* * It's an error to try to increment a constant. */ if (TclIsVarConstant(varPtr)) { if (flags & TCL_LEAVE_ERR_MSG) { TclObjVarErrMsg(interp, part1Ptr, part2Ptr, "incr", ISCONST,index); Tcl_SetErrorCode(interp, "TCL", "WRITE", "CONST", (void *)NULL); } return NULL; } if (TclIsVarInHash(varPtr)) { VarHashRefCount(varPtr)++; } varValuePtr = TclPtrGetVarIdx(interp, varPtr, arrayPtr, part1Ptr, part2Ptr, flags, index); if (TclIsVarInHash(varPtr)) { |
︙ | ︙ | |||
2425 2426 2427 2428 2429 2430 2431 | *---------------------------------------------------------------------- */ int TclPtrUnsetVarIdx( Tcl_Interp *interp, /* Command interpreter in which varName is to * be looked up. */ | | | > > > > > > > > > > > | 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 | *---------------------------------------------------------------------- */ int TclPtrUnsetVarIdx( Tcl_Interp *interp, /* Command interpreter in which varName is to * be looked up. */ Var *varPtr, /* The variable to be unset. */ Var *arrayPtr, /* NULL for scalar variables, pointer to the * containing array otherwise. */ Tcl_Obj *part1Ptr, /* Name of an array (if part2 is non-NULL) or * the name of a variable. */ Tcl_Obj *part2Ptr, /* If non-NULL, gives the name of an element * in the array part1. */ int flags, /* OR-ed combination of any of * TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, * TCL_LEAVE_ERR_MSG. */ int index) /* Index into the local variable table of the * variable, or -1. Only used when part1Ptr is * NULL. */ { Interp *iPtr = (Interp *) interp; int result = (TclIsVarUndefined(varPtr)? TCL_ERROR : TCL_OK); Var *initialArrayPtr = arrayPtr; /* * It's an error to try to unset a constant. */ if (TclIsVarConstant(varPtr)) { if (flags & TCL_LEAVE_ERR_MSG) { TclObjVarErrMsg(interp, part1Ptr, part2Ptr, "unset", ISCONST,index); Tcl_SetErrorCode(interp, "TCL", "UNSET", "CONST", (void *)NULL); } return TCL_ERROR; } /* * Keep the variable alive until we're done with it. We used to * increase/decrease the refCount for each operation, making it hard to * find [Bug 735335] - caused by unsetting the variable whose value was * the variable's name. */ |
︙ | ︙ | |||
4804 4805 4806 4807 4808 4809 4810 4811 4812 4813 4814 4815 4816 4817 | } } } /* *---------------------------------------------------------------------- * * Tcl_GlobalObjCmd -- * * This object-based function is invoked to process the "global" Tcl * command. See the user documentation for details on what it does. * * Results: * A standard Tcl object result value. | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 4840 4841 4842 4843 4844 4845 4846 4847 4848 4849 4850 4851 4852 4853 4854 4855 4856 4857 4858 4859 4860 4861 4862 4863 4864 4865 4866 4867 4868 4869 4870 4871 4872 4873 4874 4875 4876 4877 4878 4879 4880 4881 4882 4883 4884 4885 4886 4887 4888 4889 4890 4891 4892 4893 4894 4895 4896 4897 4898 4899 4900 4901 4902 4903 4904 4905 4906 4907 4908 4909 4910 4911 4912 4913 4914 4915 4916 4917 4918 4919 4920 4921 4922 4923 4924 4925 4926 4927 4928 | } } } /* *---------------------------------------------------------------------- * * Tcl_ConstObjCmd -- * * This function is invoked to process the "const" Tcl command. * See the user documentation for details on what it does. * * Results: * A standard Tcl object result value. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_ConstObjCmd( TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { Var *varPtr, *arrayPtr; Tcl_Obj *part1Ptr; if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "varName value"); return TCL_ERROR; } part1Ptr = objv[1]; varPtr = TclObjLookupVarEx(interp, part1Ptr, NULL, TCL_LEAVE_ERR_MSG, "const", /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr); if (TclIsVarArray(varPtr)) { TclObjVarErrMsg(interp, part1Ptr, NULL, "make constant", ISARRAY, -1); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CONST", (void *)NULL); return TCL_ERROR; } if (TclIsVarArrayElement(varPtr)) { if (TclIsVarUndefined(varPtr)) { CleanupVar(varPtr, arrayPtr); } TclObjVarErrMsg(interp, part1Ptr, NULL, "make constant", ISARRAYELEMENT, -1); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CONST", (void *)NULL); return TCL_ERROR; } /* * If already exists, either a constant (no problem) or an error. */ if (!TclIsVarUndefined(varPtr)) { if (TclIsVarConstant(varPtr)) { return TCL_OK; } TclObjVarErrMsg(interp, part1Ptr, NULL, "make constant", EXISTS, -1); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CONST", (void *)NULL); return TCL_ERROR; } /* * Make the variable and flag it as a constant. */ if (TclPtrSetVar(interp, (Tcl_Var) varPtr, NULL, objv[1], NULL, objv[2], TCL_LEAVE_ERR_MSG) == NULL) { if (TclIsVarUndefined(varPtr)) { CleanupVar(varPtr, arrayPtr); } return TCL_ERROR; }; TclSetVarConstant(varPtr); return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_GlobalObjCmd -- * * This object-based function is invoked to process the "global" Tcl * command. See the user documentation for details on what it does. * * Results: * A standard Tcl object result value. |
︙ | ︙ | |||
6031 6032 6033 6034 6035 6036 6037 | } } varPtr = VarHashNextVar(&search); } } } } else if (iPtr->varFramePtr->procPtr != NULL) { | | | 6142 6143 6144 6145 6146 6147 6148 6149 6150 6151 6152 6153 6154 6155 6156 | } } varPtr = VarHashNextVar(&search); } } } } else if (iPtr->varFramePtr->procPtr != NULL) { AppendLocals(interp, listPtr, simplePatternPtr, 1, 0); } if (simplePatternPtr) { Tcl_DecrRefCount(simplePatternPtr); } Tcl_SetObjResult(interp, listPtr); return TCL_OK; |
︙ | ︙ | |||
6185 6186 6187 6188 6189 6190 6191 | /* * Return a list containing names of first the compiled locals (i.e. the * ones stored in the call frame), then the variables in the local hash * table (if one exists). */ listPtr = Tcl_NewListObj(0, NULL); | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > | 6296 6297 6298 6299 6300 6301 6302 6303 6304 6305 6306 6307 6308 6309 6310 6311 6312 6313 6314 6315 6316 6317 6318 6319 6320 6321 6322 6323 6324 6325 6326 6327 6328 6329 6330 6331 6332 6333 6334 6335 6336 6337 6338 6339 6340 6341 6342 6343 6344 6345 6346 6347 6348 6349 6350 6351 6352 6353 6354 6355 6356 6357 6358 6359 6360 6361 6362 6363 6364 6365 6366 6367 6368 6369 6370 6371 6372 6373 6374 6375 6376 6377 6378 6379 6380 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 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 6501 6502 6503 6504 6505 6506 6507 6508 6509 6510 6511 6512 6513 6514 6515 6516 6517 6518 6519 6520 6521 6522 6523 6524 6525 6526 6527 6528 6529 6530 6531 6532 6533 6534 6535 6536 6537 6538 6539 6540 6541 6542 6543 6544 6545 6546 6547 6548 6549 6550 | /* * Return a list containing names of first the compiled locals (i.e. the * ones stored in the call frame), then the variables in the local hash * table (if one exists). */ listPtr = Tcl_NewListObj(0, NULL); AppendLocals(interp, listPtr, patternPtr, 0, 0); Tcl_SetObjResult(interp, listPtr); return TCL_OK; } /* *---------------------------------------------------------------------- * * TclInfoConstsCmd -- * * Called to implement the "info consts" command that returns the list of * constants in the interpreter that match an optional pattern. The * pattern, if any, consists of an optional sequence of namespace names * separated by "::" qualifiers, which is followed by a glob-style * pattern that restricts which variables are returned. Handles the * following syntax: * * info consts ?pattern? * * Results: * Returns TCL_OK if successful and TCL_ERROR if there is an error. * * Side effects: * Returns a result in the interpreter's result object. If there is an * error, the result is an error message. * *---------------------------------------------------------------------- */ int TclInfoConstsCmd( TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { Interp *iPtr = (Interp *) interp; const char *varName, *pattern, *simplePattern; Tcl_HashSearch search; Var *varPtr; Namespace *nsPtr; Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp); Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); Tcl_Obj *listPtr, *elemObjPtr, *varNamePtr; int specificNsInPattern = 0;/* Init. to avoid compiler warning. */ Tcl_Obj *simplePatternPtr = NULL; /* * Get the pattern and find the "effective namespace" in which to list * variables. We only use this effective namespace if there's no active * Tcl procedure frame. */ if (objc == 1) { simplePattern = NULL; nsPtr = currNsPtr; specificNsInPattern = 0; } else if (objc == 2) { /* * From the pattern, get the effective namespace and the simple * pattern (no namespace qualifiers or ::'s) at the end. If an error * was found while parsing the pattern, return it. Otherwise, if the * namespace wasn't found, just leave nsPtr NULL: we will return an * empty list since no variables there can be found. */ Namespace *dummy1NsPtr, *dummy2NsPtr; pattern = TclGetString(objv[1]); TclGetNamespaceForQualName(interp, pattern, NULL, /*flags*/ 0, &nsPtr, &dummy1NsPtr, &dummy2NsPtr, &simplePattern); if (nsPtr != NULL) { /* We successfully found the pattern's ns. */ specificNsInPattern = (strcmp(simplePattern, pattern) != 0); if (simplePattern == pattern) { simplePatternPtr = objv[1]; } else { simplePatternPtr = Tcl_NewStringObj(simplePattern, -1); } Tcl_IncrRefCount(simplePatternPtr); } } else { Tcl_WrongNumArgs(interp, 1, objv, "?pattern?"); return TCL_ERROR; } /* * If the namespace specified in the pattern wasn't found, just return. */ if (nsPtr == NULL) { return TCL_OK; } listPtr = Tcl_NewListObj(0, NULL); if (!HasLocalVars(iPtr->varFramePtr) || specificNsInPattern) { /* * There is no frame pointer, the frame pointer was pushed only to * activate a namespace, or we are in a procedure call frame but a * specific namespace was specified. Create a list containing only the * variables in the effective namespace's variable table. */ if (simplePattern && TclMatchIsTrivial(simplePattern)) { /* * If we can just do hash lookups, that simplifies things a lot. */ varPtr = VarHashFindVar(&nsPtr->varTable, simplePatternPtr); if (varPtr && TclIsVarConstant(varPtr)) { if (!TclIsVarUndefined(varPtr) || TclIsVarNamespaceVar(varPtr)) { if (specificNsInPattern) { TclNewObj(elemObjPtr); Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, elemObjPtr); } else { elemObjPtr = VarHashGetKey(varPtr); } Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr); } } else if ((nsPtr != globalNsPtr) && !specificNsInPattern) { varPtr = VarHashFindVar(&globalNsPtr->varTable, simplePatternPtr); if (varPtr && TclIsVarConstant(varPtr)) { if (!TclIsVarUndefined(varPtr) || TclIsVarNamespaceVar(varPtr)) { Tcl_ListObjAppendElement(interp, listPtr, VarHashGetKey(varPtr)); } } } } else { /* * Have to scan the tables of variables. */ varPtr = VarHashFirstVar(&nsPtr->varTable, &search); while (varPtr) { if (TclIsVarConstant(varPtr) && (!TclIsVarUndefined(varPtr) || TclIsVarNamespaceVar(varPtr))) { varNamePtr = VarHashGetKey(varPtr); varName = TclGetString(varNamePtr); if ((simplePattern == NULL) || Tcl_StringMatch(varName, simplePattern)) { if (specificNsInPattern) { TclNewObj(elemObjPtr); Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, elemObjPtr); } else { elemObjPtr = varNamePtr; } Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr); } } varPtr = VarHashNextVar(&search); } /* * If the effective namespace isn't the global :: namespace, and a * specific namespace wasn't requested in the pattern (i.e., the * pattern only specifies variable names), then add in all global * :: variables that match the simple pattern. Of course, add in * only those variables that aren't hidden by a variable in the * effective namespace. */ if ((nsPtr != globalNsPtr) && !specificNsInPattern) { varPtr = VarHashFirstVar(&globalNsPtr->varTable, &search); while (varPtr) { if (TclIsVarConstant(varPtr) && (!TclIsVarUndefined(varPtr) || TclIsVarNamespaceVar(varPtr))) { varNamePtr = VarHashGetKey(varPtr); varName = TclGetString(varNamePtr); if ((simplePattern == NULL) || Tcl_StringMatch(varName, simplePattern)) { if (VarHashFindVar(&nsPtr->varTable, varNamePtr) == NULL) { Tcl_ListObjAppendElement(interp, listPtr, varNamePtr); } } } varPtr = VarHashNextVar(&search); } } } } else if (iPtr->varFramePtr->procPtr != NULL) { AppendLocals(interp, listPtr, simplePatternPtr, 1, 1); } if (simplePatternPtr) { Tcl_DecrRefCount(simplePatternPtr); } Tcl_SetObjResult(interp, listPtr); return TCL_OK; } /* *---------------------------------------------------------------------- * * AppendLocals -- * * Append the local variables for the current frame to the specified list * object. * * Results: * None. * * Side effects: * None. * *---------------------------------------------------------------------- */ static int ContextObjectContainsConstant( Tcl_ObjectContext context, Tcl_Obj *varNamePtr) { /* * Helper for AppendLocals to check if an object contains a variable * that is a constant. It's too complicated without factoring this * check out! */ Object *oPtr = (Object *) Tcl_ObjectContextObject(context); Namespace *nsPtr = (Namespace *) oPtr->namespacePtr; Var *varPtr = VarHashFindVar(&nsPtr->varTable, varNamePtr); return !TclIsVarUndefined(varPtr) && TclIsVarConstant(varPtr); } static void AppendLocals( Tcl_Interp *interp, /* Current interpreter. */ Tcl_Obj *listPtr, /* List object to append names to. */ Tcl_Obj *patternPtr, /* Pattern to match against. */ int includeLinks, /* 1 if upvars should be included, else 0. */ int justConstants) /* 1 if just constants should be included. */ { Interp *iPtr = (Interp *) interp; Var *varPtr; Tcl_Size i, localVarCt; int added; Tcl_Obj *objNamePtr; const char *varName; |
︙ | ︙ | |||
6241 6242 6243 6244 6245 6246 6247 | for (i = 0; i < localVarCt; i++, varNamePtr++) { /* * Skip nameless (temporary) variables and undefined variables. */ if (*varNamePtr && !TclIsVarUndefined(varPtr) | | > | > | 6565 6566 6567 6568 6569 6570 6571 6572 6573 6574 6575 6576 6577 6578 6579 6580 6581 6582 6583 6584 | for (i = 0; i < localVarCt; i++, varNamePtr++) { /* * Skip nameless (temporary) variables and undefined variables. */ if (*varNamePtr && !TclIsVarUndefined(varPtr) && (includeLinks || !TclIsVarLink(varPtr))) { varName = TclGetString(*varNamePtr); if ((pattern == NULL) || Tcl_StringMatch(varName, pattern)) { if (!justConstants || TclIsVarConstant(varPtr)) { Tcl_ListObjAppendElement(interp, listPtr, *varNamePtr); } if (includeLinks) { Tcl_CreateHashEntry(&addedTable, *varNamePtr, &added); } } } varPtr++; } |
︙ | ︙ | |||
6271 6272 6273 6274 6275 6276 6277 | */ if ((pattern != NULL) && TclMatchIsTrivial(pattern)) { varPtr = VarHashFindVar(localVarTablePtr, patternPtr); if (varPtr != NULL) { if (!TclIsVarUndefined(varPtr) && (includeLinks || !TclIsVarLink(varPtr))) { | > | | > | 6597 6598 6599 6600 6601 6602 6603 6604 6605 6606 6607 6608 6609 6610 6611 6612 6613 6614 | */ if ((pattern != NULL) && TclMatchIsTrivial(pattern)) { varPtr = VarHashFindVar(localVarTablePtr, patternPtr); if (varPtr != NULL) { if (!TclIsVarUndefined(varPtr) && (includeLinks || !TclIsVarLink(varPtr))) { if ((!justConstants || TclIsVarConstant(varPtr))) { Tcl_ListObjAppendElement(interp, listPtr, VarHashGetKey(varPtr)); } if (includeLinks) { Tcl_CreateHashEntry(&addedTable, VarHashGetKey(varPtr), &added); } } } goto objectVars; |
︙ | ︙ | |||
6294 6295 6296 6297 6298 6299 6300 | varPtr != NULL; varPtr = VarHashNextVar(&search)) { if (!TclIsVarUndefined(varPtr) && (includeLinks || !TclIsVarLink(varPtr))) { objNamePtr = VarHashGetKey(varPtr); varName = TclGetString(objNamePtr); if ((pattern == NULL) || Tcl_StringMatch(varName, pattern)) { | > | > > > | < > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 6622 6623 6624 6625 6626 6627 6628 6629 6630 6631 6632 6633 6634 6635 6636 6637 6638 6639 6640 6641 6642 6643 6644 6645 6646 6647 6648 6649 6650 6651 6652 6653 6654 6655 6656 6657 6658 6659 6660 6661 6662 6663 6664 6665 6666 6667 6668 6669 6670 6671 6672 6673 6674 6675 6676 6677 6678 6679 6680 6681 6682 6683 6684 6685 6686 6687 6688 6689 6690 6691 6692 6693 6694 6695 6696 6697 6698 6699 6700 6701 6702 6703 6704 6705 6706 6707 6708 6709 6710 6711 6712 6713 6714 6715 6716 6717 6718 6719 6720 6721 6722 6723 6724 6725 6726 6727 6728 6729 6730 6731 6732 6733 6734 6735 6736 6737 6738 6739 6740 6741 6742 6743 6744 6745 6746 6747 6748 6749 6750 6751 6752 6753 6754 6755 6756 6757 | varPtr != NULL; varPtr = VarHashNextVar(&search)) { if (!TclIsVarUndefined(varPtr) && (includeLinks || !TclIsVarLink(varPtr))) { objNamePtr = VarHashGetKey(varPtr); varName = TclGetString(objNamePtr); if ((pattern == NULL) || Tcl_StringMatch(varName, pattern)) { if (!justConstants || TclIsVarConstant(varPtr)) { Tcl_ListObjAppendElement(interp, listPtr, objNamePtr); } if (includeLinks) { Tcl_CreateHashEntry(&addedTable, objNamePtr, &added); } } } } objectVars: if (!includeLinks) { return; } if (iPtr->varFramePtr->isProcCallFrame & FRAME_IS_METHOD) { Tcl_ObjectContext context = (Tcl_ObjectContext) iPtr->varFramePtr->clientData; Method *mPtr = (Method *) Tcl_ObjectContextMethod(context); PrivateVariableMapping *privatePtr; if (mPtr->declaringObjectPtr) { Object *oPtr = mPtr->declaringObjectPtr; FOREACH(objNamePtr, oPtr->variables) { Tcl_CreateHashEntry(&addedTable, objNamePtr, &added); if (justConstants && !ContextObjectContainsConstant(context, objNamePtr)) { continue; } if (added && (!pattern || Tcl_StringMatch(TclGetString(objNamePtr), pattern))) { Tcl_ListObjAppendElement(interp, listPtr, objNamePtr); } } FOREACH_STRUCT(privatePtr, oPtr->privateVariables) { Tcl_CreateHashEntry(&addedTable, privatePtr->variableObj, &added); if (justConstants && !ContextObjectContainsConstant(context, privatePtr->fullNameObj)) { continue; } if (added && (!pattern || Tcl_StringMatch(TclGetString(privatePtr->variableObj), pattern))) { Tcl_ListObjAppendElement(interp, listPtr, privatePtr->variableObj); } } } else { Class *clsPtr = mPtr->declaringClassPtr; FOREACH(objNamePtr, clsPtr->variables) { Tcl_CreateHashEntry(&addedTable, objNamePtr, &added); if (justConstants && !ContextObjectContainsConstant(context, objNamePtr)) { continue; } if (added && (!pattern || Tcl_StringMatch(TclGetString(objNamePtr), pattern))) { Tcl_ListObjAppendElement(interp, listPtr, objNamePtr); } } FOREACH_STRUCT(privatePtr, clsPtr->privateVariables) { Tcl_CreateHashEntry(&addedTable, privatePtr->variableObj, &added); if (justConstants && !ContextObjectContainsConstant(context, privatePtr->fullNameObj)) { continue; } if (added && (!pattern || Tcl_StringMatch(TclGetString(privatePtr->variableObj), pattern))) { Tcl_ListObjAppendElement(interp, listPtr, privatePtr->variableObj); } } } } Tcl_DeleteHashTable(&addedTable); } /* *---------------------------------------------------------------------- * * TclInfoConstantCmd -- * * Called to implement the "info constant" command that wests whether a * specific variable is a constant. Handles the following syntax: * * info constant varName * * Results: * Returns TCL_OK if successful and TCL_ERROR if there is an error. * * Side effects: * Returns a result in the interpreter's result object. If there is an * error, the result is an error message. * *---------------------------------------------------------------------- */ int TclInfoConstantCmd( TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { Var *varPtr, *arrayPtr; int result; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "varName"); return TCL_ERROR; } varPtr = TclObjLookupVar(interp, objv[1], NULL, 0, "lookup", 0, 0, &arrayPtr); result = (varPtr && TclIsVarConstant(varPtr)); Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result)); return TCL_OK; } /* * Hash table implementation - first, just copy and adapt the obj key stuff */ void TclInitVarHashTable( |
︙ | ︙ |
Changes to generic/tclZlib.c.
︙ | ︙ | |||
514 515 516 517 518 519 520 | /* * Ignore the 'size' field, since that is controlled by the size of the * input data. */ if (GetValue(interp, dictObj, "time", &value) != TCL_OK) { goto error; | | | 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 | /* * Ignore the 'size' field, since that is controlled by the size of the * input data. */ if (GetValue(interp, dictObj, "time", &value) != TCL_OK) { goto error; } else if (value != NULL && TclGetWideIntFromObj(interp, value, &wideValue) != TCL_OK) { goto error; } headerPtr->header.time = wideValue; if (GetValue(interp, dictObj, "type", &value) != TCL_OK) { goto error; |
︙ | ︙ | |||
2142 2143 2144 2145 2146 2147 2148 | case CMD_INFLATE: /* inflate rawcomprdata ?bufferSize? * -> decompressedData */ if (objc < 3 || objc > 4) { Tcl_WrongNumArgs(interp, 2, objv, "data ?bufferSize?"); return TCL_ERROR; } if (objc > 3) { | | | | 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 2176 | case CMD_INFLATE: /* inflate rawcomprdata ?bufferSize? * -> decompressedData */ if (objc < 3 || objc > 4) { Tcl_WrongNumArgs(interp, 2, objv, "data ?bufferSize?"); return TCL_ERROR; } if (objc > 3) { if (TclGetWideIntFromObj(interp, objv[3], &wideLen) != TCL_OK) { return TCL_ERROR; } if (wideLen < MIN_NONSTREAM_BUFFER_SIZE || wideLen > MAX_BUFFER_SIZE) { goto badBuffer; } buffersize = wideLen; } return Tcl_ZlibInflate(interp, TCL_ZLIB_FORMAT_RAW, objv[2], buffersize, NULL); case CMD_DECOMPRESS: /* decompress zlibcomprdata \ * ?bufferSize? * -> decompressedData */ if (objc < 3 || objc > 4) { Tcl_WrongNumArgs(interp, 2, objv, "data ?bufferSize?"); return TCL_ERROR; } if (objc > 3) { if (TclGetWideIntFromObj(interp, objv[3], &wideLen) != TCL_OK) { return TCL_ERROR; } if (wideLen < MIN_NONSTREAM_BUFFER_SIZE || wideLen > MAX_BUFFER_SIZE) { goto badBuffer; } |
︙ | ︙ | |||
2194 2195 2196 2197 2198 2199 2200 | if (Tcl_GetIndexFromObj(interp, objv[i], gunzipopts, "option", 0, &option) != TCL_OK) { return TCL_ERROR; } switch (option) { case 0: | | | 2194 2195 2196 2197 2198 2199 2200 2201 2202 2203 2204 2205 2206 2207 2208 | if (Tcl_GetIndexFromObj(interp, objv[i], gunzipopts, "option", 0, &option) != TCL_OK) { return TCL_ERROR; } switch (option) { case 0: if (TclGetWideIntFromObj(interp, objv[i+1], &wideLen) != TCL_OK) { return TCL_ERROR; } if (wideLen < MIN_NONSTREAM_BUFFER_SIZE || wideLen > MAX_BUFFER_SIZE) { goto badBuffer; } |
︙ | ︙ |
Added library/foreachline.tcl.
> > > > > > > > > > > > > > > > > > > > > > > > > | 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 | # foreachLine: # Iterate over the contents of a file, a line at a time. # The body script is run for each, with variable varName set to the line # contents. # # Copyright © 2023 Donal K Fellows. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # proc foreachLine {varName filename body} { upvar 1 $varName line set f [open $filename "r"] try { while {[gets $f line] >= 0} { uplevel 1 $body } } on return {msg opt} { dict incr opt -level return -options $opt $msg } finally { close $f } } |
Changes to library/http/http.tcl.
︙ | ︙ | |||
115 116 117 118 119 120 121 | array set socketProxyId {} return } init variable urlTypes if {![info exists urlTypes]} { | | | 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 | array set socketProxyId {} return } init variable urlTypes if {![info exists urlTypes]} { set urlTypes(http) [list 80 ::http::AltSocket {} 1 0] } variable encodings [string tolower [encoding names]] # This can be changed, but iso8859-1 is the RFC standard. variable defaultCharset if {![info exists defaultCharset]} { set defaultCharset "iso8859-1" |
︙ | ︙ | |||
278 279 280 281 282 283 284 | if {[info command http::Log] eq {}} {proc http::Log {args} {}} # http::register -- # # See documentation for details. # # Arguments: | | | | > > > > > > > | | | > > > > > > > > > > > > > | > > > > > > > | 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 | if {[info command http::Log] eq {}} {proc http::Log {args} {}} # http::register -- # # See documentation for details. # # Arguments: # proto URL protocol prefix, e.g. https # port Default port for protocol # command Command to use to create socket # socketCmdVarName (optional) name of variable provided by the protocol # handler whose value is the callback used by argument # "command" to open a socket. The default value "::socket" # will be overwritten by http. # useSockThread (optional, boolean) # endToEndProxy (optional, boolean) # Results: # list of port, command, variable name, (boolean) threadability, # and (boolean) endToEndProxy that was registered. proc http::register {proto port command {socketCmdVarName {}} {useSockThread 0} {endToEndProxy 0}} { variable urlTypes set lower [string tolower $proto] if {[info exists urlTypes($lower)]} { unregister $lower } set urlTypes($lower) [list $port $command $socketCmdVarName $useSockThread $endToEndProxy] # If the external handler for protocol $proto has given $socketCmdVarName the expected # value "::socket", overwrite it with the new value. if {($socketCmdVarName ne {}) && ([set $socketCmdVarName] eq {::socket})} { set $socketCmdVarName ::http::socketAsCallback } return $urlTypes($lower) } # http::unregister -- # # Unregisters URL protocol handler # # Arguments: # proto URL protocol prefix, e.g. https # Results: # list of port, command, variable name, (boolean) useSockThread, # and (boolean) endToEndProxy that was unregistered. proc http::unregister {proto} { variable urlTypes set lower [string tolower $proto] if {![info exists urlTypes($lower)]} { return -code error "unsupported url type \"$proto\"" } set old $urlTypes($lower) # Restore the external handler's original value for $socketCmdVarName. lassign $old defport defcmd socketCmdVarName useSockThread endToEndProxy if {($socketCmdVarName ne {}) && ([set $socketCmdVarName] eq {::http::socketAsCallback})} { set $socketCmdVarName ::socket } unset urlTypes($lower) return $old } # http::config -- # # See documentation for details. |
︙ | ︙ | |||
924 925 926 927 928 929 930 | # Returns a token for this connection. This token is the name of an # array that the caller should unset to garbage collect the state. proc http::geturl {url args} { variable urlTypes # - If ::tls::socketCmd has its default value "::socket", change it to the | | | | | | < | | < | < | 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 | # Returns a token for this connection. This token is the name of an # array that the caller should unset to garbage collect the state. proc http::geturl {url args} { variable urlTypes # - If ::tls::socketCmd has its default value "::socket", change it to the # new value ::http::socketAsCallback. # - If the old value is different, then it has been modified either by the # script or by the Tcl installation, and replaced by a new command. The # script or installation that modified ::tls::socketCmd is also # responsible for integrating ::http::socketAsCallback into its own "new" # command, if it wishes to do so. # - Commands that open a socket: # - ::socket - basic # - ::http::AltSocket - can use a thread to avoid blockage by slow # DNS lookup. See http::config option # -threadlevel. # - ::http::socketAsCallback - as ::http::AltSocket, but can also open a # socket for HTTPS/TLS through a proxy. set token [CreateToken $url {*}$args] variable $token upvar 0 $token state AsyncTransaction $token |
︙ | ︙ | |||
1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 | reasonPhrase {} connection keep-alive tid {} requestHeaders {} requestLine {} transfer {} proxyUsed none } set state(-keepalive) $defaultKeepalive set state(-strict) $strict # These flags have their types verified [Bug 811170] array set type { -binary boolean -blocksize integer | > > | 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 | reasonPhrase {} connection keep-alive tid {} requestHeaders {} requestLine {} transfer {} proxyUsed none protoSockThread 0 protoProxyConn 0 } set state(-keepalive) $defaultKeepalive set state(-strict) $strict # These flags have their types verified [Bug 811170] array set type { -binary boolean -blocksize integer |
︙ | ︙ | |||
1257 1258 1259 1260 1261 1262 1263 | set proto http } set lower [string tolower $proto] if {![info exists urlTypes($lower)]} { unset $token return -code error "Unsupported URL type \"$proto\"" } | > | > > > > > | > > | 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 | set proto http } set lower [string tolower $proto] if {![info exists urlTypes($lower)]} { unset $token return -code error "Unsupported URL type \"$proto\"" } lassign $urlTypes($lower) defport defcmd socketCmdVarName useSockThread end2EndProxy # If the external handler for protocol $proto has given $socketCmdVarName the expected # value "::socket", overwrite it with the new value. if {($socketCmdVarName ne {}) && ([set $socketCmdVarName] eq {::socket})} { set $socketCmdVarName ::http::socketAsCallback } set state(protoSockThread) $useSockThread set state(protoProxyConn) $end2EndProxy if {$port eq ""} { set port $defport } if {![catch {$http(-proxyfilter) $host} proxy]} { set phost [lindex $proxy 0] set pport [lindex $proxy 1] |
︙ | ︙ | |||
1340 1341 1342 1343 1344 1345 1346 | # RFC 7320 A.1 - HTTP/1.0 Keep-Alive is problematic. We do not support it. if {$state(-protocol) eq "1.0"} { set state(connection) close set state(-keepalive) 0 } # Handle proxy requests here for http:// but not for https:// | | | > > > > > | | 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 | # RFC 7320 A.1 - HTTP/1.0 Keep-Alive is problematic. We do not support it. if {$state(-protocol) eq "1.0"} { set state(connection) close set state(-keepalive) 0 } # Handle proxy requests here for http:// but not for https:// # The proxying for https is done in the ::http::socketAsCallback command. # A proxy request for http:// needs the full URL in the HTTP request line, # including the server name. # The *tls* test below attempts to describe protocols in addition to # "https on port 443" that use HTTP over TLS. if {($phost ne "") && (!$end2EndProxy)} { set srvurl $url set targetAddr [list $phost $pport] set state(proxyUsed) HttpProxy # The value of state(proxyUsed) none|HttpProxy depends only on the # all-transactions http::config settings and on the target URL. # Even if this is a persistent socket there is no need to change the # value of state(proxyUsed) for other transactions that use the socket: # they have the same value already. } else { set targetAddr [list $host $port] } set sockopts [list -async] # Pass -myaddr directly to the socket command if {[info exists state(-myaddr)]} { lappend sockopts -myaddr $state(-myaddr) } if {$useSockThread} { set targs [list -type $token] } else { set targs {} } set state(connArgs) [list $proto $phost $srvurl] set state(openCmd) [list {*}$defcmd {*}$sockopts {*}$targs {*}$targetAddr] # See if we are supposed to use a previously opened channel. # - In principle, ANY call to http::geturl could use a previously opened # channel if it is available - the "Connection: keep-alive" header is a # request to leave the channel open AFTER completion of this call. # - In fact, we try to use an existing channel only if -keepalive 1 -- this # means that at most one channel is left open for each value of |
︙ | ︙ | |||
4942 4943 4944 4945 4946 4947 4948 | interp alias {} http::mapReply {} http::quoteString interp alias {} http::meta {} http::responseHeaders interp alias {} http::metaValue {} http::responseHeaderValue interp alias {} http::ncode {} http::responseCode # ------------------------------------------------------------------------------ | | | | | > > > > > > > > > > > | | 4981 4982 4983 4984 4985 4986 4987 4988 4989 4990 4991 4992 4993 4994 4995 4996 4997 4998 4999 5000 5001 5002 5003 5004 5005 5006 5007 5008 5009 5010 5011 5012 5013 5014 5015 5016 5017 5018 5019 5020 5021 5022 5023 5024 5025 5026 5027 5028 5029 5030 5031 5032 5033 5034 5035 5036 5037 5038 5039 5040 5041 | interp alias {} http::mapReply {} http::quoteString interp alias {} http::meta {} http::responseHeaders interp alias {} http::metaValue {} http::responseHeaderValue interp alias {} http::ncode {} http::responseCode # ------------------------------------------------------------------------------ # Proc http::socketAsCallback # ------------------------------------------------------------------------------ # Command to use in place of ::socket as the value of ::tls::socketCmd. # This command does the same as http::AltSocket, and also handles https # connections through a proxy server. # # Notes. # - The proxy server works differently for https and http. This implementation # is for https. The proxy for http is implemented in http::CreateToken (in # code that was previously part of http::geturl). # - This code implicitly uses the tls options set for https in a call to # http::register, and does not need to call commands tls::*. This simple # implementation is possible because tls uses a callback to ::socket that can # be redirected by changing the value of ::tls::socketCmd. # # Arguments: # args - as for ::socket # # Return Value: a socket identifier # ------------------------------------------------------------------------------ proc http::socketAsCallback {args} { variable http set targ [lsearch -exact $args -type] if {$targ != -1} { set token [lindex $args $targ+1] upvar 0 ${token} state set protoProxyConn $state(protoProxyConn) } else { set protoProxyConn 0 } set host [lindex $args end-1] set port [lindex $args end] if { ($http(-proxyfilter) ne {}) && (![catch {$http(-proxyfilter) $host} proxy]) && $protoProxyConn } { set phost [lindex $proxy 0] set pport [lindex $proxy 1] } else { set phost {} set pport {} } if {$phost eq ""} { set sock [::http::AltSocket {*}$args] } else { set sock [::http::SecureProxyConnect {*}$args $phost $pport] } return $sock } |
︙ | ︙ | |||
5032 5033 5034 5035 5036 5037 5038 | # IPv6 address, wrap it in [] so we can append :pport set phost "\[${phost}\]" } set url http://${phost}:${pport} # Elements of args other than host and port are not used when # AsyncTransaction opens a socket. Those elements are -async and the # -type $tokenName for the https transaction. Option -async is used by | | | | 5082 5083 5084 5085 5086 5087 5088 5089 5090 5091 5092 5093 5094 5095 5096 5097 | # IPv6 address, wrap it in [] so we can append :pport set phost "\[${phost}\]" } set url http://${phost}:${pport} # Elements of args other than host and port are not used when # AsyncTransaction opens a socket. Those elements are -async and the # -type $tokenName for the https transaction. Option -async is used by # AsyncTransaction anyway, and -type $tokenName should not be # propagated: the proxy request adds its own -type value. set targ [lsearch -exact $args -type] if {$targ != -1} { # Record in the token that this is a proxy call. set token [lindex $args $targ+1] upvar 0 ${token} state set tim $state(-timeout) |
︙ | ︙ | |||
5178 5179 5180 5181 5182 5183 5184 | proc http::AllDone {varName args} { set $varName done return } # ------------------------------------------------------------------------------ | | | | | | | > > | | > | 5228 5229 5230 5231 5232 5233 5234 5235 5236 5237 5238 5239 5240 5241 5242 5243 5244 5245 5246 5247 5248 5249 5250 5251 5252 5253 5254 5255 5256 5257 5258 5259 5260 5261 5262 5263 5264 5265 5266 5267 5268 5269 5270 5271 5272 5273 5274 5275 5276 5277 5278 5279 5280 5281 5282 5283 5284 5285 5286 5287 5288 | proc http::AllDone {varName args} { set $varName done return } # ------------------------------------------------------------------------------ # Proc http::AltSocket # ------------------------------------------------------------------------------ # This command is a drop-in replacement for ::socket. # Arguments and return value as for ::socket. # # Notes. # - http::AltSocket is specified in place of ::socket by the definition of # urlTypes in the namespace header of this file (http.tcl). # - The command makes a simple call to ::socket unless the user has called # http::config to change the value of -threadlevel from the default value 0. # - For -threadlevel 1 or 2, if the Thread package is available, the command # waits in the event loop while the socket is opened in another thread. This # is a workaround for bug [824251] - it prevents http::geturl from blocking # the event loop if the DNS lookup or server connection is slow. # - FIXME Use a thread pool if connections are very frequent. # - FIXME The peer thread can transfer the socket only to the main interpreter # in the present thread. Therefore this code works only if this script runs # in the main interpreter. In a child interpreter, the parent must alias a # command to ::http::AltSocket in the child, run http::AltSocket in the # parent, and then transfer the socket to the child. # - The http::AltSocket command is simple, and can easily be replaced with an # alternative command that uses a different technique to open a socket while # entering the event loop. # - Unexpected behaviour by thread::send -async (Thread 2.8.6). # An error in thread::send -async causes return of just the error message # (not the expected 3 elements), and raises a bgerror in the main thread. # Hence wrap the command with catch as a precaution. # - Bug in Thread 2.8.8 - on Windows, read/write operations fail on a socket # moved from another thread by thread::transfer. # ------------------------------------------------------------------------------ proc http::AltSocket {args} { variable ThreadVar variable ThreadCounter variable http LoadThreadIfNeeded set targ [lsearch -exact $args -type] if {$targ != -1} { set token [lindex $args $targ+1] set args [lreplace $args $targ $targ+1] upvar 0 $token state } if {$http(usingThread) && [info exists state] && $state(protoSockThread)} { } else { # Use plain "::socket". This is the default. return [eval ::socket $args] } set defcmd ::socket set sockargs $args set script " |
︙ | ︙ | |||
5277 5278 5279 5280 5281 5282 5283 | if {($catchCode == 0) && ($sock ni [chan names])} { return -code error {Transfer of socket from peer thread failed.\ Check that this script is not running in a child interpreter.} } return -options $errdict -code $catchCode $sock } | | > > > | > > | | 5330 5331 5332 5333 5334 5335 5336 5337 5338 5339 5340 5341 5342 5343 5344 5345 5346 5347 5348 5349 5350 5351 5352 5353 5354 5355 5356 5357 5358 5359 5360 5361 5362 5363 5364 5365 5366 5367 5368 5369 5370 5371 5372 5373 5374 5375 5376 5377 5378 5379 5380 5381 5382 5383 5384 5385 5386 | if {($catchCode == 0) && ($sock ni [chan names])} { return -code error {Transfer of socket from peer thread failed.\ Check that this script is not running in a child interpreter.} } return -options $errdict -code $catchCode $sock } # The commands below are dependencies of http::AltSocket and # http::SecureProxyConnect and are not used elsewhere. # ------------------------------------------------------------------------------ # Proc http::LoadThreadIfNeeded # ------------------------------------------------------------------------------ # Command to load the Thread package if it is needed. If it is needed and not # loadable, the outcome depends on $http(-threadlevel): # value 0 => Thread package not required, no problem # value 1 => operate as if -threadlevel 0 # value 2 => error return # # The command assigns a value to http(usingThread), which records whether # command http::AltSocket can use a separate thread. # # Arguments: none # Return Value: none # ------------------------------------------------------------------------------ proc http::LoadThreadIfNeeded {} { variable http if {$http(-threadlevel) == 0} { set http(usingThread) 0 return } if {[catch {package require Thread}]} { if {$http(-threadlevel) == 2} { set msg {[http::config -threadlevel] has value 2,\ but the Thread package is not available} return -code error $msg } set http(usingThread) 0 return } set http(usingThread) 1 return } # ------------------------------------------------------------------------------ # Proc http::SockInThread # ------------------------------------------------------------------------------ # Command http::AltSocket is a ::socket replacement. It defines and runs this # command, http::SockInThread, in a peer thread. # # Arguments: # caller # defcmd # sockargs # |
︙ | ︙ |
Changes to library/manifest.txt.
1 2 3 4 | ### # Package manifest for all Tcl packages included in the /library file system ### apply {{dir} { | < | 1 2 3 4 5 6 7 8 9 10 11 | ### # Package manifest for all Tcl packages included in the /library file system ### apply {{dir} { set isafe [interp issafe] foreach {safe package version file} { 0 http 2.10b1 {http http.tcl} 1 msgcat 1.7.1 {msgcat msgcat.tcl} 1 opt 0.4.8 {opt optparse.tcl} 0 cookiejar 0.2.0 {cookiejar cookiejar.tcl} 0 tcl::idna 1.0.1 {cookiejar idna.tcl} |
︙ | ︙ |
Added library/readfile.tcl.
> > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 | # readFile: # Read the contents of a file. # # Copyright © 2023 Donal K Fellows. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # proc readFile {filename {mode text}} { # Parse the arguments set MODES {binary text} set ERR [list -level 1 -errorcode [list TCL LOOKUP MODE $mode]] set mode [tcl::prefix match -message "mode" -error $ERR $MODES $mode] # Read the file set f [open $filename [dict get {text r binary rb} $mode]] try { return [read $f] } finally { close $f } } |
Changes to library/tclIndex.
︙ | ︙ | |||
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 | set auto_index(::auto_mkindex_parser::cleanup) [list ::tcl::Pkg::source [file join $dir auto.tcl]] set auto_index(::auto_mkindex_parser::mkindex) [list ::tcl::Pkg::source [file join $dir auto.tcl]] set auto_index(::auto_mkindex_parser::hook) [list ::tcl::Pkg::source [file join $dir auto.tcl]] set auto_index(::auto_mkindex_parser::childhook) [list ::tcl::Pkg::source [file join $dir auto.tcl]] set auto_index(::auto_mkindex_parser::command) [list ::tcl::Pkg::source [file join $dir auto.tcl]] set auto_index(::auto_mkindex_parser::commandInit) [list ::tcl::Pkg::source [file join $dir auto.tcl]] set auto_index(::auto_mkindex_parser::fullname) [list ::tcl::Pkg::source [file join $dir auto.tcl]] set auto_index(history) [list ::tcl::Pkg::source [file join $dir history.tcl]] set auto_index(::tcl::HistAdd) [list ::tcl::Pkg::source [file join $dir history.tcl]] set auto_index(::tcl::HistKeep) [list ::tcl::Pkg::source [file join $dir history.tcl]] set auto_index(::tcl::HistClear) [list ::tcl::Pkg::source [file join $dir history.tcl]] set auto_index(::tcl::HistInfo) [list ::tcl::Pkg::source [file join $dir history.tcl]] set auto_index(::tcl::HistRedo) [list ::tcl::Pkg::source [file join $dir history.tcl]] set auto_index(::tcl::HistIndex) [list ::tcl::Pkg::source [file join $dir history.tcl]] set auto_index(::tcl::HistEvent) [list ::tcl::Pkg::source [file join $dir history.tcl]] set auto_index(::tcl::HistChange) [list ::tcl::Pkg::source [file join $dir history.tcl]] set auto_index(pkg_mkIndex) [list ::tcl::Pkg::source [file join $dir package.tcl]] set auto_index(tclPkgSetup) [list ::tcl::Pkg::source [file join $dir package.tcl]] set auto_index(tclPkgUnknown) [list ::tcl::Pkg::source [file join $dir package.tcl]] set auto_index(::tcl::MacOSXPkgUnknown) [list ::tcl::Pkg::source [file join $dir package.tcl]] set auto_index(::pkg::create) [list ::tcl::Pkg::source [file join $dir package.tcl]] set auto_index(parray) [list ::tcl::Pkg::source [file join $dir parray.tcl]] set auto_index(::safe::InterpStatics) [list ::tcl::Pkg::source [file join $dir safe.tcl]] set auto_index(::safe::InterpNested) [list ::tcl::Pkg::source [file join $dir safe.tcl]] set auto_index(::safe::interpCreate) [list ::tcl::Pkg::source [file join $dir safe.tcl]] set auto_index(::safe::interpInit) [list ::tcl::Pkg::source [file join $dir safe.tcl]] set auto_index(::safe::CheckInterp) [list ::tcl::Pkg::source [file join $dir safe.tcl]] set auto_index(::safe::interpConfigure) [list ::tcl::Pkg::source [file join $dir safe.tcl]] set auto_index(::safe::InterpCreate) [list ::tcl::Pkg::source [file join $dir safe.tcl]] | > > | 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 | set auto_index(::auto_mkindex_parser::cleanup) [list ::tcl::Pkg::source [file join $dir auto.tcl]] set auto_index(::auto_mkindex_parser::mkindex) [list ::tcl::Pkg::source [file join $dir auto.tcl]] set auto_index(::auto_mkindex_parser::hook) [list ::tcl::Pkg::source [file join $dir auto.tcl]] set auto_index(::auto_mkindex_parser::childhook) [list ::tcl::Pkg::source [file join $dir auto.tcl]] set auto_index(::auto_mkindex_parser::command) [list ::tcl::Pkg::source [file join $dir auto.tcl]] set auto_index(::auto_mkindex_parser::commandInit) [list ::tcl::Pkg::source [file join $dir auto.tcl]] set auto_index(::auto_mkindex_parser::fullname) [list ::tcl::Pkg::source [file join $dir auto.tcl]] set auto_index(foreachLine) [list ::tcl::Pkg::source [file join $dir foreachline.tcl]] set auto_index(history) [list ::tcl::Pkg::source [file join $dir history.tcl]] set auto_index(::tcl::HistAdd) [list ::tcl::Pkg::source [file join $dir history.tcl]] set auto_index(::tcl::HistKeep) [list ::tcl::Pkg::source [file join $dir history.tcl]] set auto_index(::tcl::HistClear) [list ::tcl::Pkg::source [file join $dir history.tcl]] set auto_index(::tcl::HistInfo) [list ::tcl::Pkg::source [file join $dir history.tcl]] set auto_index(::tcl::HistRedo) [list ::tcl::Pkg::source [file join $dir history.tcl]] set auto_index(::tcl::HistIndex) [list ::tcl::Pkg::source [file join $dir history.tcl]] set auto_index(::tcl::HistEvent) [list ::tcl::Pkg::source [file join $dir history.tcl]] set auto_index(::tcl::HistChange) [list ::tcl::Pkg::source [file join $dir history.tcl]] set auto_index(pkg_mkIndex) [list ::tcl::Pkg::source [file join $dir package.tcl]] set auto_index(tclPkgSetup) [list ::tcl::Pkg::source [file join $dir package.tcl]] set auto_index(tclPkgUnknown) [list ::tcl::Pkg::source [file join $dir package.tcl]] set auto_index(::tcl::MacOSXPkgUnknown) [list ::tcl::Pkg::source [file join $dir package.tcl]] set auto_index(::pkg::create) [list ::tcl::Pkg::source [file join $dir package.tcl]] set auto_index(parray) [list ::tcl::Pkg::source [file join $dir parray.tcl]] set auto_index(readFile) [list ::tcl::Pkg::source [file join $dir readfile.tcl]] set auto_index(::safe::InterpStatics) [list ::tcl::Pkg::source [file join $dir safe.tcl]] set auto_index(::safe::InterpNested) [list ::tcl::Pkg::source [file join $dir safe.tcl]] set auto_index(::safe::interpCreate) [list ::tcl::Pkg::source [file join $dir safe.tcl]] set auto_index(::safe::interpInit) [list ::tcl::Pkg::source [file join $dir safe.tcl]] set auto_index(::safe::CheckInterp) [list ::tcl::Pkg::source [file join $dir safe.tcl]] set auto_index(::safe::interpConfigure) [list ::tcl::Pkg::source [file join $dir safe.tcl]] set auto_index(::safe::InterpCreate) [list ::tcl::Pkg::source [file join $dir safe.tcl]] |
︙ | ︙ | |||
63 64 65 66 67 68 69 70 71 72 73 74 75 76 | set auto_index(::safe::AliasEncoding) [list ::tcl::Pkg::source [file join $dir safe.tcl]] set auto_index(::safe::setSyncMode) [list ::tcl::Pkg::source [file join $dir safe.tcl]] set auto_index(tcl_wordBreakAfter) [list ::tcl::Pkg::source [file join $dir word.tcl]] set auto_index(tcl_wordBreakBefore) [list ::tcl::Pkg::source [file join $dir word.tcl]] set auto_index(tcl_endOfWord) [list ::tcl::Pkg::source [file join $dir word.tcl]] set auto_index(tcl_startOfNextWord) [list ::tcl::Pkg::source [file join $dir word.tcl]] set auto_index(tcl_startOfPreviousWord) [list ::tcl::Pkg::source [file join $dir word.tcl]] set auto_index(::tcl::tm::add) [list ::tcl::Pkg::source [file join $dir tm.tcl]] set auto_index(::tcl::tm::remove) [list ::tcl::Pkg::source [file join $dir tm.tcl]] set auto_index(::tcl::tm::list) [list ::tcl::Pkg::source [file join $dir tm.tcl]] set auto_index(::tcl::tm::Defaults) [list ::tcl::Pkg::source [file join $dir tm.tcl]] set auto_index(::tcl::tm::UnknownHandler) [list ::tcl::Pkg::source [file join $dir tm.tcl]] set auto_index(::tcl::tm::roots) [list ::tcl::Pkg::source [file join $dir tm.tcl]] set auto_index(::tcl::tm::path) [list ::tcl::Pkg::source [file join $dir tm.tcl]] | > | 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 | set auto_index(::safe::AliasEncoding) [list ::tcl::Pkg::source [file join $dir safe.tcl]] set auto_index(::safe::setSyncMode) [list ::tcl::Pkg::source [file join $dir safe.tcl]] set auto_index(tcl_wordBreakAfter) [list ::tcl::Pkg::source [file join $dir word.tcl]] set auto_index(tcl_wordBreakBefore) [list ::tcl::Pkg::source [file join $dir word.tcl]] set auto_index(tcl_endOfWord) [list ::tcl::Pkg::source [file join $dir word.tcl]] set auto_index(tcl_startOfNextWord) [list ::tcl::Pkg::source [file join $dir word.tcl]] set auto_index(tcl_startOfPreviousWord) [list ::tcl::Pkg::source [file join $dir word.tcl]] set auto_index(writeFile) [list ::tcl::Pkg::source [file join $dir writefile.tcl]] set auto_index(::tcl::tm::add) [list ::tcl::Pkg::source [file join $dir tm.tcl]] set auto_index(::tcl::tm::remove) [list ::tcl::Pkg::source [file join $dir tm.tcl]] set auto_index(::tcl::tm::list) [list ::tcl::Pkg::source [file join $dir tm.tcl]] set auto_index(::tcl::tm::Defaults) [list ::tcl::Pkg::source [file join $dir tm.tcl]] set auto_index(::tcl::tm::UnknownHandler) [list ::tcl::Pkg::source [file join $dir tm.tcl]] set auto_index(::tcl::tm::roots) [list ::tcl::Pkg::source [file join $dir tm.tcl]] set auto_index(::tcl::tm::path) [list ::tcl::Pkg::source [file join $dir tm.tcl]] |
Changes to library/tzdata/America/Nuuk.
︙ | ︙ | |||
85 86 87 88 89 90 91 | {1572138000 -10800 0 -03} {1585443600 -7200 1 -02} {1603587600 -10800 0 -03} {1616893200 -7200 1 -02} {1635642000 -10800 0 -03} {1648342800 -7200 1 -02} {1667091600 -10800 0 -03} | | | 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 | {1572138000 -10800 0 -03} {1585443600 -7200 1 -02} {1603587600 -10800 0 -03} {1616893200 -7200 1 -02} {1635642000 -10800 0 -03} {1648342800 -7200 1 -02} {1667091600 -10800 0 -03} {1679792400 -7200 0 -02} {1698541200 -7200 0 -02} {1711846800 -3600 1 -01} {1729990800 -7200 0 -02} {1743296400 -3600 1 -01} {1761440400 -7200 0 -02} {1774746000 -3600 1 -01} {1792890000 -7200 0 -02} |
︙ | ︙ |
Changes to library/tzdata/America/Scoresbysund.
︙ | ︙ | |||
87 88 89 90 91 92 93 | {1603587600 -3600 0 -01} {1616893200 0 1 +00} {1635642000 -3600 0 -01} {1648342800 0 1 +00} {1667091600 -3600 0 -01} {1679792400 0 1 +00} {1698541200 -3600 0 -01} | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 | {1603587600 -3600 0 -01} {1616893200 0 1 +00} {1635642000 -3600 0 -01} {1648342800 0 1 +00} {1667091600 -3600 0 -01} {1679792400 0 1 +00} {1698541200 -3600 0 -01} {1711846800 -3600 0 -01} {1729990800 -7200 0 -02} {1743296400 -3600 1 -01} {1761440400 -7200 0 -02} {1774746000 -3600 1 -01} {1792890000 -7200 0 -02} {1806195600 -3600 1 -01} {1824944400 -7200 0 -02} {1837645200 -3600 1 -01} {1856394000 -7200 0 -02} {1869094800 -3600 1 -01} {1887843600 -7200 0 -02} {1901149200 -3600 1 -01} {1919293200 -7200 0 -02} {1932598800 -3600 1 -01} {1950742800 -7200 0 -02} {1964048400 -3600 1 -01} {1982797200 -7200 0 -02} {1995498000 -3600 1 -01} {2014246800 -7200 0 -02} {2026947600 -3600 1 -01} {2045696400 -7200 0 -02} {2058397200 -3600 1 -01} {2077146000 -7200 0 -02} {2090451600 -3600 1 -01} {2108595600 -7200 0 -02} {2121901200 -3600 1 -01} {2140045200 -7200 0 -02} {2153350800 -3600 1 -01} {2172099600 -7200 0 -02} {2184800400 -3600 1 -01} {2203549200 -7200 0 -02} {2216250000 -3600 1 -01} {2234998800 -7200 0 -02} {2248304400 -3600 1 -01} {2266448400 -7200 0 -02} {2279754000 -3600 1 -01} {2297898000 -7200 0 -02} {2311203600 -3600 1 -01} {2329347600 -7200 0 -02} {2342653200 -3600 1 -01} {2361402000 -7200 0 -02} {2374102800 -3600 1 -01} {2392851600 -7200 0 -02} {2405552400 -3600 1 -01} {2424301200 -7200 0 -02} {2437606800 -3600 1 -01} {2455750800 -7200 0 -02} {2469056400 -3600 1 -01} {2487200400 -7200 0 -02} {2500506000 -3600 1 -01} {2519254800 -7200 0 -02} {2531955600 -3600 1 -01} {2550704400 -7200 0 -02} {2563405200 -3600 1 -01} {2582154000 -7200 0 -02} {2595459600 -3600 1 -01} {2613603600 -7200 0 -02} {2626909200 -3600 1 -01} {2645053200 -7200 0 -02} {2658358800 -3600 1 -01} {2676502800 -7200 0 -02} {2689808400 -3600 1 -01} {2708557200 -7200 0 -02} {2721258000 -3600 1 -01} {2740006800 -7200 0 -02} {2752707600 -3600 1 -01} {2771456400 -7200 0 -02} {2784762000 -3600 1 -01} {2802906000 -7200 0 -02} {2816211600 -3600 1 -01} {2834355600 -7200 0 -02} {2847661200 -3600 1 -01} {2866410000 -7200 0 -02} {2879110800 -3600 1 -01} {2897859600 -7200 0 -02} {2910560400 -3600 1 -01} {2929309200 -7200 0 -02} {2942010000 -3600 1 -01} {2960758800 -7200 0 -02} {2974064400 -3600 1 -01} {2992208400 -7200 0 -02} {3005514000 -3600 1 -01} {3023658000 -7200 0 -02} {3036963600 -3600 1 -01} {3055712400 -7200 0 -02} {3068413200 -3600 1 -01} {3087162000 -7200 0 -02} {3099862800 -3600 1 -01} {3118611600 -7200 0 -02} {3131917200 -3600 1 -01} {3150061200 -7200 0 -02} {3163366800 -3600 1 -01} {3181510800 -7200 0 -02} {3194816400 -3600 1 -01} {3212960400 -7200 0 -02} {3226266000 -3600 1 -01} {3245014800 -7200 0 -02} {3257715600 -3600 1 -01} {3276464400 -7200 0 -02} {3289165200 -3600 1 -01} {3307914000 -7200 0 -02} {3321219600 -3600 1 -01} {3339363600 -7200 0 -02} {3352669200 -3600 1 -01} {3370813200 -7200 0 -02} {3384118800 -3600 1 -01} {3402867600 -7200 0 -02} {3415568400 -3600 1 -01} {3434317200 -7200 0 -02} {3447018000 -3600 1 -01} {3465766800 -7200 0 -02} {3479072400 -3600 1 -01} {3497216400 -7200 0 -02} {3510522000 -3600 1 -01} {3528666000 -7200 0 -02} {3541971600 -3600 1 -01} {3560115600 -7200 0 -02} {3573421200 -3600 1 -01} {3592170000 -7200 0 -02} {3604870800 -3600 1 -01} {3623619600 -7200 0 -02} {3636320400 -3600 1 -01} {3655069200 -7200 0 -02} {3668374800 -3600 1 -01} {3686518800 -7200 0 -02} {3699824400 -3600 1 -01} {3717968400 -7200 0 -02} {3731274000 -3600 1 -01} {3750022800 -7200 0 -02} {3762723600 -3600 1 -01} {3781472400 -7200 0 -02} {3794173200 -3600 1 -01} {3812922000 -7200 0 -02} {3825622800 -3600 1 -01} {3844371600 -7200 0 -02} {3857677200 -3600 1 -01} {3875821200 -7200 0 -02} {3889126800 -3600 1 -01} {3907270800 -7200 0 -02} {3920576400 -3600 1 -01} {3939325200 -7200 0 -02} {3952026000 -3600 1 -01} {3970774800 -7200 0 -02} {3983475600 -3600 1 -01} {4002224400 -7200 0 -02} {4015530000 -3600 1 -01} {4033674000 -7200 0 -02} {4046979600 -3600 1 -01} {4065123600 -7200 0 -02} {4078429200 -3600 1 -01} {4096573200 -7200 0 -02} } |
Changes to library/tzdata/Antarctica/Casey.
︙ | ︙ | |||
10 11 12 13 14 15 16 17 | {1477065600 39600 0 +11} {1520701200 28800 0 +08} {1538856000 39600 0 +11} {1552752000 28800 0 +08} {1570129200 39600 0 +11} {1583596800 28800 0 +08} {1601740860 39600 0 +11} } | > > > > > | 10 11 12 13 14 15 16 17 18 19 20 21 22 | {1477065600 39600 0 +11} {1520701200 28800 0 +08} {1538856000 39600 0 +11} {1552752000 28800 0 +08} {1570129200 39600 0 +11} {1583596800 28800 0 +08} {1601740860 39600 0 +11} {1615640400 28800 0 +08} {1633190460 39600 0 +11} {1647090000 28800 0 +08} {1664640060 39600 0 +11} {1678291200 28800 0 +08} } |
Changes to library/tzdata/Antarctica/Vostok.
1 | # created by tools/tclZIC.tcl - do not edit | < < | | > > > > > > | 1 2 3 4 5 6 7 8 9 | # created by tools/tclZIC.tcl - do not edit set TZData(:Antarctica/Vostok) { {-9223372036854775808 0 0 -00} {-380073600 25200 0 +07} {760035600 0 0 -00} {783648000 25200 0 +07} {1702839600 18000 0 +05} } |
Changes to library/tzdata/Asia/Gaza.
︙ | ︙ | |||
256 257 258 259 260 261 262 | {3163276800 10800 1 EEST} {3179602800 7200 0 EET} {3194726400 10800 1 EEST} {3209842800 7200 0 EET} {3226176000 10800 1 EEST} {3240687600 7200 0 EET} {3243715200 10800 1 EEST} | > | > | > | | 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 | {3163276800 10800 1 EEST} {3179602800 7200 0 EET} {3194726400 10800 1 EEST} {3209842800 7200 0 EET} {3226176000 10800 1 EEST} {3240687600 7200 0 EET} {3243715200 10800 1 EEST} {3244921200 7200 0 EET} {3257625600 10800 1 EEST} {3271532400 7200 0 EET} {3274560000 10800 1 EEST} {3276370800 7200 0 EET} {3289075200 10800 1 EEST} {3301772400 7200 0 EET} {3305404800 10800 1 EEST} {3307820400 7200 0 EET} {3321129600 10800 1 EEST} {3332617200 7200 0 EET} {3335644800 10800 1 EEST} {3339270000 7200 0 EET} {3352579200 10800 1 EEST} {3362857200 7200 0 EET} {3366489600 10800 1 EEST} {3370719600 7200 0 EET} |
︙ | ︙ |
Changes to library/tzdata/Asia/Hebron.
︙ | ︙ | |||
255 256 257 258 259 260 261 | {3163276800 10800 1 EEST} {3179602800 7200 0 EET} {3194726400 10800 1 EEST} {3209842800 7200 0 EET} {3226176000 10800 1 EEST} {3240687600 7200 0 EET} {3243715200 10800 1 EEST} | > | > | > | | 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 | {3163276800 10800 1 EEST} {3179602800 7200 0 EET} {3194726400 10800 1 EEST} {3209842800 7200 0 EET} {3226176000 10800 1 EEST} {3240687600 7200 0 EET} {3243715200 10800 1 EEST} {3244921200 7200 0 EET} {3257625600 10800 1 EEST} {3271532400 7200 0 EET} {3274560000 10800 1 EEST} {3276370800 7200 0 EET} {3289075200 10800 1 EEST} {3301772400 7200 0 EET} {3305404800 10800 1 EEST} {3307820400 7200 0 EET} {3321129600 10800 1 EEST} {3332617200 7200 0 EET} {3335644800 10800 1 EEST} {3339270000 7200 0 EET} {3352579200 10800 1 EEST} {3362857200 7200 0 EET} {3366489600 10800 1 EEST} {3370719600 7200 0 EET} |
︙ | ︙ |
Added library/writefile.tcl.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | # writeFile: # Write the contents of a file. # # Copyright © 2023 Donal K Fellows. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # proc writeFile {args} { # Parse the arguments switch [llength $args] { 2 { lassign $args filename data set mode text } 3 { lassign $args filename mode data set MODES {binary text} set ERR [list -level 1 -errorcode [list TCL LOOKUP MODE $mode]] set mode [tcl::prefix match -message "mode" -error $ERR $MODES $mode] } default { set COMMAND [lindex [info level 0] 0] return -code error -errorcode {TCL WRONGARGS} \ "wrong # args: should be \"$COMMAND filename ?mode? data\"" } } # Write the file set f [open $filename [dict get {text w binary wb} $mode]] try { puts -nonewline $f $data } finally { close $f } } |
Changes to macosx/Tcl.xcodeproj/project.pbxproj.
︙ | ︙ | |||
238 239 240 241 242 243 244 | F96D3E0808F272A5004A47F5 /* Backslash.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = Backslash.3; sourceTree = "<group>"; }; F96D3E0908F272A5004A47F5 /* bgerror.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = bgerror.n; sourceTree = "<group>"; }; F96D3E0A08F272A5004A47F5 /* binary.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = binary.n; sourceTree = "<group>"; }; F96D3E0B08F272A5004A47F5 /* BoolObj.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = BoolObj.3; sourceTree = "<group>"; }; F96D3E0C08F272A5004A47F5 /* break.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = break.n; sourceTree = "<group>"; }; F96D3E0D08F272A5004A47F5 /* ByteArrObj.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = ByteArrObj.3; sourceTree = "<group>"; }; F96D3E0E08F272A5004A47F5 /* CallDel.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CallDel.3; sourceTree = "<group>"; }; | < | 238 239 240 241 242 243 244 245 246 247 248 249 250 251 | F96D3E0808F272A5004A47F5 /* Backslash.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = Backslash.3; sourceTree = "<group>"; }; F96D3E0908F272A5004A47F5 /* bgerror.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = bgerror.n; sourceTree = "<group>"; }; F96D3E0A08F272A5004A47F5 /* binary.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = binary.n; sourceTree = "<group>"; }; F96D3E0B08F272A5004A47F5 /* BoolObj.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = BoolObj.3; sourceTree = "<group>"; }; F96D3E0C08F272A5004A47F5 /* break.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = break.n; sourceTree = "<group>"; }; F96D3E0D08F272A5004A47F5 /* ByteArrObj.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = ByteArrObj.3; sourceTree = "<group>"; }; F96D3E0E08F272A5004A47F5 /* CallDel.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CallDel.3; sourceTree = "<group>"; }; F96D3E1008F272A5004A47F5 /* catch.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = catch.n; sourceTree = "<group>"; }; F96D3E1108F272A5004A47F5 /* cd.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = cd.n; sourceTree = "<group>"; }; F96D3E1208F272A5004A47F5 /* chan.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = chan.n; sourceTree = "<group>"; }; F96D3E1308F272A5004A47F5 /* ChnlStack.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = ChnlStack.3; sourceTree = "<group>"; }; F96D3E1408F272A5004A47F5 /* clock.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = clock.n; sourceTree = "<group>"; }; F96D3E1508F272A5004A47F5 /* close.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = close.n; sourceTree = "<group>"; }; F96D3E1608F272A5004A47F5 /* CmdCmplt.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CmdCmplt.3; sourceTree = "<group>"; }; |
︙ | ︙ | |||
973 974 975 976 977 978 979 | F96D3E0808F272A5004A47F5 /* Backslash.3 */, F96D3E0908F272A5004A47F5 /* bgerror.n */, F96D3E0A08F272A5004A47F5 /* binary.n */, F96D3E0B08F272A5004A47F5 /* BoolObj.3 */, F96D3E0C08F272A5004A47F5 /* break.n */, F96D3E0D08F272A5004A47F5 /* ByteArrObj.3 */, F96D3E0E08F272A5004A47F5 /* CallDel.3 */, | < | 972 973 974 975 976 977 978 979 980 981 982 983 984 985 | F96D3E0808F272A5004A47F5 /* Backslash.3 */, F96D3E0908F272A5004A47F5 /* bgerror.n */, F96D3E0A08F272A5004A47F5 /* binary.n */, F96D3E0B08F272A5004A47F5 /* BoolObj.3 */, F96D3E0C08F272A5004A47F5 /* break.n */, F96D3E0D08F272A5004A47F5 /* ByteArrObj.3 */, F96D3E0E08F272A5004A47F5 /* CallDel.3 */, F96D3E1008F272A5004A47F5 /* catch.n */, F96D3E1108F272A5004A47F5 /* cd.n */, F96D3E1208F272A5004A47F5 /* chan.n */, F96D3E1308F272A5004A47F5 /* ChnlStack.3 */, F93599CF0DF1F87F00E04F67 /* Class.3 */, F93599D00DF1F89E00E04F67 /* class.n */, F96D3E1408F272A5004A47F5 /* clock.n */, |
︙ | ︙ |
Changes to macosx/tclMacOSXFCmd.c.
︙ | ︙ | |||
639 640 641 642 643 644 645 | const char *string; int result = TCL_OK; Tcl_DString ds; Tcl_Encoding encoding = Tcl_GetEncoding(NULL, "macRoman"); Tcl_Size length; string = Tcl_GetStringFromObj(objPtr, &length); | | | 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 | const char *string; int result = TCL_OK; Tcl_DString ds; Tcl_Encoding encoding = Tcl_GetEncoding(NULL, "macRoman"); Tcl_Size length; string = Tcl_GetStringFromObj(objPtr, &length); Tcl_UtfToExternalDStringEx(NULL, encoding, string, length, TCL_ENCODING_PROFILE_LOSSLESS, &ds, NULL); if (Tcl_DStringLength(&ds) > 4) { if (interp) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "expected Macintosh OS type but got \"%s\": ", string)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "MAC_OSTYPE", (void *)NULL); } |
︙ | ︙ |
Changes to tests/abstractlist.test.
︙ | ︙ | |||
12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 | catch { ::tcltest::loadTestedCommands package require -exact tcl::test [info patchlevel] } testConstraint testevalex [llength [info commands testevalex]] set abstractlisttestvars [info var *] proc value-cmp {vara varb} { upvar $vara a upvar $varb b set ta [tcl::unsupported::representation $a] set tb [tcl::unsupported::representation $b] return [string compare $ta $tb] } set str "If you can keep your head when all about you Are losing theirs and blaming it on you," set str2 "If you can trust yourself when all men doubt you, But make allowance for their doubting, too." | > > > | | | | | | | | 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 | catch { ::tcltest::loadTestedCommands package require -exact tcl::test [info patchlevel] } testConstraint testevalex [llength [info commands testevalex]] testConstraint testobj [llength [info commands testobj]] testConstraint lstring [llength [info commands lstring]] testConstraint lgen [llength [info commands lgegenn]] set abstractlisttestvars [info var *] proc value-cmp {vara varb} { upvar $vara a upvar $varb b set ta [tcl::unsupported::representation $a] set tb [tcl::unsupported::representation $b] return [string compare $ta $tb] } set str "If you can keep your head when all about you Are losing theirs and blaming it on you," set str2 "If you can trust yourself when all men doubt you, But make allowance for their doubting, too." test abstractlist-1.0 {error cases} -constraints lstring -body { lstring } \ -returnCodes 1 \ -result {wrong # args: should be "lstring string"} test abstractlist-1.1 {error cases} -constraints lstring -body { lstring a b c } -returnCodes 1 \ -result {wrong # args: should be "lstring string"} test abstractlist-2.0 {no shimmer llength} -constraints {testobj lstring} -body { set l [lstring $str] set l-isa [testobj objtype $l] set len [llength $l] set l-isa2 [testobj objtype $l] list $l ${l-isa} ${len} ${l-isa2} } -cleanup { unset l } -result {{I f { } y o u { } c a n { } k e e p { } y o u r { } h e a d { } w h e n { } a l l { } a b o u t { } y o u { } A r e { } l o s i n g { } t h e i r s { } a n d { } b l a m i n g { } i t { } o n { } y o u ,} lstring 85 lstring} test abstractlist-2.1 {no shimmer lindex} {testobj lstring} { set l [lstring $str] set l-isa [testobj objtype $l] set ele [lindex $l 22] set l-isa2 [testobj objtype $l] list $l ${l-isa} ${ele} ${l-isa2} } {{I f { } y o u { } c a n { } k e e p { } y o u r { } h e a d { } w h e n { } a l l { } a b o u t { } y o u { } A r e { } l o s i n g { } t h e i r s { } a n d { } b l a m i n g { } i t { } o n { } y o u ,} lstring e lstring} test abstractlist-2.2 {no shimmer lreverse} {testobj lstring} { set l [lstring $str] set l-isa [testobj objtype $l] set r [lreverse $l] set r-isa [testobj objtype $r] set l-isa2 [testobj objtype $l] list $r ${l-isa} ${r-isa} ${l-isa2} } {{, u o y { } n o { } t i { } g n i m a l b { } d n a { } s r i e h t { } g n i s o l { } e r A { } u o y { } t u o b a { } l l a { } n e h w { } d a e h { } r u o y { } p e e k { } n a c { } u o y { } f I} lstring lstring lstring} test abstractlist-2.3 {no shimmer lrange} {testobj lstring} { set l [lstring $str] set l-isa [testobj objtype $l] set il [lsearch -all [lstring $str] { }] set l-isa2 [testobj objtype $l] lappend il [llength $l] set start 0 set words [lmap i $il { set w [join [lrange $l $start $i-1] {} ] set start [expr {$i+1}] set w }] set l-isa3 [testobj objtype $l] list ${l-isa} $il ${l-isa2} ${l-isa3} $words } {lstring {2 6 10 15 20 25 30 34 40 44 48 55 62 66 74 77 80 85} lstring lstring {If you can keep your head when all about you Are losing theirs and blaming it on you,}} test abstractlist-2.4 {no shimmer foreach} {testobj lstring} { set l [lstring $str] set l-isa [testobj objtype $l] set word {} set words {} foreach c $l { if {$c eq { }} { lappend words $word |
︙ | ︙ | |||
103 104 105 106 107 108 109 | set l-isa2 [testobj objtype $l] list ${l-isa} ${l-isa2} $words } {lstring lstring {If you can keep your head when all about you Are losing theirs and blaming it on you,}} # # The TBCE implements lreplace as a lrange + lappend operation, so, in this case, $m list, not an lstring. # | | | | | | | | | | | | | | | | | 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 | set l-isa2 [testobj objtype $l] list ${l-isa} ${l-isa2} $words } {lstring lstring {If you can keep your head when all about you Are losing theirs and blaming it on you,}} # # The TBCE implements lreplace as a lrange + lappend operation, so, in this case, $m list, not an lstring. # test abstractlist-2.5 {!no shimmer lreplace} {testobj lstring} { set l [lstring $str2] set l-isa [testobj objtype $l] set m [lreplace $l 78 86 { } f a i l i n g] set m-isa [testobj objtype $m] set l-isa1 [testobj objtype $l] list ${l-isa} $m ${m-isa} ${l-isa1} } {lstring {I f { } y o u { } c a n { } t r u s t { } y o u r s e l f { } w h e n { } a l l { } m e n { } d o u b t { } y o u , { } B u t { } m a k e { } a l l o w a n c e { } f o r { } t h e i r { } f a i l i n g , { } t o o .} lstring lstring} test abstractlist-2.6 {no shimmer ledit} {testobj lstring} { # "ledit m 9 8 S" set l [lstring $str2] set l-isa [testobj objtype $l] set e [ledit l 68 67 s] set e-isa [testobj objtype $e] list ${l-isa} $e ${e-isa} } {lstring {I f { } y o u { } c a n { } t r u s t { } y o u r s e l f { } w h e n { } a l l { } m e n { } d o u b t { } y o u , { } B u t { } m a k e { } a l l o w a n c e s { } f o r { } t h e i r { } d o u b t i n g , { } t o o .} lstring} test abstractlist-2.7 {no shimmer linsert} -constraints {testobj lstring} -body { # "ledit m 9 8 S" set l [lstring $str2] set l-isa [testobj objtype $l] set i [linsert $l 11 {*}[split "truly " {}]] set i-isa [testobj objtype $i] set res [list ${l-isa} $i ${i-isa}] set p [lpop i 23] set p-isa [testobj objtype $p] set i-isa2 [testobj objtype $i] lappend res $p ${p-isa} $i ${i-isa2} } -cleanup { unset l i l-isa i-isa res p p-isa } -result {lstring {I f { } y o u { } c a n { } t r u l y { } t r u s t { } y o u r s e l f { } w h e n { } a l l { } m e n { } d o u b t { } y o u , { } B u t { } m a k e { } a l l o w a n c e { } f o r { } t h e i r { } d o u b t i n g , { } t o o .} lstring y none {I f { } y o u { } c a n { } t r u l y { } t r u s t { } o u r s e l f { } w h e n { } a l l { } m e n { } d o u b t { } y o u , { } B u t { } m a k e { } a l l o w a n c e { } f o r { } t h e i r { } d o u b t i n g , { } t o o .} lstring} test abstractlist-2.8 {shimmer lassign} {testobj lstring} { set l [lstring Inconceivable] set l-isa [testobj objtype $l] set l2 [lassign $l i n c] set l-isa2 [testobj objtype $l] set l2-isa [testobj objtype $l2] list $l ${l-isa} $l2 ${l-isa2} ${l2-isa} } {{I n c o n c e i v a b l e} lstring {o n c e i v a b l e} lstring lstring} test abstractlist-2.9 {no shimmer lremove} {testobj lstring} { set l [lstring Inconceivable] set l-isa [testobj objtype $l] set l2 [lremove $l 0 1] set l-isa2 [testobj objtype $l] set l2-isa [testobj objtype $l2] list $l ${l-isa} $l2 ${l-isa2} ${l2-isa} } {{I n c o n c e i v a b l e} lstring {c o n c e i v a b l e} lstring lstring} test abstractlist-2.10 {shimmer lreverse} {testobj lstring} { set l [lstring Inconceivable] set l-isa [testobj objtype $l] set l2 [lreverse $l] set l-isa2 [testobj objtype $l] set l2-isa [testobj objtype $l2] list $l ${l-isa} $l2 ${l-isa2} ${l2-isa} } {{I n c o n c e i v a b l e} lstring {e l b a v i e c n o c n I} lstring lstring} test abstractlist-2.11 {shimmer lset} {testobj lstring} { set l [lstring Inconceivable] set l-isa [testobj objtype $l] set m [lset l 2 k] set m-isa [testobj objtype $m] list $l ${l-isa} $m ${m-isa} [value-cmp l m] } {{I n k o n c e i v a b l e} lstring {I n k o n c e i v a b l e} lstring 0} # lrepeat test abstractlist-2.12 {shimmer lrepeat} {testobj lstring} { set l [lstring Inconceivable] set l-isa [testobj objtype $l] set m [lrepeat 3 $l] set m-isa [testobj objtype $m] set n [lindex $m 1] list $l ${l-isa} $m ${m-isa} [testobj objtype $n] [value-cmp l n] } {{I n c o n c e i v a b l e} lstring {{I n c o n c e i v a b l e} {I n c o n c e i v a b l e} {I n c o n c e i v a b l e}} list lstring 0} test abstractlist-2.13 {no shimmer join llength==1} {testobj lstring} { set l [lstring G] set l-isa [testobj objtype $l] set j [join $l :] set j-isa [testobj objtype $j] list ${l-isa} $l ${j-isa} $j } {lstring G none G} test abstractlist-2.14 {error case lset multiple indicies} -constraints {testobj lstring} -body { set l [lstring Inconceivable] set l-isa [testobj objtype $l] set m [lset l 2 0 1 k] set m-isa [testobj objtype $m] list $l ${l-isa} $m ${m-isa} [value-cmp l m] } -returnCodes 1 \ -result {Multiple indicies not supported by lstring.} # lsort test abstractlist-3.0 {no shimmer llength} {testobj lstring} { set l [lstring -not SLICE $str] set l-isa [testobj objtype $l] set len [llength $l] set l-isa2 [testobj objtype $l] list $l ${l-isa} ${len} ${l-isa2} } {{I f { } y o u { } c a n { } k e e p { } y o u r { } h e a d { } w h e n { } a l l { } a b o u t { } y o u { } A r e { } l o s i n g { } t h e i r s { } a n d { } b l a m i n g { } i t { } o n { } y o u ,} lstring 85 lstring} test abstractlist-3.1 {no shimmer lindex} {testobj lstring} { set l [lstring -not SLICE $str] set l-isa [testobj objtype $l] set n 22 set ele [lindex $l $n] ;# exercise INST_LIST_INDEX set l-isa2 [testobj objtype $l] list $l ${l-isa} ${ele} ${l-isa2} } {{I f { } y o u { } c a n { } k e e p { } y o u r { } h e a d { } w h e n { } a l l { } a b o u t { } y o u { } A r e { } l o s i n g { } t h e i r s { } a n d { } b l a m i n g { } i t { } o n { } y o u ,} lstring e lstring} test abstractlist-3.2 {no shimmer lreverse} {testobj lstring} { set l [lstring -not SLICE $str] set l-isa [testobj objtype $l] set r [lreverse $l] set r-isa [testobj objtype $r] set l-isa2 [testobj objtype $l] list $r ${l-isa} ${r-isa} ${l-isa2} } {{, u o y { } n o { } t i { } g n i m a l b { } d n a { } s r i e h t { } g n i s o l { } e r A { } u o y { } t u o b a { } l l a { } n e h w { } d a e h { } r u o y { } p e e k { } n a c { } u o y { } f I} lstring lstring lstring} test abstractlist-3.3 {shimmer lrange} {testobj lstring} { set l [lstring -not SLICE $str] set l-isa [testobj objtype $l] set il [lsearch -all [lstring -not SLICE $str] { }] set l-isa2 [testobj objtype $l] lappend il [llength $l] set start 0 set words [lmap i $il { set w [join [lrange $l $start $i-1] {} ] set start [expr {$i+1}] set w }] set l-isa3 [testobj objtype $l]; # lrange defaults to list behavior list ${l-isa} $il ${l-isa2} ${l-isa3} $words } {lstring {2 6 10 15 20 25 30 34 40 44 48 55 62 66 74 77 80 85} lstring list {If you can keep your head when all about you Are losing theirs and blaming it on you,}} test abstractlist-3.4 {no shimmer foreach} {testobj lstring} { set l [lstring -not SLICE $str] set l-isa [testobj objtype $l] set word {} set words {} foreach c $l { if {$c eq { }} { lappend words $word |
︙ | ︙ | |||
265 266 267 268 269 270 271 | set l-isa2 [testobj objtype $l] list ${l-isa} ${l-isa2} $words } {lstring lstring {If you can keep your head when all about you Are losing theirs and blaming it on you,}} # # The TBCE implements lreplace as a lrange + lappend operation, so, in this case, $m list, not an lstring. # | | | | | | | | | | | | | | | 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 | set l-isa2 [testobj objtype $l] list ${l-isa} ${l-isa2} $words } {lstring lstring {If you can keep your head when all about you Are losing theirs and blaming it on you,}} # # The TBCE implements lreplace as a lrange + lappend operation, so, in this case, $m list, not an lstring. # test abstractlist-3.5 {!no shimmer lreplace} {testobj lstring} { set l [lstring -not SLICE $str2] set l-isa [testobj objtype $l] set m [lreplace $l 79 86 f a i l i n g] set m-isa [testobj objtype $m] set l-isa1 [testobj objtype $l] list ${l-isa} $m ${m-isa} ${l-isa1} } {lstring {I f { } y o u { } c a n { } t r u s t { } y o u r s e l f { } w h e n { } a l l { } m e n { } d o u b t { } y o u , { } B u t { } m a k e { } a l l o w a n c e { } f o r { } t h e i r { } f a i l i n g , { } t o o .} lstring lstring} test abstractlist-3.6 {no shimmer ledit} {testobj lstring} { # "ledit m 9 8 S" set l [lstring -not SLICE $str2] set l-isa [testobj objtype $l] set e [ledit l 68 67 s] set e-isa [testobj objtype $e] list ${l-isa} $e ${e-isa} } {lstring {I f { } y o u { } c a n { } t r u s t { } y o u r s e l f { } w h e n { } a l l { } m e n { } d o u b t { } y o u , { } B u t { } m a k e { } a l l o w a n c e s { } f o r { } t h e i r { } d o u b t i n g , { } t o o .} lstring} test abstractlist-3.7 {no shimmer linsert} {testobj lstring} { # "ledit m 9 8 S" set res {} set l [lstring -not SLICE $str2] set l-isa [testobj objtype $l] set i [linsert $l 35 {*}[split "wo" {}]] set i-isa [testobj objtype $i] set res [list ${l-isa} $i ${i-isa}] set p [lpop i 23] set p-isa [testobj objtype $p] set i-isa2 [testobj objtype $i] lappend res $p ${p-isa} $i ${i-isa2} } {lstring {I f { } y o u { } c a n { } t r u s t { } y o u r s e l f { } w h e n { } a l l { } w o m e n { } d o u b t { } y o u , { } B u t { } m a k e { } a l l o w a n c e { } f o r { } t h e i r { } d o u b t i n g , { } t o o .} lstring l none {I f { } y o u { } c a n { } t r u s t { } y o u r s e f { } w h e n { } a l l { } w o m e n { } d o u b t { } y o u , { } B u t { } m a k e { } a l l o w a n c e { } f o r { } t h e i r { } d o u b t i n g , { } t o o .} lstring} test abstractlist-3.8 {shimmer lassign} {testobj lstring} { set l [lstring -not SLICE Inconceivable] set l-isa [testobj objtype $l] set l2 [lassign $l i n c] ;# must be using lrange internally set l-isa2 [testobj objtype $l] set l2-isa [testobj objtype $l2] list $l ${l-isa} $l2 ${l-isa2} ${l2-isa} } {{I n c o n c e i v a b l e} lstring {o n c e i v a b l e} list list} test abstractlist-3.9 {no shimmer lremove} {testobj lstring} { set l [lstring -not SLICE Inconceivable] set l-isa [testobj objtype $l] set l2 [lremove $l 0 1] set l-isa2 [testobj objtype $l] set l2-isa [testobj objtype $l2] list $l ${l-isa} $l2 ${l-isa2} ${l2-isa} } {{I n c o n c e i v a b l e} lstring {c o n c e i v a b l e} lstring lstring} test abstractlist-3.10 {shimmer lreverse} {testobj lstring} { set l [lstring -not SLICE Inconceivable] set l-isa [testobj objtype $l] set l2 [lreverse $l] set l-isa2 [testobj objtype $l] set l2-isa [testobj objtype $l2] list $l ${l-isa} $l2 ${l-isa2} ${l2-isa} } {{I n c o n c e i v a b l e} lstring {e l b a v i e c n o c n I} lstring lstring} test abstractlist-3.11 {shimmer lset} {testobj lstring} { set l [lstring -not SLICE Inconceivable] set l-isa [testobj objtype $l] set four 4 set m [lset l $four-2 k] set m-isa [testobj objtype $m] list $l ${l-isa} $m ${m-isa} [value-cmp l m] } {{I n k o n c e i v a b l e} lstring {I n k o n c e i v a b l e} lstring 0} # lrepeat test abstractlist-3.12 {shimmer lrepeat} {testobj lstring} { set l [lstring -not SLICE Inconceivable] set l-isa [testobj objtype $l] set m [lrepeat 3 $l] set m-isa [testobj objtype $m] set n [lindex $m 1] list $l ${l-isa} $m ${m-isa} [testobj objtype $n] [value-cmp l n] } {{I n c o n c e i v a b l e} lstring {{I n c o n c e i v a b l e} {I n c o n c e i v a b l e} {I n c o n c e i v a b l e}} list lstring 0} # lsort foreach not {{} REVERSE SLICE SETELEMENT REPLACE GETELEMENTS} { testConstraint [format "%sShimmer" [string totitle $not]] [expr {$not eq ""}] set options [expr {$not ne "" ? "-not $not" : ""}] test abstractlist-$not-4.0 {no shimmer llength} {testobj lstring} { set l [lstring {*}$options $str] set l-isa [testobj objtype $l] set len [llength $l] set l-isa2 [testobj objtype $l] list $l ${l-isa} ${len} ${l-isa2} } {{I f { } y o u { } c a n { } k e e p { } y o u r { } h e a d { } w h e n { } a l l { } a b o u t { } y o u { } A r e { } l o s i n g { } t h e i r s { } a n d { } b l a m i n g { } i t { } o n { } y o u ,} lstring 85 lstring} test abstractlist-$not-4.1 {no shimmer lindex} {testobj lstring} { set l [lstring {*}$options $str] set l-isa [testobj objtype $l] set ele [lindex $l 22] set l-isa2 [testobj objtype $l] list $l ${l-isa} ${ele} ${l-isa2} } {{I f { } y o u { } c a n { } k e e p { } y o u r { } h e a d { } w h e n { } a l l { } a b o u t { } y o u { } A r e { } l o s i n g { } t h e i r s { } a n d { } b l a m i n g { } i t { } o n { } y o u ,} lstring e lstring} test abstractlist-$not-4.2 {lreverse} {ReverseShimmer testobj lstring} { set l [lstring {*}$options $str] set l-isa [testobj objtype $l] set r [lreverse $l] set r-isa [testobj objtype $r] set l-isa2 [testobj objtype $l] list $r ${l-isa} ${r-isa} ${l-isa2} } {{, u o y { } n o { } t i { } g n i m a l b { } d n a { } s r i e h t { } g n i s o l { } e r A { } u o y { } t u o b a { } l l a { } n e h w { } d a e h { } r u o y { } p e e k { } n a c { } u o y { } f I} lstring lstring lstring} test abstractlist-$not-4.3 {no shimmer lrange} {RangeShimmer testobj lstring} { set l [lstring {*}$options $str] set l-isa [testobj objtype $l] set il [lsearch -all [lstring {*}$options $str] { }] set l-isa2 [testobj objtype $l] lappend il [llength $l] set start 0 set words [lmap i $il { set w [join [lrange $l $start $i-1] {} ] set start [expr {$i+1}] set w }] set l-isa3 [testobj objtype $l] list ${l-isa} $il ${l-isa2} ${l-isa3} $words } {lstring {2 7 10 16 25 29 36 39 47 55 58 63} lstring lstring {If you can keep your head when all about you Are losing theirs and blaming it on you,}} test abstractlist-$not-4.4 {no shimmer foreach} {testobj lstring} { set l [lstring {*}$options $str] set l-isa [testobj objtype $l] set word {} set words {} foreach c $l { if {$c eq { }} { lappend words $word |
︙ | ︙ | |||
413 414 415 416 417 418 419 | set l-isa2 [testobj objtype $l] list ${l-isa} ${l-isa2} $words } {lstring lstring {If you can keep your head when all about you Are losing theirs and blaming it on you,}} # # The TBCE implements lreplace as a lrange + lappend operation, so, in this case, $m list, not an lstring. # | | | | | | | | | | | | | 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 | set l-isa2 [testobj objtype $l] list ${l-isa} ${l-isa2} $words } {lstring lstring {If you can keep your head when all about you Are losing theirs and blaming it on you,}} # # The TBCE implements lreplace as a lrange + lappend operation, so, in this case, $m list, not an lstring. # test abstractlist-$not-4.5 {!no shimmer lreplace} {RangeShimmer testobj lstring} { set l [lstring {*}$options $str2] set l-isa [testobj objtype $l] set m [lreplace $l 18 23 { } f a i l ?] set m-isa [testobj objtype $m] set l-isa1 [testobj objtype $l] list ${l-isa} $m ${m-isa} ${l-isa1} } {lstring {} list lstring} test abstractlist-$not-4.6 {no shimmer ledit} {SetelementShimmer ReplaceShimmer testobj lstring} { set l [lstring {*}$options $str2] set l-isa [testobj objtype $l] set e [ledit l 68 67 s] set e-isa [testobj objtype $e] list ${l-isa} $e ${e-isa} } {lstring {I f { } y o u { } c a n { } t r u s t { } y o u r s e l f { } w h e n { } a l l { } m e n { } d o u b t { } y o u , { } B u t { } m a k e { } a l l o w a n c e s { } f o r { } t h e i r { } d o u b t i n g , { } t o o .} lstring} test abstractlist-$not-4.7 {no shimmer linsert} {ReplaceShimmer GetelementsShimmer testobj lstring} { set l [lstring {*}$options $str2] set l-isa [testobj objtype $l] set i [linsert $l 12 {*}[split "almost " {}]] set i-isa [testobj objtype $i] set res [list ${l-isa} $i ${i-isa}] set p [lpop i 23] set p-isa [testobj objtype $p] set i-isa2 [testobj objtype $i] lappend res $p ${p-isa} $i ${i-isa2} } {lstring {I f { } y o u { } c a n { } t r u s t { } y o u r s e l f { } w h e n { } a l l { } m e n { } d o u b t { } y o u , { } B u t { } m a k e { } a l l o w a n c e { } f o r { } t h e i r { } d o u b t i n g , { } t o o .} lstring} # lassign probably uses lrange internally test abstractlist-$not-4.8 {shimmer lassign} {RangeShimmer testobj lstring} { set l [lstring {*}$options Inconceivable] set l-isa [testobj objtype $l] set l2 [lassign $l i n c] set l-isa2 [testobj objtype $l] set l2-isa [testobj objtype $l2] list $l ${l-isa} $l2 ${l-isa2} ${l2-isa} } {{I n c o n c e i v a b l e} lstring {o n c e i v a b l e} lstring lstring} test abstractlist-$not-4.9 {no shimmer lremove} {ReplaceShimmer testobj lstring} { set l [lstring {*}$options Inconceivable] set l-isa [testobj objtype $l] set l2 [lremove $l 0 1] set l-isa2 [testobj objtype $l] set l2-isa [testobj objtype $l2] list $l ${l-isa} $l2 ${l-isa2} ${l2-isa} } {{I n c o n c e i v a b l e} lstring {c o n c e i v a b l e} lstring lstring} test abstractlist-$not-4.10 {shimmer lreverse} {ReverseShimmer testobj lstring} { set l [lstring {*}$options Inconceivable] set l-isa [testobj objtype $l] set l2 [lreverse $l] set l-isa2 [testobj objtype $l] set l2-isa [testobj objtype $l2] list $l ${l-isa} $l2 ${l-isa2} ${l2-isa} } {{I n c o n c e i v a b l e} lstring {e l b a v i e c n o c n I} lstring lstring} test abstractlist-$not-4.11 {shimmer lset} {SetelementShimmer testobj lstring} { set l [lstring {*}$options Inconceivable] set l-isa [testobj objtype $l] set m [lset l 2 k] set m-isa [testobj objtype $m] list $l ${l-isa} $m ${m-isa} [value-cmp l m] } {{I n k o n c e i v a b l e} lstring {I n k o n c e i v a b l e} lstring 0} test abstractlist-$not-4.11x {lset not compiled} {SetelementShimmer testobj lstring testevalex} { set l [lstring {*}$options Inconceivable] set l-isa [testobj objtype $l] set m [testevalex {lset l 2 k}] set m-isa [testobj objtype $m] list $l ${l-isa} $m ${m-isa} [value-cmp l m] } {{I n k o n c e i v a b l e} lstring {I n k o n c e i v a b l e} lstring 0} test abstractlist-$not-4.11e {error case lset multiple indicies} \ -constraints {SetelementShimmer testobj lstring testevalex} -body { set l [lstring Inconceivable] set l-isa [testobj objtype $l] set m [testevalex {lset l 2 0 1 k}] set m-isa [testobj objtype $m] list $l ${l-isa} $m ${m-isa} [value-cmp l m] } -returnCodes 1 \ -result {Multiple indicies not supported by lstring.} # lrepeat test abstractlist-$not-4.12 {shimmer lrepeat} -constraints {testobj lstring} -body { set l [lstring {*}$options Inconceivable] set l-isa [testobj objtype $l] set m [lrepeat 3 $l] set m-isa [testobj objtype $m] set n [lindex $m 1] list $l ${l-isa} $m ${m-isa} [testobj objtype $n] [value-cmp l n] } -cleanup { } -result {{I n c o n c e i v a b l e} lstring {{I n c o n c e i v a b l e} {I n c o n c e i v a b l e} {I n c o n c e i v a b l e}} list lstring 0} # Disable constraint testConstraint [format "%sShimmer" [string totitle $not]] 1 } # # Test fix for bug in TEBC for STR CONCAT, and LIST INDEX # instructions. # This example abstract list (lgen) causes a rescursive call in TEBC, # stack management was not included for these instructions in TEBC. # test abstractlist-lgen-bug {bug in str concat and list operations} -constraints lgen -setup { set lgenfile [makeFile { # Test TIP 192 - Lazy Lists set res {} set cntr 0 # Fatal error here when [source]'d -- It is a refcounting problem... |
︙ | ︙ | |||
579 580 581 582 583 584 585 | #puts stderr "eval $script" eval $script } -cleanup { removeFile source.file unset res } -result {Index*2:0:-- {0 -> 0} {1 -> 6} {2 -> 12} {3 -> 18} {4 -> 24} {5 -> 30} {6 -> 36} {7 -> 42} {8 -> 48} {9 -> 54} {10 -> 60} {11 -> 66} {12 -> 72} {13 -> 78} {14 -> 84} {15 -> 90} {16 -> 96} my_expr(3):3 {7 8 9 10 11 12 13 14 15 16 17 18 19 20 21} {s2:Index+7: {7 8 9 10 11 12 13 14 15 16 17 18 19 20 21} :--} {foo:Index-8: {-8 -7 -6 -5 -4 -3 -2 -1 0 1 2 3 4 5 6} :--} 9len=15 9(3)=10 {bar:Index+7: {7 8 9 10 11 12 13 14 15 16 17 18 19 20 21} :--} {Index+7:7 8 9 10 11 12 13 14 15 16 17 18 19 20 21:--} {Index+7:7 8 9 10 11 12 13 14 15 16 17 18 19 20 21:--} {fib:0 1 1 2 3} {First 20 fibbinacci:0 1 1 2 3 5 8 13 21 34 55 89 144 233 377 610 987 1597 2584 4181} {First 20 fibbinacci from x :0 1 1 2 3 5 8 13 21 34 55 89 144 233 377 610 987 1597 2584 4181} Good-Bye!} | | | | 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 | #puts stderr "eval $script" eval $script } -cleanup { removeFile source.file unset res } -result {Index*2:0:-- {0 -> 0} {1 -> 6} {2 -> 12} {3 -> 18} {4 -> 24} {5 -> 30} {6 -> 36} {7 -> 42} {8 -> 48} {9 -> 54} {10 -> 60} {11 -> 66} {12 -> 72} {13 -> 78} {14 -> 84} {15 -> 90} {16 -> 96} my_expr(3):3 {7 8 9 10 11 12 13 14 15 16 17 18 19 20 21} {s2:Index+7: {7 8 9 10 11 12 13 14 15 16 17 18 19 20 21} :--} {foo:Index-8: {-8 -7 -6 -5 -4 -3 -2 -1 0 1 2 3 4 5 6} :--} 9len=15 9(3)=10 {bar:Index+7: {7 8 9 10 11 12 13 14 15 16 17 18 19 20 21} :--} {Index+7:7 8 9 10 11 12 13 14 15 16 17 18 19 20 21:--} {Index+7:7 8 9 10 11 12 13 14 15 16 17 18 19 20 21:--} {fib:0 1 1 2 3} {First 20 fibbinacci:0 1 1 2 3 5 8 13 21 34 55 89 144 233 377 610 987 1597 2584 4181} {First 20 fibbinacci from x :0 1 1 2 3 5 8 13 21 34 55 89 144 233 377 610 987 1597 2584 4181} Good-Bye!} test abstractlist-lgen-bug2 {bug in foreach} -constraints lgen -body { set x [lseq 17] set y [lgen 17 expr 6*] lappend res x-[lrange [tcl::unsupported::representation $x] 0 3] lappend res y-[lrange [tcl::unsupported::representation $y] 0 3] foreach i $x n $y { lappend res "$i -> $n" } lappend res x-[lrange [tcl::unsupported::representation $x] 0 3] lappend res y-[lrange [tcl::unsupported::representation $y] 0 3] } -cleanup { unset res } -result {{x-value is a arithseries} {y-value is a lgenseries} {0 -> 0} {1 -> 6} {2 -> 12} {3 -> 18} {4 -> 24} {5 -> 30} {6 -> 36} {7 -> 42} {8 -> 48} {9 -> 54} {10 -> 60} {11 -> 66} {12 -> 72} {13 -> 78} {14 -> 84} {15 -> 90} {16 -> 96} {x-value is a arithseries} {y-value is a lgenseries}} # scalar values test abstractlist-int {TclLengthOne: anti-shimmer of boolean, int, double, bignum} testobj { set res {} foreach i [list [expr {1+0}] [expr {true}] [expr {3.141592}] [expr {round(double(0x7fffffffffffffff))}]] { lappend res [testobj objtype $i] lappend res [llength $i] lappend res [testobj objtype $i] } #set w [expr {3.141592}] |
︙ | ︙ |
Changes to tests/binary.test.
︙ | ︙ | |||
3044 3045 3046 3047 3048 3049 3050 | } -result "expected byte sequence but character 4 was '乎' (U+004E4E)" test binary-80.3 {Tcl_GetBytesFromObj} -constraints testbytestring -returnCodes 1 -body { testbytestring [testbytestring "\xC0\x80\xA0\xA0\xA0\xE4\xB9\x8E"] } -result "expected byte sequence but character 4 was '乎' (U+004E4E)" test binary-80.4 {Tcl_GetBytesFromObj} -constraints testbytestring -returnCodes 1 -body { testbytestring [testbytestring "\xC0\x80\xA0\xA0\xA0\xF0\x9F\x98\x81"] } -result "expected byte sequence but character 4 was '\U01F601' (U+01F601)" | | | 3044 3045 3046 3047 3048 3049 3050 3051 3052 3053 3054 3055 3056 3057 3058 | } -result "expected byte sequence but character 4 was '乎' (U+004E4E)" test binary-80.3 {Tcl_GetBytesFromObj} -constraints testbytestring -returnCodes 1 -body { testbytestring [testbytestring "\xC0\x80\xA0\xA0\xA0\xE4\xB9\x8E"] } -result "expected byte sequence but character 4 was '乎' (U+004E4E)" test binary-80.4 {Tcl_GetBytesFromObj} -constraints testbytestring -returnCodes 1 -body { testbytestring [testbytestring "\xC0\x80\xA0\xA0\xA0\xF0\x9F\x98\x81"] } -result "expected byte sequence but character 4 was '\U01F601' (U+01F601)" test binary-80.5 {Tcl_GetBytesFromObj} -constraints {testbytestring pointerIs64bit deprecated} -body { testbytestring [string repeat A [expr 2**31]] } -returnCodes 1 -result "byte sequence length exceeds INT_MAX" # ---------------------------------------------------------------------- # cleanup ::tcltest::cleanupTests |
︙ | ︙ |
Changes to tests/cmdAH.test.
︙ | ︙ | |||
642 643 644 645 646 647 648 649 650 | # Failure expected set result $prefix incr expected_failidx $prefixLen } testfailindex cmdAH-4.4.14.$printable.middle convertto $enc $prefix$str$suffix $result $expected_failidx $profile } } test cmdAH-4.4.xx {convertto -profile strict} -constraints {testbytestring knownBug} -body { | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | 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 | # Failure expected set result $prefix incr expected_failidx $prefixLen } testfailindex cmdAH-4.4.14.$printable.middle convertto $enc $prefix$str$suffix $result $expected_failidx $profile } } proc ascii_compatible {enc} { # All bytes under 128 should map to their ascii values for {set i 0} {$i < 128} {incr i} { set bin [binary format c $i] if {[catch {set ch [encoding convertfrom -profile strict $enc $bin]}]} { return 0 } if {$ch ne [encoding convertfrom -profile strict ascii $bin]} { return 0 } } return 1 } # # Roundtrip tests for lossless profile foreach {enc hex profile str failidx ctrl comment} $encInvalidBytes { if {"knownBug" in $ctrl} continue if {$profile ne "lossless"} continue # There are multiple test cases based on location of invalid bytes set bytes [binary decode hex $hex] set prefix A set suffix B set prefix_bytes [encoding convertto $enc $prefix] set suffix_bytes [encoding convertto $enc $suffix] set prefixLen [string length $prefix_bytes] if {![ascii_compatible $enc]} { # These do not implement lossless behaviors test cmdAH-4.4.15.$hex.solo.$enc "Invalid byte under 128 for lossless profile" -body { encoding convertfrom -profile lossless $enc $bytes } -result \uFFFD* -match glob continue } if {$ctrl eq {} || "solo" in $ctrl} { test cmdAH-4.4.15.$hex.solo.$enc "Lossless roundtrip $hex for $enc" -body { set decoded [encoding convertfrom -profile lossless $enc $bytes] string equal $bytes [encoding convertto -profile lossless $enc $decoded] } -result 1 } if {$ctrl eq {} || "lead" in $ctrl} { test cmdAH-4.4.15.$hex.lead.$enc "Lossless roundtrip $hex for $enc" -body { set decoded [encoding convertfrom -profile lossless $enc $bytes$suffix_bytes] string equal $bytes$suffix_bytes [encoding convertto -profile lossless $enc $decoded] } -result 1 } if {$ctrl eq {} || "tail" in $ctrl} { test cmdAH-4.4.15.$hex.tail.$enc "Lossless roundtrip $hex for $enc" -body { set decoded [encoding convertfrom -profile lossless $enc $prefix_bytes$bytes] string equal $prefix_bytes$bytes [encoding convertto -profile lossless $enc $decoded] } -result 1 } if {$ctrl eq {} || "middle" in $ctrl} { test cmdAH-4.4.15.$hex.middle.$enc "Lossless roundtrip $hex for $enc" -body { set decoded [encoding convertfrom -profile lossless $enc $prefix_bytes$bytes$suffix_bytes] string equal $prefix_bytes$bytes$suffix_bytes [encoding convertto -profile lossless $enc $decoded] } -result 1 } } # # Non-ascii encoding should not output lossless wrappers foreach enc [encoding names] { if {$enc eq "cesu-8"} { test cmdAH-4.4.16.$enc "Lossless output for CESU-8" -body { encoding convertto -profile lossless $enc \uDC41 } -result \xED\xB1\x81 } elseif {[ascii_compatible $enc]} { test cmdAH-4.4.16.$enc "Lossless output for ascii-compatible encodings" -body { encoding convertto -profile lossless $enc \uDC41 } -result A } else { test cmdAH-4.4.16.$enc "Lossless output for ascii-incompatible encodings" -body { encoding convertto -profile lossless $enc \uDC41 } -result [encoding convertto -profile tcl8 $enc \uFFFD] } } # # Invalid bytes < 128 should map to FFFD for lossless profile # Find an invalid byte within a range for the given encoding proc find_invalid_byte {enc {lo 0} {hi 127}} { for {set i $lo} {$i <= $hi} {incr i} { set bin [binary format c $i] if {[catch {set ch [encoding convertfrom -profile strict $enc $bin]}]} { return $bin } } # All bytes under 128 are valid return "" } foreach enc [encoding names] { set byte [find_invalid_byte $enc] if {$byte ne ""} { test cmdAH-4.4.17.$enc "Invalid byte under 128 for lossless profile" -body { encoding convertfrom -profile lossless $enc $byte } -result \uFFFD } } test cmdAH-4.4.xx {convertto -profile strict} -constraints {testbytestring knownBug} -body { # TODO - what does testbytestring even test? Invalid UTF8 in the Tcl_Obj bytes field? encoding convertto -profile strict utf-8 A[testbytestring \x80]B } -returnCodes error -result {unexpected byte sequence starting at index 1: '\x80'} # # encoding names 4.5.* badnumargs cmdAH-4.5.1 {encoding names} {foo} test cmdAH-4.5.2 {encoding names should include at least utf-8 and iso8859-1 and at least one more} -body { set names [encoding names] list [expr {"utf-8" in $names}] [expr {"iso8859-1" in $names}] [expr {[llength $names] > 2}] } -result {1 1 1} # # encoding profiles 4.6.* badnumargs cmdAH-4.6.1 {encoding profiles} {foo} test cmdAH-4.6.2 {encoding profiles} -body { lsort [encoding profiles] } -result {lossless replace strict tcl8} # # file command test cmdAH-5.1 {Tcl_FileObjCmd} -returnCodes error -body { file } -result {wrong # args: should be "file subcommand ?arg ...?"} |
︙ | ︙ |
Changes to tests/dict.test.
︙ | ︙ | |||
15 16 17 18 19 20 21 22 23 24 25 26 27 28 | } catch { ::tcltest::loadTestedCommands package require -exact tcl::test [info patchlevel] } # Used for constraining memory leak tests testConstraint memory [llength [info commands memory]] if {[testConstraint memory]} { proc memtest script { set end [lindex [split [memory info] \n] 3 3] for {set i 0} {$i < 5} {incr i} { uplevel 1 $script | > > | 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 | } catch { ::tcltest::loadTestedCommands package require -exact tcl::test [info patchlevel] } testConstraint testobj [llength [info commands testobj]] # Used for constraining memory leak tests testConstraint memory [llength [info commands memory]] if {[testConstraint memory]} { proc memtest script { set end [lindex [split [memory info] \n] 3 3] for {set i 0} {$i < 5} {incr i} { uplevel 1 $script |
︙ | ︙ | |||
140 141 142 143 144 145 146 | } -result {missing value to go with key} test dict-3.15 {compiled dict get error cleanliness - Bug 2431847} -body { apply {{} { dict set a(z) b c dict get $a(z) d }} } -returnCodes error -result {key "d" not known in dictionary} | | | | 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 | } -result {missing value to go with key} test dict-3.15 {compiled dict get error cleanliness - Bug 2431847} -body { apply {{} { dict set a(z) b c dict get $a(z) d }} } -returnCodes error -result {key "d" not known in dictionary} test dict-3.16 {dict/list shimmering - Bug 3004007} testobj { set l [list p 1 p 2 q 3] dict get $l q list $l [testobj objtype $l] } {{p 1 p 2 q 3} dict} test dict-3.17 {dict/list shimmering - Bug 3004007} testobj { set l [list p 1 p 2 q 3] dict get $l q list [llength $l] [testobj objtype $l] } {6 dict} test dict-4.1 {dict replace command} { dict replace {a b c d} |
︙ | ︙ | |||
667 668 669 670 671 672 673 | dict for {k v} {a b} { return ok,$k,$v error "skipped return completely" } error "return didn't go far enough" }} } ok,a,b | | | 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 | dict for {k v} {a b} { return ok,$k,$v error "skipped return completely" } error "return didn't go far enough" }} } ok,a,b test dict-14.14 {dict for command: handle representation loss} -constraints testobj -body { set dictVar {a b c d e f g h} set keys {} set values {} dict for {k v} $dictVar { if {[string length $dictVar]} { lappend keys $k lappend values $v |
︙ | ︙ | |||
1812 1813 1814 1815 1816 1817 1818 | dict map {k v} {a b} { return ok,$k,$v error "skipped return completely" } error "return didn't go far enough" }} } ok,a,b | | | | 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 | dict map {k v} {a b} { return ok,$k,$v error "skipped return completely" } error "return didn't go far enough" }} } ok,a,b test dict-24.14 {dict map command: handle representation loss} -constraints testobj -setup { set keys {} set values {} } -body { set dictVar {a b c d e f g h} list [dict size [dict map {k v} $dictVar { if {[string length $dictVar]} { lappend keys $k lappend values $v return -level 0 $k } }]] [lsort $keys] [lsort $values] [testobj objtype $dictVar] } -cleanup { unset dictVar keys values k v } -result {4 {a c e g} {b d f h} string} test dict-24.14a {dict map command: handle representation loss} -constraints testobj -body { apply {{} { set dictVar {a b c d e f g h} list [dict size [dict map {k v} $dictVar { if {[string length $dictVar]} { lappend keys $k lappend values $v return -level 0 $k |
︙ | ︙ |
Changes to tests/encoding.test.
︙ | ︙ | |||
35 36 37 38 39 40 41 | variable x # Some tests require the testencoding command testConstraint testencoding [llength [info commands testencoding]] testConstraint testbytestring [llength [info commands testbytestring]] testConstraint teststringbytes [llength [info commands teststringbytes]] testConstraint exec [llength [info commands exec]] | < | 35 36 37 38 39 40 41 42 43 44 45 46 47 48 | variable x # Some tests require the testencoding command testConstraint testencoding [llength [info commands testencoding]] testConstraint testbytestring [llength [info commands testbytestring]] testConstraint teststringbytes [llength [info commands teststringbytes]] testConstraint exec [llength [info commands exec]] # TclInitEncodingSubsystem is tested by the rest of this file # TclFinalizeEncodingSubsystem is not currently tested test encoding-1.1 {Tcl_GetEncoding: system encoding} -setup { set old [encoding system] } -constraints {testencoding} -body { |
︙ | ︙ | |||
810 811 812 813 814 815 816 | test encoding-24.15.tcl8 {Parse invalid utf-8, -profile tcl8} -body { encoding convertfrom -profile tcl8 utf-8 "Z\xE0\x80" } -result Z\xE0\u20AC test encoding-24.16 {Parse valid or invalid utf-8} -constraints testbytestring -body { encoding convertto utf-8 [testbytestring "Z\u4343\x80"] } -returnCodes 1 -result {expected byte sequence but character 1 was '䍃' (U+004343)} test encoding-24.17 {Parse valid or invalid utf-8} -constraints testbytestring -body { | | | 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 | test encoding-24.15.tcl8 {Parse invalid utf-8, -profile tcl8} -body { encoding convertfrom -profile tcl8 utf-8 "Z\xE0\x80" } -result Z\xE0\u20AC test encoding-24.16 {Parse valid or invalid utf-8} -constraints testbytestring -body { encoding convertto utf-8 [testbytestring "Z\u4343\x80"] } -returnCodes 1 -result {expected byte sequence but character 1 was '䍃' (U+004343)} test encoding-24.17 {Parse valid or invalid utf-8} -constraints testbytestring -body { encoding convertto -profile tcl8 utf-8 [testbytestring "Z\xE0\x80"] } -result "Z\xC3\xA0\xE2\x82\xAC" test encoding-24.18 {Parse valid or invalid utf-8} -constraints testbytestring -body { encoding convertto utf-8 [testbytestring "Z\xE0\x80xxxxxx"] } -result "Z\xC3\xA0\xE2\x82\xACxxxxxx" test encoding-24.19.1 {Parse valid or invalid utf-8} -body { encoding convertto -profile tcl8 utf-8 "ZX\uD800" } -result ZX\xED\xA0\x80 |
︙ | ︙ | |||
1025 1026 1027 1028 1029 1030 1031 | } -cleanup { close $fa close $fb } -result {} } } | | < < | | | | | 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 | } -cleanup { close $fa close $fb } -result {} } } test encoding-26.0 {Tcl_GetEncodingSearchPath} -setup { set origPath [encoding dirs] encoding dirs slappy } -body { encoding dirs } -cleanup { encoding dirs $origPath } -result slappy file delete {*}[glob -directory [temporaryDirectory] *.chars *.tcltestout] # ===> Cut here <=== # EscapeFreeProc, GetTableEncoding, unilen are fully tested by the rest of # this file. |
︙ | ︙ | |||
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 | encoding convertfrom -profile tcl8 gb12345 x } -result x test encoding-bug-66ffafd309-1-strict {Bug [66ffafd309] - truncated DBCS} -body { encoding convertfrom -profile strict gb12345 x } -result {unexpected byte sequence starting at index 0: '\x78'} -returnCodes error test encoding-bug-66ffafd309-1-replace {Bug [66ffafd309] - truncated DBCS} -body { encoding convertfrom -profile replace gb12345 x } -result \uFFFD test encoding-bug-66ffafd309-2-tcl8 {Bug [66ffafd309] - invalid DBCS} -body { # Not truncated but invalid encoding convertfrom -profile tcl8 jis0208 \x78\x79 } -result \x78\x79 test encoding-bug-66ffafd309-2-strict {Bug [66ffafd309] - invalid DBCS} -body { # Not truncated but invalid encoding convertfrom -profile strict jis0208 \x78\x79 } -result {unexpected byte sequence starting at index 1: '\x79'} -returnCodes error test encoding-bug-66ffafd309-2-replace {Bug [66ffafd309] - invalid DBCS} -body { # Not truncated but invalid encoding convertfrom -profile replace jis0208 \x78\x79 } -result \uFFFD\uFFFD # cleanup namespace delete ::tcl::test::encoding ::tcltest::cleanupTests return # Local Variables: # mode: tcl # End: | > > > > > > > > > > > > > > > > | 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 | encoding convertfrom -profile tcl8 gb12345 x } -result x test encoding-bug-66ffafd309-1-strict {Bug [66ffafd309] - truncated DBCS} -body { encoding convertfrom -profile strict gb12345 x } -result {unexpected byte sequence starting at index 0: '\x78'} -returnCodes error test encoding-bug-66ffafd309-1-replace {Bug [66ffafd309] - truncated DBCS} -body { encoding convertfrom -profile replace gb12345 x } -result \uFFFD test encoding-bug-66ffafd309-1-lossless-a {Bug [66ffafd309] - truncated DBCS} -body { # lossless - byte < 128 encoding convertfrom -profile lossless gb12345 x } -result \uFFFD test encoding-bug-66ffafd309-1-lossless-b {Bug [66ffafd309] - truncated DBCS} -body { # lossless - byte > 128 encoding convertfrom -profile lossless gb12345 \x82 } -result \uFFFD test encoding-bug-66ffafd309-2-tcl8 {Bug [66ffafd309] - invalid DBCS} -body { # Not truncated but invalid encoding convertfrom -profile tcl8 jis0208 \x78\x79 } -result \x78\x79 test encoding-bug-66ffafd309-2-strict {Bug [66ffafd309] - invalid DBCS} -body { # Not truncated but invalid encoding convertfrom -profile strict jis0208 \x78\x79 } -result {unexpected byte sequence starting at index 1: '\x79'} -returnCodes error test encoding-bug-66ffafd309-2-replace {Bug [66ffafd309] - invalid DBCS} -body { # Not truncated but invalid encoding convertfrom -profile replace jis0208 \x78\x79 } -result \uFFFD\uFFFD test encoding-bug-66ffafd309-2-lossless-a {Bug [66ffafd309] - invalid DBCS} -body { # Not truncated but invalid. \x78 is invalid prefix encoding convertfrom -profile lossless jis0208 \x78\x79 } -result \uFFFD\uFFFD test encoding-bug-66ffafd309-2-lossless-b {Bug [66ffafd309] - invalid DBCS} -body { # Not truncated but invalid. \x21 is valid prefix but FF is not valid suffix encoding convertfrom -profile lossless jis0208 \x21\xFF } -result \uFFFD\uFFFD # cleanup namespace delete ::tcl::test::encoding ::tcltest::cleanupTests return # Local Variables: # mode: tcl # End: |
Changes to tests/encodingVectors.tcl.
1 2 3 4 5 6 7 8 9 10 11 | # This file contains test vectors for verifying various encodings. They are # stored in a common file so that they can be sourced into the various test # modules that are dependent on encodings. This file contains statically defined # test vectors. In addition, it sources the ICU-generated test vectors from # icuUcmTests.tcl. # # Note that sourcing the file will reinitialize any existing encoding test # vectors. # # List of defined encoding profiles | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | # This file contains test vectors for verifying various encodings. They are # stored in a common file so that they can be sourced into the various test # modules that are dependent on encodings. This file contains statically defined # test vectors. In addition, it sources the ICU-generated test vectors from # icuUcmTests.tcl. # # Note that sourcing the file will reinitialize any existing encoding test # vectors. # # List of defined encoding profiles set encProfiles {tcl8 strict replace lossless} set encDefaultProfile strict; # Should reflect the default from implementation # encValidStrings - Table of valid strings. # # Each row is <ENCODING STR BYTES CTRL COMMENT> # The pair <ENCODING,STR> should be unique for generated test ids to be unique. # STR is a string that can be encoded in the encoding ENCODING resulting |
︙ | ︙ | |||
107 108 109 110 111 112 113 114 115 116 117 118 119 120 | # ascii - Any byte above 127 is invalid and is mapped # to the same numeric code point except for the range # 80-9F which is treated as cp1252. # This tests the TableToUtfProc code path. lappend encInvalidBytes {*}{ ascii 80 tcl8 \u20AC -1 {knownBug} {map to cp1252} ascii 80 replace \uFFFD -1 {} {Smallest invalid byte} ascii 80 strict {} 0 {} {Smallest invalid byte} ascii 81 tcl8 \u0081 -1 {knownBug} {map to cp1252} ascii 82 tcl8 \u201A -1 {knownBug} {map to cp1252} ascii 83 tcl8 \u0192 -1 {knownBug} {map to cp1252} ascii 84 tcl8 \u201E -1 {knownBug} {map to cp1252} ascii 85 tcl8 \u2026 -1 {knownBug} {map to cp1252} ascii 86 tcl8 \u2020 -1 {knownBug} {map to cp1252} | > | 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 | # ascii - Any byte above 127 is invalid and is mapped # to the same numeric code point except for the range # 80-9F which is treated as cp1252. # This tests the TableToUtfProc code path. lappend encInvalidBytes {*}{ ascii 80 tcl8 \u20AC -1 {knownBug} {map to cp1252} ascii 80 replace \uFFFD -1 {} {Smallest invalid byte} ascii 80 lossless \uDC80 -1 {} {Smallest invalid byte} ascii 80 strict {} 0 {} {Smallest invalid byte} ascii 81 tcl8 \u0081 -1 {knownBug} {map to cp1252} ascii 82 tcl8 \u201A -1 {knownBug} {map to cp1252} ascii 83 tcl8 \u0192 -1 {knownBug} {map to cp1252} ascii 84 tcl8 \u201E -1 {knownBug} {map to cp1252} ascii 85 tcl8 \u2026 -1 {knownBug} {map to cp1252} ascii 86 tcl8 \u2020 -1 {knownBug} {map to cp1252} |
︙ | ︙ | |||
142 143 144 145 146 147 148 149 150 151 152 153 154 155 | ascii 9C tcl8 \u0153 -1 {knownBug} {map to cp1252} ascii 9D tcl8 \u009D -1 {knownBug} {map to cp1252} ascii 9E tcl8 \u017E -1 {knownBug} {map to cp1252} ascii 9F tcl8 \u0178 -1 {knownBug} {map to cp1252} ascii FF tcl8 \u00FF -1 {} {Largest invalid byte} ascii FF replace \uFFFD -1 {} {Largest invalid byte} ascii FF strict {} 0 {} {Largest invalid byte} } # utf-8 - valid sequences based on Table 3.7 in the Unicode # standard. # # Code Points First Second Third Fourth Byte | > | 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 | ascii 9C tcl8 \u0153 -1 {knownBug} {map to cp1252} ascii 9D tcl8 \u009D -1 {knownBug} {map to cp1252} ascii 9E tcl8 \u017E -1 {knownBug} {map to cp1252} ascii 9F tcl8 \u0178 -1 {knownBug} {map to cp1252} ascii FF tcl8 \u00FF -1 {} {Largest invalid byte} ascii FF replace \uFFFD -1 {} {Largest invalid byte} ascii FF lossless \uDCFF -1 {} {Largest invalid byte} ascii FF strict {} 0 {} {Largest invalid byte} } # utf-8 - valid sequences based on Table 3.7 in the Unicode # standard. # # Code Points First Second Third Fourth Byte |
︙ | ︙ | |||
166 167 168 169 170 171 172 173 174 175 176 177 178 179 | # Tests below are based on the "gaps" in the above table. Note ascii test # values are repeated because internally a different code path is used # (UtfToUtfProc). # Note C0, C1, F5:FF are invalid bytes ANYWHERE. Exception is C080 lappend encInvalidBytes {*}{ utf-8 80 tcl8 \u20AC -1 {} {map to cp1252} utf-8 80 replace \uFFFD -1 {} {Smallest invalid byte} utf-8 80 strict {} 0 {} {Smallest invalid byte} utf-8 81 tcl8 \u0081 -1 {} {map to cp1252} utf-8 82 tcl8 \u201A -1 {} {map to cp1252} utf-8 83 tcl8 \u0192 -1 {} {map to cp1252} utf-8 84 tcl8 \u201E -1 {} {map to cp1252} utf-8 85 tcl8 \u2026 -1 {} {map to cp1252} utf-8 86 tcl8 \u2020 -1 {} {map to cp1252} | > | 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 | # Tests below are based on the "gaps" in the above table. Note ascii test # values are repeated because internally a different code path is used # (UtfToUtfProc). # Note C0, C1, F5:FF are invalid bytes ANYWHERE. Exception is C080 lappend encInvalidBytes {*}{ utf-8 80 tcl8 \u20AC -1 {} {map to cp1252} utf-8 80 replace \uFFFD -1 {} {Smallest invalid byte} utf-8 80 lossless \uDC80 -1 {} {Smallest invalid byte} utf-8 80 strict {} 0 {} {Smallest invalid byte} utf-8 81 tcl8 \u0081 -1 {} {map to cp1252} utf-8 82 tcl8 \u201A -1 {} {map to cp1252} utf-8 83 tcl8 \u0192 -1 {} {map to cp1252} utf-8 84 tcl8 \u201E -1 {} {map to cp1252} utf-8 85 tcl8 \u2026 -1 {} {map to cp1252} utf-8 86 tcl8 \u2020 -1 {} {map to cp1252} |
︙ | ︙ | |||
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 | utf-8 9D tcl8 \u009D -1 {} {map to cp1252} utf-8 9E tcl8 \u017E -1 {} {map to cp1252} utf-8 9F tcl8 \u0178 -1 {} {map to cp1252} utf-8 C0 tcl8 \u00C0 -1 {} {C0 is invalid anywhere} utf-8 C0 strict {} 0 {} {C0 is invalid anywhere} utf-8 C0 replace \uFFFD -1 {} {C0 is invalid anywhere} utf-8 C080 tcl8 \u0000 -1 {} {C080 -> U+0 in Tcl's internal modified UTF8} utf-8 C080 strict {} 0 {} {C080 -> invalid} utf-8 C080 replace \uFFFD -1 {} {C080 -> single replacement char} utf-8 C0A2 tcl8 \u00C0\u00A2 -1 {} {websec.github.io - A} utf-8 C0A2 replace \uFFFD\uFFFD -1 {} {websec.github.io - A} utf-8 C0A2 strict {} 0 {} {websec.github.io - A} utf-8 C0A7 tcl8 \u00C0\u00A7 -1 {} {websec.github.io - double quote} utf-8 C0A7 replace \uFFFD\uFFFD -1 {} {websec.github.io - double quote} utf-8 C0A7 strict {} 0 {} {websec.github.io - double quote} utf-8 C0AE tcl8 \u00C0\u00AE -1 {} {websec.github.io - full stop} utf-8 C0AE replace \uFFFD\uFFFD -1 {} {websec.github.io - full stop} utf-8 C0AE strict {} 0 {} {websec.github.io - full stop} utf-8 C0AF tcl8 \u00C0\u00AF -1 {} {websec.github.io - solidus} utf-8 C0AF replace \uFFFD\uFFFD -1 {} {websec.github.io - solidus} utf-8 C0AF strict {} 0 {} {websec.github.io - solidus} utf-8 C1 tcl8 \u00C1 -1 {} {C1 is invalid everywhere} utf-8 C1 replace \uFFFD -1 {} {C1 is invalid everywhere} utf-8 C1 strict {} 0 {} {C1 is invalid everywhere} utf-8 C181 tcl8 \u00C1\u0081 -1 {} {websec.github.io - base test (A)} utf-8 C181 replace \uFFFD\uFFFD -1 {} {websec.github.io - base test (A)} utf-8 C181 strict {} 0 {} {websec.github.io - base test (A)} utf-8 C19C tcl8 \u00C1\u0153 -1 {} {websec.github.io - reverse solidus} utf-8 C19C replace \uFFFD\uFFFD -1 {} {websec.github.io - reverse solidus} utf-8 C19C strict {} 0 {} {websec.github.io - reverse solidus} utf-8 C2 tcl8 \u00C2 -1 {} {Missing trail byte} utf-8 C2 replace \uFFFD -1 {} {Missing trail byte} utf-8 C2 strict {} 0 {} {Missing trail byte} utf-8 C27F tcl8 \u00C2\x7F -1 {} {Trail byte must be 80:BF} utf-8 C27F replace \uFFFD\x7F -1 {} {Trail byte must be 80:BF} utf-8 C27F strict {} 0 {} {Trail byte must be 80:BF} utf-8 DF tcl8 \u00DF -1 {} {Missing trail byte} utf-8 DF replace \uFFFD -1 {} {Missing trail byte} utf-8 DF strict {} 0 {} {Missing trail byte} utf-8 DF7F tcl8 \u00DF\x7F -1 {} {Trail byte must be 80:BF} utf-8 DF7F replace \uFFFD\x7F -1 {} {Trail byte must be 80:BF} utf-8 DF7F strict {} 0 {} {Trail byte must be 80:BF} utf-8 DFE0A080 tcl8 \u00DF\u0800 -1 {} {Invalid trail byte is start of valid sequence} utf-8 DFE0A080 replace \uFFFD\u0800 -1 {} {Invalid trail byte is start of valid sequence} utf-8 DFE0A080 strict {} 0 {} {Invalid trail byte is start of valid sequence} utf-8 E0 tcl8 \u00E0 -1 {} {Missing trail byte} utf-8 E0 replace \uFFFD -1 {} {Missing trail byte} utf-8 E0 strict {} 0 {} {Missing trail byte} utf-8 E080 tcl8 \u00E0\u20AC -1 {} {First trail byte must be A0:BF} utf-8 E080 replace \uFFFD\uFFFD -1 {} {First trail byte must be A0:BF} utf-8 E080 strict {} 0 {} {First trail byte must be A0:BF} utf-8 E0819C tcl8 \u00E0\u0081\u0153 -1 {} {websec.github.io - reverse solidus} utf-8 E0819C replace \uFFFD\uFFFD\uFFFD -1 {} {websec.github.io - reverse solidus} utf-8 E0819C strict {} 0 {} {websec.github.io - reverse solidus} utf-8 E09F tcl8 \u00E0\u0178 -1 {} {First trail byte must be A0:BF} utf-8 E09F replace \uFFFD\uFFFD -1 {} {First trail byte must be A0:BF} utf-8 E09F strict {} 0 {} {First trail byte must be A0:BF} utf-8 E0A0 tcl8 \u00E0\u00A0 -1 {} {Missing second trail byte} utf-8 E0A0 replace \uFFFD -1 {knownW3C} {Missing second trail byte} utf-8 E0A0 strict {} 0 {} {Missing second trail byte} utf-8 E0BF tcl8 \u00E0\u00BF -1 {} {Missing second trail byte} utf-8 E0BF replace \uFFFD -1 {knownW3C} {Missing second trail byte} utf-8 E0BF strict {} 0 {} {Missing second trail byte} utf-8 E0A07F tcl8 \u00E0\u00A0\x7F -1 {} {Second trail byte must be 80:BF} | > > > > > > > > > > > > > > > > > > > > | > | > > > > > | > | > > > > > | > | > | | > > > > | > | > > > > > > > > | | > > > > | > | > > > > > > | > | > > > > > > > > > > > > > > > > > > | > | > > > | > > > > > > > | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > | > | > > > > > | > > | > | > > > > > < < | > | 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 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 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 | utf-8 9D tcl8 \u009D -1 {} {map to cp1252} utf-8 9E tcl8 \u017E -1 {} {map to cp1252} utf-8 9F tcl8 \u0178 -1 {} {map to cp1252} utf-8 C0 tcl8 \u00C0 -1 {} {C0 is invalid anywhere} utf-8 C0 strict {} 0 {} {C0 is invalid anywhere} utf-8 C0 replace \uFFFD -1 {} {C0 is invalid anywhere} utf-8 C0 lossless \uDCC0 -1 {} {C0 is invalid anywhere} utf-8 C080 tcl8 \u0000 -1 {} {C080 -> U+0 in Tcl's internal modified UTF8} utf-8 C080 strict {} 0 {} {C080 -> invalid} utf-8 C080 replace \uFFFD -1 {} {C080 -> single replacement char} utf-8 C080 lossless \uDCC0\uDC80 -1 {} {C080 -> two lossless wrappers} utf-8 C0A2 tcl8 \u00C0\u00A2 -1 {} {websec.github.io - A} utf-8 C0A2 replace \uFFFD\uFFFD -1 {} {websec.github.io - A} utf-8 C0A2 lossless \uDCC0\uDCA2 -1 {} {websec.github.io - A} utf-8 C0A2 strict {} 0 {} {websec.github.io - A} utf-8 C0A7 tcl8 \u00C0\u00A7 -1 {} {websec.github.io - double quote} utf-8 C0A7 replace \uFFFD\uFFFD -1 {} {websec.github.io - double quote} utf-8 C0A7 lossless \uDCC0\uDCA7 -1 {} {websec.github.io - A} utf-8 C0A7 strict {} 0 {} {websec.github.io - double quote} utf-8 C0AE tcl8 \u00C0\u00AE -1 {} {websec.github.io - full stop} utf-8 C0AE replace \uFFFD\uFFFD -1 {} {websec.github.io - full stop} utf-8 C0AE lossless \uDCC0\uDCAE -1 {} {websec.github.io - A} utf-8 C0AE strict {} 0 {} {websec.github.io - full stop} utf-8 C0AF tcl8 \u00C0\u00AF -1 {} {websec.github.io - solidus} utf-8 C0AF replace \uFFFD\uFFFD -1 {} {websec.github.io - solidus} utf-8 C0AF lossless \uDCC0\uDCAF -1 {} {websec.github.io - A} utf-8 C0AF strict {} 0 {} {websec.github.io - solidus} utf-8 C1 tcl8 \u00C1 -1 {} {C1 is invalid everywhere} utf-8 C1 replace \uFFFD -1 {} {C1 is invalid everywhere} utf-8 C1 lossless \uDCC1 -1 {} {C1 is invalid anywhere} utf-8 C1 strict {} 0 {} {C1 is invalid everywhere} utf-8 C181 tcl8 \u00C1\u0081 -1 {} {websec.github.io - base test (A)} utf-8 C181 replace \uFFFD\uFFFD -1 {} {websec.github.io - base test (A)} utf-8 C181 lossless \uDCC1\uDC81 -1 {} {websec.github.io - base test (A)} utf-8 C181 strict {} 0 {} {websec.github.io - base test (A)} utf-8 C19C tcl8 \u00C1\u0153 -1 {} {websec.github.io - reverse solidus} utf-8 C19C replace \uFFFD\uFFFD -1 {} {websec.github.io - reverse solidus} utf-8 C19C lossless \uDCC1\uDC9C -1 {} {websec.github.io - reverse solidus} utf-8 C19C strict {} 0 {} {websec.github.io - reverse solidus} utf-8 C2 tcl8 \u00C2 -1 {} {Missing trail byte} utf-8 C2 replace \uFFFD -1 {} {Missing trail byte} utf-8 C2 lossless \uDCC2 -1 {} {Missing trail byte} utf-8 C2 strict {} 0 {} {Missing trail byte} utf-8 C27F tcl8 \u00C2\x7F -1 {} {Trail byte must be 80:BF} utf-8 C27F replace \uFFFD\x7F -1 {} {Trail byte must be 80:BF} utf-8 C27F lossless \uDCC2\x7F -1 {} {Trail byte must be 80:BF} utf-8 C27F strict {} 0 {} {Trail byte must be 80:BF} utf-8 DF tcl8 \u00DF -1 {} {Missing trail byte} utf-8 DF replace \uFFFD -1 {} {Missing trail byte} utf-8 DF lossless \uDCDF -1 {} {Missing trail byte} utf-8 DF strict {} 0 {} {Missing trail byte} utf-8 DF7F tcl8 \u00DF\x7F -1 {} {Trail byte must be 80:BF} utf-8 DF7F replace \uFFFD\x7F -1 {} {Trail byte must be 80:BF} utf-8 DF7F lossless \uDCDF\x7F -1 {} {Trail byte must be 80:BF} utf-8 DF7F strict {} 0 {} {Trail byte must be 80:BF} utf-8 DFE0A080 tcl8 \u00DF\u0800 -1 {} {Invalid trail byte is start of valid sequence} utf-8 DFE0A080 replace \uFFFD\u0800 -1 {} {Invalid trail byte is start of valid sequence} utf-8 DFE0A080 lossless \uDCDF\u0800 -1 {} {Invalid trail byte is start of valid sequence} utf-8 DFE0A080 strict {} 0 {} {Invalid trail byte is start of valid sequence} utf-8 E0 tcl8 \u00E0 -1 {} {Missing trail byte} utf-8 E0 replace \uFFFD -1 {} {Missing trail byte} utf-8 E0 lossless \uDCE0 -1 {} {Missing trail byte} utf-8 E0 strict {} 0 {} {Missing trail byte} utf-8 E080 tcl8 \u00E0\u20AC -1 {} {First trail byte must be A0:BF} utf-8 E080 replace \uFFFD\uFFFD -1 {} {First trail byte must be A0:BF} utf-8 E080 lossless \uDCE0\uDC80 -1 {} {First trail byte must be A0:BF} utf-8 E080 strict {} 0 {} {First trail byte must be A0:BF} utf-8 E0819C tcl8 \u00E0\u0081\u0153 -1 {} {websec.github.io - reverse solidus} utf-8 E0819C replace \uFFFD\uFFFD\uFFFD -1 {} {websec.github.io - reverse solidus} utf-8 E0819C lossless \uDCE0\uDC81\uDC9C -1 {} {websec.github.io - reverse solidus} utf-8 E0819C strict {} 0 {} {websec.github.io - reverse solidus} utf-8 E09F tcl8 \u00E0\u0178 -1 {} {First trail byte must be A0:BF} utf-8 E09F replace \uFFFD\uFFFD -1 {} {First trail byte must be A0:BF} utf-8 E09F lossless \uDCE0\uDC9F -1 {} {First trail byte must be A0:BF} utf-8 E09F strict {} 0 {} {First trail byte must be A0:BF} utf-8 E0A0 tcl8 \u00E0\u00A0 -1 {} {Missing second trail byte} utf-8 E0A0 replace \uFFFD -1 {knownW3C} {Missing second trail byte} utf-8 E0A0 lossless \uDCE0\uDCA0 -1 {} {Missing second trail byte} utf-8 E0A0 strict {} 0 {} {Missing second trail byte} utf-8 E0BF tcl8 \u00E0\u00BF -1 {} {Missing second trail byte} utf-8 E0BF replace \uFFFD -1 {knownW3C} {Missing second trail byte} utf-8 E0BF lossless \uDCE0\uDCBF -1 {} {Missing second trail byte} utf-8 E0BF strict {} 0 {} {Missing second trail byte} utf-8 E0A07F tcl8 \u00E0\u00A0\x7F -1 {} {Second trail byte must be 80:BF} utf-8 E0A07F replace \uFFFD\x7F -1 {knownW3C} {Second trail byte must be 80:BF} utf-8 E0A07F lossless \uDCE0\uDCA0\x7F -1 {} {Second trail byte must be 80:BF} utf-8 E0A07F strict {} 0 {} {Second trail byte must be 80:BF} utf-8 E0BF7F tcl8 \u00E0\u00BF\x7F -1 {} {Second trail byte must be 80:BF} utf-8 E0BF7F replace \uFFFD\x7F -1 {knownW3C} {Second trail byte must be 80:BF} utf-8 E0BF7F lossless \uDCE0\uDCBF\x7F -1 {} {Second trail byte must be 80:BF} utf-8 E0BF7F strict {} 0 {} {Second trail byte must be 80:BF} utf-8 E1 tcl8 \u00E1 -1 {} {Missing trail byte} utf-8 E1 replace \uFFFD -1 {} {Missing trail byte} utf-8 E1 lossless \uDCE1 -1 {} {Missing trail byte} utf-8 E1 strict {} 0 {} {Missing trail byte} utf-8 E17F tcl8 \u00E1\x7F -1 {} {Trail byte must be 80:BF} utf-8 E17F replace \uFFFD\x7F -1 {} {Trail byte must be 80:BF} utf-8 E17F lossless \uDCE1\x7F -1 {} {Trail byte must be 80:BF} utf-8 E17F strict {} 0 {} {Trail byte must be 80:BF} utf-8 E181 tcl8 \u00E1\u0081 -1 {} {Missing second trail byte} utf-8 E181 replace \uFFFD -1 {knownW3C} {Missing second trail byte} utf-8 E181 lossless \uDCE1\uDC81 -1 {} {Missing second trail byte} utf-8 E181 strict {} 0 {} {Missing second trail byte} utf-8 E1BF tcl8 \u00E1\u00BF -1 {} {Missing second trail byte} utf-8 E1BF replace \uFFFD -1 {knownW3C} {Missing second trail byte} utf-8 E1BF lossless \uDCE1\uDCBF -1 {} {Missing second trail byte} utf-8 E1BF strict {} 0 {} {Missing second trail byte} utf-8 E1807F tcl8 \u00E1\u20AC\x7F -1 {} {Second trail byte must be 80:BF} utf-8 E1807F replace \uFFFD\x7F -1 {knownW3C} {Second trail byte must be 80:BF} utf-8 E1807F lossless \uDCE1\uDC80\x7F -1 {} {Second trail byte must be 80:BF} utf-8 E1807F strict {} 0 {} {Second trail byte must be 80:BF} utf-8 E1BF7F tcl8 \u00E1\u00BF\x7F -1 {} {Second trail byte must be 80:BF} utf-8 E1BF7F replace \uFFFD\x7F -1 {knownW3C} {Second trail byte must be 80:BF} utf-8 E1BF7F lossless \uDCE1\uDCBF\x7F -1 {} {Second trail byte must be 80:BF} utf-8 E1BF7F strict {} 0 {} {Second trail byte must be 80:BF} utf-8 EC tcl8 \u00EC -1 {} {Missing trail byte} utf-8 EC replace \uFFFD -1 {} {Missing trail byte} utf-8 EC lossless \uDCEC -1 {} {Missing trail byte} utf-8 EC strict {} 0 {} {Missing trail byte} utf-8 EC7F tcl8 \u00EC\x7F -1 {} {Trail byte must be 80:BF} utf-8 EC7F replace \uFFFD\x7F -1 {} {Trail byte must be 80:BF} utf-8 EC7F lossless \uDCEC\x7F -1 {} {Trail byte must be 80:BF} utf-8 EC7F strict {} 0 {} {Trail byte must be 80:BF} utf-8 EC81 tcl8 \u00EC\u0081 -1 {} {Missing second trail byte} utf-8 EC81 replace \uFFFD -1 {knownW3C} {Missing second trail byte} utf-8 EC81 lossless \uDCEC\uDC81 -1 {} {Missing second trail byte} utf-8 EC81 strict {} 0 {} {Missing second trail byte} utf-8 ECBF tcl8 \u00EC\u00BF -1 {} {Missing second trail byte} utf-8 ECBF replace \uFFFD -1 {knownW3C} {Missing second trail byte} utf-8 ECBF lossless \uDCEC\uDCBF -1 {} {Missing second trail byte} utf-8 ECBF strict {} 0 {} {Missing second trail byte} utf-8 EC807F tcl8 \u00EC\u20AC\x7F -1 {} {Second trail byte must be 80:BF} utf-8 EC807F replace \uFFFD\x7F -1 {knownW3C} {Second trail byte must be 80:BF} utf-8 EC807F lossless \uDCEC\uDC80\x7F -1 {} {Second trail byte must be 80:BF} utf-8 EC807F strict {} 0 {} {Second trail byte must be 80:BF} utf-8 ECBF7F tcl8 \u00EC\u00BF\x7F -1 {} {Second trail byte must be 80:BF} utf-8 ECBF7F replace \uFFFD\x7F -1 {knownW3C} {Second trail byte must be 80:BF} utf-8 ECBF7F lossless \uDCEC\uDCBF\x7F -1 {} {Second trail byte must be 80:BF} utf-8 ECBF7F strict {} 0 {} {Second trail byte must be 80:BF} utf-8 ED tcl8 \u00ED -1 {} {Missing trail byte} utf-8 ED replace \uFFFD -1 {} {Missing trail byte} utf-8 ED strict {} 0 {} {Missing trail byte} utf-8 ED7F tcl8 \u00ED\x7F -1 {} {First trail byte must be 80:9F} utf-8 ED7F replace \uFFFD\x7F -1 {} {First trail byte must be 80:9F} utf-8 ED7F lossless \uDCED\x7F -1 {} {First trail byte must be 80:9F} utf-8 ED7F strict {} 0 {} {First trail byte must be 80:9F} utf-8 EDA0 tcl8 \u00ED\u00A0 -1 {} {First trail byte must be 80:9F} utf-8 EDA0 replace \uFFFD\uFFFD -1 {} {First trail byte must be 80:9F} utf-8 EDA0 lossless \uDCED\uDCA0 -1 {} {First trail byte must be 80:9F} utf-8 EDA0 strict {} 0 {} {First trail byte must be 80:9F} utf-8 ED81 tcl8 \u00ED\u0081 -1 {} {Missing second trail byte} utf-8 ED81 replace \uFFFD -1 {knownW3C} {Missing second trail byte} utf-8 ED81 lossless \uDCED\uDC81 -1 {} {Missing second trail byte} utf-8 ED81 strict {} 0 {} {Missing second trail byte} utf-8 EDBF tcl8 \u00ED\u00BF -1 {} {Missing second trail byte} utf-8 EDBF replace \uFFFD -1 {knownW3C} {Missing second trail byte} utf-8 EDBF lossless \uDCED\uDCBF -1 {} {Missing second trail byte} utf-8 EDBF strict {} 0 {} {Missing second trail byte} utf-8 ED807F tcl8 \u00ED\u20AC\x7F -1 {} {Second trail byte must be 80:BF} utf-8 ED807F replace \uFFFD\x7F -1 {knownW3C} {Second trail byte must be 80:BF} utf-8 ED807F lossless \uDCED\uDC80\x7F -1 {} {Second trail byte must be 80:BF} utf-8 ED807F strict {} 0 {} {Second trail byte must be 80:BF} utf-8 ED9F7F tcl8 \u00ED\u0178\x7F -1 {} {Second trail byte must be 80:BF} utf-8 ED9F7F replace \uFFFD\x7F -1 {knownW3C} {Second trail byte must be 80:BF} utf-8 ED9F7F lossless \uDCED\uDC9F\x7F -1 {} {Second trail byte must be 80:BF} utf-8 ED9F7F strict {} 0 {} {Second trail byte must be 80:BF} utf-8 EDA080 tcl8 \uD800 -1 {} {High surrogate} utf-8 EDA080 replace \uFFFD -1 {knownBug} {High surrogate} utf-8 EDA080 lossless \uDCED\uDCA0\uED80 -1 {knownBug} {High surrogate} utf-8 EDA080 strict {} 0 {} {High surrogate} utf-8 EDAFBF tcl8 \uDBFF -1 {} {High surrogate} utf-8 EDAFBF replace \uFFFD -1 {knownBug} {High surrogate} utf-8 EDAFBF lossless \uDCED\uDCAF\uDCBF -1 {knownBug} {High surrogate} utf-8 EDAFBF strict {} 0 {} {High surrogate} utf-8 EDB080 tcl8 \uDC00 -1 {} {Low surrogate} utf-8 EDB080 replace \uFFFD -1 {knownBug} {Low surrogate} utf-8 EDB080 lossless \uDCED\uDCB0\uDC80 -1 {knownBug} {Low surrogate} utf-8 EDB080 strict {} 0 {} {Low surrogate} utf-8 EDBFBF tcl8 \uDFFF -1 {knownBug} {Low surrogate} utf-8 EDBFBF replace \uFFFD -1 {knownBug} {Low surrogate} utf-8 EDBFBF lossless \uDCED\uDCBF\uDCBF -1 {knownBug} {Low surrogate} utf-8 EDBFBF strict {} 0 {} {Low surrogate} utf-8 EDA080EDB080 tcl8 \U00010000 -1 {knownBug} {High low surrogate pair} utf-8 EDA080EDB080 replace \uFFFD\uFFFD -1 {knownBug} {High low surrogate pair} utf-8 EDA080EDB080 lossless \uDCED\uDCA0\uDC80\uDCED\uDCB0\uDC80 -1 {knownBug} {High low surrogate pair} utf-8 EDA080EDB080 strict {} 0 {} {High low surrogate pair} utf-8 EDAFBFEDBFBF tcl8 \U0010FFFF -1 {knownBug} {High low surrogate pair} utf-8 EDAFBFEDBFBF replace \uFFFD\uFFFD -1 {knownBug} {High low surrogate pair} utf-8 EDAFBFEDBFBF lossless \uDCED\uDCAF\uDCBF\uDCED\uDCBF\uDCBF -1 {knownBug} {High low surrogate pair} utf-8 EDAFBFEDBFBF strict {} 0 {} {High low surrogate pair} utf-8 EE tcl8 \u00EE -1 {} {Missing trail byte} utf-8 EE replace \uFFFD -1 {} {Missing trail byte} utf-8 EE lossless \uDCEE -1 {} {Missing trail byte} utf-8 EE strict {} 0 {} {Missing trail byte} utf-8 EE7F tcl8 \u00EE\x7F -1 {} {First trail byte must be 80:BF} utf-8 EE7F replace \uFFFD\x7F -1 {} {First trail byte must be 80:BF} utf-8 EE7F lossless \uDCEE\x7F -1 {} {First trail byte must be 80:BF} utf-8 EE7F strict {} 0 {} {First trail byte must be 80:BF} utf-8 EED0 tcl8 \u00EE\u00D0 -1 {} {First trail byte must be 80:BF} utf-8 EED0 replace \uFFFD\uFFFD -1 {} {First trail byte must be 80:BF} utf-8 EED0 lossless \uDCEE\uDCD0 -1 {} {First trail byte must be 80:BF} utf-8 EED0 strict {} 0 {} {First trail byte must be 80:BF} utf-8 EE81 tcl8 \u00EE\u0081 -1 {} {Missing second trail byte} utf-8 EE81 replace \uFFFD -1 {knownW3C} {Missing second trail byte} utf-8 EE81 lossless \uDCEE\uDC81 -1 {} {Missing second trail byte} utf-8 EE81 strict {} 0 {} {Missing second trail byte} utf-8 EEBF tcl8 \u00EE\u00BF -1 {} {Missing second trail byte} utf-8 EEBF replace \uFFFD -1 {knownW3C} {Missing second trail byte} utf-8 EEBF lossless \uDCEE\uDCBF -1 {} {Missing second trail byte} utf-8 EEBF strict {} 0 {} {Missing second trail byte} utf-8 EE807F tcl8 \u00EE\u20AC\x7F -1 {} {Second trail byte must be 80:BF} utf-8 EE807F replace \uFFFD\x7F -1 {knownW3C} {Second trail byte must be 80:BF} utf-8 EE807F lossless \uDCEE\uDC80\x7F -1 {} {Second trail byte must be 80:BF} utf-8 EE807F strict {} 0 {} {Second trail byte must be 80:BF} utf-8 EEBF7F tcl8 \u00EE\u00BF\x7F -1 {} {Second trail byte must be 80:BF} utf-8 EEBF7F replace \uFFFD\x7F -1 {knownW3C} {Second trail byte must be 80:BF} utf-8 EEBF7F lossless \uDCEE\uDCBF\x7F -1 {} {Second trail byte must be 80:BF} utf-8 EEBF7F strict {} 0 {} {Second trail byte must be 80:BF} utf-8 EF tcl8 \u00EF -1 {} {Missing trail byte} utf-8 EF replace \uFFFD -1 {} {Missing trail byte} utf-8 EF lossless \uDCEF -1 {} {Missing trail byte} utf-8 EF strict {} 0 {} {Missing trail byte} utf-8 EF7F tcl8 \u00EF\u7F -1 {} {First trail byte must be 80:BF} utf-8 EF7F replace \uFFFD\u7F -1 {} {First trail byte must be 80:BF} utf-8 EF7F lossless \uDCEF\x7F -1 {} {First trail byte must be 80:BF} utf-8 EF7F strict {} 0 {} {First trail byte must be 80:BF} utf-8 EFD0 tcl8 \u00EF\u00D0 -1 {} {First trail byte must be 80:BF} utf-8 EFD0 replace \uFFFD\uFFFD -1 {} {First trail byte must be 80:BF} utf-8 EFD0 lossless \uDCEF\uDCD0 -1 {} {First trail byte must be 80:BF} utf-8 EFD0 strict {} 0 {} {First trail byte must be 80:BF} utf-8 EF81 tcl8 \u00EF\u0081 -1 {} {Missing second trail byte} utf-8 EF81 replace \uFFFD -1 {knownW3C} {Missing second trail byte} utf-8 EF81 lossless \uDCEF\uDC81 -1 {} {Missing second trail byte} utf-8 EF81 strict {} 0 {} {Missing second trail byte} utf-8 EFBF tcl8 \u00EF\u00BF -1 {} {Missing second trail byte} utf-8 EFBF replace \uFFFD -1 {knownW3C} {Missing second trail byte} utf-8 EFBF lossless \uDCEF\uDCBF -1 {} {Missing second trail byte} utf-8 EFBF strict {} 0 {} {Missing second trail byte} utf-8 EF807F tcl8 \u00EF\u20AC\x7F -1 {} {Second trail byte must be 80:BF} utf-8 EF807F replace \uFFFD\x7F -1 {knownW3C} {Second trail byte must be 80:BF} utf-8 EF807F lossless \uDCEF\uDC80\x7F -1 {} {Second trail byte must be 80:BF} utf-8 EF807F strict {} 0 {} {Second trail byte must be 80:BF} utf-8 EFBF7F tcl8 \u00EF\u00BF\x7F -1 {} {Second trail byte must be 80:BF} utf-8 EFBF7F replace \uFFFD\x7F -1 {knownW3C} {Second trail byte must be 80:BF} utf-8 EFBF7F lossless \uDCEF\uDCBF\x7F -1 {} {Second trail byte must be 80:BF} utf-8 EFBF7F strict {} 0 {} {Second trail byte must be 80:BF} utf-8 F0 tcl8 \u00F0 -1 {} {Missing trail byte} utf-8 F0 replace \uFFFD -1 {} {Missing trail byte} utf-8 F0 lossless \uDCF0 -1 {} {Missing trail byte} utf-8 F0 strict {} 0 {} {Missing trail byte} utf-8 F080 tcl8 \u00F0\u20AC -1 {} {First trail byte must be 90:BF} utf-8 F080 replace \uFFFD -1 {knownW3C} {First trail byte must be 90:BF} utf-8 F080 lossless \uDCF0\uDC80 -1 {} {First trail byte must be 90:BF} utf-8 F080 strict {} 0 {} {First trail byte must be 90:BF} utf-8 F08F tcl8 \u00F0\u8F -1 {} {First trail byte must be 90:BF} utf-8 F08F replace \uFFFD -1 {knownW3C} {First trail byte must be 90:BF} utf-8 F08F lossless \uDCF0\uDC8F -1 {} {First trail byte must be 90:BF} utf-8 F08F strict {} 0 {} {First trail byte must be 90:BF} utf-8 F0D0 tcl8 \u00F0\u00D0 -1 {} {First trail byte must be 90:BF} utf-8 F0D0 replace \uFFFD\uFFFD -1 {} {First trail byte must be 90:BF} utf-8 F0D0 lossless \uDCF0\uDCD0 -1 {} {First trail byte must be 90:BF} utf-8 F0D0 strict {} 0 {} {First trail byte must be 90:BF} utf-8 F090 tcl8 \u00F0\u0090 -1 {} {Missing second trail byte} utf-8 F090 replace \uFFFD -1 {knownW3C} {Missing second trail byte} utf-8 F090 lossless \uDCF0\uDC90 -1 {} {Missing second trail byte} utf-8 F090 strict {} 0 {} {Missing second trail byte} utf-8 F0BF tcl8 \u00F0\u00BF -1 {} {Missing second trail byte} utf-8 F0BF replace \uFFFD -1 {knownW3C} {Missing second trail byte} utf-8 F0BF lossless \uDCF0\uDCBF -1 {} {Missing second trail byte} utf-8 F0BF strict {} 0 {} {Missing second trail byte} utf-8 F0907F tcl8 \u00F0\u0090\x7F -1 {} {Second trail byte must be 80:BF} utf-8 F0907F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF} utf-8 F0907F lossless \uDCF0\uDC90\x7F -1 {} {Second trail byte must be 80:BF} utf-8 F0907F strict {} 0 {} {Second trail byte must be 80:BF} utf-8 F0BF7F tcl8 \u00F0\u00BF\x7F -1 {} {Second trail byte must be 80:BF} utf-8 F0BF7F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF} utf-8 F0BF7F lossless \uDCF0\uDCBF\x7F -1 {} {Second trail byte must be 80:BF} utf-8 F0BF7F strict {} 0 {} {Second trail byte must be 80:BF} utf-8 F090BF tcl8 \u00F0\u0090\u00BF -1 {} {Missing third trail byte} utf-8 F090BF replace \uFFFD -1 {knownW3C} {Missing third trail byte} utf-8 F090BF lossless \uDCF0\uDC90\uDCBF -1 {} {Missing third trail byte} utf-8 F090BF strict {} 0 {} {Missing third trail byte} utf-8 F0BF81 tcl8 \u00F0\u00BF\u0081 -1 {} {Missing third trail byte} utf-8 F0BF81 replace \uFFFD -1 {knownW3C} {Missing third trail byte} utf-8 F0BF81 lossless \uDCF0\uDCBF\uDC81 -1 {} {Missing third trail byte} utf-8 F0BF81 strict {} 0 {} {Missing third trail byte} utf-8 F0BF807F tcl8 \u00F0\u00BF\u20AC\x7F -1 {} {Third trail byte must be 80:BF} utf-8 F0BF817F replace \uFFFD\x7F -1 {knownW3C} {Third trail byte must be 80:BF} utf-8 F0BF817F lossless \uDCF0\uDCBF\uDC81\x7F -1 {} {Third trail byte must be 80:BF} utf-8 F0BF817F strict {} 0 {} {Third trail byte must be 80:BF} utf-8 F090BFD0 tcl8 \u00F0\u0090\u00BF\u00D0 -1 {} {Third trail byte must be 80:BF} utf-8 F090BFD0 replace \uFFFD -1 {knownW3C} {Third trail byte must be 80:BF} utf-8 F090BFD0 lossless \uDCF0\uDC90\uDCBF\uDCD0 -1 {} {Third trail byte must be 80:BF} utf-8 F090BFD0 strict {} 0 {} {Third trail byte must be 80:BF} utf-8 F1 tcl8 \u00F1 -1 {} {Missing trail byte} utf-8 F1 replace \uFFFD -1 {} {Missing trail byte} utf-8 F1 lossless \uDCF1 -1 {} {Missing trail byte} utf-8 F1 strict {} 0 {} {Missing trail byte} utf-8 F17F tcl8 \u00F1\u7F -1 {} {First trail byte must be 80:BF} utf-8 F17F replace \uFFFD -1 {knownW3C} {First trail byte must be 80:BF} utf-8 F17F lossless \uDCF1\x7F -1 {} {First trail byte must be 80:BF} utf-8 F17F strict {} 0 {} {First trail byte must be 80:BF} utf-8 F1D0 tcl8 \u00F1\u00D0 -1 {} {First trail byte must be 80:BF} utf-8 F1D0 replace \uFFFD\uFFFD -1 {} {First trail byte must be 80:BF} utf-8 F1D0 lossless \uDCF1\uDCD0 -1 {} {First trail byte must be 80:BF} utf-8 F1D0 strict {} 0 {} {First trail byte must be 80:BF} utf-8 F180 tcl8 \u00F1\u20AC -1 {} {Missing second trail byte} utf-8 F180 replace \uFFFD -1 {knownW3C} {Missing second trail byte} utf-8 F180 lossless \uDCF1\uDC80 -1 {} {Missing second trail byte} utf-8 F180 strict {} 0 {} {Missing second trail byte} utf-8 F1BF tcl8 \u00F1\u00BF -1 {} {Missing second trail byte} utf-8 F1BF replace \uFFFD -1 {knownW3C} {Missing second trail byte} utf-8 F1BF lossless \uDCF1\uDCBF -1 {} {Missing second trail byte} utf-8 F1BF strict {} 0 {} {Missing second trail byte} utf-8 F1807F tcl8 \u00F1\u20AC\x7F -1 {} {Second trail byte must be 80:BF} utf-8 F1807F replace \uFFFD\x7F -1 {knownW3C} {Second trail byte must be 80:BF} utf-8 F1807F lossless \uDCF1\uDC80\x7F -1 {} {Second trail byte must be 80:BF} utf-8 F1807F strict {} 0 {} {Second trail byte must be 80:BF} utf-8 F1BF7F tcl8 \u00F1\u00BF\x7F -1 {} {Second trail byte must be 80:BF} utf-8 F1BF7F replace \uFFFD\x7F -1 {knownW3C} {Second trail byte must be 80:BF} utf-8 F1BF7F lossless \uDCF1\uDCBF\x7F -1 {} {Second trail byte must be 80:BF} utf-8 F1BF7F strict {} 0 {} {Second trail byte must be 80:BF} utf-8 F180BF tcl8 \u00F1\u20AC\u00BF -1 {} {Missing third trail byte} utf-8 F180BF replace \uFFFD -1 {knownW3C} {Missing third trail byte} utf-8 F180BF lossless \uDCF1\uDC80\uDCBF -1 {} {Missing third trail byte} utf-8 F180BF strict {} 0 {} {Missing third trail byte} utf-8 F1BF81 tcl8 \u00F1\u00BF\u0081 -1 {} {Missing third trail byte} utf-8 F1BF81 replace \uFFFD -1 {knownW3C} {Missing third trail byte} utf-8 F1BF81 lossless \uDCF1\uDCBF\uDC81 -1 {} {Missing third trail byte} utf-8 F1BF81 strict {} 0 {} {Missing third trail byte} utf-8 F1BF807F tcl8 \u00F1\u00BF\u20AC\x7F -1 {} {Third trail byte must be 80:BF} utf-8 F1BF817F replace \uFFFD\x7F -1 {knownW3C} {Third trail byte must be 80:BF} utf-8 F1BF817F lossless \uDCF1\uDCBF\uDC81\x7F -1 {} {Third trail byte must be 80:BF} utf-8 F1BF817F strict {} 0 {} {Third trail byte must be 80:BF} utf-8 F180BFD0 tcl8 \u00F1\u20AC\u00BF\u00D0 -1 {} {Third trail byte must be 80:BF} utf-8 F180BFD0 replace \uFFFD -1 {knownW3C} {Third trail byte must be 80:BF} utf-8 F180BFD0 lossless \uDCF1\uDC80\uDCBF\uDCD0 -1 {} {Third trail byte must be 80:BF} utf-8 F180BFD0 strict {} 0 {} {Third trail byte must be 80:BF} utf-8 F3 tcl8 \u00F3 -1 {} {Missing trail byte} utf-8 F3 replace \uFFFD -1 {} {Missing trail byte} utf-8 F3 lossless \uDCF3 -1 {} {Missing trail byte} utf-8 F3 strict {} 0 {} {Missing trail byte} utf-8 F37F tcl8 \u00F3\x7F -1 {} {First trail byte must be 80:BF} utf-8 F37F replace \uFFFD -1 {knownW3C} {First trail byte must be 80:BF} utf-8 F37F lossless \uDCF3\x7F -1 {} {First trail byte must be 80:BF} utf-8 F37F strict {} 0 {} {First trail byte must be 80:BF} utf-8 F3D0 tcl8 \u00F3\u00D0 -1 {} {First trail byte must be 80:BF} utf-8 F3D0 replace \uFFFD\uFFFD -1 {} {First trail byte must be 80:BF} utf-8 F3D0 lossless \uDCF3\uDCD0 -1 {} {First trail byte must be 80:BF} utf-8 F3D0 strict {} 0 {} {First trail byte must be 80:BF} utf-8 F380 tcl8 \u00F3\u20AC -1 {} {Missing second trail byte} utf-8 F380 replace \uFFFD -1 {knownW3C} {Missing second trail byte} utf-8 F380 lossless \uDCF3\uDC80 -1 {} {Missing second trail byte} utf-8 F380 strict {} 0 {} {Missing second trail byte} utf-8 F3BF tcl8 \u00F3\u00BF -1 {} {Missing second trail byte} utf-8 F3BF replace \uFFFD -1 {knownW3C} {Missing second trail byte} utf-8 F3BF lossless \uDCF3\uDCBF -1 {} {Missing second trail byte} utf-8 F3BF strict {} 0 {} {Missing second trail byte} utf-8 F3807F tcl8 \u00F3\u20AC\x7F -1 {} {Second trail byte must be 80:BF} utf-8 F3807F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF} utf-8 F3807F lossless \uDCF3\uDC80\x7F -1 {} {Second trail byte must be 80:BF} utf-8 F3807F strict {} 0 {} {Second trail byte must be 80:BF} utf-8 F3BF7F tcl8 \u00F3\u00BF\x7F -1 {} {Second trail byte must be 80:BF} utf-8 F3BF7F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF} utf-8 F3BF7F lossless \uDCF3\uDCBF\x7F -1 {} {Second trail byte must be 80:BF} utf-8 F3BF7F strict {} 0 {} {Second trail byte must be 80:BF} utf-8 F380BF tcl8 \u00F3\u20AC\u00BF -1 {} {Missing third trail byte} utf-8 F380BF replace \uFFFD -1 {knownW3C} {Missing third trail byte} utf-8 F380BF lossless \uDCF3\uDC80\uDCBF -1 {} {Missing third trail byte} utf-8 F380BF strict {} 0 {} {Missing third trail byte} utf-8 F3BF81 tcl8 \u00F3\u00BF\u0081 -1 {} {Missing third trail byte} utf-8 F3BF81 replace \uFFFD -1 {knownW3C} {Missing third trail byte} utf-8 F3BF81 lossless \uDCF3\uDCBF\uDC81 -1 {} {Missing third trail byte} utf-8 F3BF81 strict {} 0 {} {Missing third trail byte} utf-8 F3BF807F tcl8 \u00F3\u00BF\u20AC\x7F -1 {} {Third trail byte must be 80:BF} utf-8 F3BF817F replace \uFFFD\x7F -1 {knownW3C} {Third trail byte must be 80:BF} utf-8 F3BF817F lossless \uDCF3\uDCBF\uDC81\x7F -1 {} {Third trail byte must be 80:BF} utf-8 F3BF817F strict {} 0 {} {Third trail byte must be 80:BF} utf-8 F380BFD0 tcl8 \u00F3\u20AC\u00BF\u00D0 -1 {} {Third trail byte must be 80:BF} utf-8 F380BFD0 replace \uFFFD -1 {knownW3C} {Third trail byte must be 80:BF} utf-8 F380BFD0 lossless \uDCF3\uDC80\uDCBF\uDCD0 -1 {} {Third trail byte must be 80:BF} utf-8 F380BFD0 strict {} 0 {} {Third trail byte must be 80:BF} utf-8 F4 tcl8 \u00F4 -1 {} {Missing trail byte} utf-8 F4 replace \uFFFD -1 {} {Missing trail byte} utf-8 F4 lossless \uDCF4 -1 {} {Missing trail byte} utf-8 F4 strict {} 0 {} {Missing trail byte} utf-8 F47F tcl8 \u00F4\u7F -1 {} {First trail byte must be 80:8F} utf-8 F47F replace \uFFFD\u7F -1 {knownW3C} {First trail byte must be 80:8F} utf-8 F47F lossless \uDCF4\x7F -1 {} {First trail byte must be 80:8F} utf-8 F47F strict {} 0 {} {First trail byte must be 80:8F} utf-8 F490 tcl8 \u00F4\u0090 -1 {} {First trail byte must be 80:8F} utf-8 F490 replace \uFFFD\uFFFD -1 {} {First trail byte must be 80:8F} utf-8 F490 lossless \uDCF4\uDC90 -1 {} {First trail byte must be 80:8F} utf-8 F490 strict {} 0 {} {First trail byte must be 80:8F} utf-8 F480 tcl8 \u00F4\u20AC -1 {} {Missing second trail byte} utf-8 F480 replace \uFFFD -1 {knownW3C} {Missing second trail byte} utf-8 F480 lossless \uDCF4\uDC80 -1 {} {Missing second trail byte} utf-8 F480 strict {} 0 {} {Missing second trail byte} utf-8 F48F tcl8 \u00F4\u008F -1 {} {Missing second trail byte} utf-8 F48F replace \uFFFD -1 {knownW3C} {Missing second trail byte} utf-8 F48F lossless \uDCF4\uDC8F -1 {} {Missing second trail byte} utf-8 F48F strict {} 0 {} {Missing second trail byte} utf-8 F4807F tcl8 \u00F4\u20AC\x7F -1 {} {Second trail byte must be 80:BF} utf-8 F4807F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF} utf-8 F4807F lossless \uDCF4\uDC80\x7F -1 {} {Second trail byte must be 80:BF} utf-8 F4807F strict {} 0 {} {Second trail byte must be 80:BF} utf-8 F48F7F tcl8 \u00F4\u008F\x7F -1 {} {Second trail byte must be 80:BF} utf-8 F48F7F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF} utf-8 F48F7F lossless \uDCF4\uDC8F\x7F -1 {} {Second trail byte must be 80:BF} utf-8 F48F7F strict {} 0 {} {Second trail byte must be 80:BF} utf-8 F48081 tcl8 \u00F4\u20AC\u0081 -1 {} {Missing third trail byte} utf-8 F48081 replace \uFFFD -1 {knownW3C} {Missing third trail byte} utf-8 F48081 lossless \uDCF4\uDC80\uDC81 -1 {} {Missing third trail byte} utf-8 F48081 strict {} 0 {} {Missing third trail byte} utf-8 F48F81 tcl8 \u00F4\u008F\u0081 -1 {} {Missing third trail byte} utf-8 F48F81 replace \uFFFD -1 {knownW3C} {Missing third trail byte} utf-8 F48F81 lossless \uDCF4\uDC8F\uDC81 -1 {} {Missing third trail byte} utf-8 F48F81 strict {} 0 {} {Missing third trail byte} utf-8 F481817F tcl8 \u00F4\u0081\u0081\x7F -1 {} {Third trail byte must be 80:BF} utf-8 F480817F replace \uFFFD\x7F -1 {knownW3C} {Third trail byte must be 80:BF} utf-8 F480817F lossless \uDCF4\uDC80\uDC81\x7F -1 {} {Third trail byte must be 80:BF} utf-8 F480817F strict {} 0 {} {Third trail byte must be 80:BF} utf-8 F48FBFD0 tcl8 \u00F4\u008F\u00BF\u00D0 -1 {} {Third trail byte must be 80:BF} utf-8 F48FBFD0 replace \uFFFD -1 {knownW3C} {Third trail byte must be 80:BF} utf-8 F48FBFD0 lossless \uDCF4\uDC8F\uDCBF\uDCD0 -1 {} {Third trail byte must be 80:BF} utf-8 F48FBFD0 strict {} 0 {} {Third trail byte must be 80:BF} utf-8 F5 tcl8 \u00F5 -1 {} {F5:FF are invalid everywhere} utf-8 F5 replace \uFFFD -1 {} {F5:FF are invalid everywhere} utf-8 F5 lossless \uDCF5 -1 {} {F5:FF are invalid everywhere} utf-8 F5 strict {} 0 {} {F5:FF are invalid everywhere} utf-8 FF tcl8 \u00FF -1 {} {F5:FF are invalid everywhere} utf-8 FF replace \uFFFD -1 {} {F5:FF are invalid everywhere} utf-8 FF lossless \uDCFF -1 {} {F5:FF are invalid everywhere} utf-8 FF strict {} 0 {} {F5:FF are invalid everywhere} utf-8 C0AFE080BFF0818130 replace \uFFFD\uFFFD\uFFFD\uFFFD\uFFFD\uFFFD\uFFFD\uFFFD\x30 -1 {} {Unicode Table 3-8} utf-8 C0AFE080BFF0818130 lossless \uDCC0\uDCAF\uDCE0\uDC80\uDCBF\uDCF0\uDC81\uDC81\x30 -1 {} {Unicode Table 3-8} utf-8 EDA080EDBFBFEDAF30 replace \uFFFD\uFFFD\uFFFD\uFFFD\uFFFD\uFFFD\uFFFD\uFFFD\x30 -1 {knownW3C} {Unicode Table 3-9} utf-8 EDA080EDBFBFEDAF30 lossless \uD800\uDFFF\uDCED\uDCAF0 -1 {} {Unicode Table 3-9 - TODO assumes surrogates permitted in utf-8 lossless} utf-8 F4919293FF4180BF30 replace \uFFFD\uFFFD\uFFFD\uFFFD\uFFFD\u0041\uFFFD\uFFFD\x30 -1 {} {Unicode Table 3-10} utf-8 F4919293FF4180BF30 lossless \uDCF4\uDC91\uDC92\uDC93\uDCFF\u0041\uDC80\uDCBF\x30 -1 {} {Unicode Table 3-10} utf-8 E180E2F09192F1BF30 replace \uFFFD\uFFFD\uFFFD\uFFFD\x30 -1 {knownW3C} {Unicode Table 3.11} utf-8 E180E2F09192F1BF30 lossless \uDCE1\uDC80\uDCE2\uDCF0\uDC91\uDC92\uDCF1\uDCBF\x30 -1 {} {Unicode Table 3.11} } # utf16-le and utf16-be test cases. Note utf16 cases are automatically generated # based on these depending on platform endianness. Note truncated tests can only # happen when the sequence is at the end (including by itself) Thus {solo tail} # in some cases. lappend encInvalidBytes {*}{ utf-16le 41 tcl8 \uFFFD -1 {solo tail} {Truncated} utf-16le 41 replace \uFFFD -1 {solo tail} {Truncated} utf-16le 41 strict {} 0 {solo tail} {Truncated} utf-16le 41 lossless \uFFFD -1 {solo tail} {Truncated - byte < 0x80} utf-16le 80 lossless \uFFFD -1 {solo tail} {Truncated - byte >= 0x80} utf-16le 00D8 tcl8 \uD800 -1 {} {Missing low surrogate} utf-16le 00D8 replace \uFFFD -1 {} {Missing low surrogate} utf-16le 00D8 lossless \uFFFD -1 {} {Missing low surrogate} utf-16le 00D8 strict {} 0 {knownBug} {Missing low surrogate} utf-16le 00DC tcl8 \uDC00 -1 {} {Missing high surrogate} utf-16le 00DC replace \uFFFD -1 {} {Missing high surrogate} utf-16le 00DC lossless \uFFFD -1 {} {Missing high surrogate} utf-16le 00DC strict {} 0 {knownBug} {Missing high surrogate} utf-16be 41 tcl8 \uFFFD -1 {solo tail} {Truncated} utf-16be 41 replace \uFFFD -1 {solo tail} {Truncated} utf-16be 41 strict {} 0 {solo tail} {Truncated} utf-16be 41 lossless \uFFFD -1 {solo tail} {Truncated - byte < 0x80} utf-16be 80 lossless \uFFFD -1 {solo tail} {Truncated - byte >= 0x80} utf-16be D800 tcl8 \uD800 -1 {} {Missing low surrogate} utf-16be D800 replace \uFFFD -1 {knownBug} {Missing low surrogate} utf-16be D800 lossless \uFFFD -1 {knownBug} {Missing low surrogate} utf-16be D800 strict {} 0 {knownBug} {Missing low surrogate} utf-16be DC00 tcl8 \uDC00 -1 {} {Missing high surrogate} utf-16be DC00 replace \uFFFD -1 {knownBug} {Missing high surrogate} utf-16be DC00 lossless \uFFFD -1 {knownBug} {Missing high surrogate} utf-16be DC00 strict {} 0 {knownBug} {Missing high surrogate} } # utf32-le and utf32-be test cases. Note utf32 cases are automatically generated # based on these depending on platform endianness. Note truncated tests can only # happen when the sequence is at the end (including by itself) Thus {solo tail} # in some cases. lappend encInvalidBytes {*}{ utf-32le 41 tcl8 \uFFFD -1 {solo tail} {Truncated} utf-32le 41 replace \uFFFD -1 {solo} {Truncated} utf-32le 41 lossless \uFFFD -1 {solo} {Truncated} utf-32le 41 strict {} 0 {solo tail} {Truncated} utf-32le 4100 tcl8 \uFFFD -1 {solo tail} {Truncated} utf-32le 4100 replace \uFFFD -1 {solo} {Truncated} utf-32le 4100 lossless \uFFFD -1 {solo} {Truncated} utf-32le 4100 strict {} 0 {solo tail} {Truncated} utf-32le 410000 tcl8 \uFFFD -1 {solo tail} {Truncated} utf-32le 410000 replace \uFFFD -1 {solo} {Truncated} utf-32le 410000 lossless \uFFFD -1 {solo} {Truncated} utf-32le 410000 strict {} 0 {solo tail} {Truncated} utf-32le 00D80000 tcl8 \uD800 -1 {} {High-surrogate} utf-32le 00D80000 replace \uFFFD -1 {} {High-surrogate} utf-32le 00D80000 lossless \uFFFD -1 {} {High-surrogate} utf-32le 00D80000 strict {} 0 {} {High-surrogate} utf-32le 00DC0000 tcl8 \uDC00 -1 {} {Low-surrogate} utf-32le 00DC0000 replace \uFFFD -1 {} {Low-surrogate} utf-32le 00DC0000 lossless \uFFFD -1 {} {Low-surrogate} utf-32le 00DC0000 strict {} 0 {} {Low-surrogate} utf-32le 00D8000000DC0000 tcl8 \uD800\uDC00 -1 {} {High-low-surrogate-pair} utf-32le 00D8000000DC0000 replace \uFFFD\uFFFD -1 {} {High-low-surrogate-pair} utf-32le 00D8000000DC0000 lossless \uFFFD\uFFFD -1 {} {High-low-surrogate-pair} utf-32le 00D8000000DC0000 strict {} 0 {} {High-low-surrogate-pair} utf-32le 00001100 tcl8 \uFFFD -1 {} {Out of range} utf-32le 00001100 replace \uFFFD -1 {} {Out of range} utf-32le 00001100 lossless \uFFFD -1 {} {Out of range} utf-32le 00001100 strict {} 0 {} {Out of range} utf-32le FFFFFFFF tcl8 \uFFFD -1 {} {Out of range} utf-32le FFFFFFFF replace \uFFFD -1 {} {Out of range} utf-32le FFFFFFFF lossless \uFFFD -1 {} {Out of range} utf-32le FFFFFFFF strict {} 0 {} {Out of range} utf-32be 41 tcl8 \uFFFD -1 {solo tail} {Truncated} utf-32be 41 replace \uFFFD -1 {solo tail} {Truncated} utf-32be 41 lossless \uFFFD -1 {solo tail} {Truncated} utf-32be 41 strict {} 0 {solo tail} {Truncated} utf-32be 0041 tcl8 \uFFFD -1 {solo tail} {Truncated} utf-32be 0041 replace \uFFFD -1 {solo} {Truncated} utf-32be 0041 lossless \uFFFD -1 {solo} {Truncated} utf-32be 0041 strict {} 0 {solo tail} {Truncated} utf-32be 000041 tcl8 \uFFFD -1 {solo tail} {Truncated} utf-32be 000041 replace \uFFFD -1 {solo} {Truncated} utf-32be 000041 lossless \uFFFD -1 {solo} {Truncated} utf-32be 000041 strict {} 0 {solo tail} {Truncated} utf-32be 0000D800 tcl8 \uD800 -1 {} {High-surrogate} utf-32be 0000D800 replace \uFFFD -1 {} {High-surrogate} utf-32be 0000D800 lossless \uFFFD -1 {} {High-surrogate} utf-32be 0000D800 strict {} 0 {} {High-surrogate} utf-32be 0000DC00 tcl8 \uDC00 -1 {} {Low-surrogate} utf-32be 0000DC00 replace \uFFFD -1 {} {Low-surrogate} utf-32be 0000DC00 lossless \uFFFD -1 {} {Low-surrogate} utf-32be 0000DC00 strict {} 0 {} {Low-surrogate} utf-32be 0000D8000000DC00 tcl8 \uD800\uDC00 -1 {} {High-low-surrogate-pair} utf-32be 0000D8000000DC00 replace \uFFFD\uFFFD -1 {} {High-low-surrogate-pair} utf-32be 0000D8000000DC00 lossless \uFFFD\uFFFD -1 {} {High-low-surrogate-pair} utf-32be 0000D8000000DC00 strict {} 0 {} {High-low-surrogate-pair} utf-32be 00110000 tcl8 \uFFFD -1 {} {Out of range} utf-32be 00110000 replace \uFFFD -1 {} {Out of range} utf-32be 00110000 lossless \uFFFD -1 {} {Out of range} utf-32be 00110000 strict {} 0 {} {Out of range} utf-32be FFFFFFFF tcl8 \uFFFD -1 {} {Out of range} utf-32be FFFFFFFF replace \uFFFD -1 {} {Out of range} utf-32be FFFFFFFF lossless \uFFFD -1 {} {Out of range} utf-32be FFFFFFFF strict {} 0 {} {Out of range} } # escape tables - TODO # This tests the EscapeToUtf code path. lappend encInvalidBytes {*}{ } # Strings that cannot be encoded for specific encoding / profiles # <ENCODING STRING PROFILE EXPECTEDRESULT EXPECTEDFAILINDEX CTRL COMMENT> # <ENCODING,STRING,PROFILE> should be unique for test ids to be unique. # See earlier comments about CTRL field. # # TODO - out of range code point (note cannot be generated by \U notation) lappend encUnencodableStrings {*}{ ascii \u00e0 tcl8 3f -1 {} {unencodable} ascii \u00e0 strict {} 0 {} {unencodable} iso8859-1 \u0141 tcl8 3f -1 {} unencodable iso8859-1 \u0141 strict {} 0 {} unencodable utf-8 \uD800 tcl8 eda080 -1 {} High-surrogate utf-8 \uD800 strict {} 0 {} High-surrogate utf-8 \uDC00 tcl8 edb080 -1 {} High-surrogate utf-8 \uDC00 strict {} 0 {} High-surrogate } # The icuUcmTests.tcl is generated by the tools/ucm2tests.tcl script # and generates test vectors for the above tables for various encodings # based on ICU UCM files. # TODO - commented out for now as generating a lot of mismatches, mainly # due to Tcl using ? for replacement char and ICU often using ^Z. # source [file join [file dirname [info script]] icuUcmTests.tcl] |
Changes to tests/env.test.
︙ | ︙ | |||
14 15 16 17 18 19 20 | if {"::tcltest" ni [namespace children]} { package require tcltest 2.5 namespace import -force ::tcltest::* } source [file join [file dirname [info script]] tcltests.tcl] | < | 14 15 16 17 18 19 20 21 22 23 24 25 26 27 | if {"::tcltest" ni [namespace children]} { package require tcltest 2.5 namespace import -force ::tcltest::* } source [file join [file dirname [info script]] tcltests.tcl] if {[llength [auto_execok bash]]} { testConstraint haveBash 1 } # [exec] is required here to see the actual environment received by child # processes. proc getenv {} { |
︙ | ︙ | |||
509 510 511 512 513 514 515 | set result [gets $pipe] close $pipe if {$result ne $::env(USERPROFILE)} { list ERROR $result ne $::env(USERPROFILE) } } -result {} | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | set result [gets $pipe] close $pipe if {$result ne $::env(USERPROFILE)} { list ERROR $result ne $::env(USERPROFILE) } } -result {} test env-10.1 { Unequal environment strings test should test unequal (failed pre-TIP 671) } -constraints {unix haveBash} -setup { set tclScript [makeFile { puts [string equal $env(XX) $env(YY)] } tclScript] set shellCode { export XX=$'\351' export YY=$'\303\251' } append shellCode "[info nameofexecutable] $tclScript\n" set shScript [makeFile $shellCode shScript] set oldEnc [encoding system] encoding system utf-8 } -cleanup { encoding system $oldEnc } -body { exec {*}[auto_execok bash] $shScript } -result 0 test env-10.2 { Read invalidly encoded bytes in environment value - TIP 671 } -constraints {unix haveBash} -setup { set tclScript [makeFile { puts [format {%04x} [scan $env(XX) %c]] } tclScript] # Note following requires bash, not sh! Dunno the equivalent in sh set shellCode { export XX=$'\xe9' } append shellCode "[info nameofexecutable] $tclScript\n" set shScript [makeFile $shellCode shScript] set oldEnc [encoding system] encoding system utf-8 } -cleanup { encoding system $oldEnc } -body { exec {*}[auto_execok bash] $shScript } -result dce9 test env-10.3 { Write invalidly encoded bytes to environment value - TIP 671 } -constraints {unix haveBash} -setup { set tclScript [makeFile { set env(YY) A$env(XX)B set line [lindex [split [exec {*}[auto_execok bash] -c {echo $YY | od -t x1}] \n] 0] puts [lrange $line 1 3] } tclScript] # Note following requires bash, not sh! Dunno the equivalent in sh set shellCode { export XX=$'\xe9' } append shellCode "[info nameofexecutable] $tclScript\n" set shScript [makeFile $shellCode shScript] set oldEnc [encoding system] encoding system utf-8 } -cleanup { encoding system $oldEnc } -body { exec {*}[auto_execok bash] $shScript } -result {41 e9 42} # cleanup rename getenv {} rename envrestore {} rename envprep {} rename encodingrestore {} |
︙ | ︙ |
Changes to tests/exec.test.
︙ | ︙ | |||
708 709 710 711 712 713 714 715 716 717 718 719 720 721 | viewFile $log } -result "\"Testing exec-20.0\"" test exec-20.1 {exec .CMD file} -constraints {win} -body { set log [makeFile {} exec201.log] exec [makeFile "echo %1> $log" exec201.CMD] "Testing exec-20.1" viewFile $log } -result "\"Testing exec-20.1\"" # ---------------------------------------------------------------------- # cleanup foreach file {gorp.file gorp.file2 echo echo2 cat wc sh sh2 sleep exit err} { removeFile $file } | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | viewFile $log } -result "\"Testing exec-20.0\"" test exec-20.1 {exec .CMD file} -constraints {win} -body { set log [makeFile {} exec201.log] exec [makeFile "echo %1> $log" exec201.CMD] "Testing exec-20.1" viewFile $log } -result "\"Testing exec-20.1\"" # Test with encoding mismatches (Bug 0f1ddc0df7fb7) test exec-21.1 {exec encoding mismatch on stdout} -setup { set path(script) [makeFile { fconfigure stdout -translation binary puts a\xe9b } script] set enc [encoding system] encoding system utf-8 } -cleanup { removeFile $path(script) encoding system $enc } -body { exec [info nameofexecutable] $path(script) } -result a\uFFFDb test exec-21.2 {exec encoding mismatch on stderr} -setup { set path(script) [makeFile { fconfigure stderr -translation binary puts stderr a\xe9b } script] set enc [encoding system] encoding system utf-8 } -cleanup { removeFile $path(script) encoding system $enc } -body { list [catch {exec [info nameofexecutable] $path(script)} r] $r } -result [list 1 a\uFFFDb] # ---------------------------------------------------------------------- # cleanup foreach file {gorp.file gorp.file2 echo echo2 cat wc sh sh2 sleep exit err} { removeFile $file } |
︙ | ︙ |
Changes to tests/fileSystem.test.
︙ | ︙ | |||
277 278 279 280 281 282 283 | file normalize ~$::tcl_platform(user) } -result [file join [pwd] ~$::tcl_platform(user)] test filesystem-1.30.3 {file normalization should distinguish between ~ and ~user} -setup { set oldhome $::env(HOME) set olduserhome [file home $::tcl_platform(user)] set ::env(HOME) [file join $oldhome temp] } -cleanup { | | | 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 | file normalize ~$::tcl_platform(user) } -result [file join [pwd] ~$::tcl_platform(user)] test filesystem-1.30.3 {file normalization should distinguish between ~ and ~user} -setup { set oldhome $::env(HOME) set olduserhome [file home $::tcl_platform(user)] set ::env(HOME) [file join $oldhome temp] } -cleanup { set ::env(HOME) $oldhome } -body { list [string equal [file home] $::env(HOME)] \ [string equal $olduserhome [file home $::tcl_platform(user)]] } -result {1 1} test filesystem-1.31 {link normalisation: link near filesystem root} {testsetplatform} { testsetplatform unix file normalize /foo/../bar |
︙ | ︙ |
Changes to tests/http.test.
︙ | ︙ | |||
13 14 15 16 17 18 19 20 21 22 23 24 25 26 | if {"::tcltest" ni [namespace children]} { package require tcltest 2.5 namespace import -force ::tcltest::* } package require http 2.10 proc bgerror {args} { global errorInfo puts stderr "http.test bgerror" puts stderr [join $args] puts stderr $errorInfo } | > > > > | 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 | if {"::tcltest" ni [namespace children]} { package require tcltest 2.5 namespace import -force ::tcltest::* } package require http 2.10 #http::register http 80 ::socket # To write a separate summary for each value of ThreadLevel, set constraint ThreadLevelSummary. #testConstraint ThreadLevelSummary 0 proc bgerror {args} { global errorInfo puts stderr "http.test bgerror" puts stderr [join $args] puts stderr $errorInfo } |
︙ | ︙ | |||
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 | puts "Cannot start http server, http test skipped" catch {unset port} return } set threadStack {} } if {![info exists ThreadLevel]} { if {[catch {package require Thread}] == 0} { set ValueRange {0 1 2} } else { set ValueRange {0 1} } # For each value of ThreadLevel, source this file recursively in the # same interpreter. foreach ThreadLevel $ValueRange { source [info script] } if {[llength $threadStack]} { eval [lpop threadStack] } catch {unset ThreadLevel} catch {unset ValueRange} return } catch {puts "==== Test with ThreadLevel $ThreadLevel ===="} http::config -threadlevel $ThreadLevel test http-1.1.$ThreadLevel {http::config} { | > > > > > > > > | 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 | puts "Cannot start http server, http test skipped" catch {unset port} return } set threadStack {} } if 0 { # For debugging: run with a single value of ThreadLevel: 0|1|2 set ThreadLevel 0 testConstraint ThreadLevelSummary 1 } if {![info exists ThreadLevel]} { if {[catch {package require Thread}] == 0} { set ValueRange {0 1 2} } else { set ValueRange {0 1} } # For each value of ThreadLevel, source this file recursively in the # same interpreter. foreach ThreadLevel $ValueRange { source [info script] } if {[llength $threadStack]} { eval [lpop threadStack] } catch {unset ThreadLevel} catch {unset ValueRange} if {![testConstraint ThreadLevelSummary]} { ::tcltest::cleanupTests } return } catch {puts "==== Test with ThreadLevel $ThreadLevel ===="} http::config -threadlevel $ThreadLevel test http-1.1.$ThreadLevel {http::config} { |
︙ | ︙ | |||
157 158 159 160 161 162 163 | set url //${::HOST}:$port set badurl //${::HOST}:[expr {$port+1}] test http-3.3.$ThreadLevel {http::geturl} -body { set token [http::geturl $url] http::data $token } -cleanup { | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 | set url //${::HOST}:$port set badurl //${::HOST}:[expr {$port+1}] test http-3.3.$ThreadLevel {http::geturl} -body { set token [http::geturl $url] http::data $token } -cleanup { catch {http::cleanup $token} } -result "<html><head><title>HTTP/1.0 TEST</title></head><body> <h1>Hello, World!</h1> <h2>GET /</h2> </body></html>" set tail /a/b/c set url //${::HOST}:$port/a/b/c set fullurl HTTP://user:pass@${::HOST}:$port/a/b/c set binurl //${::HOST}:$port/binary set xmlurl //${::HOST}:$port/xml set posturl //${::HOST}:$port/post set badposturl //${::HOST}:$port/droppost set authorityurl //${::HOST}:$port set ipv6url http://\[::1\]:$port/ test http-3.4.$ThreadLevel {http::geturl} -body { set token [http::geturl $url] http::data $token } -cleanup { catch {http::cleanup $token} } -result "<html><head><title>HTTP/1.0 TEST</title></head><body> <h1>Hello, World!</h1> <h2>GET $tail</h2> </body></html>" proc selfproxy {host} { global port return [list ${::HOST} $port] } test http-3.5.$ThreadLevel {http::geturl} -body { http::config -proxyfilter selfproxy set token [http::geturl $url] http::data $token } -cleanup { http::config -proxyfilter http::ProxyRequired catch {http::cleanup $token} } -result "<html><head><title>HTTP/1.0 TEST</title></head><body> <h1>Hello, World!</h1> <h2>GET http:$url</h2> </body></html>" test http-3.6.$ThreadLevel {http::geturl} -body { http::config -proxyfilter bogus set token [http::geturl $url] http::data $token } -cleanup { http::config -proxyfilter http::ProxyRequired catch {http::cleanup $token} } -result "<html><head><title>HTTP/1.0 TEST</title></head><body> <h1>Hello, World!</h1> <h2>GET $tail</h2> </body></html>" test http-3.7.$ThreadLevel {http::geturl} -body { set token [http::geturl $url -headers {Pragma no-cache}] http::data $token } -cleanup { catch {http::cleanup $token} } -result "<html><head><title>HTTP/1.0 TEST</title></head><body> <h1>Hello, World!</h1> <h2>GET $tail</h2> </body></html>" test http-3.8.$ThreadLevel {http::geturl} -body { set token [http::geturl $url -query Name=Value&Foo=Bar -timeout 3000] http::data $token } -cleanup { catch {http::cleanup $token} } -result "<html><head><title>HTTP/1.0 TEST</title></head><body> <h1>Hello, World!</h1> <h2>POST $tail</h2> <h2>Query</h2> <dl> <dt>Name<dd>Value <dt>Foo<dd>Bar </dl> </body></html>" test http-3.9.$ThreadLevel {http::geturl} -body { set token [http::geturl $url -validate 1] http::code $token } -cleanup { catch {http::cleanup $token} } -result "HTTP/1.0 200 OK" test http-3.10.$ThreadLevel {http::geturl queryprogress} -setup { set query foo=bar set sep "" set i 0 # Create about 120K of query data while {$i < 14} { incr i append query $sep$query set sep & } } -body { proc postProgress {tok x y} { global postProgress lappend postProgress $y } set postProgress {} set token [http::geturl $posturl -keepalive 0 -query $query \ -queryprogress postProgress -queryblocksize 16384] http::wait $token list [http::status $token] [string length $query] $postProgress [http::data $token] } -cleanup { catch {http::cleanup $token} } -result {ok 122879 {16384 32768 49152 65536 81920 98304 114688 122879} {Got 122879 bytes}} test http-3.11.$ThreadLevel {http::geturl querychannel with -command} -setup { set query foo=bar set sep "" set i 0 # Create about 120K of query data while {$i < 14} { incr i append query $sep$query set sep & } set file [makeFile $query outdata] } -body { set fp [open $file] proc asyncCB {tok} { global postResult lappend postResult [http::data $tok] } set postResult [list ] set token [http::geturl $posturl -querychannel $fp] http::wait $token set testRes [list [http::status $token] [string length $query] [http::data $token]] # Now do async http::cleanup $token close $fp set fp [open $file] set token [http::geturl $posturl -querychannel $fp -command asyncCB] set postResult [list PostStart] http::wait $token close $fp lappend testRes [http::status $token] $postResult } -cleanup { removeFile outdata catch {http::cleanup $token} } -result {ok 122879 {Got 122880 bytes} ok {PostStart {Got 122880 bytes}}} # On Linux platforms when the client and server are on the same host, the # client is unable to read the server's response one it hits the write error. # The status is "eof". # On Windows, the http::wait procedure gets a "connection reset by peer" error # while reading the reply. test http-3.12.$ThreadLevel {http::geturl querychannel with aborted request} -setup { set query foo=bar set sep "" set i 0 # Create about 120K of query data while {$i < 14} { incr i append query $sep$query set sep & } set file [makeFile $query outdata] } -constraints {nonPortable} -body { set fp [open $file] proc asyncCB {tok} { global postResult lappend postResult [http::data $tok] } proc postProgress {tok x y} { global postProgress lappend postProgress $y } set postProgress {} # Now do async set postResult [list PostStart] if {[catch { set token [http::geturl $badposturl -querychannel $fp -command asyncCB \ -queryprogress postProgress] http::wait $token upvar #0 $token state } err]} { puts $::errorInfo error $err } list [http::status $token] [http::code $token] } -cleanup { removeFile outdata catch {http::cleanup $token} } -result {ok {HTTP/1.0 200 Data follows}} test http-3.13.$ThreadLevel {http::geturl socket leak test} { set chanCount [llength [file channels]] for {set i 0} {$i < 3} {incr i} { catch {http::geturl $badurl -timeout 5000} } # No extra channels should be taken expr {[llength [file channels]] == $chanCount} } 1 test http-3.14.$ThreadLevel "http::geturl $fullurl" -body { set token [http::geturl $fullurl -validate 1] http::code $token } -cleanup { catch {http::cleanup $token} } -result "HTTP/1.0 200 OK" test http-3.15.$ThreadLevel {http::geturl parse failures} -body { http::geturl "{invalid}:url" } -returnCodes error -result {Unsupported URL: {invalid}:url} test http-3.16.$ThreadLevel {http::geturl parse failures} -body { http::geturl http:relative/url } -returnCodes error -result {Unsupported URL: http:relative/url} |
︙ | ︙ | |||
388 389 390 391 392 393 394 | test http-3.25.$ThreadLevel {http::meta} -setup { unset -nocomplain m token } -body { set token [http::geturl $url -timeout 3000] array set m [http::meta $token] lsort [array names m] } -cleanup { | | | | | | | | | | | | | | | | | | | | | | | | > | > > > > > > | > | | > | > > > > > | > > | 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 | test http-3.25.$ThreadLevel {http::meta} -setup { unset -nocomplain m token } -body { set token [http::geturl $url -timeout 3000] array set m [http::meta $token] lsort [array names m] } -cleanup { catch {http::cleanup $token} unset -nocomplain m token } -result {content-length content-type date} test http-3.26.$ThreadLevel {http::meta} -setup { unset -nocomplain m token } -body { set token [http::geturl $url -headers {X-Check 1} -timeout 3000] array set m [http::meta $token] lsort [array names m] } -cleanup { catch {http::cleanup $token} unset -nocomplain m token } -result {content-length content-type date x-check} test http-3.27.$ThreadLevel {http::geturl: -headers override -type} -body { set token [http::geturl $url/headers -type "text/plain" -query dummy \ -headers [list "Content-Type" "text/plain;charset=utf-8"]] http::data $token } -cleanup { catch {http::cleanup $token} } -match regexp -result {(?n)Host .* User-Agent .* Content-Type {text/plain;charset=utf-8} Accept \*/\* Accept-Encoding .* Connection close Content-Length 5} test http-3.28.$ThreadLevel {http::geturl: -headers override -type default} -body { set token [http::geturl $url/headers -query dummy \ -headers [list "Content-Type" "text/plain;charset=utf-8"]] http::data $token } -cleanup { catch {http::cleanup $token} } -match regexp -result {(?n)Host .* User-Agent .* Content-Type {text/plain;charset=utf-8} Accept \*/\* Accept-Encoding .* Connection close Content-Length 5} test http-3.29.$ThreadLevel {http::geturl IPv6 address} -body { # We only want to see if the URL gets parsed correctly. This is # the case if http::geturl succeeds or returns a socket related # error. If the parsing is wrong, we'll get a parse error. # It'd be better to separate the URL parser from http::geturl, so # that it can be tested without also trying to make a connection. set error [catch {http::geturl $ipv6url -validate 1} token] if {$error && [string match "couldn't open socket: *" $token]} { set error 0 } set error } -cleanup { catch {http::cleanup $token} } -result 0 test http-3.30.$ThreadLevel {http::geturl query without path} -body { set token [http::geturl $authorityurl?var=val] http::ncode $token } -cleanup { catch {http::cleanup $token} } -result 200 test http-3.31.$ThreadLevel {http::geturl fragment without path} -body { set token [http::geturl "$authorityurl#fragment42"] http::ncode $token } -cleanup { catch {http::cleanup $token} } -result 200 # Bug c11a51c482 test http-3.32.$ThreadLevel {http::geturl: -headers override -accept default} -body { set token [http::geturl $url/headers -query dummy \ -headers [list "Accept" "text/plain,application/tcl-test-value"]] http::data $token } -cleanup { catch {http::cleanup $token} } -match regexp -result {(?n)Host .* User-Agent .* Accept text/plain,application/tcl-test-value Accept-Encoding .* Connection close Content-Type application/x-www-form-urlencoded Content-Length 5} # Bug 838e99a76d test http-3.33.$ThreadLevel {http::geturl application/xml is text} -body { set token [http::geturl "$xmlurl"] scan [http::data $token] "<%\[^>]>%c<%\[^>]>" } -cleanup { catch {http::cleanup $token} } -result {test 4660 /test} test http-3.34.$ThreadLevel {http::geturl -headers not a list} -returnCodes error -body { http::geturl http://test/t -headers \" } -result "Bad value for -headers (\"), must be list" test http-3.35.$ThreadLevel {http::geturl -headers not even number of elements} -returnCodes error -body { http::geturl http://test/t -headers {List Length 3} } -result {Bad value for -headers (List Length 3), number of list elements must be even} test http-4.1.$ThreadLevel {http::Event} -body { set token [http::geturl $url -keepalive 0] upvar #0 $token data array set meta $data(meta) expr {($data(totalsize) == $meta(content-length))} } -cleanup { catch {http::cleanup $token} } -result 1 test http-4.2.$ThreadLevel {http::Event} -body { set token [http::geturl $url] upvar #0 $token data array set meta $data(meta) string compare $data(type) [string trim $meta(content-type)] } -cleanup { catch {http::cleanup $token} } -result 0 test http-4.3.$ThreadLevel {http::Event} -body { set token [http::geturl $url] http::code $token } -cleanup { catch {http::cleanup $token} } -result {HTTP/1.0 200 Data follows} test http-4.4.$ThreadLevel {http::Event} -setup { set testfile [makeFile "" testfile] } -body { set out [open $testfile w] set token [http::geturl $url -channel $out] close $out set in [open $testfile] set x [read $in] } -cleanup { catch {close $in} catch {close $out} removeFile $testfile catch {http::cleanup $token} } -result "<html><head><title>HTTP/1.0 TEST</title></head><body> <h1>Hello, World!</h1> <h2>GET $tail</h2> </body></html>" test http-4.5.$ThreadLevel {http::Event} -setup { set testfile [makeFile "" testfile] } -body { set out [open $testfile w] fconfigure $out -translation lf set token [http::geturl $url -channel $out] close $out upvar #0 $token data expr {$data(currentsize) == $data(totalsize)} } -cleanup { removeFile $testfile catch {http::cleanup $token} } -result 1 test http-4.6.$ThreadLevel {http::Event} -setup { set testfile [makeFile "" testfile] } -body { set out [open $testfile w] set token [http::geturl $binurl -channel $out] close $out set in [open $testfile] fconfigure $in -translation binary read $in } -cleanup { catch {close $in} catch {close $out} removeFile $testfile catch {http::cleanup $token} } -result "$bindata[string trimleft $binurl /]" proc myProgress {token total current} { global progress httpLog if {[info exists httpLog] && $httpLog} { puts "progress $total $current" } set progress [list $total $current] } test http-4.6.1.$ThreadLevel {http::Event} knownBug { set token [http::geturl $url -blocksize 50 -progress myProgress] return $progress } {111 111} test http-4.7.$ThreadLevel {http::Event} -body { set token [http::geturl $url -keepalive 0 -progress myProgress] return $progress } -cleanup { catch {http::cleanup $token} } -result {111 111} test http-4.8.$ThreadLevel {http::Event} -body { set token [http::geturl $url] http::status $token } -cleanup { catch {http::cleanup $token} } -result {ok} test http-4.9.$ThreadLevel {http::Event} -body { set token [http::geturl $url -progress myProgress] http::code $token } -cleanup { catch {http::cleanup $token} } -result {HTTP/1.0 200 Data follows} test http-4.10.$ThreadLevel {http::Event} -body { set token [http::geturl $url -progress myProgress] http::size $token } -cleanup { catch {http::cleanup $token} } -result {111} # Timeout cases # Short timeout to working server (the test server). This lets us try a # reset during the connection. test http-4.11.$ThreadLevel {http::Event} -body { set token [http::geturl $url -timeout 1 -keepalive 0 -command \#] http::reset $token http::status $token } -cleanup { catch {http::cleanup $token} } -result {reset} # Longer timeout with reset. test http-4.12.$ThreadLevel {http::Event} -body { set token [http::geturl $url/?timeout=10 -keepalive 0 -command \#] http::reset $token http::status $token } -cleanup { catch {http::cleanup $token} } -result {reset} # Medium timeout to working server that waits even longer. The timeout # hits while waiting for a reply. test http-4.13.$ThreadLevel {http::Event} -body { set token [http::geturl $url?timeout=30 -keepalive 0 -timeout 10 -command \#] http::wait $token http::status $token } -cleanup { catch {http::cleanup $token} } -result {timeout} # Longer timeout to good host, bad port, gets an error after the # connection "completes" but the socket is bad. test http-4.14.$ThreadLevel {http::Event} -body { set token [http::geturl $badurl/?timeout=10 -timeout 10000 -command \#] if {$token eq ""} { error "bogus return from http::geturl" } http::wait $token lindex [http::error $token] 0 } -cleanup { catch {http::cleanup $token} } -result {connect failed: connection refused} # Bogus host test http-4.15.$ThreadLevel {http::Event} -body { # 1. The test assumes that http is not using a proxy server. # If http is using a proxy server, the latter is responsible for the DNS # lookup of the non-existent host. Squid responds with # "503 Service Unavailable" and an explanatory response body; but other # proxies may respond differently. # 2. The [socket] command blocks during the DNS lookup. # - When [socket] runs in the main thread (i.e. when -threadlevel is 0 or # (if Thread package not available) 1), the script cannot time out # during a prolonged DNS lookup. # - When [socket] runs in a separate thread (i.e. when the Thread package # is available and [http::config -threadlevel] is 1 or 2), the main # thread enters the event loop and has the opportunity to time out # during the DNS lookup. This causes the test to fail. # - The test uses a long -timeout so that it is not confounded by a slow # DNS lookup. # - If the error result is "timeout", this suggests a problem with # negative DNS lookups on the test host. Compare the timings for # different values of threadLevel. # set t0 [clock milliseconds] set token [http::geturl //not-a-host.nodns. -timeout 30000 -command \#] http::wait $token # set t1 [clock milliseconds] # puts "Test http-4.15.$ThreadLevel - time taken: [expr {$t1 - $t0}] ms" set result "[http::status $token] -- [lindex [http::error $token] 0]" # error codes vary among platforms. } -cleanup { catch {http::cleanup $token} } -match glob -result "error -- couldn't open socket*" test http-4.16.$ThreadLevel {Leak with Close vs Keepalive (bug [6ca52aec14]} -setup { |
︙ | ︙ | |||
683 684 685 686 687 688 689 | http::config -proxyhost ${::HOST} -proxyport $port set token [http::geturl $url] http::wait $token upvar #0 $token data set data(body) } -cleanup { http::config -proxyhost {} -proxyport {} | | | 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 | http::config -proxyhost ${::HOST} -proxyport $port set token [http::geturl $url] http::wait $token upvar #0 $token data set data(body) } -cleanup { http::config -proxyhost {} -proxyport {} catch {http::cleanup $token} } -result "<html><head><title>HTTP/1.0 TEST</title></head><body> <h1>Hello, World!</h1> <h2>GET http:$url</h2> </body></html>" test http-7.1.$ThreadLevel {http::mapReply} { http::mapReply "abc\$\[\]\"\\()\}\{" |
︙ | ︙ | |||
1181 1182 1183 1184 1185 1186 1187 | } if {[info exists removeHttpd]} { removeFile $httpdFile } rename bgerror {} | > > | > | 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 | } if {[info exists removeHttpd]} { removeFile $httpdFile } rename bgerror {} if {[testConstraint ThreadLevelSummary]} { ::tcltest::cleanupTests } # Local variables: # mode: tcl # End: |
Changes to tests/http11.test.
︙ | ︙ | |||
9 10 11 12 13 14 15 16 17 18 19 20 21 22 | if {"::tcltest" ni [namespace children]} { package require tcltest 2.5 namespace import -force ::tcltest::* } package require http 2.10 # start the server variable httpd_output proc create_httpd {} { proc httpd_read {chan} { variable httpd_output if {[gets $chan line] >= 0} { | > | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 | if {"::tcltest" ni [namespace children]} { package require tcltest 2.5 namespace import -force ::tcltest::* } package require http 2.10 #http::register http 80 ::socket # start the server variable httpd_output proc create_httpd {} { proc httpd_read {chan} { variable httpd_output if {[gets $chan line] >= 0} { |
︙ | ︙ | |||
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 | return "ok" } makeFile "<html><head><title>test</title></head><body><p>this is a test</p>\n[string repeat {<p>This is a tcl test file.</p>} 4192]\n</body></html>" testdoc.html makeFile "<html><head><title>test</title></head><body><p>this is a test</p>\n[string repeat {<p>This is a tcl test file.</p>} 5000]\n</body></html>" largedoc.html if {![info exists ThreadLevel]} { if {[catch {package require Thread}] == 0} { set ValueRange {0 1 2} } else { set ValueRange {0 1} } # For each value of ThreadLevel, source this file recursively in the # same interpreter. foreach ThreadLevel $ValueRange { source [info script] } catch {unset ThreadLevel} catch {unset ValueRange} return } catch {puts "==== Test with ThreadLevel $ThreadLevel ===="} http::config -threadlevel $ThreadLevel # ------------------------------------------------------------------------- test http11-1.0.$ThreadLevel "normal request for document " -setup { variable httpd [create_httpd] } -body { set tok [http::geturl http://localhost:$httpd_port/testdoc.html -timeout 10000] http::wait $tok list [http::status $tok] [http::code $tok] [check_crc $tok] [meta $tok connection] } -cleanup { | > > > > > > > > > > > | | | | | | | | | | | | | | | | | | 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 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 | return "ok" } makeFile "<html><head><title>test</title></head><body><p>this is a test</p>\n[string repeat {<p>This is a tcl test file.</p>} 4192]\n</body></html>" testdoc.html makeFile "<html><head><title>test</title></head><body><p>this is a test</p>\n[string repeat {<p>This is a tcl test file.</p>} 5000]\n</body></html>" largedoc.html # To write a separate summary for each value of ThreadLevel, set constraint ThreadLevelSummary. #testConstraint ThreadLevelSummary 0 if 0 { # For debugging: run with a single value of ThreadLevel: 0|1|2 set ThreadLevel 0 testConstraint ThreadLevelSummary 1 } if {![info exists ThreadLevel]} { if {[catch {package require Thread}] == 0} { set ValueRange {0 1 2} } else { set ValueRange {0 1} } # For each value of ThreadLevel, source this file recursively in the # same interpreter. foreach ThreadLevel $ValueRange { source [info script] } catch {unset ThreadLevel} catch {unset ValueRange} if {![testConstraint ThreadLevelSummary]} { ::tcltest::cleanupTests } return } catch {puts "==== Test with ThreadLevel $ThreadLevel ===="} http::config -threadlevel $ThreadLevel # ------------------------------------------------------------------------- test http11-1.0.$ThreadLevel "normal request for document " -setup { variable httpd [create_httpd] } -body { set tok [http::geturl http://localhost:$httpd_port/testdoc.html -timeout 10000] http::wait $tok list [http::status $tok] [http::code $tok] [check_crc $tok] [meta $tok connection] } -cleanup { catch {http::cleanup $tok} halt_httpd } -result {ok {HTTP/1.1 200 OK} ok close} test http11-1.1.$ThreadLevel "normal,gzip,non-chunked" -setup { variable httpd [create_httpd] } -body { set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1 \ -timeout 10000 -headers {accept-encoding gzip}] http::wait $tok list [http::status $tok] [http::code $tok] [check_crc $tok] \ [meta $tok content-encoding] [meta $tok transfer-encoding] \ [http::meta $tok content-encoding] [http::meta $tok transfer-encoding] } -cleanup { catch {http::cleanup $tok} halt_httpd } -result {ok {HTTP/1.1 200 OK} ok gzip {} {content-encoding gzip} {}} test http11-1.2.$ThreadLevel "normal,deflated,non-chunked" -setup { variable httpd [create_httpd] } -body { set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1 \ -timeout 10000 -headers {accept-encoding deflate}] http::wait $tok list [http::status $tok] [http::code $tok] [check_crc $tok] \ [meta $tok content-encoding] [meta $tok transfer-encoding] } -cleanup { catch {http::cleanup $tok} halt_httpd } -result {ok {HTTP/1.1 200 OK} ok deflate {}} test http11-1.2.1.$ThreadLevel "normal,deflated,non-chunked,msdeflate" -setup { variable httpd [create_httpd] } -body { set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1&msdeflate=1 \ -timeout 10000 -headers {accept-encoding deflate}] http::wait $tok list [http::status $tok] [http::code $tok] [check_crc $tok] \ [meta $tok content-encoding] [meta $tok transfer-encoding] } -cleanup { catch {http::cleanup $tok} halt_httpd } -result {ok {HTTP/1.1 200 OK} ok deflate {}} test http11-1.3.$ThreadLevel "normal,compressed,non-chunked" -constraints badCompress -setup { # The Tcl "compress" algorithm appears to be incorrect and has been removed. # Bug [a13b9d0ce1]. variable httpd [create_httpd] } -body { set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1 \ -timeout 10000 -headers {accept-encoding compress}] http::wait $tok list [http::status $tok] [http::code $tok] [check_crc $tok] \ [meta $tok content-encoding] [meta $tok transfer-encoding] } -cleanup { catch {http::cleanup $tok} halt_httpd } -result {ok {HTTP/1.1 200 OK} ok compress {}} test http11-1.4.$ThreadLevel "normal,identity,non-chunked" -setup { variable httpd [create_httpd] } -body { set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1 \ -timeout 10000 -headers {accept-encoding identity}] http::wait $tok list [http::status $tok] [http::code $tok] [check_crc $tok] \ [meta $tok content-encoding] [meta $tok transfer-encoding] } -cleanup { catch {http::cleanup $tok} halt_httpd } -result {ok {HTTP/1.1 200 OK} ok {} {}} test http11-1.5.$ThreadLevel "normal request for document, unsupported coding" -setup { variable httpd [create_httpd] } -body { set tok [http::geturl http://localhost:$httpd_port/testdoc.html \ -timeout 10000 -headers {accept-encoding unsupported}] http::wait $tok list [http::status $tok] [http::code $tok] [check_crc $tok] \ [meta $tok content-encoding] } -cleanup { catch {http::cleanup $tok} halt_httpd } -result {ok {HTTP/1.1 200 OK} ok {}} test http11-1.6.$ThreadLevel "normal, specify 1.1 " -setup { variable httpd [create_httpd] } -body { set tok [http::geturl http://localhost:$httpd_port/testdoc.html \ -protocol 1.1 -timeout 10000] http::wait $tok list [http::status $tok] [http::code $tok] [check_crc $tok] \ [meta $tok connection] [meta $tok transfer-encoding] \ [http::meta $tok connection] [http::meta $tok transfer-encoding] } -cleanup { catch {http::cleanup $tok} halt_httpd } -result {ok {HTTP/1.1 200 OK} ok close chunked {connection close} {transfer-encoding chunked}} test http11-1.7.$ThreadLevel "normal, 1.1 and keepalive " -setup { variable httpd [create_httpd] } -body { set tok [http::geturl http://localhost:$httpd_port/testdoc.html \ -protocol 1.1 -keepalive 1 -timeout 10000] http::wait $tok list [http::status $tok] [http::code $tok] [check_crc $tok] \ [meta $tok connection] [meta $tok transfer-encoding] } -cleanup { catch {http::cleanup $tok} halt_httpd } -result {ok {HTTP/1.1 200 OK} ok {} chunked} test http11-1.8.$ThreadLevel "normal, 1.1 and keepalive, server close" -setup { variable httpd [create_httpd] } -body { set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1 \ -protocol 1.1 -keepalive 1 -timeout 10000] http::wait $tok list [http::status $tok] [http::code $tok] [check_crc $tok] \ [meta $tok connection] [meta $tok transfer-encoding] } -cleanup { catch {http::cleanup $tok} halt_httpd } -result {ok {HTTP/1.1 200 OK} ok close {}} test http11-1.9.$ThreadLevel "normal,gzip,chunked" -setup { variable httpd [create_httpd] } -body { set tok [http::geturl http://localhost:$httpd_port/testdoc.html \ -timeout 10000 -headers {accept-encoding gzip}] http::wait $tok list [http::status $tok] [http::code $tok] [check_crc $tok] \ [meta $tok content-encoding] [meta $tok transfer-encoding] } -cleanup { catch {http::cleanup $tok} halt_httpd } -result {ok {HTTP/1.1 200 OK} ok gzip chunked} test http11-1.10.$ThreadLevel "normal,deflate,chunked" -setup { variable httpd [create_httpd] } -body { set tok [http::geturl http://localhost:$httpd_port/testdoc.html \ -timeout 10000 -headers {accept-encoding deflate}] http::wait $tok list [http::status $tok] [http::code $tok] [check_crc $tok] \ [meta $tok content-encoding] [meta $tok transfer-encoding] } -cleanup { catch {http::cleanup $tok} halt_httpd } -result {ok {HTTP/1.1 200 OK} ok deflate chunked} test http11-1.10.1.$ThreadLevel "normal,deflate,chunked,msdeflate" -setup { variable httpd [create_httpd] } -body { set tok [http::geturl http://localhost:$httpd_port/testdoc.html?msdeflate=1 \ -timeout 10000 -headers {accept-encoding deflate}] http::wait $tok list [http::status $tok] [http::code $tok] [check_crc $tok] \ [meta $tok content-encoding] [meta $tok transfer-encoding] } -cleanup { catch {http::cleanup $tok} halt_httpd } -result {ok {HTTP/1.1 200 OK} ok deflate chunked} test http11-1.11.$ThreadLevel "normal,compress,chunked" -constraints badCompress -setup { # The Tcl "compress" algorithm appears to be incorrect and has been removed. # Bug [a13b9d0ce1]. variable httpd [create_httpd] } -body { set tok [http::geturl http://localhost:$httpd_port/testdoc.html \ -timeout 10000 -headers {accept-encoding compress}] http::wait $tok list [http::status $tok] [http::code $tok] [check_crc $tok] \ [meta $tok content-encoding] [meta $tok transfer-encoding] } -cleanup { catch {http::cleanup $tok} halt_httpd } -result {ok {HTTP/1.1 200 OK} ok compress chunked} test http11-1.12.$ThreadLevel "normal,identity,chunked" -setup { variable httpd [create_httpd] } -body { set tok [http::geturl http://localhost:$httpd_port/testdoc.html \ -timeout 10000 -headers {accept-encoding identity}] http::wait $tok list [http::status $tok] [http::code $tok] [check_crc $tok] \ [meta $tok content-encoding] [meta $tok transfer-encoding] } -cleanup { catch {http::cleanup $tok} halt_httpd } -result {ok {HTTP/1.1 200 OK} ok {} chunked} test http11-1.13.$ThreadLevel "normal, 1.1 and keepalive as server default, no zip" -setup { variable httpd [create_httpd] set zipTmp [http::config -zip] http::config -zip 0 } -body { set tok [http::geturl http://localhost:$httpd_port/testdoc.html?transfer= \ -protocol 1.1 -keepalive 1 -timeout 10000] http::wait $tok set res1 [list [http::status $tok] [http::code $tok] [check_crc $tok] \ [meta $tok connection] [meta $tok transfer-encoding] [state $tok reusing] [state $tok connection]] set toj [http::geturl http://localhost:$httpd_port/testdoc.html?transfer= \ -protocol 1.1 -keepalive 1 -timeout 10000] http::wait $toj set res2 [list [http::status $toj] [http::code $toj] [check_crc $toj] \ [meta $toj connection] [meta $toj transfer-encoding] [state $toj reusing] [state $toj connection]] concat $res1 -- $res2 } -cleanup { catch {http::cleanup $tok} catch {http::cleanup $toj} halt_httpd http::config -zip $zipTmp } -result {ok {HTTP/1.1 200 OK} ok {} {} 0 keep-alive -- ok {HTTP/1.1 200 OK} ok {} {} 1 keep-alive} # ------------------------------------------------------------------------- proc progress {var token total current} { |
︙ | ︙ | |||
354 355 356 357 358 359 360 | -timeout 5000 -channel $chan] http::wait $tok seek $chan 0 set data [read $chan] list [http::status $tok] [http::code $tok] [check_crc $tok $data]\ [meta $tok connection] [meta $tok transfer-encoding] } -cleanup { | | | | 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 | -timeout 5000 -channel $chan] http::wait $tok seek $chan 0 set data [read $chan] list [http::status $tok] [http::code $tok] [check_crc $tok $data]\ [meta $tok connection] [meta $tok transfer-encoding] } -cleanup { catch {http::cleanup $tok} close $chan removeFile testfile.tmp halt_httpd } -result {ok {HTTP/1.1 200 OK} ok close chunked} test http11-2.1.$ThreadLevel "-channel, encoding gzip" -setup { variable httpd [create_httpd] set chan [open [makeFile {} testfile.tmp] wb+] } -body { set tok [http::geturl http://localhost:$httpd_port/testdoc.html \ -timeout 5000 -channel $chan -headers {accept-encoding gzip}] http::wait $tok seek $chan 0 set data [read $chan] set diff [expr {[file size testdoc.html] - [file size testfile.tmp]}] list [http::status $tok] [http::code $tok] [check_crc $tok $data]\ [meta $tok connection] [meta $tok content-encoding]\ [meta $tok transfer-encoding] -- $diff bytes lost } -cleanup { catch {http::cleanup $tok} close $chan removeFile testfile.tmp halt_httpd } -result {ok {HTTP/1.1 200 OK} ok close gzip chunked -- 0 bytes lost} # Cf. Bug [3610253] "CopyChunk does not drain decompressor(s)" # This test failed before the bugfix. |
︙ | ︙ | |||
398 399 400 401 402 403 404 | seek $chan 0 set data [read $chan] set diff [expr {[file size $fileName] - [file size testfile.tmp]}] list [http::status $tok] [http::code $tok] [check_crc $tok $data]\ [meta $tok connection] [meta $tok content-encoding]\ [meta $tok transfer-encoding] -- $diff bytes lost } -cleanup { | | | | | 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 | seek $chan 0 set data [read $chan] set diff [expr {[file size $fileName] - [file size testfile.tmp]}] list [http::status $tok] [http::code $tok] [check_crc $tok $data]\ [meta $tok connection] [meta $tok content-encoding]\ [meta $tok transfer-encoding] -- $diff bytes lost } -cleanup { catch {http::cleanup $tok} close $chan removeFile testfile.tmp halt_httpd } -result {ok {HTTP/1.1 200 OK} ok close gzip chunked -- 0 bytes lost} test http11-2.2.$ThreadLevel "-channel, encoding deflate" -setup { variable httpd [create_httpd] set chan [open [makeFile {} testfile.tmp] wb+] } -body { set tok [http::geturl http://localhost:$httpd_port/testdoc.html \ -timeout 5000 -channel $chan -headers {accept-encoding deflate}] http::wait $tok seek $chan 0 set data [read $chan] list [http::status $tok] [http::code $tok] [check_crc $tok $data]\ [meta $tok connection] [meta $tok content-encoding]\ [meta $tok transfer-encoding] } -cleanup { catch {http::cleanup $tok} close $chan removeFile testfile.tmp halt_httpd } -result {ok {HTTP/1.1 200 OK} ok close deflate chunked} test http11-2.2.1.$ThreadLevel "-channel, encoding deflate,msdeflate" -setup { variable httpd [create_httpd] set chan [open [makeFile {} testfile.tmp] wb+] } -body { set tok [http::geturl http://localhost:$httpd_port/testdoc.html?msdeflate=1 \ -timeout 5000 -channel $chan -headers {accept-encoding deflate}] http::wait $tok seek $chan 0 set data [read $chan] list [http::status $tok] [http::code $tok] [check_crc $tok $data]\ [meta $tok connection] [meta $tok content-encoding]\ [meta $tok transfer-encoding] } -cleanup { catch {http::cleanup $tok} close $chan removeFile testfile.tmp halt_httpd } -result {ok {HTTP/1.1 200 OK} ok close deflate chunked} test http11-2.3.$ThreadLevel "-channel,encoding compress" -constraints badCompress -setup { # The Tcl "compress" algorithm appears to be incorrect and has been removed. |
︙ | ︙ | |||
458 459 460 461 462 463 464 | http::wait $tok seek $chan 0 set data [read $chan] list [http::status $tok] [http::code $tok] [check_crc $tok $data]\ [meta $tok connection] [meta $tok content-encoding]\ [meta $tok transfer-encoding] } -cleanup { | | | | 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 | http::wait $tok seek $chan 0 set data [read $chan] list [http::status $tok] [http::code $tok] [check_crc $tok $data]\ [meta $tok connection] [meta $tok content-encoding]\ [meta $tok transfer-encoding] } -cleanup { catch {http::cleanup $tok} close $chan removeFile testfile.tmp halt_httpd } -result {ok {HTTP/1.1 200 OK} ok close compress chunked} test http11-2.4.$ThreadLevel "-channel,encoding identity" -setup { variable httpd [create_httpd] set chan [open [makeFile {} testfile.tmp] wb+] } -body { set tok [http::geturl http://localhost:$httpd_port/testdoc.html \ -timeout 5000 -channel $chan \ -headers {accept-encoding identity}] http::wait $tok seek $chan 0 set data [read $chan] list [http::status $tok] [http::code $tok] [check_crc $tok $data]\ [meta $tok connection] [meta $tok content-encoding]\ [meta $tok transfer-encoding] } -cleanup { catch {http::cleanup $tok} close $chan removeFile testfile.tmp halt_httpd } -result {ok {HTTP/1.1 200 OK} ok close {} chunked} test http11-2.4.1.$ThreadLevel "-channel,encoding identity with -progress" -setup { variable httpd [create_httpd] |
︙ | ︙ | |||
503 504 505 506 507 508 509 | set data [read $chan] list [http::status $tok] [http::code $tok] [check_crc $tok $data]\ [meta $tok connection] [meta $tok content-encoding]\ [meta $tok transfer-encoding] \ [expr {[lindex $logdata 0] - [lindex $logdata 1]}] \ [expr {[lindex $logdata 0] - [string length $data]}] } -cleanup { | | | 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 | set data [read $chan] list [http::status $tok] [http::code $tok] [check_crc $tok $data]\ [meta $tok connection] [meta $tok content-encoding]\ [meta $tok transfer-encoding] \ [expr {[lindex $logdata 0] - [lindex $logdata 1]}] \ [expr {[lindex $logdata 0] - [string length $data]}] } -cleanup { catch {http::cleanup $tok} close $chan removeFile testfile.tmp halt_httpd unset -nocomplain logdata data } -result {ok {HTTP/1.1 200 OK} ok close {} chunked 0 0} test http11-2.4.2.$ThreadLevel "-channel,encoding identity with -progress progressPause enters event loop" -constraints knownBug -setup { |
︙ | ︙ | |||
529 530 531 532 533 534 535 | set data [read $chan] list [http::status $tok] [http::code $tok] [check_crc $tok $data]\ [meta $tok connection] [meta $tok content-encoding]\ [meta $tok transfer-encoding] \ [expr {[lindex $logdata 0] - [lindex $logdata 1]}] \ [expr {[lindex $logdata 0] - [string length $data]}] } -cleanup { | | | | | | 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 | set data [read $chan] list [http::status $tok] [http::code $tok] [check_crc $tok $data]\ [meta $tok connection] [meta $tok content-encoding]\ [meta $tok transfer-encoding] \ [expr {[lindex $logdata 0] - [lindex $logdata 1]}] \ [expr {[lindex $logdata 0] - [string length $data]}] } -cleanup { catch {http::cleanup $tok} close $chan removeFile testfile.tmp halt_httpd unset -nocomplain logdata data ::WaitHere } -result {ok {HTTP/1.1 200 OK} ok close {} chunked 0 0} test http11-2.5.$ThreadLevel "-channel,encoding unsupported" -setup { variable httpd [create_httpd] set chan [open [makeFile {} testfile.tmp] wb+] } -body { set tok [http::geturl http://localhost:$httpd_port/testdoc.html \ -timeout 5000 -channel $chan \ -headers {accept-encoding unsupported}] http::wait $tok seek $chan 0 set data [read $chan] list [http::status $tok] [http::code $tok] [check_crc $tok $data]\ [meta $tok connection] [meta $tok content-encoding]\ [meta $tok transfer-encoding] } -cleanup { catch {http::cleanup $tok} close $chan removeFile testfile.tmp halt_httpd } -result {ok {HTTP/1.1 200 OK} ok close {} chunked} test http11-2.6.$ThreadLevel "-channel,encoding gzip,non-chunked" -setup { variable httpd [create_httpd] set chan [open [makeFile {} testfile.tmp] wb+] } -body { set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1 \ -timeout 5000 -channel $chan -headers {accept-encoding gzip}] http::wait $tok seek $chan 0 set data [read $chan] list [http::status $tok] [http::code $tok] [check_crc $tok $data]\ [meta $tok connection] [meta $tok content-encoding]\ [meta $tok transfer-encoding]\ [expr {[file size testdoc.html]-[file size testfile.tmp]}] } -cleanup { catch {http::cleanup $tok} close $chan removeFile testfile.tmp halt_httpd } -result {ok {HTTP/1.1 200 OK} ok close gzip {} 0} test http11-2.7.$ThreadLevel "-channel,encoding deflate,non-chunked" -setup { variable httpd [create_httpd] set chan [open [makeFile {} testfile.tmp] wb+] } -body { set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1 \ -timeout 5000 -channel $chan -headers {accept-encoding deflate}] http::wait $tok seek $chan 0 set data [read $chan] list [http::status $tok] [http::code $tok] [check_crc $tok $data]\ [meta $tok connection] [meta $tok content-encoding]\ [meta $tok transfer-encoding]\ [expr {[file size testdoc.html]-[file size testfile.tmp]}] } -cleanup { catch {http::cleanup $tok} close $chan removeFile testfile.tmp halt_httpd } -result {ok {HTTP/1.1 200 OK} ok close deflate {} 0} test http11-2.7.1.$ThreadLevel "-channel,encoding deflate,non-chunked,msdeflate" -constraints knownBug -setup { # Test fails because a -channel can only try one un-deflate algorithm, and the |
︙ | ︙ | |||
613 614 615 616 617 618 619 | seek $chan 0 set data [read $chan] list [http::status $tok] [http::code $tok] [check_crc $tok $data]\ [meta $tok connection] [meta $tok content-encoding]\ [meta $tok transfer-encoding]\ [expr {[file size testdoc.html]-[file size testfile.tmp]}] } -cleanup { | | | 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 | seek $chan 0 set data [read $chan] list [http::status $tok] [http::code $tok] [check_crc $tok $data]\ [meta $tok connection] [meta $tok content-encoding]\ [meta $tok transfer-encoding]\ [expr {[file size testdoc.html]-[file size testfile.tmp]}] } -cleanup { catch {http::cleanup $tok} close $chan removeFile testfile.tmp halt_httpd } -result {ok {HTTP/1.1 200 OK} ok close deflate {} 0} test http11-2.8.$ThreadLevel "-channel,encoding compress,non-chunked" -constraints badCompress -setup { # The Tcl "compress" algorithm appears to be incorrect and has been removed. |
︙ | ︙ | |||
635 636 637 638 639 640 641 | seek $chan 0 set data [read $chan] list [http::status $tok] [http::code $tok] [check_crc $tok $data]\ [meta $tok connection] [meta $tok content-encoding]\ [meta $tok transfer-encoding]\ [expr {[file size testdoc.html]-[file size testfile.tmp]}] } -cleanup { | | | | | | | | 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 | seek $chan 0 set data [read $chan] list [http::status $tok] [http::code $tok] [check_crc $tok $data]\ [meta $tok connection] [meta $tok content-encoding]\ [meta $tok transfer-encoding]\ [expr {[file size testdoc.html]-[file size testfile.tmp]}] } -cleanup { catch {http::cleanup $tok} close $chan removeFile testfile.tmp halt_httpd } -result {ok {HTTP/1.1 200 OK} ok close compress {} 0} test http11-2.9.$ThreadLevel "-channel,encoding identity,non-chunked" -setup { variable httpd [create_httpd] set chan [open [makeFile {} testfile.tmp] wb+] } -body { set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1 \ -timeout 5000 -channel $chan -headers {accept-encoding identity}] http::wait $tok seek $chan 0 set data [read $chan] list [http::status $tok] [http::code $tok] [check_crc $tok $data]\ [meta $tok connection] [meta $tok content-encoding]\ [meta $tok transfer-encoding]\ [expr {[file size testdoc.html]-[file size testfile.tmp]}] } -cleanup { catch {http::cleanup $tok} close $chan removeFile testfile.tmp halt_httpd } -result {ok {HTTP/1.1 200 OK} ok close {} {} 0} test http11-2.10.$ThreadLevel "-channel,deflate,keepalive" -setup { variable httpd [create_httpd] set chan [open [makeFile {} testfile.tmp] wb+] } -body { set tok [http::geturl http://localhost:$httpd_port/testdoc.html \ -timeout 5000 -channel $chan -keepalive 1 \ -headers {accept-encoding deflate}] http::wait $tok seek $chan 0 set data [read $chan] list [http::status $tok] [http::code $tok] [check_crc $tok $data]\ [meta $tok connection] [meta $tok content-encoding]\ [meta $tok transfer-encoding]\ [expr {[file size testdoc.html]-[file size testfile.tmp]}] } -cleanup { catch {http::cleanup $tok} close $chan removeFile testfile.tmp halt_httpd } -result {ok {HTTP/1.1 200 OK} ok {} deflate chunked 0} test http11-2.10.1.$ThreadLevel "-channel,deflate,keepalive,msdeflate" -setup { variable httpd [create_httpd] set chan [open [makeFile {} testfile.tmp] wb+] } -body { set tok [http::geturl http://localhost:$httpd_port/testdoc.html?msdeflate=1 \ -timeout 5000 -channel $chan -keepalive 1 \ -headers {accept-encoding deflate}] http::wait $tok seek $chan 0 set data [read $chan] list [http::status $tok] [http::code $tok] [check_crc $tok $data]\ [meta $tok connection] [meta $tok content-encoding]\ [meta $tok transfer-encoding]\ [expr {[file size testdoc.html]-[file size testfile.tmp]}] } -cleanup { catch {http::cleanup $tok} close $chan removeFile testfile.tmp halt_httpd } -result {ok {HTTP/1.1 200 OK} ok {} deflate chunked 0} test http11-2.11.$ThreadLevel "-channel,identity,keepalive" -setup { variable httpd [create_httpd] set chan [open [makeFile {} testfile.tmp] wb+] } -body { set tok [http::geturl http://localhost:$httpd_port/testdoc.html \ -headers {accept-encoding identity} \ -timeout 5000 -channel $chan -keepalive 1] http::wait $tok seek $chan 0 set data [read $chan] list [http::status $tok] [http::code $tok] [check_crc $tok $data]\ [meta $tok connection] [meta $tok content-encoding]\ [meta $tok transfer-encoding] } -cleanup { catch {http::cleanup $tok} close $chan removeFile testfile.tmp halt_httpd } -result {ok {HTTP/1.1 200 OK} ok {} {} chunked} test http11-2.12.$ThreadLevel "-channel,negotiate,keepalive" -setup { variable httpd [create_httpd] set chan [open [makeFile {} testfile.tmp] wb+] } -body { set tok [http::geturl http://localhost:$httpd_port/testdoc.html \ -timeout 5000 -channel $chan -keepalive 1] http::wait $tok seek $chan 0 set data [read $chan] list [http::status $tok] [http::code $tok] [check_crc $tok $data]\ [meta $tok connection] [meta $tok content-encoding]\ [meta $tok transfer-encoding] [meta $tok x-requested-encodings]\ [expr {[file size testdoc.html]-[file size testfile.tmp]}] } -cleanup { catch {http::cleanup $tok} close $chan removeFile testfile.tmp halt_httpd } -result {ok {HTTP/1.1 200 OK} ok {} gzip chunked gzip,deflate 0} # ------------------------------------------------------------------------- |
︙ | ︙ | |||
783 784 785 786 787 788 789 | -timeout 10000 -handler [namespace code [list handler testdata]]] http::wait $tok list [http::status $tok] [http::code $tok] [check_crc $tok $testdata]\ [meta $tok connection] [meta $tok content-encoding] \ [meta $tok transfer-encoding] \ [expr {[file size testdoc.html]-[string length $testdata]}] } -cleanup { | | | | | | 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 | -timeout 10000 -handler [namespace code [list handler testdata]]] http::wait $tok list [http::status $tok] [http::code $tok] [check_crc $tok $testdata]\ [meta $tok connection] [meta $tok content-encoding] \ [meta $tok transfer-encoding] \ [expr {[file size testdoc.html]-[string length $testdata]}] } -cleanup { catch {http::cleanup $tok} unset -nocomplain testdata halt_httpd } -result {ok {HTTP/1.0 200 OK} ok close {} {} 0} test http11-3.1.$ThreadLevel "-handler,protocol1.0" -setup { variable httpd [create_httpd] set testdata "" } -body { set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1 \ -timeout 10000 -protocol 1.0 \ -handler [namespace code [list handler testdata]]] http::wait $tok list [http::status $tok] [http::code $tok] [check_crc $tok $testdata]\ [meta $tok connection] [meta $tok content-encoding] \ [meta $tok transfer-encoding] \ [expr {[file size testdoc.html]-[string length $testdata]}] } -cleanup { catch {http::cleanup $tok} unset -nocomplain testdata halt_httpd } -result {ok {HTTP/1.0 200 OK} ok close {} {} 0} test http11-3.2.$ThreadLevel "-handler,close,chunked" -setup { variable httpd [create_httpd] set testdata "" } -body { set tok [http::geturl http://localhost:$httpd_port/testdoc.html \ -timeout 10000 -keepalive 0 -binary 1\ -handler [namespace code [list handler testdata]]] http::wait $tok list [http::status $tok] [http::code $tok] [check_crc $tok $testdata]\ [meta $tok connection] [meta $tok content-encoding] \ [meta $tok transfer-encoding] \ [expr {[file size testdoc.html]-[string length $testdata]}] } -cleanup { catch {http::cleanup $tok} unset -nocomplain testdata halt_httpd } -result {ok {HTTP/1.0 200 OK} ok close {} {} 0} test http11-3.3.$ThreadLevel "-handler,keepalive,chunked" -setup { variable httpd [create_httpd] set testdata "" } -body { set tok [http::geturl http://localhost:$httpd_port/testdoc.html \ -timeout 10000 -keepalive 1 -binary 1\ -handler [namespace code [list handler testdata]]] http::wait $tok list [http::status $tok] [http::code $tok] [check_crc $tok $testdata]\ [meta $tok connection] [meta $tok content-encoding] \ [meta $tok transfer-encoding] \ [expr {[file size testdoc.html]-[string length $testdata]}] } -cleanup { catch {http::cleanup $tok} unset -nocomplain testdata halt_httpd } -result {ok {HTTP/1.0 200 OK} ok close {} {} 0} # http11-3.4 # This test is a blatant attempt to confuse the client by instructing the server # to send neither "Connection: close" nor "Content-Length" when in non-chunked |
︙ | ︙ | |||
864 865 866 867 868 869 870 | -timeout 10000 -handler [namespace code [list handler testdata]]] http::wait $tok list [http::status $tok] [http::code $tok] [check_crc $tok $testdata]\ [meta $tok connection] [meta $tok content-encoding] \ [meta $tok transfer-encoding] \ [expr {[file size testdoc.html]-[string length $testdata]}] } -cleanup { | | | | | | | | | | | | 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 | -timeout 10000 -handler [namespace code [list handler testdata]]] http::wait $tok list [http::status $tok] [http::code $tok] [check_crc $tok $testdata]\ [meta $tok connection] [meta $tok content-encoding] \ [meta $tok transfer-encoding] \ [expr {[file size testdoc.html]-[string length $testdata]}] } -cleanup { catch {http::cleanup $tok} unset -nocomplain testdata halt_httpd } -result {ok {HTTP/1.0 200 OK} ok {} {} {} 0} # It is not forbidden for a handler to enter the event loop. test http11-3.5.$ThreadLevel "-handler,close,identity as http11-3.0 but handlerPause enters event loop" -setup { variable httpd [create_httpd] set testdata "" } -body { set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1 \ -timeout 10000 -handler [namespace code [list handlerPause testdata]]] http::wait $tok list [http::status $tok] [http::code $tok] [check_crc $tok $testdata]\ [meta $tok connection] [meta $tok content-encoding] \ [meta $tok transfer-encoding] \ [expr {[file size testdoc.html]-[string length $testdata]}] } -cleanup { catch {http::cleanup $tok} unset -nocomplain testdata ::WaitHere halt_httpd } -result {ok {HTTP/1.0 200 OK} ok close {} {} 0} test http11-3.6.$ThreadLevel "-handler,close,identity as http11-3.0 but with -progress" -setup { variable httpd [create_httpd] set testdata "" set logdata "" } -body { set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1 \ -timeout 10000 -handler [namespace code [list handler testdata]] \ -progress [namespace code [list progress logdata]]] http::wait $tok list [http::status $tok] [http::code $tok] [check_crc $tok $testdata]\ [meta $tok connection] [meta $tok content-encoding] \ [meta $tok transfer-encoding] \ [expr {[file size testdoc.html]-[string length $testdata]}] \ [expr {[lindex $logdata 0] - [lindex $logdata 1]}] \ [expr {[lindex $logdata 0] - [string length $testdata]}] } -cleanup { catch {http::cleanup $tok} unset -nocomplain testdata logdata ::WaitHere halt_httpd } -result {ok {HTTP/1.0 200 OK} ok close {} {} 0 0 0} test http11-3.7.$ThreadLevel "-handler,close,identity as http11-3.0 but with -progress progressPause enters event loop" -setup { variable httpd [create_httpd] set testdata "" set logdata "" } -body { set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1 \ -timeout 10000 -handler [namespace code [list handler testdata]] \ -progress [namespace code [list progressPause logdata]]] http::wait $tok list [http::status $tok] [http::code $tok] [check_crc $tok $testdata]\ [meta $tok connection] [meta $tok content-encoding] \ [meta $tok transfer-encoding] \ [expr {[file size testdoc.html]-[string length $testdata]}] \ [expr {[lindex $logdata 0] - [lindex $logdata 1]}] \ [expr {[lindex $logdata 0] - [string length $testdata]}] } -cleanup { catch {http::cleanup $tok} unset -nocomplain testdata logdata ::WaitHere halt_httpd } -result {ok {HTTP/1.0 200 OK} ok close {} {} 0 0 0} test http11-3.8.$ThreadLevel "close,identity no -handler but with -progress" -setup { variable httpd [create_httpd] set logdata "" } -body { set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1 \ -timeout 10000 \ -progress [namespace code [list progress logdata]] \ -headers {accept-encoding {}}] http::wait $tok list [http::status $tok] [http::code $tok] [check_crc $tok]\ [meta $tok connection] [meta $tok content-encoding] \ [meta $tok transfer-encoding] \ [expr {[file size testdoc.html]-[string length [http::data $tok]]}] \ [expr {[lindex $logdata 0] - [lindex $logdata 1]}] \ [expr {[lindex $logdata 0] - [string length [http::data $tok]]}] } -cleanup { catch {http::cleanup $tok} unset -nocomplain logdata ::WaitHere halt_httpd } -result {ok {HTTP/1.1 200 OK} ok close {} {} 0 0 0} test http11-3.9.$ThreadLevel "close,identity no -handler but with -progress progressPause enters event loop" -setup { variable httpd [create_httpd] set logdata "" } -body { set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1 \ -timeout 10000 \ -progress [namespace code [list progressPause logdata]] \ -headers {accept-encoding {}}] http::wait $tok list [http::status $tok] [http::code $tok] [check_crc $tok]\ [meta $tok connection] [meta $tok content-encoding] \ [meta $tok transfer-encoding] \ [expr {[file size testdoc.html]-[string length [http::data $tok]]}] \ [expr {[lindex $logdata 0] - [lindex $logdata 1]}] \ [expr {[lindex $logdata 0] - [string length [http::data $tok]]}] } -cleanup { catch {http::cleanup $tok} unset -nocomplain logdata ::WaitHere halt_httpd } -result {ok {HTTP/1.1 200 OK} ok close {} {} 0 0 0} test http11-4.0.$ThreadLevel "normal post request" -setup { variable httpd [create_httpd] } -body { set query [http::formatQuery q 1 z 2] set tok [http::geturl http://localhost:$httpd_port/testdoc.html \ -query $query -timeout 10000] http::wait $tok list status [http::status $tok] code [http::code $tok]\ crc [check_crc $tok]\ connection [meta $tok connection]\ query-length [meta $tok x-query-length] } -cleanup { catch {http::cleanup $tok} halt_httpd } -result {status ok code {HTTP/1.1 200 OK} crc ok connection close query-length 7} test http11-4.1.$ThreadLevel "normal post request, check query length" -setup { variable httpd [create_httpd] } -body { set query [http::formatQuery q 1 z 2] set tok [http::geturl http://localhost:$httpd_port/testdoc.html \ -headers [list x-check-query yes] \ -query $query -timeout 10000] http::wait $tok list status [http::status $tok] code [http::code $tok]\ crc [check_crc $tok]\ connection [meta $tok connection]\ query-length [meta $tok x-query-length] } -cleanup { catch {http::cleanup $tok} halt_httpd } -result {status ok code {HTTP/1.1 200 OK} crc ok connection close query-length 7} test http11-4.2.$ThreadLevel "normal post request, check long query length" -setup { variable httpd [create_httpd] } -body { set query [string repeat a 24576] set tok [http::geturl http://localhost:$httpd_port/testdoc.html\ -headers [list x-check-query yes]\ -query $query -timeout 10000] http::wait $tok list status [http::status $tok] code [http::code $tok]\ crc [check_crc $tok]\ connection [meta $tok connection]\ query-length [meta $tok x-query-length] } -cleanup { catch {http::cleanup $tok} halt_httpd } -result {status ok code {HTTP/1.1 200 OK} crc ok connection close query-length 24576} test http11-4.3.$ThreadLevel "normal post request, check channel query length" -setup { variable httpd [create_httpd] set chan [open [makeFile {} testfile.tmp] wb+] puts -nonewline $chan [string repeat [encoding convertto utf-8 "This is a test\n"] 8192] flush $chan seek $chan 0 } -body { set tok [http::geturl http://localhost:$httpd_port/testdoc.html\ -headers [list x-check-query yes]\ -querychannel $chan -timeout 10000] http::wait $tok list status [http::status $tok] code [http::code $tok]\ crc [check_crc $tok]\ connection [meta $tok connection]\ query-length [meta $tok x-query-length] } -cleanup { catch {http::cleanup $tok} close $chan removeFile testfile.tmp halt_httpd } -result {status ok code {HTTP/1.1 200 OK} crc ok connection close query-length 122880} # ------------------------------------------------------------------------- |
︙ | ︙ | |||
1059 1060 1061 1062 1063 1064 1065 | foreach p {create_httpd httpd_read halt_httpd meta check_crc} { if {[llength [info proc $p]]} {rename $p {}} } removeFile testdoc.html removeFile largedoc.html unset -nocomplain httpd_port httpd p | > | > | 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 | foreach p {create_httpd httpd_read halt_httpd meta check_crc} { if {[llength [info proc $p]]} {rename $p {}} } removeFile testdoc.html removeFile largedoc.html unset -nocomplain httpd_port httpd p if {[testConstraint ThreadLevelSummary]} { ::tcltest::cleanupTests } |
Changes to tests/httpPipeline.test.
︙ | ︙ | |||
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 | package require http 2.10 # ------------------------------------------------------------------------------ # (0) Socket Creation in Thread, which triples the number of tests. # ------------------------------------------------------------------------------ if {![info exists ThreadLevel]} { if {[catch {package require Thread}] == 0} { set ValueRange {0 1 2} } else { set ValueRange {0 1} } # For each value of ThreadLevel, source this file recursively in the # same interpreter. foreach ThreadLevel $ValueRange { source [info script] } catch {unset ThreadLevel} catch {unset ValueRange} return } catch {puts "==== Test with ThreadLevel $ThreadLevel ===="} http::config -threadlevel $ThreadLevel set sourcedir [file normalize [file dirname [info script]]] | > > > > > > > > > > > | 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 | package require http 2.10 # ------------------------------------------------------------------------------ # (0) Socket Creation in Thread, which triples the number of tests. # ------------------------------------------------------------------------------ # To write a separate summary for each value of ThreadLevel, set constraint ThreadLevelSummary. #testConstraint ThreadLevelSummary 0 if 0 { # For debugging: run with a single value of ThreadLevel: 0|1|2 set ThreadLevel 0 testConstraint ThreadLevelSummary 1 } if {![info exists ThreadLevel]} { if {[catch {package require Thread}] == 0} { set ValueRange {0 1 2} } else { set ValueRange {0 1} } # For each value of ThreadLevel, source this file recursively in the # same interpreter. foreach ThreadLevel $ValueRange { source [info script] } catch {unset ThreadLevel} catch {unset ValueRange} if {![testConstraint ThreadLevelSummary]} { ::tcltest::cleanupTests } return } catch {puts "==== Test with ThreadLevel $ThreadLevel ===="} http::config -threadlevel $ThreadLevel set sourcedir [file normalize [file dirname [info script]]] |
︙ | ︙ | |||
885 886 887 888 889 890 891 | # ------------------------------------------------------------------------------ unset header footer delay label suffix match cons name te namespace delete ::httpTest namespace delete ::httpTestScript | > | > | 896 897 898 899 900 901 902 903 904 905 | # ------------------------------------------------------------------------------ unset header footer delay label suffix match cons name te namespace delete ::httpTest namespace delete ::httpTestScript if {[testConstraint ThreadLevelSummary]} { ::tcltest::cleanupTests } |
Changes to tests/httpProxy.test.
1 2 3 4 5 6 7 8 9 | # Commands covered: http::geturl when using a proxy server. # # This file contains a collection of tests for the http script library. # Sourcing this file into Tcl runs the tests and generates output for errors. # No output means no errors were found. # # Copyright © 1991-1993 The Regents of the University of California. # Copyright © 1994-1996 Sun Microsystems, Inc. # Copyright © 1998-2000 Ajuba Solutions. | | > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > | | | | > | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > | | > > | | > > | | > > | | > > | | > > | | > > | | > > | | > > | | > > | | > > | | > > | | > > | | > > | | > > | | > > | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | > | < < < < < < | < < < < < < < < < < < < < < < < < < < < | | | > > > | | | > > > | | | > > > > | | | > > > | | | > > > | | | > > > > | | | > > > > | | | > > | | > > | | > > | | > > | | > > | | > > | | > > > | | | > > > | | | > > > | | | > > > > | | | > > > | | | > > < > > | | | > > | | > > | | > > | | > > | | > > | | > > | | > > > | | | > > > > | | | > > > | | | > > > > | | | > > > | | | > > > | | | > > | > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 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 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 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 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 | # Commands covered: http::geturl when using a proxy server. # # This file contains a collection of tests for the http script library. # Sourcing this file into Tcl runs the tests and generates output for errors. # No output means no errors were found. # # Copyright © 1991-1993 The Regents of the University of California. # Copyright © 1994-1996 Sun Microsystems, Inc. # Copyright © 1998-2000 Ajuba Solutions. # Copyright © 2022-2023 Keith Nash. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { package require tcltest 2.5 namespace import -force ::tcltest::* } package require http 2.10 # To write a separate summary for each value of ThreadLevel, set constraint ThreadLevelSummary. #testConstraint ThreadLevelSummary 0 #testConstraint needsSquidNoAuth 0 #testConstraint needsSquidAuth 0 #testConstraint needsTclTls 0 #testConstraint needsTwapi 0 #testConstraint needsTwapiFull 0 #testConstraint knownBug 0 # # The values of constraints needsTls, knownTwapiFullBugThreadlevelAny, knownTwapiFullBugThreadUsed are always generated by this script. proc bgerror {args} { global errorInfo puts stderr "httpProxy.test bgerror" puts stderr [join $args] puts stderr $errorInfo } proc stopMe {token} { set ${token}(z) done } proc putsBlurb {} { puts {} puts {- Constraints needsTls, knownTwapiFullBugThreadlevelAny, knownTwapiFullBugThreadUsed are} puts { always set by the script, not by the caller.} puts {- Set one of needsTclTls, needsTwapi, needsTwapiFull instead of needsTls.} puts {- Set knownBug instead of knownTwapiFullBugThreadlevelAny, knownTwapiFullBugThreadUsed.} puts {- If the caller sets constraint needsTwapi, the script forces needsSquidNoAuth and needsSquidAuth to 0.} puts {} return } if 0 { # For debugging: run with a single value of ThreadLevel: 0|1|2 set ThreadLevel 0 testConstraint ThreadLevelSummary 1 } if {![info exists ThreadLevel]} { if {[catch {package require Thread}] == 0} { set ValueRange {0 1 2} } else { set ValueRange {0 1} } # For each value of ThreadLevel, source this file recursively in the # same interpreter. foreach ThreadLevel $ValueRange { source [info script] } catch {unset ThreadLevel} catch {unset ValueRange} if {![testConstraint ThreadLevelSummary]} { putsBlurb ::tcltest::cleanupTests } return } catch {puts "==== Test with ThreadLevel $ThreadLevel ===="} http::config -threadlevel $ThreadLevel testConstraint needsTls [expr { [testConstraint needsTclTls] || [testConstraint needsTwapi] || [testConstraint needsTwapiFull] }] if {[testConstraint needsTclTls]} { package require tls http::register https 443 [list ::tls::socket -ssl2 0 -ssl3 0 \ -tls1 0 -tls1.1 0 -tls1.2 1 -tls1.3 0 -autoservername 1] ::tls::socketCmd 1 1 testConstraint knownTwapiFullBugThreadlevelAny 1 testConstraint knownTwapiFullBugThreadUsed 1 } elseif {[testConstraint needsTwapi]} { # "Original" http::register with 3 arguments has the same capabilities as # in http 2.9 and earlier. This means that: # (1) it cannot open a socket in a background thread (this option stops a # slow DNS lookup from blocking a [socket -async] command); and # (2) it cannot use a https proxy. # testConstraint needsSquidNoAuth 0 testConstraint needsSquidAuth 0 package require twapi http::register https 443 ::twapi::tls_socket testConstraint knownTwapiFullBugThreadlevelAny 1 testConstraint knownTwapiFullBugThreadUsed 1 } elseif {[testConstraint needsTwapiFull]} { # (Any revisions to TWAPI, and the contents/existence of the twapiTlsPlus # wrapper, can be negotiated if the bugs listed below can be fixed.) # Use a temporary wrapper package twapiTlsPlus to present a suitable API. # # N.B. MUST EDIT twapi*/tls.tcl so that #- set so [$socketcmd {*}$socket_args {*}$args] #+ set so [{*}$socketcmd {*}$socket_args {*}$args] # # Bug with https, threadLevel 1,2, no proxy: try test 'httpProxy-2.2.*' # Bug with https, threadLevel 0, with proxy: try test 'httpProxy-3.4.0' # In both cases (using TWAPI 4.7.2 25d8bc), the result is: # ---- Test generated error; Return code was: 1 # ---- Return code should have been one of: 0 2 # ---- errorInfo: cannot yield: C stack busy # while executing # "http::geturl https://www.google.com/" # source [file join [file dirname [info script]] twapiTlsPlus.tcl] package require twapiTlsPlus http::register https 443 ::twapiTlsPlus::socket ::twapiTlsPlus::socketCmd 1 1 testConstraint knownTwapiFullBugThreadlevelAny [testConstraint knownBug] if {($ThreadLevel == 1)} { if {[catch {package require Thread}]} { set usingThread 0 } else { set usingThread 2 } } else { set usingThread $ThreadLevel } if {$usingThread} { testConstraint knownTwapiFullBugThreadUsed [testConstraint knownBug] } else { testConstraint knownTwapiFullBugThreadUsed 1 } } else { } # Testing with Squid # - Example Squid configuration for Enterprise Linux 8 (Red Hat, Oracle, Rocky, # Alma, ...) is in file tests/httpProxySquidConfigForEL8.tar.gz. # - Example Squid configuration for Diladele Squid on Windows is in # file tests/httpProxySquidConfigForWindowsDiladele.zip. # # - Two instances of Squid are launched, one that needs authentication and one # that does not. # - Each instance of Squid listens on IPv4 and IPv6, on different ports. # - If only one instance of Squid can be launched at a time, use the separate # constraints needsSquidNoAuth, needsSquidAuth when testing. # Instance of Squid that does not need authentication. set n4host 127.0.0.1 set n6host ::1 set n4port 3128 set n6port 3130 # Instance of Squid that needs authentication. set a4host 127.0.0.1 set a6host ::1 set a4port 3129 set a6port 3131 # concat Basic [base64::encode alice:alicia] set aliceCreds {Basic YWxpY2U6YWxpY2lh} # concat Basic [base64::encode intruder:intruder] set badCreds {Basic aW50cnVkZXI6aW50cnVkZXI=} # For the benefit of the target server, have a short delay between tests. set fetchPause 200 foreach constr { ThreadLevelSummary needsSquidNoAuth needsSquidAuth needsTclTls needsTwapi needsTwapiFull needsTls knownTwapiFullBugThreadlevelAny knownTwapiFullBugThreadUsed } { # For debugging. # puts [list testConstraint $constr [testConstraint $constr]] } #putsBlurb test httpProxy-1.1.$ThreadLevel {squid is running - ipv4 no-auth} -constraints {needsSquidNoAuth} -setup { } -body { after $fetchPause set token [http::geturl http://$n4host:$n4port/] set ri [http::responseInfo $token] set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ [dict get $ri proxyUsed]" } -result {complete ok 400 -- none} -cleanup { catch {http::cleanup $token} unset -nocomplain token ri res } test httpProxy-1.2.$ThreadLevel {squid is running - ipv6 no-auth} -constraints {needsSquidNoAuth} -setup { } -body { after $fetchPause set token [http::geturl http://\[$n6host\]:$n6port/] set ri [http::responseInfo $token] set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ [dict get $ri proxyUsed]" } -result {complete ok 400 -- none} -cleanup { catch {http::cleanup $token} unset -nocomplain token ri res } test httpProxy-1.3.$ThreadLevel {squid is running - ipv4 with-auth} -constraints {needsSquidAuth} -setup { } -body { after $fetchPause set token [http::geturl http://$a4host:$a4port/] set ri [http::responseInfo $token] set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ [dict get $ri proxyUsed]" } -result {complete ok 400 -- none} -cleanup { catch {http::cleanup $token} unset -nocomplain token ri res } test httpProxy-1.4.$ThreadLevel {squid is running - ipv6 with-auth} -constraints {needsSquidAuth} -setup { } -body { after $fetchPause set token [http::geturl http://\[$a6host\]:$a6port/] set ri [http::responseInfo $token] set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ [dict get $ri proxyUsed]" } -result {complete ok 400 -- none} -cleanup { catch {http::cleanup $token} unset -nocomplain token ri res } test httpProxy-2.1.$ThreadLevel {http no-proxy no-auth} -constraints {} -setup { http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} } -body { after $fetchPause set token [http::geturl http://www.google.com/] set ri [http::responseInfo $token] set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ [dict get $ri proxyUsed] --\ [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]" } -result {complete ok 200 -- none -- -1} -cleanup { catch {http::cleanup $token} unset -nocomplain token ri res } test httpProxy-2.2.$ThreadLevel {https no-proxy no-auth} -constraints {needsTls knownTwapiFullBugThreadUsed} -setup { http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} } -body { after $fetchPause set token [http::geturl https://www.google.com/] set ri [http::responseInfo $token] set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ [dict get $ri proxyUsed] --\ [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]" } -result {complete ok 200 -- none -- -1} -cleanup { catch {http::cleanup $token} unset -nocomplain token ri res } test httpProxy-2.3.$ThreadLevel {http with-proxy ipv4 no-auth} -constraints {needsSquidNoAuth} -setup { http::config -proxyhost $n4host -proxyport $n4port -proxynot {127.0.0.1 localhost} -proxyauth {} } -body { after $fetchPause set token [http::geturl http://www.google.com/] set ri [http::responseInfo $token] set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ [dict get $ri proxyUsed] --\ [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]" } -result {complete ok 200 -- HttpProxy -- -1} -cleanup { catch {http::cleanup $token} unset -nocomplain token ri res http::config -proxyhost {} -proxyport {} -proxynot {} } test httpProxy-2.4.$ThreadLevel {https with-proxy ipv4 no-auth} -constraints {needsSquidNoAuth needsTls knownTwapiFullBugThreadlevelAny} -setup { http::config -proxyhost $n4host -proxyport $n4port -proxynot {127.0.0.1 localhost} -proxyauth {} } -body { after $fetchPause set token [http::geturl https://www.google.com/] set ri [http::responseInfo $token] set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ [dict get $ri proxyUsed] --\ [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]" } -result {complete ok 200 -- SecureProxy -- -1} -cleanup { catch {http::cleanup $token} unset -nocomplain token ri res http::config -proxyhost {} -proxyport {} -proxynot {} } test httpProxy-2.5.$ThreadLevel {http with-proxy ipv6 no-auth} -constraints {needsSquidNoAuth} -setup { http::config -proxyhost $n6host -proxyport $n6port -proxynot {::1 localhost} -proxyauth {} } -body { after $fetchPause set token [http::geturl http://www.google.com/] set ri [http::responseInfo $token] set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ [dict get $ri proxyUsed] --\ [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]" } -result {complete ok 200 -- HttpProxy -- -1} -cleanup { catch {http::cleanup $token} unset -nocomplain token ri res http::config -proxyhost {} -proxyport {} -proxynot {} } test httpProxy-2.6.$ThreadLevel {https with-proxy ipv6 no-auth} -constraints {needsSquidNoAuth needsTls knownTwapiFullBugThreadlevelAny} -setup { http::config -proxyhost $n6host -proxyport $n6port -proxynot {::1 localhost} -proxyauth {} } -body { after $fetchPause set token [http::geturl https://www.google.com/] set ri [http::responseInfo $token] set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ [dict get $ri proxyUsed] --\ [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]" } -result {complete ok 200 -- SecureProxy -- -1} -cleanup { catch {http::cleanup $token} unset -nocomplain token ri res http::config -proxyhost {} -proxyport {} -proxynot {} } test httpProxy-3.1.$ThreadLevel {http no-proxy with-auth valid-creds-provided} -constraints {} -setup { http::config -proxyhost {} -proxyport $a4port -proxynot {127.0.0.1 localhost} -proxyauth $aliceCreds } -body { after $fetchPause set token [http::geturl http://www.google.com/] set ri [http::responseInfo $token] set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]" } -result {complete ok 200 -- none 0 0 -- -1} -cleanup { catch {http::cleanup $token} unset -nocomplain token ri res pos1 pos2 http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} } test httpProxy-3.2.$ThreadLevel {https no-proxy with-auth valid-creds-provided} -constraints {needsTls knownTwapiFullBugThreadUsed} -setup { http::config -proxyhost {} -proxyport $a4port -proxynot {127.0.0.1 localhost} -proxyauth $aliceCreds } -body { after $fetchPause set token [http::geturl https://www.google.com/] set ri [http::responseInfo $token] set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]" } -result {complete ok 200 -- none 0 0 -- -1} -cleanup { catch {http::cleanup $token} unset -nocomplain token ri res pos1 pos2 http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} } test httpProxy-3.3.$ThreadLevel {http with-proxy ipv4 with-auth valid-creds-provided} -constraints {needsSquidAuth} -setup { http::config -proxyhost $a4host -proxyport $a4port -proxynot {127.0.0.1 localhost} -proxyauth $aliceCreds } -body { after $fetchPause set token [http::geturl http://www.google.com/] set ri [http::responseInfo $token] set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]" } -result {complete ok 200 -- HttpProxy 1 1 -- -1} -cleanup { catch {http::cleanup $token} unset -nocomplain token ri res pos1 pos2 http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} } test httpProxy-3.4.$ThreadLevel {https with-proxy ipv4 with-auth valid-creds-provided} -constraints {needsSquidAuth needsTls knownTwapiFullBugThreadlevelAny} -setup { http::config -proxyhost $a4host -proxyport $a4port -proxynot {127.0.0.1 localhost} -proxyauth $aliceCreds } -body { after $fetchPause set token [http::geturl https://www.google.com/] set ri [http::responseInfo $token] set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]" } -result {complete ok 200 -- SecureProxy 0 0 -- -1} -cleanup { catch {http::cleanup $token} unset -nocomplain token ri res pos1 pos2 http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} } test httpProxy-3.5.$ThreadLevel {http with-proxy ipv6 with-auth valid-creds-provided} -constraints {needsSquidAuth} -setup { http::config -proxyhost $a6host -proxyport $a6port -proxynot {::1 localhost} -proxyauth $aliceCreds } -body { after $fetchPause set token [http::geturl http://www.google.com/] set ri [http::responseInfo $token] set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]" } -result {complete ok 200 -- HttpProxy 1 1 -- -1} -cleanup { catch {http::cleanup $token} unset -nocomplain token ri res pos1 pos2 http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} } test httpProxy-3.6.$ThreadLevel {https with-proxy ipv6 with-auth valid-creds-provided} -constraints {needsSquidAuth needsTls knownTwapiFullBugThreadlevelAny} -setup { http::config -proxyhost $a6host -proxyport $a6port -proxynot {::1 localhost} -proxyauth $aliceCreds } -body { after $fetchPause set token [http::geturl https://www.google.com/] set ri [http::responseInfo $token] set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]" } -result {complete ok 200 -- SecureProxy 0 0 -- -1} -cleanup { catch {http::cleanup $token} unset -nocomplain token ri res pos1 pos2 http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} } test httpProxy-3.7.$ThreadLevel {http with-proxy ipv4 with-auth valid-creds-provided; check that 2nd valid request with creds is possible, and keep-alive works} -constraints {needsSquidAuth} -setup { array unset ::http::socketMapping http::config -proxyhost $a4host -proxyport $a4port -proxynot {127.0.0.1 localhost} -proxyauth $aliceCreds after $fetchPause set token0 [http::geturl http://www.google.com/ -keepalive 1 -timeout 5000] } -body { after $fetchPause # Use the same caution as for the corresponding https test. set can [after 6000 {http::reset $token; set ${token}(z) timeout}] set token [http::geturl http://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe] vwait ${token}(z) after cancel $can set ri [http::responseInfo $token] set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] set same [string equal [set ${token0}(sock)] [set ${token}(sock)]] set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*] [set ${token}(z)] $same" } -result {complete ok 200 -- HttpProxy 1 1 -- -1 done 1} -cleanup { catch {http::cleanup $token0} catch {http::cleanup $token} unset -nocomplain token0 token ri res pos1 pos2 can same array unset ::http::socketMapping http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} } test httpProxy-3.7x.$ThreadLevel {http with-proxy ipv4 with-auth 1st request no-creds-provided; check that 2nd request with creds is possible} -constraints {needsSquidAuth} -setup { array unset ::http::socketMapping http::config -proxyhost $a4host -proxyport $a4port -proxynot {127.0.0.1 localhost} -proxyauth {} after $fetchPause set token0 [http::geturl http://www.google.com/ -keepalive 1 -timeout 5000] http::config -proxyauth $aliceCreds } -body { after $fetchPause # Use the same caution as for the corresponding https test. set can [after 6000 {http::reset $token; set ${token}(z) timeout}] set token [http::geturl http://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe] vwait ${token}(z) after cancel $can set ri [http::responseInfo $token] set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] set same [string equal [set ${token0}(sock)] [set ${token}(sock)]] set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*] [set ${token}(z)] $same" } -result {complete ok 200 -- HttpProxy 1 1 -- -1 done 1} -cleanup { catch {http::cleanup $token0} catch {http::cleanup $token} unset -nocomplain token0 token ri res pos1 pos2 can same array unset ::http::socketMapping http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} } test httpProxy-3.8.$ThreadLevel {https with-proxy ipv4 with-auth valid-creds-provided; check that 2nd valid request with creds is possible, and keep-alive works} -constraints {needsSquidAuth needsTls knownTwapiFullBugThreadlevelAny} -setup { array unset ::http::socketMapping http::config -proxyhost $a4host -proxyport $a4port -proxynot {127.0.0.1 localhost} -proxyauth $aliceCreds after $fetchPause set token0 [http::geturl https://www.google.com/ -keepalive 1 -timeout 5000] } -body { after $fetchPause # If a bug passes the socket of a failed CONNECT to the main request, an infinite # wait can occur despite -timeout. Fix this with http::reset; to do this the call # to http::geturl must be async so we have $token for use as argument of reset. set can [after 6000 {http::reset $token; set ${token}(z) timeout}] set token [http::geturl https://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe] vwait ${token}(z) after cancel $can set ri [http::responseInfo $token] set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] set same [string equal [set ${token0}(sock)] [set ${token}(sock)]] set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*] [set ${token}(z)] $same" } -result {complete ok 200 -- SecureProxy 0 0 -- -1 done 1} -cleanup { catch {http::cleanup $token0} catch {http::cleanup $token} unset -nocomplain token0 token ri res pos1 pos2 can same array unset ::http::socketMapping http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} } test httpProxy-3.8x.$ThreadLevel {https with-proxy ipv4 with-auth 1st request no-creds-provided; check that 2nd request with creds is possible} -constraints {needsSquidAuth needsTls knownTwapiFullBugThreadlevelAny} -setup { array unset ::http::socketMapping http::config -proxyhost $a4host -proxyport $a4port -proxynot {127.0.0.1 localhost} -proxyauth {} after $fetchPause set token0 [http::geturl https://www.google.com/ -keepalive 1 -timeout 5000] http::config -proxyauth $aliceCreds } -body { after $fetchPause # If a bug passes the socket of a failed CONNECT to the main request, an infinite # wait can occur despite -timeout. Fix this with http::reset; to do this the call # to http::geturl must be async so we have $token for use as argument of reset. set can [after 6000 {http::reset $token; set ${token}(z) timeout}] set token [http::geturl https://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe] vwait ${token}(z) after cancel $can set ri [http::responseInfo $token] set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] set same [string equal [set ${token0}(sock)] [set ${token}(sock)]] set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*] [set ${token}(z)] $same" } -result {complete ok 200 -- SecureProxy 0 0 -- -1 done 0} -cleanup { catch {http::cleanup $token0} catch {http::cleanup $token} unset -nocomplain token0 token ri res pos1 pos2 can same array unset ::http::socketMapping http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} } test httpProxy-3.9.$ThreadLevel {http with-proxy ipv6 with-auth valid-creds-provided; check that 2nd valid request with creds is possible, and keep-alive works} -constraints {needsSquidAuth} -setup { array unset ::http::socketMapping http::config -proxyhost $a6host -proxyport $a6port -proxynot {::1 localhost} -proxyauth $aliceCreds after $fetchPause set token0 [http::geturl http://www.google.com/ -keepalive 1 -timeout 5000] } -body { after $fetchPause # Use the same caution as for the corresponding https test. set can [after 6000 {http::reset $token; set ${token}(z) timeout}] set token [http::geturl http://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe] vwait ${token}(z) after cancel $can set ri [http::responseInfo $token] set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] set same [string equal [set ${token0}(sock)] [set ${token}(sock)]] set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*] [set ${token}(z)] $same" } -result {complete ok 200 -- HttpProxy 1 1 -- -1 done 1} -cleanup { catch {http::cleanup $token0} catch {http::cleanup $token} unset -nocomplain token0 token ri res pos1 pos2 can same array unset ::http::socketMapping http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} } test httpProxy-3.9p.$ThreadLevel {http with-proxy ipv6 with-auth valid-creds-provided; check that 2nd valid request with creds is possible, and keep-alive works, pipelining requested and possible} -constraints {needsSquidAuth} -setup { array unset ::http::socketMapping http::config -proxyhost $a6host -proxyport $a6port -proxynot {::1 localhost} -proxyauth $aliceCreds } -body { after $fetchPause set can0 [after 6000 {http::reset $token0; set ${token0}(z) timeout}] set token0 [http::geturl http://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe] after idle { after $fetchPause # Use the same caution as for the corresponding https test. set can [after 6000 {http::reset $token; set ${token}(z) timeout}] set token [http::geturl http://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe] vwait ${token}(z) after cancel $can } vwait ${token0}(z) after cancel $can0 set ri [http::responseInfo $token] set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] set same [string equal [set ${token0}(sock)] [set ${token}(sock)]] set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*] [set ${token}(z)] $same" } -result {complete ok 200 -- HttpProxy 1 1 -- -1 done 1} -cleanup { catch {http::cleanup $token0} catch {http::cleanup $token} unset -nocomplain token0 token ri res pos1 pos2 can0 can same array unset ::http::socketMapping http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} } test httpProxy-3.9x.$ThreadLevel {http with-proxy ipv6 with-auth 1st request no-creds-provided; check that 2nd request with creds is possible} -constraints {needsSquidAuth} -setup { array unset ::http::socketMapping http::config -proxyhost $a6host -proxyport $a6port -proxynot {::1 localhost} -proxyauth {} after $fetchPause set token0 [http::geturl http://www.google.com/ -keepalive 1 -timeout 5000] http::config -proxyauth $aliceCreds } -body { after $fetchPause # Use the same caution as for the corresponding https test. set can [after 6000 {http::reset $token; set ${token}(z) timeout}] set token [http::geturl http://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe] vwait ${token}(z) after cancel $can set ri [http::responseInfo $token] set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] set same [string equal [set ${token0}(sock)] [set ${token}(sock)]] set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*] [set ${token}(z)] $same" } -result {complete ok 200 -- HttpProxy 1 1 -- -1 done 1} -cleanup { catch {http::cleanup $token0} catch {http::cleanup $token} unset -nocomplain token0 token ri res pos1 pos2 can same array unset ::http::socketMapping http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} } test httpProxy-3.10.$ThreadLevel {https with-proxy ipv6 with-auth valid-creds-provided; check that 2nd valid request with creds is possible, and keep-alive works} -constraints {needsSquidAuth needsTls knownTwapiFullBugThreadlevelAny} -setup { array unset ::http::socketMapping http::config -proxyhost $a6host -proxyport $a6port -proxynot {::1 localhost} -proxyauth $aliceCreds after $fetchPause set token0 [http::geturl https://www.google.com/ -keepalive 1 -timeout 5000] } -body { after $fetchPause # If a bug passes the socket of a failed CONNECT to the main request, an infinite # wait can occur despite -timeout. Fix this with http::reset; to do this the call # to http::geturl must be async so we have $token for use as argument of reset. set can [after 6000 {http::reset $token; set ${token}(z) timeout}] set token [http::geturl https://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe] vwait ${token}(z) after cancel $can set ri [http::responseInfo $token] set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] set same [string equal [set ${token0}(sock)] [set ${token}(sock)]] set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*] [set ${token}(z)] $same" } -result {complete ok 200 -- SecureProxy 0 0 -- -1 done 1} -cleanup { catch {http::cleanup $token0} catch {http::cleanup $token} unset -nocomplain token0 token ri res pos1 pos2 can same array unset ::http::socketMapping http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} } test httpProxy-3.10p.$ThreadLevel {https with-proxy ipv6 with-auth valid-creds-provided; check that 2nd valid request with creds is possible, and keep-alive works, pipelining requested and possible} -constraints {needsSquidAuth needsTls knownTwapiFullBugThreadlevelAny} -setup { array unset ::http::socketMapping http::config -proxyhost $a6host -proxyport $a6port -proxynot {::1 localhost} -proxyauth $aliceCreds } -body { after $fetchPause set can0 [after 6000 {http::reset $token0; set ${token0}(z) timeout}] set token0 [http::geturl https://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe] after idle { after $fetchPause # If a bug passes the socket of a failed CONNECT to the main request, an infinite # wait can occur despite -timeout. Fix this with http::reset; to do this the call # to http::geturl must be async so we have $token for use as argument of reset. set can [after 6000 {http::reset $token0; set ${token}(z) timeout}] set token [http::geturl https://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe] vwait ${token}(z) after cancel $can } vwait ${token0}(z) after cancel $can0 set ri [http::responseInfo $token] set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] set same [string equal [set ${token0}(sock)] [set ${token}(sock)]] set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*] [set ${token}(z)] $same" } -result {complete ok 200 -- SecureProxy 0 0 -- -1 done 1} -cleanup { catch {http::cleanup $token0} catch {http::cleanup $token} unset -nocomplain token0 token ri res pos1 pos2 can0 can same array unset ::http::socketMapping http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} } test httpProxy-3.10x.$ThreadLevel {https with-proxy ipv6 with-auth 1st request no-creds-provided; check that 2nd request with creds is possible} -constraints {needsSquidAuth needsTls knownTwapiFullBugThreadlevelAny} -setup { array unset ::http::socketMapping http::config -proxyhost $a6host -proxyport $a6port -proxynot {::1 localhost} -proxyauth {} after $fetchPause set token0 [http::geturl https://www.google.com/ -keepalive 1 -timeout 5000] http::config -proxyauth $aliceCreds } -body { after $fetchPause # If a bug passes the socket of a failed CONNECT to the main request, an infinite # wait can occur despite -timeout. Fix this with http::reset; to do this the call # to http::geturl must be async so we have $token for use as argument of reset. set can [after 6000 {http::reset $token; set ${token}(z) timeout}] set token [http::geturl https://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe] vwait ${token}(z) after cancel $can set ri [http::responseInfo $token] set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] set same [string equal [set ${token0}(sock)] [set ${token}(sock)]] set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*] [set ${token}(z)] $same" } -result {complete ok 200 -- SecureProxy 0 0 -- -1 done 0} -cleanup { catch {http::cleanup $token0} catch {http::cleanup $token} unset -nocomplain token0 token ri res pos1 pos2 can same array unset ::http::socketMapping http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} } test httpProxy-4.1.$ThreadLevel {http no-proxy with-auth no-creds-provided} -constraints {} -setup { http::config -proxyhost {} -proxyport $a4port -proxynot {127.0.0.1 localhost} -proxyauth {} } -body { after $fetchPause set token [http::geturl http://www.google.com/] set ri [http::responseInfo $token] set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]" } -result {complete ok 200 -- none 0 0 -- -1} -cleanup { catch {http::cleanup $token} unset -nocomplain token ri res pos1 pos2 http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} } test httpProxy-4.2.$ThreadLevel {https no-proxy with-auth no-creds-provided} -constraints {needsTls knownTwapiFullBugThreadUsed} -setup { http::config -proxyhost {} -proxyport $a4port -proxynot {127.0.0.1 localhost} -proxyauth {} } -body { after $fetchPause set token [http::geturl https://www.google.com/] set ri [http::responseInfo $token] set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]" } -result {complete ok 200 -- none 0 0 -- -1} -cleanup { catch {http::cleanup $token} unset -nocomplain token ri res pos1 pos2 http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} } test httpProxy-4.3.$ThreadLevel {http with-proxy ipv4 with-auth no-creds-provided} -constraints {needsSquidAuth} -setup { http::config -proxyhost $a4host -proxyport $a4port -proxynot {127.0.0.1 localhost} -proxyauth {} } -body { after $fetchPause set token [http::geturl http://www.google.com/] set ri [http::responseInfo $token] set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]" } -result {complete ok 407 -- HttpProxy 0 0 -- -1} -cleanup { catch {http::cleanup $token} unset -nocomplain token ri res pos1 pos2 http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} } test httpProxy-4.4.$ThreadLevel {https with-proxy ipv4 with-auth no-creds-provided} -constraints {needsSquidAuth needsTls knownTwapiFullBugThreadlevelAny} -setup { http::config -proxyhost $a4host -proxyport $a4port -proxynot {127.0.0.1 localhost} -proxyauth {} } -body { after $fetchPause set token [http::geturl https://www.google.com/] set ri [http::responseInfo $token] set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]" } -result {complete ok 407 -- SecureProxyFailed 0 0 -- -1} -cleanup { catch {http::cleanup $token} unset -nocomplain token ri res pos1 pos2 http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} } test httpProxy-4.5.$ThreadLevel {http with-proxy ipv6 with-auth no-creds-provided} -constraints {needsSquidAuth} -setup { http::config -proxyhost $a6host -proxyport $a6port -proxynot {::1 localhost} -proxyauth {} } -body { after $fetchPause set token [http::geturl http://www.google.com/] set ri [http::responseInfo $token] set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]" } -result {complete ok 407 -- HttpProxy 0 0 -- -1} -cleanup { catch {http::cleanup $token} unset -nocomplain token ri res pos1 pos2 http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} } test httpProxy-4.6.$ThreadLevel {https with-proxy ipv6 with-auth no-creds-provided} -constraints {needsSquidAuth needsTls knownTwapiFullBugThreadlevelAny} -setup { http::config -proxyhost $a6host -proxyport $a6port -proxynot {::1 localhost} -proxyauth {} } -body { after $fetchPause set token [http::geturl https://www.google.com/] set ri [http::responseInfo $token] set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]" } -result {complete ok 407 -- SecureProxyFailed 0 0 -- -1} -cleanup { catch {http::cleanup $token} unset -nocomplain token ri res pos1 pos2 http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} } test httpProxy-4.7.$ThreadLevel {http with-proxy ipv4 with-auth no-creds-provided; check that 2nd request is possible} -constraints {needsSquidAuth} -setup { array unset ::http::socketMapping http::config -proxyhost $a4host -proxyport $a4port -proxynot {127.0.0.1 localhost} -proxyauth {} after $fetchPause set token0 [http::geturl http://www.google.com/ -keepalive 1 -timeout 5000] } -body { after $fetchPause # Use the same caution as for the corresponding https test. set can [after 6000 {http::reset $token; set ${token}(z) timeout}] set token [http::geturl http://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe] vwait ${token}(z) after cancel $can set ri [http::responseInfo $token] set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] set same [string equal [set ${token0}(sock)] [set ${token}(sock)]] set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*] [set ${token}(z)] $same" } -result {complete ok 407 -- HttpProxy 0 0 -- -1 done 1} -cleanup { catch {http::cleanup $token0} catch {http::cleanup $token} unset -nocomplain token0 token ri res pos1 pos2 can same array unset ::http::socketMapping http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} } test httpProxy-4.8.$ThreadLevel {https with-proxy ipv4 with-auth no-creds-provided; check that 2nd request is possible} -constraints {needsSquidAuth needsTls knownTwapiFullBugThreadlevelAny} -setup { array unset ::http::socketMapping http::config -proxyhost $a4host -proxyport $a4port -proxynot {127.0.0.1 localhost} -proxyauth {} after $fetchPause set token0 [http::geturl https://www.google.com/ -keepalive 1 -timeout 5000] } -body { after $fetchPause # If a bug passes the socket of a failed CONNECT to the main request, an infinite # wait can occur despite -timeout. Fix this with http::reset; to do this the call # to http::geturl must be async so we have $token for use as argument of reset. set can [after 6000 {http::reset $token; set ${token}(z) timeout}] set token [http::geturl https://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe] vwait ${token}(z) after cancel $can set ri [http::responseInfo $token] set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] set same [string equal [set ${token0}(sock)] [set ${token}(sock)]] set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*] [set ${token}(z)] $same" } -result {complete ok 407 -- SecureProxyFailed 0 0 -- -1 done 0} -cleanup { catch {http::cleanup $token0} catch {http::cleanup $token} unset -nocomplain token0 token ri res pos1 pos2 can same array unset ::http::socketMapping http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} } test httpProxy-4.9.$ThreadLevel {http with-proxy ipv6 with-auth no-creds-provided; check that 2nd request is possible} -constraints {needsSquidAuth} -setup { array unset ::http::socketMapping http::config -proxyhost $a6host -proxyport $a6port -proxynot {::1 localhost} -proxyauth {} after $fetchPause set token0 [http::geturl http://www.google.com/ -keepalive 1 -timeout 5000] } -body { after $fetchPause # Use the same caution as for the corresponding https test. set can [after 6000 {http::reset $token; set ${token}(z) timeout}] set token [http::geturl http://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe] vwait ${token}(z) after cancel $can set ri [http::responseInfo $token] set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] set same [string equal [set ${token0}(sock)] [set ${token}(sock)]] set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*] [set ${token}(z)] $same" } -result {complete ok 407 -- HttpProxy 0 0 -- -1 done 1} -cleanup { catch {http::cleanup $token0} catch {http::cleanup $token} unset -nocomplain token0 token ri res pos1 pos2 can same array unset ::http::socketMapping http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} } test httpProxy-4.9p.$ThreadLevel {http with-proxy ipv6 with-auth no-creds-provided; check that 2nd request is possible, pipelining requested and possible} -constraints {needsSquidAuth} -setup { array unset ::http::socketMapping http::config -proxyhost $a6host -proxyport $a6port -proxynot {::1 localhost} -proxyauth {} } -body { after $fetchPause set can0 [after 6000 {http::reset $token0; set ${token0}(z) timeout}] set token0 [http::geturl http://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe] after idle { after $fetchPause # Use the same caution as for the corresponding https test. set can [after 6000 {http::reset $token0; set ${token}(z) timeout}] set token [http::geturl http://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe] vwait ${token}(z) after cancel $can } vwait ${token0}(z) after cancel $can0 set ri [http::responseInfo $token] set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] set same [string equal [set ${token0}(sock)] [set ${token}(sock)]] set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*] [set ${token}(z)] $same" } -result {complete ok 407 -- HttpProxy 0 0 -- -1 done 1} -cleanup { catch {http::cleanup $token0} catch {http::cleanup $token} unset -nocomplain token0 token ri res pos1 pos2 can0 can same array unset ::http::socketMapping http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} } test httpProxy-4.10.$ThreadLevel {https with-proxy ipv6 with-auth no-creds-provided; check that 2nd request is possible} -constraints {needsSquidAuth needsTls knownTwapiFullBugThreadlevelAny} -setup { array unset ::http::socketMapping http::config -proxyhost $a6host -proxyport $a6port -proxynot {::1 localhost} -proxyauth {} after $fetchPause set token0 [http::geturl https://www.google.com/ -keepalive 1 -timeout 5000] } -body { after $fetchPause # If a bug passes the socket of a failed CONNECT to the main request, an infinite # wait can occur despite -timeout. Fix this with http::reset; to do this the call # to http::geturl must be async so we have $token for use as argument of reset. set can [after 6000 {http::reset $token; set ${token}(z) timeout}] set token [http::geturl https://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe] vwait ${token}(z) after cancel $can set ri [http::responseInfo $token] set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] set same [string equal [set ${token0}(sock)] [set ${token}(sock)]] set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*] [set ${token}(z)] $same" } -result {complete ok 407 -- SecureProxyFailed 0 0 -- -1 done 0} -cleanup { catch {http::cleanup $token0} catch {http::cleanup $token} unset -nocomplain token0 token ri res pos1 pos2 can same array unset ::http::socketMapping http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} } test httpProxy-4.10p.$ThreadLevel {https with-proxy ipv6 with-auth no-creds-provided; check that 2nd request is possible, pipelining requested but not possible} -constraints {needsSquidAuth needsTls knownTwapiFullBugThreadlevelAny} -setup { array unset ::http::socketMapping http::config -proxyhost $a6host -proxyport $a6port -proxynot {::1 localhost} -proxyauth {} } -body { after $fetchPause set can0 [after 6000 {http::reset $token0; set ${token0}(z) timeout}] set token0 [http::geturl https://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe] after idle { after $fetchPause # If a bug passes the socket of a failed CONNECT to the main request, an infinite # wait can occur despite -timeout. Fix this with http::reset; to do this the call # to http::geturl must be async so we have $token for use as argument of reset. set can [after 6000 {http::reset $token; set ${token}(z) timeout}] set token [http::geturl https://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe] vwait ${token}(z) after cancel $can } vwait ${token0}(z) after cancel $can0 set ri [http::responseInfo $token] set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] set same [string equal [set ${token0}(sock)] [set ${token}(sock)]] set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*] [set ${token}(z)] $same" } -result {complete ok 407 -- SecureProxyFailed 0 0 -- -1 done 0} -cleanup { catch {http::cleanup $token0} catch {http::cleanup $token} unset -nocomplain token0 token ri res pos1 pos2 can0 can same array unset ::http::socketMapping http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} } test httpProxy-5.1.$ThreadLevel {http no-proxy with-auth bad-creds-provided} -constraints {} -setup { http::config -proxyhost {} -proxyport $a4port -proxynot {127.0.0.1 localhost} -proxyauth $badCreds } -body { after $fetchPause set token [http::geturl http://www.google.com/] set ri [http::responseInfo $token] set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] set pos2 [lsearch -exact [set ${token}(requestHeaders)] $badCreds] set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]" } -result {complete ok 200 -- none 0 0 -- -1} -cleanup { catch {http::cleanup $token} unset -nocomplain token ri res pos1 pos2 http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} } test httpProxy-5.2.$ThreadLevel {https no-proxy with-auth bad-creds-provided} -constraints {needsTls knownTwapiFullBugThreadUsed} -setup { http::config -proxyhost {} -proxyport $a4port -proxynot {127.0.0.1 localhost} -proxyauth $badCreds } -body { after $fetchPause set token [http::geturl https://www.google.com/] set ri [http::responseInfo $token] set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] set pos2 [lsearch -exact [set ${token}(requestHeaders)] $badCreds] set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]" } -result {complete ok 200 -- none 0 0 -- -1} -cleanup { catch {http::cleanup $token} unset -nocomplain token ri res pos1 pos2 http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} } test httpProxy-5.3.$ThreadLevel {http with-proxy ipv4 with-auth bad-creds-provided} -constraints {needsSquidAuth} -setup { http::config -proxyhost $a4host -proxyport $a4port -proxynot {127.0.0.1 localhost} -proxyauth $badCreds } -body { after $fetchPause set token [http::geturl http://www.google.com/] set ri [http::responseInfo $token] set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] set pos2 [lsearch -exact [set ${token}(requestHeaders)] $badCreds] set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]" } -result {complete ok 407 -- HttpProxy 1 1 -- -1} -cleanup { catch {http::cleanup $token} unset -nocomplain token ri res pos1 pos2 http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} } test httpProxy-5.4.$ThreadLevel {https with-proxy ipv4 with-auth bad-creds-provided} -constraints {needsSquidAuth needsTls knownTwapiFullBugThreadlevelAny} -setup { http::config -proxyhost $a4host -proxyport $a4port -proxynot {127.0.0.1 localhost} -proxyauth $badCreds } -body { after $fetchPause set token [http::geturl https://www.google.com/] set ri [http::responseInfo $token] set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] set pos2 [lsearch -exact [set ${token}(requestHeaders)] $badCreds] set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]" } -result {complete ok 407 -- SecureProxyFailed 1 1 -- -1} -cleanup { catch {http::cleanup $token} unset -nocomplain token ri res pos1 pos2 http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} } test httpProxy-5.5.$ThreadLevel {http with-proxy ipv6 with-auth bad-creds-provided} -constraints {needsSquidAuth} -setup { http::config -proxyhost $a6host -proxyport $a6port -proxynot {::1 localhost} -proxyauth $badCreds } -body { after $fetchPause set token [http::geturl http://www.google.com/] set ri [http::responseInfo $token] set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] set pos2 [lsearch -exact [set ${token}(requestHeaders)] $badCreds] set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]" } -result {complete ok 407 -- HttpProxy 1 1 -- -1} -cleanup { catch {http::cleanup $token} unset -nocomplain token ri res pos1 pos2 http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} } test httpProxy-5.6.$ThreadLevel {https with-proxy ipv6 with-auth bad-creds-provided} -constraints {needsSquidAuth needsTls knownTwapiFullBugThreadlevelAny} -setup { http::config -proxyhost $a6host -proxyport $a6port -proxynot {::1 localhost} -proxyauth $badCreds } -body { after $fetchPause set token [http::geturl https://www.google.com/] set ri [http::responseInfo $token] set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] set pos2 [lsearch -exact [set ${token}(requestHeaders)] $badCreds] set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]" } -result {complete ok 407 -- SecureProxyFailed 1 1 -- -1} -cleanup { catch {http::cleanup $token} unset -nocomplain token ri res pos1 pos2 http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} } test httpProxy-5.7.$ThreadLevel {http with-proxy ipv4 with-auth bad-creds-provided; check that 2nd request is possible} -constraints {needsSquidAuth} -setup { array unset ::http::socketMapping http::config -proxyhost $a4host -proxyport $a4port -proxynot {127.0.0.1 localhost} -proxyauth $badCreds after $fetchPause set token0 [http::geturl http://www.google.com/ -keepalive 1 -timeout 5000] } -body { after $fetchPause # Use the same caution as for the corresponding https test. set can [after 6000 {http::reset $token; set ${token}(z) timeout}] set token [http::geturl http://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe] vwait ${token}(z) after cancel $can set ri [http::responseInfo $token] set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] set pos2 [lsearch -exact [set ${token}(requestHeaders)] $badCreds] set same [string equal [set ${token0}(sock)] [set ${token}(sock)]] set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*] [set ${token}(z)] $same" } -result {complete ok 407 -- HttpProxy 1 1 -- -1 done 1} -cleanup { catch {http::cleanup $token0} catch {http::cleanup $token} unset -nocomplain token0 token ri res pos1 pos2 can same array unset ::http::socketMapping http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} } test httpProxy-5.7p.$ThreadLevel {http with-proxy ipv4 with-auth bad-creds-provided; check that 2nd request is possible, pipelining requested and possible} -constraints {needsSquidAuth} -setup { array unset ::http::socketMapping http::config -proxyhost $a4host -proxyport $a4port -proxynot {127.0.0.1 localhost} -proxyauth $badCreds } -body { after $fetchPause set can0 [after 6000 {http::reset $token0; set ${token0}(z) timeout}] set token0 [http::geturl http://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe] # Use the same caution as for the corresponding https test. after idle { after $fetchPause set can [after 6000 {http::reset $token; set ${token}(z) timeout}] set token [http::geturl http://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe] vwait ${token}(z) after cancel $can } vwait ${token0}(z) after cancel $can0 set ri [http::responseInfo $token] set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] set pos2 [lsearch -exact [set ${token}(requestHeaders)] $badCreds] set same [string equal [set ${token0}(sock)] [set ${token}(sock)]] set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*] [set ${token}(z)] $same" } -result {complete ok 407 -- HttpProxy 1 1 -- -1 done 1} -cleanup { catch {http::cleanup $token0} catch {http::cleanup $token} unset -nocomplain token0 token ri res pos1 pos2 can0 can same array unset ::http::socketMapping http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} } test httpProxy-5.8.$ThreadLevel {https with-proxy ipv4 with-auth bad-creds-provided; check that 2nd request is possible} -constraints {needsSquidAuth needsTls knownTwapiFullBugThreadlevelAny} -setup { array unset ::http::socketMapping http::config -proxyhost $a4host -proxyport $a4port -proxynot {127.0.0.1 localhost} -proxyauth $badCreds after $fetchPause set token0 [http::geturl https://www.google.com/ -keepalive 1 -timeout 5000] } -body { after $fetchPause # If a bug passes the socket of a failed CONNECT to the main request, an infinite # wait can occur despite -timeout. Fix this with http::reset; to do this the call # to http::geturl must be async so we have $token for use as argument of reset. set can [after 6000 {http::reset $token; set ${token}(z) timeout}] set token [http::geturl https://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe] vwait ${token}(z) after cancel $can set ri [http::responseInfo $token] set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] set pos2 [lsearch -exact [set ${token}(requestHeaders)] $badCreds] set same [string equal [set ${token0}(sock)] [set ${token}(sock)]] set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*] [set ${token}(z)] $same" } -result {complete ok 407 -- SecureProxyFailed 1 1 -- -1 done 0} -cleanup { catch {http::cleanup $token0} catch {http::cleanup $token} unset -nocomplain token0 token ri res pos1 pos2 can same array unset ::http::socketMapping http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} } test httpProxy-5.8p.$ThreadLevel {https with-proxy ipv4 with-auth bad-creds-provided; check that 2nd request is possible, pipelining requested but not possible} -constraints {needsSquidAuth needsTls knownTwapiFullBugThreadlevelAny} -setup { array unset ::http::socketMapping http::config -proxyhost $a4host -proxyport $a4port -proxynot {127.0.0.1 localhost} -proxyauth $badCreds } -body { after $fetchPause set can0 [after 6000 {http::reset $token0; set ${token0}(z) timeout}] set token0 [http::geturl https://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe] # If a bug passes the socket of a failed CONNECT to the main request, an infinite # wait can occur despite -timeout. Fix this with http::reset; to do this the call # to http::geturl must be async so we have $token for use as argument of reset. after idle { after $fetchPause set can [after 6000 {http::reset $token; set ${token}(z) timeout}] set token [http::geturl https://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe] vwait ${token}(z) after cancel $can } vwait ${token0}(z) after cancel $can0 set ri [http::responseInfo $token] set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] set pos2 [lsearch -exact [set ${token}(requestHeaders)] $badCreds] set same [string equal [set ${token0}(sock)] [set ${token}(sock)]] set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*] [set ${token}(z)] $same" } -result {complete ok 407 -- SecureProxyFailed 1 1 -- -1 done 0} -cleanup { catch {http::cleanup $token0} catch {http::cleanup $token} unset -nocomplain token0 token ri res pos1 pos2 can0 can same array unset ::http::socketMapping http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} } test httpProxy-5.9.$ThreadLevel {http with-proxy ipv6 with-auth bad-creds-provided; check that 2nd request is possible} -constraints {needsSquidAuth} -setup { array unset ::http::socketMapping http::config -proxyhost $a6host -proxyport $a6port -proxynot {::1 localhost} -proxyauth $badCreds after $fetchPause set token0 [http::geturl http://www.google.com/ -keepalive 1 -timeout 5000] } -body { after $fetchPause # Use the same caution as for the corresponding https test. set can [after 6000 {http::reset $token; set ${token}(z) timeout}] set token [http::geturl http://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe] vwait ${token}(z) after cancel $can set ri [http::responseInfo $token] set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] set pos2 [lsearch -exact [set ${token}(requestHeaders)] $badCreds] set same [string equal [set ${token0}(sock)] [set ${token}(sock)]] set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*] [set ${token}(z)] $same" } -result {complete ok 407 -- HttpProxy 1 1 -- -1 done 1} -cleanup { catch {http::cleanup $token0} catch {http::cleanup $token} unset -nocomplain token0 token ri res pos1 pos2 can same array unset ::http::socketMapping http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} } test httpProxy-5.10.$ThreadLevel {https with-proxy ipv6 with-auth bad-creds-provided; check that 2nd request is possible} -constraints {needsSquidAuth needsTls knownTwapiFullBugThreadlevelAny} -setup { array unset ::http::socketMapping http::config -proxyhost $a6host -proxyport $a6port -proxynot {::1 localhost} -proxyauth $badCreds after $fetchPause set token0 [http::geturl https://www.google.com/ -keepalive 1 -timeout 5000] } -body { after $fetchPause # If a bug passes the socket of a failed CONNECT to the main request, an infinite # wait can occur despite -timeout. Fix this with http::reset; to do this the call # to http::geturl must be async so we have $token for use as argument of reset. set can [after 6000 {http::reset $token; set ${token}(z) timeout}] set token [http::geturl https://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe] vwait ${token}(z) after cancel $can set ri [http::responseInfo $token] set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] set pos2 [lsearch -exact [set ${token}(requestHeaders)] $badCreds] set same [string equal [set ${token0}(sock)] [set ${token}(sock)]] set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*] [set ${token}(z)] $same" } -result {complete ok 407 -- SecureProxyFailed 1 1 -- -1 done 0} -cleanup { catch {http::cleanup $token0} catch {http::cleanup $token} unset -nocomplain token0 token ri res pos1 pos2 can same array unset ::http::socketMapping http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} } # cleanup unset -nocomplain n4host n6host n4port n6port a4host a6host a4port a6port aliceCreds badCreds fetchPause rename bgerror {} rename stopMe {} if {[testConstraint ThreadLevelSummary]} { putsBlurb ::tcltest::cleanupTests rename putsBlurb {} } # Local variables: # mode: tcl # End: |
Added tests/httpProxySquidConfigForWindowsDiladele.zip.
cannot compute difference between binary files
Changes to tests/info.test.
︙ | ︙ | |||
674 675 676 677 678 679 680 | unset functions msg test info-21.1 {miscellaneous error conditions} -returnCodes error -body { info } -result {wrong # args: should be "info subcommand ?arg ...?"} test info-21.2 {miscellaneous error conditions} -returnCodes error -body { info gorp | | | | | | 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 | unset functions msg test info-21.1 {miscellaneous error conditions} -returnCodes error -body { info } -result {wrong # args: should be "info subcommand ?arg ...?"} test info-21.2 {miscellaneous error conditions} -returnCodes error -body { info gorp } -result {unknown or ambiguous subcommand "gorp": must be args, body, class, cmdcount, cmdtype, commands, complete, constant, consts, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars} test info-21.3 {miscellaneous error conditions} -returnCodes error -body { info c } -result {unknown or ambiguous subcommand "c": must be args, body, class, cmdcount, cmdtype, commands, complete, constant, consts, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars} test info-21.4 {miscellaneous error conditions} -returnCodes error -body { info l } -result {unknown or ambiguous subcommand "l": must be args, body, class, cmdcount, cmdtype, commands, complete, constant, consts, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars} test info-21.5 {miscellaneous error conditions} -returnCodes error -body { info s } -result {unknown or ambiguous subcommand "s": must be args, body, class, cmdcount, cmdtype, commands, complete, constant, consts, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars} ## # ### ### ### ######### ######### ######### ## info frame ## Helper # For the more complex results we cut the file name down to remove path |
︙ | ︙ |
Changes to tests/io.test.
︙ | ︙ | |||
7714 7715 7716 7717 7718 7719 7720 7721 7722 7723 7724 7725 7726 7727 | fconfigure $out -encoding koi8-r -translation lf fcopy $in $out } -cleanup { close $in close $out } -returnCodes 1 -match glob -result {error reading "file*": invalid or incomplete multibyte or wide character} test io-52.21 {TclCopyChannel & encodings} -setup { set out [open $path(utf8-fcopy.txt) w] fconfigure $out -encoding utf-8 -translation lf puts $out "Á" close $out } -constraints {fcopy} -body { # binary to encoding => the input has to be | > > > > > > > > > > > > > > > > > > > > > > > | 7714 7715 7716 7717 7718 7719 7720 7721 7722 7723 7724 7725 7726 7727 7728 7729 7730 7731 7732 7733 7734 7735 7736 7737 7738 7739 7740 7741 7742 7743 7744 7745 7746 7747 7748 7749 7750 | fconfigure $out -encoding koi8-r -translation lf fcopy $in $out } -cleanup { close $in close $out } -returnCodes 1 -match glob -result {error reading "file*": invalid or incomplete multibyte or wide character} test io-52.20.2 {TclCopyChannel & encoding error on same encoding} -setup { set out [open $path(utf8-fcopy.txt) w] fconfigure $out -encoding utf-8 -translation lf puts $out "AÁ" close $out } -constraints {fcopy} -body { # binary to encoding => the input has to be # in utf-8 to make sense to the encoder set in [open $path(utf8-fcopy.txt) r] set out [open $path(kyrillic.txt) w] # Using "-encoding ascii" means reading the "Á" gives an error fconfigure $in -encoding ascii -profile strict fconfigure $out -encoding ascii -translation lf fcopy $in $out } -cleanup { close $in close $out } -returnCodes 1 -match glob -result {error reading "file*": invalid or incomplete multibyte or wide character} test io-52.21 {TclCopyChannel & encodings} -setup { set out [open $path(utf8-fcopy.txt) w] fconfigure $out -encoding utf-8 -translation lf puts $out "Á" close $out } -constraints {fcopy} -body { # binary to encoding => the input has to be |
︙ | ︙ | |||
7735 7736 7737 7738 7739 7740 7741 7742 7743 7744 7745 7746 7747 7748 | fconfigure $out -encoding ascii -translation lf -profile strict fcopy $in $out } -cleanup { close $in close $out } -returnCodes 1 -match glob -result {error writing "file*": invalid or incomplete multibyte or wide character} test io-52.22 {TclCopyChannel & encodings} -setup { set out [open $path(utf8-fcopy.txt) w] fconfigure $out -encoding utf-8 -translation lf puts $out "Á" close $out } -constraints {fcopy} -body { # binary to encoding => the input has to be | > | 7758 7759 7760 7761 7762 7763 7764 7765 7766 7767 7768 7769 7770 7771 7772 | fconfigure $out -encoding ascii -translation lf -profile strict fcopy $in $out } -cleanup { close $in close $out } -returnCodes 1 -match glob -result {error writing "file*": invalid or incomplete multibyte or wide character} test io-52.22 {TclCopyChannel & encodings} -setup { set out [open $path(utf8-fcopy.txt) w] fconfigure $out -encoding utf-8 -translation lf puts $out "Á" close $out } -constraints {fcopy} -body { # binary to encoding => the input has to be |
︙ | ︙ | |||
7762 7763 7764 7765 7766 7767 7768 7769 7770 7771 7772 7773 7774 7775 | vwait ::s0 set ::s0 } -cleanup { close $in close $out unset ::s0 } -match glob -result {0 {error reading "file*": invalid or incomplete multibyte or wide character}} test io-52.23 {TclCopyChannel & encodings} -setup { set out [open $path(utf8-fcopy.txt) w] fconfigure $out -encoding utf-8 -translation lf puts $out "Á" close $out } -constraints {fcopy} -body { # binary to encoding => the input has to be | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 7786 7787 7788 7789 7790 7791 7792 7793 7794 7795 7796 7797 7798 7799 7800 7801 7802 7803 7804 7805 7806 7807 7808 7809 7810 7811 7812 7813 7814 7815 7816 7817 7818 7819 7820 7821 7822 7823 7824 7825 7826 7827 7828 | vwait ::s0 set ::s0 } -cleanup { close $in close $out unset ::s0 } -match glob -result {0 {error reading "file*": invalid or incomplete multibyte or wide character}} test io-52.22.1 {TclCopyChannel & encodings & tell position} -setup { set out [open $path(utf8-fcopy.txt) w] fconfigure $out -encoding utf-8 -translation lf puts $out "AÁ" close $out } -constraints {fcopy} -body { # binary to encoding => the input has to be # in utf-8 to make sense to the encoder set in [open $path(utf8-fcopy.txt) r] set out [open $path(kyrillic.txt) w] # Using "-encoding ascii" means reading the "Á" gives an error fconfigure $in -encoding ascii -profile strict fconfigure $out -encoding koi8-r -translation lf proc ::xxx args { set ::s0 $args } fcopy $in $out -command ::xxx vwait ::s0 list [tell $in] [tell $out] {*}[set ::s0] } -cleanup { close $in close $out unset ::s0 } -match glob -result {1 1 1 {error reading "file*": invalid or incomplete multibyte or wide character}} test io-52.23 {TclCopyChannel & encodings} -setup { set out [open $path(utf8-fcopy.txt) w] fconfigure $out -encoding utf-8 -translation lf puts $out "Á" close $out } -constraints {fcopy} -body { # binary to encoding => the input has to be |
︙ | ︙ | |||
7812 7813 7814 7815 7816 7817 7818 | read $out } -cleanup { close $in close $out catch {file delete utf8-fcopy-52.24.txt} catch {file delete utf8-fcopy-52.24.out.txt} } -result Á | < | 7865 7866 7867 7868 7869 7870 7871 7872 7873 7874 7875 7876 7877 7878 | read $out } -cleanup { close $in close $out catch {file delete utf8-fcopy-52.24.txt} catch {file delete utf8-fcopy-52.24.out.txt} } -result Á test io-53.1 {CopyData} {fcopy} { file delete $path(test1) set f1 [open $thisScript] set f2 [open $path(test1) w] fconfigure $f1 -translation lf -blocking 0 fconfigure $f2 -translation cr -blocking 0 |
︙ | ︙ | |||
9276 9277 9278 9279 9280 9281 9282 | binary scan $d H* hd set hd } -cleanup { close $f removeFile io-75.5 } -result 4181 | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | < > > | | | | | | | | | | 9328 9329 9330 9331 9332 9333 9334 9335 9336 9337 9338 9339 9340 9341 9342 9343 9344 9345 9346 9347 9348 9349 9350 9351 9352 9353 9354 9355 9356 9357 9358 9359 9360 9361 9362 9363 9364 9365 9366 9367 9368 9369 9370 9371 9372 9373 9374 9375 9376 9377 9378 9379 9380 9381 9382 9383 9384 9385 9386 9387 9388 9389 9390 9391 9392 9393 9394 9395 9396 9397 9398 9399 9400 9401 9402 9403 9404 9405 9406 9407 9408 9409 9410 9411 9412 9413 9414 9415 9416 9417 9418 9419 9420 9421 9422 9423 9424 9425 9426 9427 9428 9429 9430 9431 9432 9433 9434 9435 9436 9437 9438 9439 9440 9441 9442 9443 9444 9445 9446 9447 9448 9449 9450 9451 9452 9453 9454 9455 9456 9457 9458 9459 9460 9461 9462 9463 9464 9465 9466 9467 9468 9469 9470 9471 9472 9473 9474 9475 9476 9477 9478 9479 9480 9481 9482 9483 9484 9485 9486 9487 9488 9489 9490 9491 9492 9493 9494 9495 9496 9497 9498 9499 9500 9501 9502 9503 9504 9505 9506 9507 9508 9509 9510 9511 9512 9513 9514 9515 9516 9517 9518 9519 9520 9521 9522 9523 9524 | binary scan $d H* hd set hd } -cleanup { close $f removeFile io-75.5 } -result 4181 test io-75.6 {incomplete utf-8 encoding, blocking gets is not ignored (-profile strict)} -setup { set fn [makeFile {} io-75.6] set f [open $fn w+] fconfigure $f -encoding binary # \x81 is an incomplete byte sequence in utf-8 puts -nonewline $f A\x81 flush $f seek $f 0 fconfigure $f -encoding utf-8 -buffering none -eofchar {} \ -translation lf -profile strict } -body { gets $f } -cleanup { close $f removeFile io-75.6 } -match glob -returnCodes 1 -result {error reading "file*":\ invalid or incomplete multibyte or wide character} test io-75.6.1 {invalid utf-8 encoding, blocking gets is not ignored (-profile strict)} -setup { set fn [makeFile {} io-75.6.1] set f [open $fn w+] fconfigure $f -encoding binary # utf-8: \xC3 requires a 2nd byte > x80, but <x80 is delivered puts -nonewline $f A\xC3B flush $f seek $f 0 fconfigure $f -encoding utf-8 -buffering none -eofchar {} \ -translation lf -profile strict } -body { gets $f } -cleanup { close $f removeFile io-75.6.1 } -match glob -returnCodes 1 -result {error reading "file*":\ invalid or incomplete multibyte or wide character} test io-75.6.2 {invalid utf-8 encoding, blocking gets is not ignored (-profile strict), recover functionality} -setup { set fn [makeFile {} io-75.6.2] set f [open $fn w+] fconfigure $f -encoding binary # utf-8: \xC3 requires a 2nd byte > x80, but <x80 is delivered puts -nonewline $f A\xC3B flush $f seek $f 0 fconfigure $f -encoding utf-8 -buffering none -eofchar {} \ -translation lf -profile strict } -body { set l {} lappend l [catch {gets $f}] lappend l [tell $f] fconfigure $f -encoding binary lappend l [expr {[gets $f] eq "A\xC3B"}] } -cleanup { close $f removeFile io-75.6.2 } -match glob -returnCodes 0 -result {1 0 1} # TCL ticket c4eb46a196: non blocking case had endless loop, so test it test io-75.6.3 {invalid utf-8 encoding, non blocking gets is not ignored (-profile strict)} -setup { set fn [makeFile {} io-75.6.3] set f [open $fn w+] fconfigure $f -encoding binary # utf-8: \xC3 requires a 2nd byte > x80, but <x80 is delivered puts -nonewline $f A\xC3B flush $f seek $f 0 fconfigure $f -encoding utf-8 -buffering none -eofchar {} \ -translation lf -profile strict -blocking 0 } -body { gets $f } -cleanup { close $f removeFile io-75.6.3 } -match glob -returnCodes 1 -result {error reading "file*":\ invalid or incomplete multibyte or wide character} test io-75.6.4 {incomplete utf-8 encoding, non blocking gets is not ignored (-profile strict)} -setup { set fn [makeFile {} io-75.6.4] set f [open $fn w+] fconfigure $f -encoding binary # \x81 is an incomplete byte sequence in utf-8 puts -nonewline $f A\x81 flush $f seek $f 0 fconfigure $f -encoding utf-8 -buffering none -eofchar {} \ -translation lf -profile strict -blocking 0 } -body { gets $f # only the 2nd gets returns the error gets $f } -cleanup { close $f removeFile io-75.6.4 } -match glob -returnCodes 1 -result {error reading "file*":\ invalid or incomplete multibyte or wide character} test io-75.7 { invalid utf-8 encoding read is not ignored (-profile strict) } -setup { set fn [makeFile {} io-75.7] set f [open $fn w+] fconfigure $f -encoding binary # \x81 is invalid in utf-8 puts -nonewline $f A\x81 flush $f seek $f 0 fconfigure $f -encoding utf-8 -buffering none -eofchar {} -translation lf \ -profile strict } -body { list [catch {read $f} msg data] $msg [dict get $data -data] } -cleanup { close $f removeFile io-75.7 unset msg data f fn } -match glob -result {1 {error reading "file*":\ invalid or incomplete multibyte or wide character} A} test io-75.8 {invalid utf-8 encoding eof first handling (-profile strict)} -setup { set fn [makeFile {} io-75.8] set f [open $fn w+] fconfigure $f -encoding binary # \x81 is invalid in utf-8, but since \x1A comes first, -eofchar takes # precedence. puts -nonewline $f A\x1A\x81 flush $f seek $f 0 fconfigure $f -encoding utf-8 -buffering none -eofchar \x1A \ -translation lf -profile strict } -body { set d [read $f] binary scan $d H* hd lappend hd [eof $f] lappend hd [read $f] set hd } -cleanup { close $f removeFile io-75.8 unset f d hd } -result {41 1 {}} test io-75.8.eoflater {invalid utf-8 encoding eof after handling (-profile strict)} -setup { set fn [makeFile {} io-75.8] set f [open $fn w+] # This also configures the channel encoding profile as strict. fconfigure $f -encoding binary # \x81 is invalid in utf-8. -eofchar is not detected, because it comes later. puts -nonewline $f A\x81\x81\x1A flush $f seek $f 0 fconfigure $f -encoding utf-8 -buffering none -eofchar \x1A \ -translation lf -profile strict } -body { set res [list [catch {read $f} msg data] [eof $f] [dict get $data -data]] chan configure $f -encoding iso8859-1 lappend res [read $f 1] chan configure $f -encoding utf-8 lappend res [catch {read $f 1} msg data] $msg [dict get $data -data] } -cleanup { close $f removeFile io-75.8 unset res msg data fn f } -match glob -result "1 0 A \x81 1 {error reading \"*\":\ invalid or incomplete multibyte or wide character} {}" test io-strict-multibyte-eof { incomplete utf-8 sequence immediately prior to eof character See issue 25cdcb7e8fb381fb } -setup { set chan [file tempfile]; fconfigure $chan -encoding binary puts -nonewline $chan \x81\x1A flush $chan seek $chan 0 chan configure $chan -encoding utf-8 -profile strict } -body { list [catch {read $chan 1} msg data] $msg [dict get $data -data] } -cleanup { close $chan unset msg chan data } -match glob -result {1 {error reading "*":\ invalid or incomplete multibyte or wide character} {}} test io-75.9 {unrepresentable character write throws error in strict profile} -setup { set fn [makeFile {} io-75.9] set f [open $fn w+] fconfigure $f -encoding iso8859-1 -profile strict } -body { catch {puts -nonewline $f "A\u2022"} msg |
︙ | ︙ | |||
9444 9445 9446 9447 9448 9449 9450 | flush $f seek $f 0 fconfigure $f -encoding shiftjis -blocking 0 -eofchar {} -translation lf \ -profile strict } -body { set d [read $f] binary scan $d H* hd | | | | | 9575 9576 9577 9578 9579 9580 9581 9582 9583 9584 9585 9586 9587 9588 9589 9590 9591 9592 9593 9594 9595 | flush $f seek $f 0 fconfigure $f -encoding shiftjis -blocking 0 -eofchar {} -translation lf \ -profile strict } -body { set d [read $f] binary scan $d H* hd lappend hd [catch {set d [read $f]} msg data] $msg [dict exists $data -data] } -cleanup { close $f removeFile io-75.11 unset d hd msg data f } -match glob -result {41 1 {error reading "file*":\ invalid or incomplete multibyte or wide character} 0} test io-75.12 { invalid utf-8 encoding read is not ignored because setting the encoding to "binary" also set the profile to strict } -setup { set res {} set fn [makeFile {} io-75.12] |
︙ | ︙ | |||
9496 9497 9498 9499 9500 9501 9502 | flush $f seek $f 0 fconfigure $f -encoding utf-8 -blocking 0 -eofchar {} -translation lf \ -profile strict } -body { set d [read $f] binary scan $d H* hd | | | | | | | | | | | 9627 9628 9629 9630 9631 9632 9633 9634 9635 9636 9637 9638 9639 9640 9641 9642 9643 9644 9645 9646 9647 9648 9649 9650 9651 9652 9653 9654 9655 9656 9657 9658 9659 9660 9661 9662 9663 9664 9665 9666 9667 9668 9669 9670 9671 9672 9673 9674 9675 9676 9677 9678 9679 9680 9681 9682 9683 9684 9685 9686 9687 9688 9689 9690 9691 9692 9693 9694 9695 9696 9697 9698 9699 9700 9701 9702 9703 9704 9705 9706 9707 9708 | flush $f seek $f 0 fconfigure $f -encoding utf-8 -blocking 0 -eofchar {} -translation lf \ -profile strict } -body { set d [read $f] binary scan $d H* hd lappend hd [catch {read $f} msg data] $msg [dict exists $data -data] } -cleanup { close $f removeFile io-75.13 unset d hd msg data f fn } -match glob -result {41 1 {error reading "file*":\ invalid or incomplete multibyte or wide character} 0} test io-75.14 { [gets] succesfully returns lines prior to error invalid utf-8 encoding [gets] continues in non-strict mode after error } -setup { set chan [file tempfile] fconfigure $chan -encoding binary # \xC0\n is an invalid utf-8 sequence puts -nonewline $chan a\nb\nc\xC0\nd\n flush $chan seek $chan 0 fconfigure $chan -encoding utf-8 -buffering none -eofchar {} \ -translation auto -profile strict } -body { set res [gets $chan] lappend res [gets $chan] lappend res [catch {gets $chan} msg data] $msg [dict exists $data -data] chan configure $chan -profile tcl8 lappend res [gets $chan] lappend res [gets $chan] return $res } -cleanup { close $chan unset chan res msg data } -match glob -result {a b 1 {error reading "*":\ invalid or incomplete multibyte or wide character} 0 cÀ d} test io-75.15 { invalid utf-8 encoding strict gets does not hang gets succeeds for the first two lines } -setup { set res {} set chan [file tempfile] fconfigure $chan -encoding binary # \xC0\x40 is an invalid utf-8 sequence puts $chan hello\nAB\nCD\xC0\x40EF\nGHI seek $chan 0 } -body { #Now try to read it with [gets] fconfigure $chan -encoding utf-8 -profile strict lappend res [gets $chan] lappend res [gets $chan] lappend res [catch {gets $chan} msg data] $msg [dict exists $data -data] lappend res [catch {gets $chan} msg data] $msg [dict exists $data -data] chan configure $chan -translation binary set data [read $chan 4] foreach char [split $data {}] { scan $char %c ord lappend res [format %x $ord] } fconfigure $chan -encoding utf-8 -profile strict -translation auto lappend res [gets $chan] lappend res [gets $chan] return $res } -cleanup { close $chan unset chan res msg data } -match glob -result {hello AB 1 {error reading "*": invalid or incomplete multibyte or wide character}\ 0 1 {error reading "*": invalid or incomplete multibyte or wide character} 0 43 44 c0 40 EF GHI} # ### ### ### ######### ######### ######### test io-76.0 {channel modes} -setup { set datafile [makeFile {some characters} dummy] |
︙ | ︙ | |||
9688 9689 9690 9691 9692 9693 9694 9695 9696 | testchannel mremove-rd $f testchannel mremove-wr $f } -returnCodes error -cleanup { close $f removeFile dummy } -match glob -result {Tcl_RemoveChannelMode error:\ Bad mode, would make channel inacessible. Channel: "*"} # cleanup | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | 9819 9820 9821 9822 9823 9824 9825 9826 9827 9828 9829 9830 9831 9832 9833 9834 9835 9836 9837 9838 9839 9840 9841 9842 9843 9844 9845 9846 9847 9848 9849 9850 9851 9852 9853 9854 9855 9856 9857 9858 9859 9860 9861 9862 9863 9864 9865 9866 9867 9868 | testchannel mremove-rd $f testchannel mremove-wr $f } -returnCodes error -cleanup { close $f removeFile dummy } -match glob -result {Tcl_RemoveChannelMode error:\ Bad mode, would make channel inacessible. Channel: "*"} # Encoding errors on pipeline # Ensures fix for exec bug [0f1ddc0df7] does not affect open # It should still fail unless -profile is explicitly set to replace test io-77.1 {open pipe encoding mismatch} -setup { set scriptFile [makeFile { fconfigure stdout -translation binary puts -nonewline a\xe9b flush stdout } script] } -cleanup { close $fd removeFile $scriptFile } -body { set fd [open |[list [info nameofexecutable] $scriptFile r+]] fconfigure $fd -encoding utf-8 list [catch {read $fd} result opts] [string match {error reading "*": invalid or incomplete multibyte or wide character} $result] [dict get $opts -errorcode] } -result [list 1 1 {POSIX EILSEQ {invalid or incomplete multibyte or wide character}}] test io-77.2 {open pipe encoding mismatch - use replace profile} -setup { set scriptFile [makeFile { fconfigure stdout -translation binary puts -nonewline a\xe9b flush stdout } script] } -cleanup { close $fd removeFile $scriptFile } -body { set fd [open |[list [info nameofexecutable] $scriptFile r+]] fconfigure $fd -encoding utf-8 -profile replace read $fd } -result a\uFFFDb # cleanup foreach file [list fooBar longfile script2 output test1 pipe my_script \ test2 test3 cat stdout kyrillic.txt utf8-fcopy.txt utf8-rp.txt] { removeFile $file } cleanupTests } namespace delete ::tcl::test::io return |
Changes to tests/ioCmd.test.
1 2 | # -*- tcl -*- # Commands covered: open, close, gets, read, puts, seek, tell, eof, flush, | | > | 1 2 3 4 5 6 7 8 9 10 11 | # -*- tcl -*- # Commands covered: open, close, gets, read, puts, seek, tell, eof, flush, # fblocked, fconfigure, open, channel, fcopy, # readFile, writeFile, foreachLine # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright © 1991-1994 The Regents of the University of California. # Copyright © 1994-1996 Sun Microsystems, Inc. |
︙ | ︙ | |||
367 368 369 370 371 372 373 | 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-8.23 {fconfigure -profile badprofile} -body { fconfigure stdin -profile froboz | | | 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 | 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-8.23 {fconfigure -profile badprofile} -body { fconfigure stdin -profile froboz } -returnCodes error -result {bad profile name "froboz": must be lossless, replace, strict, or tcl8} 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} { list [catch {eof a b} msg] $msg $::errorCode } {1 {wrong # args: should be "eof channelId"} {TCL WRONGARGS}} |
︙ | ︙ | |||
3909 3910 3911 3912 3913 3914 3915 3916 3917 3918 3919 3920 3921 3922 | catch {thread::release $tida} thread::release $tidb set res } -constraints {testchannel thread notValgrind} \ -result {Owner lost} # ### ### ### ######### ######### ######### # ### ### ### ######### ######### ######### rename track {} # cleanup | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 3910 3911 3912 3913 3914 3915 3916 3917 3918 3919 3920 3921 3922 3923 3924 3925 3926 3927 3928 3929 3930 3931 3932 3933 3934 3935 3936 3937 3938 3939 3940 3941 3942 3943 3944 3945 3946 3947 3948 3949 3950 3951 3952 3953 3954 3955 3956 3957 3958 3959 3960 3961 3962 3963 3964 3965 3966 3967 3968 3969 3970 3971 3972 3973 3974 3975 3976 3977 3978 3979 3980 3981 3982 3983 3984 3985 3986 3987 3988 3989 3990 3991 3992 3993 3994 3995 3996 3997 3998 3999 4000 4001 4002 4003 4004 4005 4006 4007 4008 4009 4010 4011 4012 4013 4014 4015 4016 4017 4018 4019 4020 4021 4022 4023 4024 4025 4026 4027 4028 4029 4030 4031 4032 4033 4034 4035 4036 4037 4038 4039 4040 4041 4042 4043 4044 4045 4046 4047 4048 4049 4050 4051 4052 4053 4054 4055 4056 4057 4058 4059 4060 4061 4062 4063 4064 4065 4066 4067 4068 4069 4070 4071 4072 4073 4074 4075 4076 4077 4078 4079 4080 4081 4082 4083 4084 4085 4086 4087 4088 4089 4090 4091 4092 4093 4094 4095 4096 4097 4098 4099 4100 4101 4102 4103 4104 4105 4106 4107 4108 4109 4110 4111 4112 4113 4114 4115 4116 4117 4118 4119 4120 4121 4122 4123 4124 4125 4126 | catch {thread::release $tida} thread::release $tidb set res } -constraints {testchannel thread notValgrind} \ -result {Owner lost} # Tests of readFile set BIN_DATA "\u0000\u0001\u0002\u0003\u0004\u001a\u001b\u000d\u000a\u0000" test iocmd.readFile-1.1 "readFile procedure: syntax" -body { readFile } -returnCodes error -result {wrong # args: should be "readFile filename ?mode?"} test iocmd.readFile-1.2 "readFile procedure: syntax" -body { readFile a b c } -returnCodes error -result {wrong # args: should be "readFile filename ?mode?"} test iocmd.readFile-1.3 "readFile procedure: syntax" -body { readFile gorp gorp2 } -returnCodes error -result {bad mode "gorp2": must be binary or text} test iocmd.readFile-2.1 "readFile procedure: behaviour" -setup { set f [makeFile "File\nContents" readFile21.txt] } -body { readFile $f } -cleanup { removeFile $f } -result "File\nContents\n" test iocmd.readFile-2.2 "readFile procedure: behaviour" -setup { set f [makeFile "File\nContents" readFile22.txt] } -body { readFile $f text } -cleanup { removeFile $f } -result "File\nContents\n" test iocmd.readFile-2.3 "readFile procedure: behaviour" -setup { set f [makeFile "" readFile23.bindata] apply {filename { global BIN_DATA set ff [open $filename wb] puts -nonewline $ff $BIN_DATA close $ff }} $f } -body { list [binary scan [readFile $f binary] c* x] $x } -cleanup { removeFile $f } -result {1 {0 1 2 3 4 26 27 13 10 0}} # Need to set up ahead of the test set f [makeFile "" readFile24.txt] removeFile $f test iocmd.readFile-2.4 "readFile procedure: behaviour" -body { readFile $f } -returnCodes error -result "couldn't open \"$f\": no such file or directory" # Tests of writeFile test iocmd.writeFile-1.1 "writeFile procedure: syntax" -body { writeFile } -returnCodes error -result {wrong # args: should be "writeFile filename ?mode? data"} test iocmd.writeFile-1.2 "writeFile procedure: syntax" -body { writeFile a b c d } -returnCodes error -result {wrong # args: should be "writeFile filename ?mode? data"} test iocmd.writeFile-1.3 "writeFile procedure: syntax" -body { writeFile gorp gorp2 gorp3 } -returnCodes error -result {bad mode "gorp2": must be binary or text} test iocmd.writeFile-2.1 "readFile procedure: behaviour" -setup { set f [makeFile "" writeFile21.txt] removeFile $f } -body { list [writeFile $f "File\nContents\n"] [apply {filename { set f [open $filename] set text [read $f] close $f return $text }} $f] } -cleanup { file delete $f } -result [list {} "File\nContents\n"] test iocmd.writeFile-2.2 "readFile procedure: behaviour" -setup { set f [makeFile "" writeFile22.txt] removeFile $f } -body { writeFile $f text "File\nContents\n" apply {filename { set f [open $filename] set text [read $f] close $f return $text }} $f } -cleanup { file delete $f } -result "File\nContents\n" test iocmd.writeFile-2.3 "readFile procedure: behaviour" -setup { set f [makeFile "" writeFile23.txt] removeFile $f } -body { writeFile $f binary $BIN_DATA apply {filename { set f [open $filename rb] set bytes [read $f] close $f binary scan $bytes c* x return $x }} $f } -cleanup { file delete $f } -result {0 1 2 3 4 26 27 13 10 0} # Tests of foreachLine test iocmd.foreachLine-1.1 "foreachLine procedure: syntax" -returnCodes error -body { foreachLine } -result {wrong # args: should be "foreachLine varName filename body"} test iocmd.foreachLine-1.2 "foreachLine procedure: syntax" -returnCodes error -body { foreachLine a b c d } -result {wrong # args: should be "foreachLine varName filename body"} test iocmd.foreachLine-1.3 "foreachLine procedure: basic errors" -setup { set f [makeFile "" foreachLine13.txt] } -body { apply {filename { array set b {1 1} foreachLine b $filename {} }} $f } -cleanup { removeFile $f } -returnCodes error -result {can't set "line": variable is array} set f [makeFile "" foreachLine14.txt] removeFile $f test iocmd.foreachLine-1.4 "foreachLine procedure: basic errors" -body { apply {filename { foreachLine var $filename {} }} $f } -returnCodes error -result "couldn't open \"$f\": no such file or directory" test iocmd.foreachLine-2.1 "foreachLine procedure: behaviour" -setup { set f [makeFile "a\nb\nc" foreachLine21.txt] } -body { apply {filename { set lines {} foreachLine var $filename { lappend lines $var } return $lines }} $f } -cleanup { removeFile $f } -result {a b c} test iocmd.foreachLine-2.2 "foreachLine procedure: behaviour" -setup { set f [makeFile "a\nbb\nc\ndd" foreachLine22.txt] } -body { apply {filename { set lines {} foreachLine var $filename { if {[string length $var] == 1} continue lappend lines $var } return $lines }} $f } -cleanup { removeFile $f } -result {bb dd} test iocmd.foreachLine-2.3 "foreachLine procedure: behaviour" -setup { set f [makeFile "a\nbb\nccc\ndd\ne" foreachLine23.txt] } -body { apply {filename { set lines {} foreachLine var $filename { if {[string length $var] > 2} break lappend lines $var } return $lines }} $f } -cleanup { removeFile $f } -result {a bb} test iocmd.foreachLine-2.4 "foreachLine procedure: behaviour" -setup { set f [makeFile "a\nbb\nccc\ndd\ne" foreachLine24.txt] } -body { apply {filename { set lines {} foreachLine var $filename { if {[string length $var] > 2} { return $var } lappend lines $var } return $lines }} $f } -cleanup { removeFile $f } -result {ccc} test iocmd.foreachLine-2.5 "foreachLine procedure: behaviour" -setup { set f [makeFile "a\nbb\nccc\ndd\ne" foreachLine25.txt] } -body { apply {filename { set lines {} foreachLine var $filename { if {[string length $var] > 2} { error "line too long" } lappend lines $var } return $lines }} $f } -cleanup { removeFile $f } -returnCodes error -result {line too long} # ### ### ### ######### ######### ######### # ### ### ### ######### ######### ######### rename track {} # cleanup |
︙ | ︙ |
Changes to tests/main.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | # This file contains a collection of tests for generic/tclMain.c. if {"::tcltest" ni [namespace children]} { package require tcltest 2.5 namespace import -force ::tcltest::* } namespace eval ::tcl::test::main { namespace import ::tcltest::* # Is [exec] defined? testConstraint exec [llength [info commands exec]] # Is the tcl::test package loaded? testConstraint tcl::test [expr { [llength [package provide tcl::test]] && [package vsatisfies [package provide tcl::test] 8.5-]}] # Procedure to simulate interactive typing of commands, line by line | > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 | # This file contains a collection of tests for generic/tclMain.c. if {"::tcltest" ni [namespace children]} { package require tcltest 2.5 namespace import -force ::tcltest::* } namespace eval ::tcl::test::main { namespace import ::tcltest::* # Is [exec] defined? testConstraint exec [llength [info commands exec]] if {[llength [auto_execok bash]]} { testConstraint haveBash 1 } # Is the tcl::test package loaded? testConstraint tcl::test [expr { [llength [package provide tcl::test]] && [package vsatisfies [package provide tcl::test] 8.5-]}] # Procedure to simulate interactive typing of commands, line by line |
︙ | ︙ | |||
1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 | set tcl_interactive 1} >& result set f [open result] read $f } -cleanup { close $f file delete result } -result "1\nfoo\n" cd [workingDirectory] cleanupTests } namespace delete ::tcl::test::main return | > > > > > > > > > > > > > > > > > > > | 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 | set tcl_interactive 1} >& result set f [open result] read $f } -cleanup { close $f file delete result } -result "1\nfoo\n" test Tcl_Main-10.1 { Invalidly encoded bytes in arguments - TIP 671 } -constraints {unix haveBash} -setup { set tclScript [makeFile { lassign $::argv a b # a should be \udce9 (lossless map ofe9) b should be \ue9 puts [list [format %x [scan $a %c]] [format %x [scan $b %c]]] } tclScript] # Note following requires bash, not sh! Dunno the equivalent in sh set shellCode [string cat "[info nameofexecutable] $tclScript" { $'\351'} { $'\303\251'} \n] set shScript [makeFile $shellCode shScript] set oldEnc [encoding system] encoding system utf-8 } -cleanup { encoding system $oldEnc } -body { exec {*}[auto_execok bash] $shScript } -result {dce9 e9} cd [workingDirectory] cleanupTests } namespace delete ::tcl::test::main return |
Changes to tests/oo.test.
︙ | ︙ | |||
1681 1682 1683 1684 1685 1686 1687 | }}} rename obj1 {} # No segmentation fault return done } done | < | < | < < < | < < | < < < | < < | < < < | < < | 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 | }}} rename obj1 {} # No segmentation fault return done } done test oo-11.6.1 {OO: cleanup of when an class is mixed into itself} -constraints memory -body { leaktest { interp create interp1 oo::class create obj1 ::oo::define obj1 {self mixin [uplevel 1 {namespace which obj1}]} rename obj1 {} interp delete interp1 } } -result 0 test oo-11.6.2 {OO: cleanup ReleaseClassContents() where class is mixed into one of its instances} -constraints memory -body { leaktest { interp create interp1 interp1 eval { oo::class create obj1 ::oo::copy obj1 obj2 rename obj2 {} rename obj1 {} } interp delete interp1 } } -result 0 test oo-11.6.3 {OO: cleanup ReleaseClassContents() where class is mixed into one of its instances} -constraints memory -body { leaktest { interp create interp1 interp1 eval { oo::class create obj1 ::oo::define obj1 {self mixin [uplevel 1 {namespace which obj1}]} ::oo::copy obj1 obj2 rename obj2 {} rename obj1 {} } interp delete interp1 } } -result 0 test oo-11.6.4 {OO: cleanup ReleaseClassContents() where class is mixed into one of its instances} -body { oo::class create obj1 ::oo::define obj1 {self mixin [self]} ::oo::copy obj1 obj2 ::oo::objdefine obj2 {mixin [self]} ::oo::copy obj2 obj3 |
︙ | ︙ | |||
2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 | oo::class create cls { superclass parent mixin mix method test {} {lappend ::result cls; next; return $::result} } [cls new] test } -result {mix cls} test oo-15.1 {OO: object cloning} { oo::class create Aclass oo::define Aclass method test {} {lappend ::result [self object]->test} Aclass create Ainstance set result {} Ainstance test | > > > > > > > > > > > > > > > > > > > > > > > > > | 2197 2198 2199 2200 2201 2202 2203 2204 2205 2206 2207 2208 2209 2210 2211 2212 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 2228 2229 2230 2231 2232 2233 2234 2235 | oo::class create cls { superclass parent mixin mix method test {} {lappend ::result cls; next; return $::result} } [cls new] test } -result {mix cls} test oo-14.9 {OO: class mixins must be unique in list} -setup { oo::class create parent } -body { oo::class create A {superclass parent} oo::class create B { superclass parent mixin A } oo::define B mixin -append A } -returnCodes error -cleanup { parent destroy } -result {class should only be a direct mixin once} test oo-14.10 {OO: instance mixins must be unique in list} -setup { oo::class create parent } -body { oo::class create A {superclass parent} oo::class create B { superclass parent constructor {} {oo::objdefine [self] mixin A} } B create obj oo::objdefine obj {mixin -append A} } -returnCodes error -cleanup { parent destroy } -result {class should only be a direct mixin once} test oo-15.1 {OO: object cloning} { oo::class create Aclass oo::define Aclass method test {} {lappend ::result [self object]->test} Aclass create Ainstance set result {} Ainstance test |
︙ | ︙ | |||
4194 4195 4196 4197 4198 4199 4200 4201 4202 4203 4204 4205 4206 4207 | }] -body { # Method names beginning with "-" are special to slots $s -grill q } -returnCodes error -cleanup [SampleSlotCleanup { rename $s {} }] -result \ {unknown method "-grill": must be -append, -appendifnew, -clear, -prepend, -remove, -set, contents or ops} test oo-34.1 {TIP 380: slots - presence} -setup { set obj [oo::object new] set result {} } -body { oo::define oo::object { ::lappend ::result [::info object class filter] | > > > > > > > > > > > > > | 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 | }] -body { # Method names beginning with "-" are special to slots $s -grill q } -returnCodes error -cleanup [SampleSlotCleanup { rename $s {} }] -result \ {unknown method "-grill": must be -append, -appendifnew, -clear, -prepend, -remove, -set, contents or ops} test oo-33.5 {TIP 567: slots -appendifnew} -setup [SampleSlotSetup { set s [SampleSlot new] }] -body { list \ [$s -clear $s contents] \ [$s -append p q r $s contents] \ [$s -appendifnew q s r t p $s contents] } -cleanup [SampleSlotCleanup { rename $s {} }] -result {{} {p q r} {p q r s t}} test oo-34.1 {TIP 380: slots - presence} -setup { set obj [oo::object new] set result {} } -body { oo::define oo::object { ::lappend ::result [::info object class filter] |
︙ | ︙ |
Changes to tests/ooUtil.test.
︙ | ︙ | |||
522 523 524 525 526 527 528 529 530 531 532 533 534 535 | } } cls create o pqr list [o foo] [pqr] [rename [info object namespace o]::my {}] [catch pqr msg] $msg } -cleanup { parent destroy } -result {{in foo of ::o} {in foo of ::o} {} 1 {invalid command name "pqr"}} # Tests that verify issues detected with the tcllib version of the code test ooUtil-tcllib-ticket-b3577ed586 {test scoping of delegation in oo::class.Delegate } -setup { oo::class create animal {} namespace eval ::ooutiltest { oo::class create pet { superclass animal } } | > > > > > > > > > > > > > > > > > > > > > > > | 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 | } } cls create o pqr list [o foo] [pqr] [rename [info object namespace o]::my {}] [catch pqr msg] $msg } -cleanup { parent destroy } -result {{in foo of ::o} {in foo of ::o} {} 1 {invalid command name "pqr"}} # Tests a very weird combination of things (with a key problem locus in # MixinClassDelegates) that TIP 567 fixes test ooUtil-8.1 {TIP 567: call oo::define twice from metaclass constructor} -setup { oo::class create parent } -body { ::oo::class create A { superclass parent } ::oo::class create B { superclass ::oo::class parent constructor {{definitionScript ""}} { next $definitionScript next {superclass ::A} } } B create C { superclass A } C create instance } -cleanup { parent destroy } -result ::instance # Tests that verify issues detected with the tcllib version of the code test ooUtil-tcllib-ticket-b3577ed586 {test scoping of delegation in oo::class.Delegate } -setup { oo::class create animal {} namespace eval ::ooutiltest { oo::class create pet { superclass animal } } |
︙ | ︙ |
Changes to tests/reg.test.
︙ | ︙ | |||
639 640 641 642 643 644 645 | expectMatch 13.26 MP "a\\010b" "a\bb" "a\bb" expectMatch 13.27 P "a\\U00001234x" "a\u1234x" "a\u1234x" expectMatch 13.28 P {a\U00001234x} "a\u1234x" "a\u1234x" expectMatch 13.29 P "a\\U0001234x" "a\u1234x" "a\u1234x" expectMatch 13.30 P {a\U0001234x} "a\u1234x" "a\u1234x" expectMatch 13.31 P "a\\U000012345x" "a\u12345x" "a\u12345x" expectMatch 13.32 P {a\U000012345x} "a\u12345x" "a\u12345x" | | | | 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 | expectMatch 13.26 MP "a\\010b" "a\bb" "a\bb" expectMatch 13.27 P "a\\U00001234x" "a\u1234x" "a\u1234x" expectMatch 13.28 P {a\U00001234x} "a\u1234x" "a\u1234x" expectMatch 13.29 P "a\\U0001234x" "a\u1234x" "a\u1234x" expectMatch 13.30 P {a\U0001234x} "a\u1234x" "a\u1234x" expectMatch 13.31 P "a\\U000012345x" "a\u12345x" "a\u12345x" expectMatch 13.32 P {a\U000012345x} "a\u12345x" "a\u12345x" expectMatch 13.33 P "a\\U100000x" "a\U100000x" "a\U100000x" expectMatch 13.34 P {a\U100000x} "a\U100000x" "a\U100000x" doing 14 "back references" # ugh expectMatch 14.1 RP {a(b*)c\1} abbcbb abbcbb bb expectMatch 14.2 RP {a(b*)c\1} ac ac "" expectNomatch 14.3 RP {a(b*)c\1} abbcb |
︙ | ︙ |
Added tests/twapiTlsPlus.tcl.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | # Module twapiTlsPlus # # Temporary wrapper for package twapi, to expose the same API as package tls. # - Command twapiTlsPlus::socket, cf. tls::socket, replacement for ::socket, for # use with http::register. # - Variable twapiTlsPlus::socketCmd, cf. tls::socketCmd, holds the value of the # callback command used by twapi to open a socket. # # Intended to allow twapi TLS to use an https proxy server, and a background # thread for evaluation of ::socket. # # For twapiTlsPlus to work correctly, twapi*/tls.tcl must be edited so that #- set so [$socketcmd {*}$socket_args {*}$args] #+ set so [{*}$socketcmd {*}$socket_args {*}$args] package require http package require twapi namespace eval twapiTlsPlus { variable socketCmd [::twapi::tls_socket_command] namespace export socket } # Proc twapiTlsPlus::socket # Replacement for ::socket, use with http::register. proc twapiTlsPlus::socket {args} { variable socketCmd set targ [lsearch -exact $args -type] if {$targ != -1} { set token [lindex $args $targ+1] set args [lreplace $args $targ $targ+1 -socketcmd [list {*}$socketCmd -type $token]] } ::twapi::tls_socket {*}$args } # Variable twapi::tls::_socket_cmd does it. proc twapiTlsPlus::TraceSocketCmd {args} { variable socketCmd ::twapi::tls_socket_command $socketCmd return } trace add variable ::twapiTlsPlus::socketCmd write ::twapiTlsPlus::TraceSocketCmd package provide twapiTlsPlus 0.1 |
Changes to tests/unixInit.test.
︙ | ︙ | |||
13 14 15 16 17 18 19 | if {"::tcltest" ni [namespace children]} { package require tcltest 2.5 namespace import -force ::tcltest::* } unset -nocomplain path catch {set oldlang $env(LANG)} set env(LANG) C | < < < | 13 14 15 16 17 18 19 20 21 22 23 24 25 26 | if {"::tcltest" ni [namespace children]} { package require tcltest 2.5 namespace import -force ::tcltest::* } unset -nocomplain path catch {set oldlang $env(LANG)} set env(LANG) C test unixInit-1.1 {TclpInitPlatform: ignore SIGPIPE} {unix stdio} { set x {} # Watch out for a race condition here. If tcltest is too slow to start # then we'll kill it before it has a chance to set up its signal handler. set f [open "|[list [interpreter]]" w+] puts $f "puts hi" |
︙ | ︙ |
Changes to tests/utf.test.
︙ | ︙ | |||
58 59 60 61 62 63 64 | } 1 test utf-1.10 {Tcl_UniCharToUtf: 3 byte sequence, high surrogate} testbytestring { expr {[format %c 0xD842] eq [testbytestring \xED\xA1\x82]} } 1 test utf-1.11 {Tcl_UniCharToUtf: 3 byte sequence, low surrogate} testbytestring { expr {[format %c 0xDC42] eq [testbytestring \xED\xB1\x82]} } 1 | | | | | | 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 | } 1 test utf-1.10 {Tcl_UniCharToUtf: 3 byte sequence, high surrogate} testbytestring { expr {[format %c 0xD842] eq [testbytestring \xED\xA1\x82]} } 1 test utf-1.11 {Tcl_UniCharToUtf: 3 byte sequence, low surrogate} testbytestring { expr {[format %c 0xDC42] eq [testbytestring \xED\xB1\x82]} } 1 test utf-1.12 {Tcl_UniCharToUtf: Invalid surrogate} testbytestring { expr {"\UD842" eq [testbytestring \xED\xA1\x82]} } 1 test utf-1.13 {Tcl_UniCharToUtf: Invalid surrogate} { expr {"\UD842" eq "\uD842"} } 1 test utf-1.14 {Tcl_UniCharToUtf: surrogate pairs from concat} { set lo \uDE02 return \uD83D$lo } \uD83D\uDE02 test utf-1.15 {Tcl_UniCharToUtf: surrogate pairs from concat} { set hi \uD83D |
︙ | ︙ | |||
159 160 161 162 163 164 165 | } 2 test utf-4.10 {Tcl_NumUtfChars: #x00, calc len, overcomplete} {testnumutfchars testbytestring} { testnumutfchars [testbytestring \x00] end+1 } 2 test utf-4.11 {Tcl_NumUtfChars: 3 bytes of 4-byte UTF-8 characater} {testnumutfchars testbytestring} { testnumutfchars [testbytestring \xF0\x9F\x92\xA9] end-1 } 3 | | | 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 | } 2 test utf-4.10 {Tcl_NumUtfChars: #x00, calc len, overcomplete} {testnumutfchars testbytestring} { testnumutfchars [testbytestring \x00] end+1 } 2 test utf-4.11 {Tcl_NumUtfChars: 3 bytes of 4-byte UTF-8 characater} {testnumutfchars testbytestring} { testnumutfchars [testbytestring \xF0\x9F\x92\xA9] end-1 } 3 test utf-4.12 {Tcl_NumUtfChars: #4-byte UTF-8 character} {testnumutfchars testbytestring} { testnumutfchars [testbytestring \xF0\x9F\x92\xA9] end } 1 test utf-4.13 {Tcl_NumUtfChars: end of string} {testnumutfchars testbytestring} { testnumutfchars foobar[testbytestring \xF2\xC2\xA0] end } 8 test utf-4.14 {Tcl_NumUtfChars: 3 bytes of 4-byte UTF-8 characater} {testnumutfchars testbytestring} { testnumutfchars [testbytestring \xF4\x90\x80\x80] end-1 |
︙ | ︙ | |||
208 209 210 211 212 213 214 | } 1 test utf-6.9 {Tcl_UtfNext} {testutfnext testbytestring} { testutfnext [testbytestring \xA0\x00] } 1 test utf-6.10 {Tcl_UtfNext} {testutfnext testbytestring} { testutfnext [testbytestring \xA0]G } 1 | | | 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 | } 1 test utf-6.9 {Tcl_UtfNext} {testutfnext testbytestring} { testutfnext [testbytestring \xA0\x00] } 1 test utf-6.10 {Tcl_UtfNext} {testutfnext testbytestring} { testutfnext [testbytestring \xA0]G } 1 test utf-6.11 {Tcl_UtfNext} {testutfnext testbytestring} { testutfnext [testbytestring \xA0\xA0\x00] } 2 test utf-6.12 {Tcl_UtfNext} {testutfnext testbytestring} { testutfnext [testbytestring \xA0\xD0] } 1 test utf-6.13 {Tcl_UtfNext} {testutfnext testbytestring} { testutfnext [testbytestring \xA0\xE8] |
︙ | ︙ | |||
527 528 529 530 531 532 533 | } 2 test utf-7.9.1 {Tcl_UtfPrev} {testutfprev testbytestring} { testutfprev A[testbytestring \xF8\xA0\xA0\xA0] 3 } 2 test utf-7.9.2 {Tcl_UtfPrev} {testutfprev testbytestring} { testutfprev A[testbytestring \xF8\xA0\xF8\xA0] 3 } 2 | | | 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 | } 2 test utf-7.9.1 {Tcl_UtfPrev} {testutfprev testbytestring} { testutfprev A[testbytestring \xF8\xA0\xA0\xA0] 3 } 2 test utf-7.9.2 {Tcl_UtfPrev} {testutfprev testbytestring} { testutfprev A[testbytestring \xF8\xA0\xF8\xA0] 3 } 2 test utf-7.10 {Tcl_UtfPrev} {testutfprev testbytestring} { testutfprev A[testbytestring \xF2\xA0] } 1 test utf-7.10.1 {Tcl_UtfPrev} {testutfprev testbytestring} { testutfprev A[testbytestring \xF2\xA0\xA0\xA0] 3 } 1 test utf-7.10.2 {Tcl_UtfPrev} {testutfprev testbytestring} { testutfprev A[testbytestring \xF2\xA0\xF8\xA0] 3 |
︙ | ︙ | |||
575 576 577 578 579 580 581 | } 3 test utf-7.14.1 {Tcl_UtfPrev} {testutfprev testbytestring} { testutfprev A[testbytestring \xF8\xA0\xA0\xA0] 4 } 3 test utf-7.14.2 {Tcl_UtfPrev} {testutfprev testbytestring} { testutfprev A[testbytestring \xF8\xA0\xA0\xF8] 4 } 3 | | | 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 | } 3 test utf-7.14.1 {Tcl_UtfPrev} {testutfprev testbytestring} { testutfprev A[testbytestring \xF8\xA0\xA0\xA0] 4 } 3 test utf-7.14.2 {Tcl_UtfPrev} {testutfprev testbytestring} { testutfprev A[testbytestring \xF8\xA0\xA0\xF8] 4 } 3 test utf-7.15 {Tcl_UtfPrev} {testutfprev testbytestring} { testutfprev A[testbytestring \xF2\xA0\xA0] } 1 test utf-7.15.1 {Tcl_UtfPrev} {testutfprev testbytestring} { testutfprev A[testbytestring \xF2\xA0\xA0\xA0] 4 } 1 test utf-7.15.2 {Tcl_UtfPrev} {testutfprev testbytestring} { testutfprev A[testbytestring \xF2\xA0\xA0\xF8] 4 |
︙ | ︙ | |||
710 711 712 713 714 715 716 | } 0 test utf-7.47.1 {Tcl_UtfPrev, pointing to 3th byte of 3-byte valid sequence} testutfprev { testutfprev 蠠 2 } 0 test utf-7.47.2 {Tcl_UtfPrev, pointing to 3th byte of 3-byte invalid sequence} {testutfprev testbytestring} { testutfprev [testbytestring \xE8\xA0\x00] 2 } 0 | | | 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 | } 0 test utf-7.47.1 {Tcl_UtfPrev, pointing to 3th byte of 3-byte valid sequence} testutfprev { testutfprev 蠠 2 } 0 test utf-7.47.2 {Tcl_UtfPrev, pointing to 3th byte of 3-byte invalid sequence} {testutfprev testbytestring} { testutfprev [testbytestring \xE8\xA0\x00] 2 } 0 test utf-7.48.0 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbytestring} { testutfprev A[testbytestring \xF4\x8F\xBF\xBF] } 1 test utf-7.48.1 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbytestring} { testutfprev A[testbytestring \xF4\x8F\xBF\xBF] 4 } 1 test utf-7.48.2 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbytestring} { testutfprev A[testbytestring \xF4\x8F\xBF\xBF] 3 |
︙ | ︙ | |||
1022 1023 1024 1025 1026 1027 1028 | } -cleanup { unset -nocomplain foo } -result {1 4} test utf-20.1 {TclUniCharNcmp} { string compare [string range [format %c 0xFFFF] 0 0] [string range [format %c 0x10000] 0 0] } -1 | | | 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 | } -cleanup { unset -nocomplain foo } -result {1 4} test utf-20.1 {TclUniCharNcmp} { string compare [string range [format %c 0xFFFF] 0 0] [string range [format %c 0x10000] 0 0] } -1 test utf-20.2 {[4c591fa487] Tcl_UniCharNcmp/Tcl_UtfNcmp} { set one [format %c 0xFFFF] set two [format %c 0x10000] set first [string compare $one $two] string range $one 0 0 string range $two 0 0 set second [string compare $one $two] expr {($first == $second) ? "agree" : "disagree"} |
︙ | ︙ |
Changes to tests/var.test.
︙ | ︙ | |||
1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 | test var-24.24 {array default unset: errors} -setup { unset -nocomplain ary } -body { array default unset ary x } -returnCodes error -cleanup { unset -nocomplain ary } -result * -match glob catch {namespace delete ns} catch {unset arr} catch {unset v} catch {rename getbytes ""} catch {rename p ""} | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 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 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 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 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 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 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 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 2192 2193 2194 2195 2196 2197 2198 2199 2200 2201 2202 2203 2204 2205 2206 2207 2208 2209 2210 2211 2212 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 2228 2229 2230 2231 2232 2233 2234 2235 2236 2237 2238 2239 2240 2241 2242 2243 2244 2245 2246 2247 2248 2249 2250 2251 2252 2253 2254 2255 2256 2257 2258 2259 2260 2261 2262 2263 2264 | test var-24.24 {array default unset: errors} -setup { unset -nocomplain ary } -body { array default unset ary x } -returnCodes error -cleanup { unset -nocomplain ary } -result * -match glob # The const command test var-25.1 {const: no argument} -body { apply {{} { const return $X }} } -returnCodes error -result {wrong # args: should be "const varName value"} test var-25.2 {const: single argument} -body { apply {{} { const X return $X }} } -returnCodes error -result {wrong # args: should be "const varName value"} test var-25.3 {const: two arguments (basic correct usage)} { apply {{} { set res [const X gorp] return [list $res $X] }} } {{} gorp} test var-25.4 {const: three arguments} -body { apply {{} { const X gorp foo return $X }} } -returnCodes error -result {wrong # args: should be "const varName value"} test var-25.5 {const: four arguments} -body { apply {{} { const X gorp foo bar return $X }} } -returnCodes error -result {wrong # args: should be "const varName value"} test var-26.1 {const: unmodifiable by set} -body { apply {{} { const X 123 set X gorp }} } -returnCodes error -result {can't set "X": variable is a constant} test var-26.2 {const: unmodifiable by append} -body { apply {{} { const X 123 append X gorp }} } -returnCodes error -result {can't set "X": variable is a constant} test var-26.3 {const: unmodifiable by lappend} -body { apply {{} { const X 123 lappend X gorp }} } -returnCodes error -result {can't set "X": variable is a constant} test var-26.4 {const: unmodifiable by incr} -body { apply {{} { const X 123 incr X }} } -returnCodes error -result {can't incr "X": variable is a constant} test var-26.5 {const: unmodifiable by dict set} -body { apply {{} { const X {a 123} dict set X a gorp }} } -returnCodes error -result {can't set "X": variable is a constant} test var-26.6 {const: unmodifiable by regsub} -body { apply {{} { const X abcabc regsub -all {a(.)} $X {\1\1} X }} } -returnCodes error -result {can't set "X": variable is a constant} test var-26.7 {const: unmodifiable by gets} -setup { set file [makeFile foo var26.7.txt] set f [open $file] } -body { apply {f { const X abcabc gets $f X }} $f } -returnCodes error -cleanup { close $f removeFile $file } -result {can't set "X": variable is a constant} test var-26.8 {const: may not be array} -body { apply {{} { array set X {a b} const X 1 return $X }} } -returnCodes error -result {can't make constant "X": variable is array} test var-26.9.1 {const: may not be array element} -body { apply {{} { array set X {a b} const X(a) 1 return $X(a) }} } -returnCodes error -result {can't make constant "X(a)": name refers to an element in an array} test var-26.9.2 {const: may not be array element} -body { apply {{} { array set X {a b} const X(b) 1 return $X(b) }} } -returnCodes error -result {can't make constant "X(b)": name refers to an element in an array} test var-26.10.1 {const: unmodifiable by const but not an error} { apply {{} { const X 1 const X 2 return $X }} } 1 test var-26.10.2 {const: unmodifiable by const but not an error} { apply {{} { lmap x {1 2 3} { const A 2 const B 3 const C 5 expr {$A * $x**2 + $B * $x + $C} } }} } {10 19 32} test var-26.11 {const: may not be unset} -body { apply {{} { const X 1 unset X }} } -returnCodes error -result {can't unset "X": variable is a constant} test var-26.12 {const: may not be unset, but -nocomplain doesn't complain} { apply {{} { const X 1 unset -nocomplain X return $X }} } 1 test var-26.13 {const and traces: write trace causes fail} -body { apply {{} { trace add variable X write {apply {args { error "ERR: $args" }}} const X gorp return $X }} } -returnCodes error -result {can't set "X": ERR: X {} write} test var-26.14 {const and traces: write trace err causes no const} -body { apply {{} { set trace {apply {args { error "ERR: $args" }}} trace add variable X write $trace catch { const X gorp } trace remove variable X write $trace set X 123 return $X }} } -result 123 test var-26.15 {const and traces: read traces} -setup { unset -nocomplain traces set traces {} } -body { apply {{} { trace add variable X read {apply {args { lappend ::traces $args }}} const X gorp list $X $X $::traces }} } -result {gorp gorp {{X {} read} {X {} read}}} -cleanup { unset -nocomplain traces } test var-26.16 {const and traces: write traces} -setup { unset -nocomplain traces set traces {} } -body { apply {{} { trace add variable X write {apply {args { lappend ::traces $args }}} const X gorp const X foo catch {set X bar} list $X $::traces }} } -result {gorp {{X {} write}}} -cleanup { unset -nocomplain traces } test var-26.17 {const and traces: unset traces} -setup { unset -nocomplain traces set traces {} } -body { list {*}[apply {{} { trace add variable X unset {apply {args { lappend ::traces $args }}} const X gorp unset -nocomplain X list $X $::traces }}] $traces } -result {gorp {} {{X {} unset}}} -cleanup { unset -nocomplain traces } # Same [const], but definitely not compiled test var-27.1 {const: unmodifiable by set} -body { apply {const { $const X 123 set X gorp }} const } -returnCodes error -result {can't set "X": variable is a constant} test var-27.2 {const: unmodifiable by append} -body { apply {const { $const X 123 append X gorp }} const } -returnCodes error -result {can't set "X": variable is a constant} test var-27.3 {const: unmodifiable by lappend} -body { apply {const { $const X 123 lappend X gorp }} const } -returnCodes error -result {can't set "X": variable is a constant} test var-27.4 {const: unmodifiable by incr} -body { apply {const { $const X 123 incr X }} const } -returnCodes error -result {can't incr "X": variable is a constant} test var-27.5 {const: unmodifiable by dict set} -body { apply {const { $const X {a 123} dict set X a gorp }} const } -returnCodes error -result {can't set "X": variable is a constant} test var-27.6 {const: unmodifiable by regsub} -body { apply {const { $const X abcabc regsub -all {a(.)} $X {\1\1} X }} const } -returnCodes error -result {can't set "X": variable is a constant} test var-27.7 {const: unmodifiable by gets} -setup { set file [makeFile foo var27.7.txt] set f [open $file] } -body { apply {{const f} { $const X abcabc gets $f X }} const $f } -returnCodes error -cleanup { close $f removeFile $file } -result {can't set "X": variable is a constant} test var-27.8 {const: may not be array} -body { apply {const { array set X {a b} $const X 1 return $X }} const } -returnCodes error -result {can't make constant "X": variable is array} test var-27.9.1 {const: may not be array element} -body { apply {const { array set X {a b} $const X(a) 1 return $X(a) }} const } -returnCodes error -result {can't make constant "X(a)": name refers to an element in an array} test var-27.9.2 {const: may not be array element} -body { apply {const { array set X {a b} $const X(b) 1 return $X(b) }} const } -returnCodes error -result {can't make constant "X(b)": name refers to an element in an array} test var-27.10.1 {const: unmodifiable by const but not an error} { apply {const { $const X 1 $const X 2 return $X }} const } 1 test var-27.10.2 {const: unmodifiable by const but not an error} { apply {const { lmap x {1 2 3} { $const A 2 $const B 3 $const C 5 expr {$A * $x**2 + $B * $x + $C} } }} const } {10 19 32} test var-27.11 {const: may not be unset} -body { apply {const { $const X 1 unset X }} const } -returnCodes error -result {can't unset "X": variable is a constant} test var-27.12 {const: may not be unset, but -nocomplain doesn't complain} { apply {const { $const X 1 unset -nocomplain X return $X }} const } 1 test var-27.13 {const and traces: write trace causes fail} -body { apply {const { trace add variable X write {apply {args { error "ERR: $args" }}} $const X gorp return $X }} const } -returnCodes error -result {can't set "X": ERR: X {} write} test var-27.14 {const and traces: write trace err causes no const} -body { apply {const { set trace {apply {args { error "ERR: $args" }}} trace add variable X write $trace catch { $const X gorp } trace remove variable X write $trace set X 123 return $X }} const } -result 123 test var-27.15 {const and traces: read traces} -setup { unset -nocomplain traces set traces {} } -body { apply {const { trace add variable X read {apply {args { lappend ::traces $args }}} $const X gorp list $X $X $::traces }} const } -result {gorp gorp {{X {} read} {X {} read}}} -cleanup { unset -nocomplain traces } test var-27.16 {const and traces: write traces} -setup { unset -nocomplain traces set traces {} } -body { apply {const { trace add variable X write {apply {args { lappend ::traces $args }}} $const X gorp $const X foo catch {set X bar} list $X $::traces }} const } -result {gorp {{X {} write}}} -cleanup { unset -nocomplain traces } test var-27.17 {const and traces: unset traces} -setup { unset -nocomplain traces set traces {} } -body { list {*}[apply {const { trace add variable X unset {apply {args { lappend ::traces $args }}} $const X gorp unset -nocomplain X list $X $::traces }} const] $traces } -result {gorp {} {{X {} unset}}} -cleanup { unset -nocomplain traces } test var-28.1 {const: in a namespace} -setup { namespace eval var28 {} } -body { namespace eval var28 { variable X const X gorp return $X } } -cleanup { namespace delete var28 } -result gorp test var-28.2 {const: in a namespace} -setup { namespace eval var28 {} } -body { namespace eval var28 { variable X const X gorp } apply {{} { variable X set X 123 } var28} } -cleanup { namespace delete var28 } -returnCodes error -result {can't set "X": variable is a constant} test var-28.3 {const: in a namespace} -setup { namespace eval var28 {} } -body { namespace eval var28 { variable X const X gorp } apply {{} { variable X unset X } var28} } -cleanup { namespace delete var28 } -returnCodes error -result {can't unset "X": variable is a constant} test var-28.4 {const: in a namespace} -setup { namespace eval var28 {} } -body { namespace eval var28 { variable X const X gorp } namespace delete var28 namespace eval var28 { variable X abc } apply {{} { variable X return $X } var28} } -cleanup { namespace delete var28 } -result abc test var-28.5 {const: in a namespace, direct access from proc} -setup { namespace eval var28 {} } -body { set result [apply {{} { const ::var28::X abc # Constant in namespace, NOT locally! info exists X }}] apply {res { variable X list $res [catch {unset X} msg] $msg $X } var28} $result } -cleanup { namespace delete var28 } -result {0 1 {can't unset "X": variable is a constant} abc} test var-29.1 {const: globally} -setup { set int [interp create] } -body { $int eval { const X gorp apply {{} { global X return $X }} } } -cleanup { interp delete $int } -result gorp test var-29.2 {const: TclOO variable resolution} -setup { oo::class create Parent } -body { oo::class create C { superclass Parent variable X constructor {} { const X 123 } method checkRead {} { return $X } method checkWrite {} { list [catch { set X abc } msg] $msg } method checkUnset {} { list [catch { unset X } msg] $msg } method checkProbe {} { info constant X } method checkList {} { info consts } } set c [C new] list [$c checkRead] [$c checkWrite] [$c checkUnset] [$c checkProbe] [$c checkList] } -cleanup { Parent destroy } -result {123 {1 {can't set "X": variable is a constant}} {1 {can't unset "X": variable is a constant}} 1 X} test var-29.3 {const: TclOO variable resolution} -setup { oo::class create Parent } -body { oo::class create C { superclass Parent private variable X constructor {} { const X 123 } method checkRead {} { return $X } method checkWrite {} { list [catch { set X abc } msg] $msg } method checkUnset {} { list [catch { unset X } msg] $msg } method checkProbe {} { info constant X } method checkList {} { info consts } } set c [C new] list [$c checkRead] [$c checkWrite] [$c checkUnset] [$c checkProbe] [$c checkList] } -cleanup { Parent destroy } -result {123 {1 {can't set "X": variable is a constant}} {1 {can't unset "X": variable is a constant}} 1 X} test var-29.4 {const: TclOO variable resolution} -setup { oo::class create Parent } -body { oo::class create C { superclass Parent variable X constructor {} { set X 123 } method checkRead {} { return $X } method checkWrite {} { list [catch { set X abc } msg] $msg } method checkUnset {} { list [catch { unset X set X gorp } msg] $msg } method checkProbe {} { info constant X } method checkList {} { info consts } } set c [C new] list [$c checkRead] [$c checkWrite] [$c checkUnset] [$c checkProbe] [$c checkList] } -cleanup { Parent destroy } -result {123 {0 abc} {0 gorp} 0 {}} test var-29.5 {const: TclOO variable resolution} -setup { set c [oo::object create Instance] } -body { oo::objdefine $c { variable X method init {} { const X 123 } method checkRead {} { return $X } method checkWrite {} { list [catch { set X abc } msg] $msg } method checkUnset {} { list [catch { unset X } msg] $msg } method checkProbe {} { info constant X } method checkList {} { info consts } } $c init list [$c checkRead] [$c checkWrite] [$c checkUnset] [$c checkProbe] [$c checkList] } -cleanup { Instance destroy } -result {123 {1 {can't set "X": variable is a constant}} {1 {can't unset "X": variable is a constant}} 1 X} test var-29.6 {const: TclOO variable resolution} -setup { set c [oo::object create Instance] } -body { oo::objdefine $c { private variable X method init {} { const X 123 } method checkRead {} { return $X } method checkWrite {} { list [catch { set X abc } msg] $msg } method checkUnset {} { list [catch { unset X } msg] $msg } method checkProbe {} { info constant X } method checkList {} { info consts } } $c init list [$c checkRead] [$c checkWrite] [$c checkUnset] [$c checkProbe] [$c checkList] } -cleanup { Instance destroy } -result {123 {1 {can't set "X": variable is a constant}} {1 {can't unset "X": variable is a constant}} 1 X} test var-29.7 {const: TclOO variable resolution} -setup { set c [oo::object create Instance] } -body { oo::objdefine $c { variable X method init {} { set X 123 } method checkRead {} { return $X } method checkWrite {} { list [catch { set X abc } msg] $msg } method checkUnset {} { list [catch { unset X set X gorp } msg] $msg } method checkProbe {} { info constant X } method checkList {} { info consts } } $c init list [$c checkRead] [$c checkWrite] [$c checkUnset] [$c checkProbe] [$c checkList] } -cleanup { Instance destroy } -result {123 {0 abc} {0 gorp} 0 {}} # The info constant and info consts commands test var-30.1 {info constant and info consts} { apply {{} { lappend consts [lsort [info consts]] [info constant X] const X 1 lappend consts [lsort [info consts]] [info constant X] const Y 2 lappend consts [lsort [info consts]] const X 3 lappend consts [lsort [info consts]] }} } {{} 0 X 1 {X Y} {X Y}} test var-30.2 {info constant and info consts} { apply {{} { lappend consts [lsort [info consts X]] const X 1 lappend consts [lsort [info consts X]] const Y 2 lappend consts [lsort [info consts X]] const X 3 lappend consts [lsort [info consts X]] }} } {{} X X X} test var-30.3 {info constant and info consts} { apply {{} { lappend consts [lsort [info consts ?]] const X 1 lappend consts [lsort [info consts ?]] const Y 2 lappend consts [lsort [info consts ?]] const XX 3 lappend consts [lsort [info consts ?]] }} } {{} X {X Y} {X Y}} test var-30.4 {info constant and info consts} { apply {{} { lappend consts [lsort [info consts X]] set X 1 lappend consts [lsort [info consts X]] set Y 2 lappend consts [lsort [info consts X]] set X 3 lappend consts [lsort [info consts X]] }} } {{} {} {} {}} test var-30.5 {info consts: in a namespace} -setup { namespace eval var30 {} } -body { namespace eval var30 { const X gorp info consts } } -cleanup { namespace delete var30 } -result X test var-30.6 {info consts: in a namespace} -setup { namespace eval var30 {} } -body { namespace eval var30 { const X gorp variable Y foo } info consts var30::* } -cleanup { namespace delete var30 } -result ::var30::X test var-30.7 {info constant: bad constant names: array element} { apply {{} { info constant a(b) }} } 0 test var-30.8 {info constant: bad constant names: array} { apply {{} { array set a {} info constant a }} } 0 test var-30.9 {info constant: bad constant names: no var} { apply {{} { info constant a }} } 0 test var-30.10 {info constant: bad constant names: no namespace} { apply {{} { info constant ::var29::no::such::ns::a }} } 0 test var-30.11 {info constant: bad constant names: dangling upvar} { apply {{} { upvar 0 no_var a info constant a }} } 0 test var-30.12 {info constant: bad constant names: bad name} { apply {{} { info constant a(b }} } 0 test var-30.13 {info constant: bad constant names: nesting} { apply {{} { array set b {c d} upvar 0 b(c) a info constant a(d) }} } 0 test var-31.1 {info constant: syntax} -returnCodes error -body { info constant } -result {wrong # args: should be "info constant varName"} test var-31.2 {info constant: syntax} -returnCodes error -body { info constant foo bar } -result {wrong # args: should be "info constant varName"} test var-31.3 {info consts: syntax} -returnCodes error -body { info consts foo bar } -result {wrong # args: should be "info consts ?pattern?"} catch {namespace delete ns} catch {unset arr} catch {unset v} catch {rename getbytes ""} catch {rename p ""} |
︙ | ︙ |
Changes to tests/winPipe.test.
︙ | ︙ | |||
314 315 316 317 318 319 320 | puts -nonewline $f $big$big$big$big flush $f after 100 { lappend x timeout } vwait x lappend x [catch {close $f} msg] $msg } {writable timeout 0 {}} | | > | | | | | | | | | > | > > > > > > > < < < < | 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 | puts -nonewline $f $big$big$big$big flush $f after 100 { lappend x timeout } vwait x lappend x [catch {close $f} msg] $msg } {writable timeout 0 {}} proc _testExecArgs {flags args} { variable path if {![info exists path(echoArgs.tcl)] || ![file exists $path(echoArgs.tcl)]} { set path(echoArgs.tcl) [makeFile { puts "[list [file tail $argv0] {*}$argv]" } echoArgs.tcl] } if {![info exists path(echoArgs.bat)] || ![file exists $path(echoArgs.bat)]} { set path(echoArgs.bat) [makeFile "@[file native [interpreter]] $path(echoArgs.tcl) %*" "echoArgs.bat"] } set cmds [list [list [interpreter] $path(echoArgs.tcl)]] if {"exe-only" ni $flags} { if {"batch2" ni $flags} { lappend cmds [list $path(echoArgs.bat)] } else { if {![info exists path(echoArgs2.bat)] || ![file exists $path(echoArgs2.bat)]} { set path(echoArgs2.bat) [makeFile \ "@[file native [interpreter]] $path(echoArgs.tcl) %*" \ "echo(Cmd)Test Args & Batch.bat" [makeDirectory test(Dir)Check]] } lappend cmds [list $path(echoArgs2.bat)] } } set broken {} foreach args $args { if {"enclose" in $flags} { # enclose single test-arg between 1st/3rd to be sure nothing is truncated # (e. g. to cover unexpected trim by nts-zero case, and args don't recombined): set args [list "1st" $args "3rd"] } set args [list {*}$args]; # normalized canonical list foreach cmd $cmds { set e [linsert $args 0 [file tail $path(echoArgs.tcl)]] tcltest::DebugPuts 4 " ## test exec [file extension [lindex $cmd 0]] ($cmd) for\n ## $args" if {[catch { exec {*}$cmd {*}$args } r]} { set r "ERROR: $r" } if {[file extension [lindex $cmd 0]] eq ".bat"} { set evm {}; foreach ev [lsort -unique [regexp -inline -all {%[A-Z]+%} $e]] { set ev [string range $ev 1 end-1] if {[info exists ::env($ev)]} { lappend evm %$ev% $::env($ev) } } set e [string map $evm $e] } if {$r ne $e} { append broken "\[ERROR\]: exec [file extension [lindex $cmd 0]] on $args\n -- result:\n$r\n -- expected:\n$e\n" } } } return $broken } ### validate the raw output of BuildCommandLine(). ### |
︙ | ︙ | |||
490 491 492 493 494 495 496 | {test" %USERDOMAIN%\\&\\"test} } ### validate the pass-thru from BuildCommandLine() to the crt's parse_cmdline(). ### test winpipe-8.1 {BuildCommandLine/parse_cmdline pass-thru: dumped arguments are equal original} \ -constraints {win exec} -body { | | | 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 | {test" %USERDOMAIN%\\&\\"test} } ### validate the pass-thru from BuildCommandLine() to the crt's parse_cmdline(). ### test winpipe-8.1 {BuildCommandLine/parse_cmdline pass-thru: dumped arguments are equal original} \ -constraints {win exec} -body { _testExecArgs {} \ [list foo "" bar] \ [list foo {} bar] \ [list foo "\"" bar] \ [list foo {""} bar] \ [list foo "\" " bar] \ [list foo {a="b"} bar] \ [list foo {a = "b"} bar] \ |
︙ | ︙ | |||
514 515 516 517 518 519 520 | [list foo \{ bar] \ [list foo \} bar] \ [list foo * makefile.?c bar] } -result {} test winpipe-8.2 {BuildCommandLine/parse_cmdline pass-thru: check injection on special meta-chars (particular)} \ -constraints {win exec slowTest} -body { | | | | | 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 | [list foo \{ bar] \ [list foo \} bar] \ [list foo * makefile.?c bar] } -result {} test winpipe-8.2 {BuildCommandLine/parse_cmdline pass-thru: check injection on special meta-chars (particular)} \ -constraints {win exec slowTest} -body { _testExecArgs enclose {*}$injectList } -result {} test winpipe-8.3 {BuildCommandLine/parse_cmdline pass-thru: check injection on special meta-chars (jointly)} \ -constraints {win exec notWine} -body { _testExecArgs {} \ [list START {*}$injectList END] \ [list "START\"" {*}$injectList END] \ [list START {*}$injectList "\"END"] \ [list "START\"" {*}$injectList "\"END"] } -result {} test winpipe-8.4 {BuildCommandLine/parse_cmdline pass-thru: check injection on special meta-chars (command/jointly args)} \ -constraints {win exec notWine} -body { _testExecArgs batch2 \ [list START {*}$injectList END] \ [list "START\"" {*}$injectList END] \ [list START {*}$injectList "\"END"] \ [list "START\"" {*}$injectList "\"END"] } -result {} test winpipe-8.5 {BuildCommandLine/parse_cmdline pass-thru: check injection on special meta-chars (random mix)} \ |
︙ | ︙ | |||
560 561 562 563 564 565 566 | while {[string length $a] < 50} { append a [string index $map [expr {int(rand()*[string length $map])}]] } lappend args $a } 20 lappend lst $args } 10 | | | | | 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 | while {[string length $a] < 50} { append a [string index $map [expr {int(rand()*[string length $map])}]] } lappend args $a } 20 lappend lst $args } 10 _testExecArgs {} {*}$lst } -result {} -cleanup { unset -nocomplain lst args a map maps } set injectList { "test\"\nwhoami" "test\"\"\nwhoami" "test\"\"\"\nwhoami" "test\"\"\"\"\nwhoami" "test;\n&echo \"" "\"test;\n&echo \"" "test\";\n&echo \"" "\"test\";\n&echo \"" "\"\"test\";\n&echo \"" } test winpipe-8.6 {BuildCommandLine/parse_cmdline pass-thru: check new-line quoted in args} \ -constraints {win exec} -body { # test exe only, because currently there is no proper way to escape a new-line char resp. # to supply a new-line to the batch-files within arguments (command line is truncated). _testExecArgs exe-only \ [list START {*}$injectList END] \ [list "START\"" {*}$injectList END] \ [list START {*}$injectList "\"END"] \ [list "START\"" {*}$injectList "\"END"] } -result {} test winpipe-8.7 {BuildCommandLine/parse_cmdline pass-thru: check new-line quoted in args (batch)} \ -constraints {win exec knownBug} -body { # this will fail if executed batch-file, because currently there is no proper way to escape a new-line char. _testExecArgs {} $injectList } -result {} rename _testExecArgs {} # restore old values for env(TMP) and env(TEMP) |
︙ | ︙ |
Changes to tools/genStubs.tcl.
︙ | ︙ | |||
807 808 809 810 811 812 813 | append text [addPlatformGuard $plat $temp] set emit 1 } ## aqua ## set temp {} set plat aqua if {!$slot(unix) && !$slot(macosx)} { | < < < < < < < < < < < < < < < | 807 808 809 810 811 812 813 814 815 816 817 818 819 820 | append text [addPlatformGuard $plat $temp] set emit 1 } ## aqua ## set temp {} set plat aqua if {!$slot(unix) && !$slot(macosx)} { if {$slot($plat)} { append temp [$slotProc $name $stubs($name,$plat,$i) $i] } elseif {$onAll} { eval {append temp} $skipString } } if {$temp ne ""} { |
︙ | ︙ |
Changes to tools/tcltk-man2html.tcl.
︙ | ︙ | |||
574 575 576 577 578 579 580 | return $result } ## ## Set up some special cases. It would be nice if we didn't have them, ## but we do... ## | | | 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 | return $result } ## ## Set up some special cases. It would be nice if we didn't have them, ## but we do... ## set excluded_pages {} set forced_index_pages {GetDash} set process_first_patterns {*/ttk_widget.n */options.n} set ensemble_commands { after array binary chan clock dde dict encoding file history info interp memory namespace package registry self string trace update zlib clipboard console font grab grid image option pack place selection tk tkwait ttk::style winfo wm itcl::delete itcl::find itcl::is |
︙ | ︙ |
Changes to unix/Makefile.in.
︙ | ︙ | |||
2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 | # The following target generates the file generic/tclDate.c from the yacc # grammar found in generic/tclGetDate.y. This is only run by hand as yacc is # not available in all environments. The name of the .c file is different than # the name of the .y file so that make doesn't try to automatically regenerate # the .c file. gendate: bison --output-file=$(GENERIC_DIR)/tclDate.c \ --no-lines \ --name-prefix=TclDate \ $(GENERIC_DIR)/tclGetDate.y # yacc -l $(GENERIC_DIR)/tclGetDate.y | > > | 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 | # The following target generates the file generic/tclDate.c from the yacc # grammar found in generic/tclGetDate.y. This is only run by hand as yacc is # not available in all environments. The name of the .c file is different than # the name of the .y file so that make doesn't try to automatically regenerate # the .c file. # # Remark: see [54a305cb88]. tclDate.c is manually edited, removing the unused "yynerrs" variable gendate: bison --output-file=$(GENERIC_DIR)/tclDate.c \ --no-lines \ --name-prefix=TclDate \ $(GENERIC_DIR)/tclGetDate.y # yacc -l $(GENERIC_DIR)/tclGetDate.y |
︙ | ︙ | |||
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 | @echo cp -r $(TOP_DIR)/libtommath $(DISTDIR)/libtommath @( cd $(TOP_DIR)/libtommath; find . -type f -print ) \ | ( cd $(TOP_DIR)/libtommath ; xargs tar cf - ) \ | ( cd $(DISTDIR)/libtommath ; tar xfp - ) $(INSTALL_DATA_DIR) $(DISTDIR)/tests $(DIST_INSTALL_DATA) $(TOP_DIR)/license.terms $(DISTDIR)/tests $(DIST_INSTALL_DATA) $(TOP_DIR)/tests/*.test $(TOP_DIR)/tests/README \ $(TOP_DIR)/tests/httpd $(TOP_DIR)/tests/*.tcl \ $(TOP_DIR)/tests/auto-files.zip $(DISTDIR)/tests @mkdir $(DISTDIR)/tests/auto0 for i in auto1 auto2 ; \ do \ $(INSTALL_DATA_DIR) $(DISTDIR)/tests/auto0/$$i ;\ $(DIST_INSTALL_DATA) $(TOP_DIR)/tests/auto0/$$i/tclIndex $(TOP_DIR)/tests/auto0/$$i/*.tcl \ $(DISTDIR)/tests/auto0/$$i; \ done; for i in modules modules/mod1 modules/mod2 ; \ do \ $(INSTALL_DATA_DIR) $(DISTDIR)/tests/auto0/$$i ;\ $(DIST_INSTALL_DATA) $(TOP_DIR)/tests/auto0/$$i/*.tm \ $(DISTDIR)/tests/auto0/$$i; \ done; $(INSTALL_DATA_DIR) $(DISTDIR)/win $(DIST_INSTALL_DATA) $(TOP_DIR)/win/Makefile.in $(DISTDIR)/win $(DIST_INSTALL_DATA) $(TOP_DIR)/win/configure.ac \ $(TOP_DIR)/win/tclConfig.sh.in $(TOP_DIR)/win/tclooConfig.sh \ $(TOP_DIR)/win/tcl.m4 $(TOP_DIR)/win/aclocal.m4 \ $(TOP_DIR)/win/tclsh.exe.manifest.in $(TOP_DIR)/win/tclUuid.h.in \ $(TOP_DIR)/win/gitmanifest.in $(TOP_DIR)/win/svnmanifest.in \ | > > > > > > > > > > > | 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 | @echo cp -r $(TOP_DIR)/libtommath $(DISTDIR)/libtommath @( cd $(TOP_DIR)/libtommath; find . -type f -print ) \ | ( cd $(TOP_DIR)/libtommath ; xargs tar cf - ) \ | ( cd $(DISTDIR)/libtommath ; tar xfp - ) $(INSTALL_DATA_DIR) $(DISTDIR)/tests $(DIST_INSTALL_DATA) $(TOP_DIR)/license.terms $(DISTDIR)/tests $(DIST_INSTALL_DATA) $(TOP_DIR)/tests/*.test $(TOP_DIR)/tests/README \ $(TOP_DIR)/tests/*.bench $(TOP_DIR)/tests/*.tar.gz \ $(TOP_DIR)/tests/httpd $(TOP_DIR)/tests/*.tcl \ $(TOP_DIR)/tests/auto-files.zip $(DISTDIR)/tests @mkdir $(DISTDIR)/tests/auto0 for i in auto1 auto2 ; \ do \ $(INSTALL_DATA_DIR) $(DISTDIR)/tests/auto0/$$i ;\ $(DIST_INSTALL_DATA) $(TOP_DIR)/tests/auto0/$$i/tclIndex $(TOP_DIR)/tests/auto0/$$i/*.tcl \ $(DISTDIR)/tests/auto0/$$i; \ done; for i in modules modules/mod1 modules/mod2 ; \ do \ $(INSTALL_DATA_DIR) $(DISTDIR)/tests/auto0/$$i ;\ $(DIST_INSTALL_DATA) $(TOP_DIR)/tests/auto0/$$i/*.tm \ $(DISTDIR)/tests/auto0/$$i; \ done; @mkdir $(DISTDIR)/tests/zipfiles $(INSTALL_DATA_DIR) $(DISTDIR)/tests/zipfiles $(DIST_INSTALL_DATA) $(TOP_DIR)/tests/zipfiles/*.zip \ $(DISTDIR)/tests/zipfiles $(DIST_INSTALL_DATA) $(TOP_DIR)/tests/zipfiles/README \ $(DISTDIR)/tests/zipfiles $(DIST_INSTALL_DATA) $(TOP_DIR)/tests/zipfiles/LICENSE-libzip \ $(DISTDIR)/tests/zipfiles $(INSTALL_DATA_DIR) $(DISTDIR)/tests-perf $(DIST_INSTALL_DATA) $(TOP_DIR)/tests-perf/*.tcl $(DISTDIR)/tests-perf $(INSTALL_DATA_DIR) $(DISTDIR)/win $(DIST_INSTALL_DATA) $(TOP_DIR)/win/Makefile.in $(DISTDIR)/win $(DIST_INSTALL_DATA) $(TOP_DIR)/win/configure.ac \ $(TOP_DIR)/win/tclConfig.sh.in $(TOP_DIR)/win/tclooConfig.sh \ $(TOP_DIR)/win/tcl.m4 $(TOP_DIR)/win/aclocal.m4 \ $(TOP_DIR)/win/tclsh.exe.manifest.in $(TOP_DIR)/win/tclUuid.h.in \ $(TOP_DIR)/win/gitmanifest.in $(TOP_DIR)/win/svnmanifest.in \ |
︙ | ︙ | |||
2387 2388 2389 2390 2391 2392 2393 | $(MAC_OSX_DIR)/Tcl.xcodeproj/default.pbxuser \ $(DISTDIR)/macosx/Tcl.xcodeproj $(INSTALL_DATA_DIR) $(DISTDIR)/unix/dltest $(DIST_INSTALL_DATA) $(UNIX_DIR)/dltest/*.c $(UNIX_DIR)/dltest/Makefile.in \ $(UNIX_DIR)/dltest/README $(DISTDIR)/unix/dltest $(INSTALL_DATA_DIR) $(DISTDIR)/tools $(DIST_INSTALL_DATA) $(TOOL_DIR)/README $(TOOL_DIR)/*.c $(TOOL_DIR)/*.svg \ | | | | 2400 2401 2402 2403 2404 2405 2406 2407 2408 2409 2410 2411 2412 2413 2414 2415 | $(MAC_OSX_DIR)/Tcl.xcodeproj/default.pbxuser \ $(DISTDIR)/macosx/Tcl.xcodeproj $(INSTALL_DATA_DIR) $(DISTDIR)/unix/dltest $(DIST_INSTALL_DATA) $(UNIX_DIR)/dltest/*.c $(UNIX_DIR)/dltest/Makefile.in \ $(UNIX_DIR)/dltest/README $(DISTDIR)/unix/dltest $(INSTALL_DATA_DIR) $(DISTDIR)/tools $(DIST_INSTALL_DATA) $(TOOL_DIR)/README $(TOOL_DIR)/*.c $(TOOL_DIR)/*.svg \ $(TOOL_DIR)/*.tcl $(TOOL_DIR)/*.bmp $(TOOL_DIR)/valgrind_suppress \ $(TOOL_DIR)/valgrind_check_success $(DISTDIR)/tools chmod 755 $(DISTDIR)/tools/checkLibraryDoc.tcl \ $(DISTDIR)/tools/findBadExternals.tcl \ $(DISTDIR)/tools/loadICU.tcl \ $(DISTDIR)/tools/makeTestCases.tcl $(DISTDIR)/tools/tclZIC.tcl \ $(DISTDIR)/tools/tcltk-man2html.tcl $(INSTALL_DATA_DIR) $(DISTDIR)/pkgs $(DIST_INSTALL_DATA) $(TOP_DIR)/pkgs/README $(DISTDIR)/pkgs |
︙ | ︙ | |||
2415 2416 2417 2418 2419 2420 2421 | gzip -9 $(DISTNAME)-src.tar; \ zip -qr8 $(ZIPNAME) $(DISTNAME) ) #-------------------------------------------------------------------------- # This target creates the HTML folder for Tcl & Tk and places it in # DISTDIR/html. It uses the tcltk-man2html.tcl tool from the Tcl group's tool # workspace. It depends on the Tcl & Tk being in directories called tcl9.* & | | | 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 2440 2441 2442 | gzip -9 $(DISTNAME)-src.tar; \ zip -qr8 $(ZIPNAME) $(DISTNAME) ) #-------------------------------------------------------------------------- # This target creates the HTML folder for Tcl & Tk and places it in # DISTDIR/html. It uses the tcltk-man2html.tcl tool from the Tcl group's tool # workspace. It depends on the Tcl & Tk being in directories called tcl9.* & # tk9.* up two directories from the TOOL_DIR. # # Note that for platforms where this is important, it is more common to use a # build of this HTML documentation that has already been placed online. As # such, this rule is not guaranteed to work well on all systems; it only needs # to function on those of the Tcl/Tk maintainers. # # Also note that the 8.6 tool build requires an installed 8.6 native Tcl |
︙ | ︙ |
Changes to unix/configure.
︙ | ︙ | |||
8086 8087 8088 8089 8090 8091 8092 | case $ac_cv_c_bigendian in #( yes) printf "%s\n" "#define WORDS_BIGENDIAN 1" >>confdefs.h ;; #( no) ;; #( universal) | | < < | 8086 8087 8088 8089 8090 8091 8092 8093 8094 8095 8096 8097 8098 8099 8100 | case $ac_cv_c_bigendian in #( yes) printf "%s\n" "#define WORDS_BIGENDIAN 1" >>confdefs.h ;; #( no) ;; #( universal) # ;; #( *) as_fn_error $? "unknown endianness presetting ac_cv_c_bigendian=no (or yes) will help" "$LINENO" 5 ;; esac |
︙ | ︙ | |||
11211 11212 11213 11214 11215 11216 11217 | } ' DEFS=`sed -n "$ac_script" confdefs.h` CFLAGS="${CFLAGS} ${CPPFLAGS}"; CPPFLAGS="" | < | 11209 11210 11211 11212 11213 11214 11215 11216 11217 11218 11219 11220 11221 11222 | } ' DEFS=`sed -n "$ac_script" confdefs.h` CFLAGS="${CFLAGS} ${CPPFLAGS}"; CPPFLAGS="" : "${CONFIG_STATUS=./config.status}" ac_write_fail=0 ac_clean_files_save=$ac_clean_files ac_clean_files="$ac_clean_files $CONFIG_STATUS" { printf "%s\n" "$as_me:${as_lineno-$LINENO}: creating $CONFIG_STATUS" >&5 printf "%s\n" "$as_me: creating $CONFIG_STATUS" >&6;} |
︙ | ︙ |
Changes to unix/configure.ac.
︙ | ︙ | |||
215 216 217 218 219 220 221 | SC_TCL_64BIT_FLAGS #-------------------------------------------------------------------- # Check endianness because we can optimize comparisons of # Tcl_UniChar strings to memcmp on big-endian systems. #-------------------------------------------------------------------- | | | 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 | SC_TCL_64BIT_FLAGS #-------------------------------------------------------------------- # Check endianness because we can optimize comparisons of # Tcl_UniChar strings to memcmp on big-endian systems. #-------------------------------------------------------------------- AC_C_BIGENDIAN(,,,[#]) #-------------------------------------------------------------------- # Supply substitutes for missing POSIX library procedures, or # set flags so Tcl uses alternate procedures. #-------------------------------------------------------------------- # Check if Posix compliant getcwd exists, if not we'll use getwd. |
︙ | ︙ |
Changes to unix/tcl.m4.
︙ | ︙ | |||
222 223 224 225 226 227 228 | if test x"${ac_cv_c_tkconfig}" = x ; then for i in `ls -d ${libdir} 2>/dev/null` \ `ls -d ${exec_prefix}/lib 2>/dev/null` \ `ls -d ${prefix}/lib 2>/dev/null` \ `ls -d /usr/local/lib 2>/dev/null` \ `ls -d /usr/contrib/lib 2>/dev/null` \ `ls -d /usr/pkg/lib 2>/dev/null` \ | | | | | 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 | if test x"${ac_cv_c_tkconfig}" = x ; then for i in `ls -d ${libdir} 2>/dev/null` \ `ls -d ${exec_prefix}/lib 2>/dev/null` \ `ls -d ${prefix}/lib 2>/dev/null` \ `ls -d /usr/local/lib 2>/dev/null` \ `ls -d /usr/contrib/lib 2>/dev/null` \ `ls -d /usr/pkg/lib 2>/dev/null` \ `ls -d /usr/lib/tk9.0 2>/dev/null` \ `ls -d /usr/lib 2>/dev/null` \ `ls -d /usr/lib64 2>/dev/null` \ `ls -d /usr/local/lib/tk9.0 2>/dev/null` \ `ls -d /usr/local/lib/tcl/tk9.0 2>/dev/null` \ ; do if test -f "$i/tkConfig.sh" ; then ac_cv_c_tkconfig="`(cd $i; pwd)`" break fi done fi |
︙ | ︙ |
Changes to unix/tclConfig.h.in.
1 2 3 4 5 6 | /* ../unix/tclConfig.h.in. Generated from configure.ac by autoheader. */ #ifndef _TCLCONFIG #define _TCLCONFIG | < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 | /* ../unix/tclConfig.h.in. Generated from configure.ac by autoheader. */ #ifndef _TCLCONFIG #define _TCLCONFIG /* Is gettimeofday() actually declared in <sys/time.h>? */ #undef GETTOD_NOT_DECLARED /* Define to 1 if you have the <AvailabilityMacros.h> header file. */ #undef HAVE_AVAILABILITYMACROS_H /* Define to 1 if the system has the type `blkcnt_t'. */ |
︙ | ︙ |
Changes to unix/tclUnixChan.c.
︙ | ︙ | |||
815 816 817 818 819 820 821 | */ tcgetattr(fsPtr->fileState.fd, &iostate); CLEAR_BITS(iostate.c_iflag, IXON | IXOFF | IXANY); #ifdef CRTSCTS CLEAR_BITS(iostate.c_cflag, CRTSCTS); #endif /* CRTSCTS */ | | | | | | 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 | */ tcgetattr(fsPtr->fileState.fd, &iostate); CLEAR_BITS(iostate.c_iflag, IXON | IXOFF | IXANY); #ifdef CRTSCTS CLEAR_BITS(iostate.c_cflag, CRTSCTS); #endif /* CRTSCTS */ if (strncasecmp(value, "NONE", vlen) == 0) { /* * Leave all handshake options disabled. */ } else if (strncasecmp(value, "XONXOFF", vlen) == 0) { SET_BITS(iostate.c_iflag, IXON | IXOFF | IXANY); } else if (strncasecmp(value, "RTSCTS", vlen) == 0) { #ifdef CRTSCTS SET_BITS(iostate.c_cflag, CRTSCTS); #else /* !CRTSTS */ UNSUPPORTED_OPTION("-handshake RTSCTS"); return TCL_ERROR; #endif /* CRTSCTS */ } else if (strncasecmp(value, "DTRDSR", vlen) == 0) { UNSUPPORTED_OPTION("-handshake DTRDSR"); return TCL_ERROR; } else { if (interp) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "bad value for -handshake: must be one of" " xonxoff, rtscts, dtrdsr or none", -1)); |
︙ | ︙ | |||
936 937 938 939 940 941 942 | 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; } | | | | | 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 | 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 (strncasecmp(argv[i], "DTR", strlen(argv[i])) == 0) { if (flag) { SET_BITS(control, TIOCM_DTR); } else { CLEAR_BITS(control, TIOCM_DTR); } } else if (strncasecmp(argv[i], "RTS", strlen(argv[i])) == 0) { if (flag) { SET_BITS(control, TIOCM_RTS); } else { CLEAR_BITS(control, TIOCM_RTS); } } else if (strncasecmp(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 */ |
︙ | ︙ | |||
986 987 988 989 990 991 992 | } /* * Option -closemode drain|discard */ if ((len > 2) && (strncmp(optionName, "-closemode", len) == 0)) { | | | | | 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 | } /* * Option -closemode drain|discard */ if ((len > 2) && (strncmp(optionName, "-closemode", len) == 0)) { if (strncasecmp(value, "DEFAULT", vlen) == 0) { fsPtr->closeMode = CLOSE_DEFAULT; } else if (strncasecmp(value, "DRAIN", vlen) == 0) { fsPtr->closeMode = CLOSE_DRAIN; } else if (strncasecmp(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", |
︙ | ︙ | |||
1018 1019 1020 1021 1022 1023 1024 | if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't read serial terminal control state: %s", Tcl_PosixError(interp))); } return TCL_ERROR; } | | | | | | 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 | if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't read serial terminal control state: %s", Tcl_PosixError(interp))); } return TCL_ERROR; } if (strncasecmp(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 (strncasecmp(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 (strncasecmp(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 (strncasecmp(value, "RESET", vlen) == 0) { /* * Reset to the initial state, whatever that is. */ memcpy(&iostate, &fsPtr->initState, sizeof(struct termios)); } else { if (interp) { |
︙ | ︙ | |||
1209 1210 1211 1212 1213 1214 1215 | if (len==0 || (len>1 && strncmp(optionName, "-xchar", len)==0)) { Tcl_DString ds; valid = 1; tcgetattr(fsPtr->fileState.fd, &iostate); Tcl_DStringInit(&ds); | | | | 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 | if (len==0 || (len>1 && strncmp(optionName, "-xchar", len)==0)) { Tcl_DString ds; valid = 1; tcgetattr(fsPtr->fileState.fd, &iostate); Tcl_DStringInit(&ds); TclSystemToInternalEncoding(NULL, (char *) &iostate.c_cc[VSTART], 1, &ds); Tcl_DStringAppendElement(dsPtr, Tcl_DStringValue(&ds)); TclDStringClear(&ds); TclSystemToInternalEncoding(NULL, (char *) &iostate.c_cc[VSTOP], 1, &ds); Tcl_DStringAppendElement(dsPtr, Tcl_DStringValue(&ds)); Tcl_DStringFree(&ds); } if (len == 0) { Tcl_DStringEndSublist(dsPtr); } |
︙ | ︙ | |||
1288 1289 1290 1291 1292 1293 1294 | } #endif /* TIOCGWINSZ */ if (valid) { return TCL_OK; } return Tcl_BadChannelOption(interp, optionName, | | | 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 | } #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 |
︙ | ︙ | |||
1902 1903 1904 1905 1906 1907 1908 | int mode) /* OR'ed 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; | | | | 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 | int mode) /* OR'ed 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; Tcl_StatBuf buf; if (mode == 0) { return NULL; } #ifdef SUPPORTS_TTY if (isatty(fd)) { channelTypePtr = &ttyChannelType; snprintf(channelName, sizeof(channelName), "serial%d", fd); } else #endif /* SUPPORTS_TTY */ if (TclOSfstat(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 |
︙ | ︙ |
Changes to unix/tclUnixFCmd.c.
︙ | ︙ | |||
1506 1507 1508 1509 1510 1511 1512 | Tcl_Obj *fileName, /* The name of the file (UTF-8). */ Tcl_Obj *attributePtr) /* New group for file. */ { Tcl_WideInt gid; int result; const char *native; | | | 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 | Tcl_Obj *fileName, /* The name of the file (UTF-8). */ Tcl_Obj *attributePtr) /* New group for file. */ { Tcl_WideInt gid; int result; const char *native; if (TclGetWideIntFromObj(NULL, attributePtr, &gid) != TCL_OK) { Tcl_DString ds; struct group *groupPtr = NULL; const char *string; Tcl_Size length; string = Tcl_GetStringFromObj(attributePtr, &length); |
︙ | ︙ | |||
1577 1578 1579 1580 1581 1582 1583 | Tcl_Obj *fileName, /* The name of the file (UTF-8). */ Tcl_Obj *attributePtr) /* New owner for file. */ { Tcl_WideInt uid; int result; const char *native; | | | 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 | Tcl_Obj *fileName, /* The name of the file (UTF-8). */ Tcl_Obj *attributePtr) /* New owner for file. */ { Tcl_WideInt uid; int result; const char *native; if (TclGetWideIntFromObj(NULL, attributePtr, &uid) != TCL_OK) { Tcl_DString ds; struct passwd *pwPtr = NULL; const char *string; Tcl_Size length; string = Tcl_GetStringFromObj(attributePtr, &length); |
︙ | ︙ | |||
1663 1664 1665 1666 1667 1668 1669 | && (modeStringPtr[scanned+1] >= '0') && (modeStringPtr[scanned+1] <= '7')) { /* Leading zero - attempt octal interpretation */ Tcl_Obj *modeObj; TclNewLiteralStringObj(modeObj, "0o"); Tcl_AppendToObj(modeObj, modeStringPtr+scanned+1, TCL_INDEX_NONE); | | | | 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 | && (modeStringPtr[scanned+1] >= '0') && (modeStringPtr[scanned+1] <= '7')) { /* Leading zero - attempt octal interpretation */ Tcl_Obj *modeObj; TclNewLiteralStringObj(modeObj, "0o"); Tcl_AppendToObj(modeObj, modeStringPtr+scanned+1, TCL_INDEX_NONE); result = TclGetWideIntFromObj(NULL, modeObj, &mode); Tcl_DecrRefCount(modeObj); } if (result == TCL_OK || TclGetWideIntFromObj(NULL, attributePtr, &mode) == TCL_OK) { newMode = (mode_t) (mode & 0x00007FFF); } else { Tcl_StatBuf buf; /* * Try the forms "rwxrwxrwx" and "ugo=rwx" * |
︙ | ︙ |
Changes to unix/tclUnixFile.c.
︙ | ︙ | |||
151 152 153 154 155 156 157 | #ifdef DJGPP if (name[1] == ':') #else if (name[0] == '/') #endif { encoding = Tcl_GetEncoding(NULL, NULL); | | | 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 | #ifdef DJGPP if (name[1] == ':') #else if (name[0] == '/') #endif { encoding = Tcl_GetEncoding(NULL, NULL); Tcl_ExternalToUtfDStringEx(NULL, encoding, name, TCL_INDEX_NONE, TCL_ENCODING_PROFILE_LOSSLESS, &utfName, NULL); TclSetObjNameOfExecutable( Tcl_NewStringObj(Tcl_DStringValue(&utfName), TCL_INDEX_NONE), encoding); Tcl_DStringFree(&utfName); goto done; } if (TclpGetCwd(NULL, &cwd) == NULL) { |
︙ | ︙ | |||
179 180 181 182 183 184 185 | } Tcl_DStringInit(&nameString); Tcl_DStringAppend(&nameString, name, TCL_INDEX_NONE); Tcl_DStringFree(&buffer); Tcl_UtfToExternalDStringEx(NULL, NULL, Tcl_DStringValue(&cwd), | | | | 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 | } Tcl_DStringInit(&nameString); Tcl_DStringAppend(&nameString, name, TCL_INDEX_NONE); Tcl_DStringFree(&buffer); Tcl_UtfToExternalDStringEx(NULL, NULL, Tcl_DStringValue(&cwd), Tcl_DStringLength(&cwd), TCL_ENCODING_PROFILE_LOSSLESS, &buffer, NULL); if (Tcl_DStringValue(&cwd)[Tcl_DStringLength(&cwd) -1] != '/') { TclDStringAppendLiteral(&buffer, "/"); } Tcl_DStringFree(&cwd); TclDStringAppendDString(&buffer, &nameString); Tcl_DStringFree(&nameString); encoding = Tcl_GetEncoding(NULL, NULL); Tcl_ExternalToUtfDStringEx(NULL, encoding, Tcl_DStringValue(&buffer), TCL_INDEX_NONE, TCL_ENCODING_PROFILE_LOSSLESS, &utfName, NULL); TclSetObjNameOfExecutable( Tcl_NewStringObj(Tcl_DStringValue(&utfName), TCL_INDEX_NONE), encoding); Tcl_DStringFree(&utfName); done: Tcl_DStringFree(&buffer); } |
︙ | ︙ | |||
304 305 306 307 308 309 310 | } } /* * Now open the directory for reading and iterate over the contents. */ | | | 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 | } } /* * Now open the directory for reading and iterate over the contents. */ if (Tcl_UtfToExternalDStringEx(interp, NULL, dirName, TCL_INDEX_NONE, TCL_ENCODING_PROFILE_LOSSLESS, &ds, NULL) != TCL_OK) { Tcl_DStringFree(&dsOrig); Tcl_DStringFree(&ds); Tcl_DecrRefCount(fileNamePtr); return TCL_ERROR; } native = Tcl_DStringValue(&ds); |
︙ | ︙ | |||
375 376 377 378 379 380 381 | /* * Now check to see if the file matches, according to both type * and pattern. If so, add the file to the result. */ if (Tcl_ExternalToUtfDStringEx(interp, NULL, entryPtr->d_name, TCL_INDEX_NONE, | | | 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 | /* * Now check to see if the file matches, according to both type * and pattern. If so, add the file to the result. */ if (Tcl_ExternalToUtfDStringEx(interp, NULL, entryPtr->d_name, TCL_INDEX_NONE, TCL_ENCODING_PROFILE_LOSSLESS, &utfDs, NULL) != TCL_OK) { matchResult = -1; break; } utfname = Tcl_DStringValue(&utfDs); if (Tcl_StringCaseMatch(utfname, pattern, 0)) { int typeOk = 1; |
︙ | ︙ | |||
607 608 609 610 611 612 613 | Tcl_DString *bufferPtr) /* Uninitialized or free DString filled with * name of user's home directory. */ { struct passwd *pwPtr; Tcl_DString ds; const char *native; | | | | 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 | Tcl_DString *bufferPtr) /* Uninitialized or free DString filled with * name of user's home directory. */ { struct passwd *pwPtr; Tcl_DString ds; const char *native; if (Tcl_UtfToExternalDStringEx(NULL, NULL, name, TCL_INDEX_NONE, TCL_ENCODING_PROFILE_LOSSLESS, &ds, NULL) != TCL_OK) { Tcl_DStringFree(&ds); return NULL; } native = Tcl_DStringValue(&ds); pwPtr = TclpGetPwNam(native); /* INTL: Native. */ Tcl_DStringFree(&ds); if (pwPtr == NULL) { return NULL; } if (Tcl_ExternalToUtfDStringEx(NULL, NULL, pwPtr->pw_dir, TCL_INDEX_NONE, TCL_ENCODING_PROFILE_LOSSLESS, bufferPtr, NULL) != TCL_OK) { return NULL; } else { return Tcl_DStringValue(bufferPtr); } } /* |
︙ | ︙ | |||
801 802 803 804 805 806 807 | if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "error getting working directory name: %s", Tcl_PosixError(interp))); } return NULL; } | | | 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 | if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "error getting working directory name: %s", Tcl_PosixError(interp))); } return NULL; } if (Tcl_ExternalToUtfDStringEx(interp, NULL, buffer, TCL_INDEX_NONE, TCL_ENCODING_PROFILE_LOSSLESS, bufferPtr, NULL) != TCL_OK) { return NULL; } return Tcl_DStringValue(bufferPtr); } /* *--------------------------------------------------------------------------- |
︙ | ︙ | |||
839 840 841 842 843 844 845 | { #ifndef DJGPP char link[MAXPATHLEN]; Tcl_Size length; const char *native; Tcl_DString ds; | | | | 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 | { #ifndef DJGPP char link[MAXPATHLEN]; Tcl_Size length; const char *native; Tcl_DString ds; if (Tcl_UtfToExternalDStringEx(NULL, NULL, path, TCL_INDEX_NONE, TCL_ENCODING_PROFILE_LOSSLESS, &ds, NULL) != TCL_OK) { Tcl_DStringFree(&ds); return NULL; } native = Tcl_DStringValue(&ds); length = readlink(native, link, sizeof(link)); /* INTL: Native. */ Tcl_DStringFree(&ds); if (length < 0) { return NULL; } if (Tcl_ExternalToUtfDStringEx(NULL, NULL, link, length, TCL_ENCODING_PROFILE_LOSSLESS, linkPtr, NULL) == TCL_OK) { return Tcl_DStringValue(linkPtr); } #endif /* !DJGPP */ return NULL; } |
︙ | ︙ | |||
986 987 988 989 990 991 992 | */ transPtr = Tcl_FSGetTranslatedPath(NULL, toPtr); if (transPtr == NULL) { return NULL; } target = Tcl_GetStringFromObj(transPtr, &length); | | | 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 | */ transPtr = Tcl_FSGetTranslatedPath(NULL, toPtr); if (transPtr == NULL) { return NULL; } target = Tcl_GetStringFromObj(transPtr, &length); if (Tcl_UtfToExternalDStringEx(NULL, NULL, target, length, TCL_ENCODING_PROFILE_LOSSLESS, &ds, NULL) != TCL_OK) { Tcl_DStringFree(&ds); return NULL; } target = Tcl_DStringValue(&ds); Tcl_DecrRefCount(transPtr); if (symlink(target, src) != 0) { |
︙ | ︙ | |||
1025 1026 1027 1028 1029 1030 1031 | Tcl_DecrRefCount(transPtr); length = readlink((const char *)Tcl_FSGetNativePath(pathPtr), link, sizeof(link)); if (length < 0) { return NULL; } | | | 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 | Tcl_DecrRefCount(transPtr); length = readlink((const char *)Tcl_FSGetNativePath(pathPtr), link, sizeof(link)); if (length < 0) { return NULL; } if (Tcl_ExternalToUtfDStringEx(NULL, NULL, link, (size_t)length, TCL_ENCODING_PROFILE_LOSSLESS, &ds, NULL) != TCL_OK) { return NULL; } linkPtr = Tcl_DStringToObj(&ds); Tcl_IncrRefCount(linkPtr); return linkPtr; } } |
︙ | ︙ | |||
1092 1093 1094 1095 1096 1097 1098 | Tcl_Obj * TclpNativeToNormalized( void *clientData) { Tcl_DString ds; | | | 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 | Tcl_Obj * TclpNativeToNormalized( void *clientData) { Tcl_DString ds; Tcl_ExternalToUtfDStringEx(NULL, NULL, (const char *) clientData, TCL_INDEX_NONE, TCL_ENCODING_PROFILE_LOSSLESS, &ds, NULL); return Tcl_DStringToObj(&ds); } /* *--------------------------------------------------------------------------- * * TclNativeCreateNativeRep -- |
︙ | ︙ | |||
1146 1147 1148 1149 1150 1151 1152 | if (validPathPtr == NULL) { return NULL; } Tcl_IncrRefCount(validPathPtr); } str = Tcl_GetStringFromObj(validPathPtr, &len); | | | 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 | if (validPathPtr == NULL) { return NULL; } Tcl_IncrRefCount(validPathPtr); } str = Tcl_GetStringFromObj(validPathPtr, &len); if (Tcl_UtfToExternalDStringEx(NULL, NULL, str, len, TCL_ENCODING_PROFILE_LOSSLESS, &ds, NULL) != TCL_OK) { Tcl_DecrRefCount(validPathPtr); Tcl_DStringFree(&ds); return NULL; } len = Tcl_DStringLength(&ds) + sizeof(char); if (strlen(Tcl_DStringValue(&ds)) < len - sizeof(char)) { /* See bug [3118489]: NUL in filenames */ |
︙ | ︙ |
Changes to unix/tclUnixInit.c.
︙ | ︙ | |||
469 470 471 472 473 474 475 | * Look for the library relative to the TCL_LIBRARY env variable. If the * last dirname in the TCL_LIBRARY path does not match the last dirname in * the installLib variable, use the last dir name of installLib in * addition to the original TCL_LIBRARY path. */ str = getenv("TCL_LIBRARY"); /* INTL: Native. */ | | | > > > > | 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 | * Look for the library relative to the TCL_LIBRARY env variable. If the * last dirname in the TCL_LIBRARY path does not match the last dirname in * the installLib variable, use the last dir name of installLib in * addition to the original TCL_LIBRARY path. */ str = getenv("TCL_LIBRARY"); /* INTL: Native. */ if (TclSystemToInternalEncoding(NULL, str, -1, &buffer) == TCL_OK) { str = Tcl_DStringValue(&buffer); } else { /* Note buffer is initialized even on error so can be cleared later */ str = NULL; } if ((str != NULL) && (str[0] != '\0')) { Tcl_DString ds; Tcl_Size pathc; const char **pathv; char installLib[LIBRARY_SIZE]; |
︙ | ︙ |
Changes to unix/tclUnixPipe.c.
︙ | ︙ | |||
634 635 636 637 638 639 640 | errno = strtol(errSpace, &end, 10); Tcl_SetObjResult(interp, Tcl_ObjPrintf("%s: %s", end, Tcl_PosixError(interp))); goto error; } TclpCloseFile(errPipeIn); | | | 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 | errno = strtol(errSpace, &end, 10); Tcl_SetObjResult(interp, Tcl_ObjPrintf("%s: %s", end, Tcl_PosixError(interp))); goto error; } TclpCloseFile(errPipeIn); *pidPtr = (Tcl_Pid)INT2PTR(pid); return TCL_OK; error: if (pid != -1) { /* * Reap the child process now if an error occurred during its startup. * We don't call this with WNOHANG because that can lead to defunct |
︙ | ︙ | |||
1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 | * routine. */ if (pipePtr->errorFile) { errChan = Tcl_MakeFileChannel( INT2PTR(GetFd(pipePtr->errorFile)), TCL_READABLE); } else { errChan = NULL; } result = TclCleanupChildren(interp, pipePtr->numPids, pipePtr->pidPtr, errChan); } | > > | 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 | * routine. */ if (pipePtr->errorFile) { errChan = Tcl_MakeFileChannel( INT2PTR(GetFd(pipePtr->errorFile)), TCL_READABLE); /* Error channels should not raise encoding errors */ Tcl_SetChannelOption(NULL, errChan, "-profile", "replace"); } else { errChan = NULL; } result = TclCleanupChildren(interp, pipePtr->numPids, pipePtr->pidPtr, errChan); } |
︙ | ︙ | |||
1338 1339 1340 1341 1342 1343 1344 | { int result; pid_t real_pid = (pid_t) PTR2INT(pid); while (1) { result = (int) waitpid(real_pid, statPtr, options); if ((result != -1) || (errno != EINTR)) { | | | 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 | { int result; pid_t real_pid = (pid_t) PTR2INT(pid); while (1) { result = (int) waitpid(real_pid, statPtr, options); if ((result != -1) || (errno != EINTR)) { return (Tcl_Pid)INT2PTR(result); } } } /* *---------------------------------------------------------------------- * |
︙ | ︙ |
Changes to win/configure.
︙ | ︙ | |||
740 741 742 743 744 745 746 747 748 749 750 751 752 753 | ZLIB_LIBS TOMMATH_DLL_FILE ZLIB_DLL_FILE CFLAGS_NOLTO CFLAGS_WARNING CFLAGS_OPTIMIZE CFLAGS_DEBUG WINE CYGPATH SHARED_BUILD SET_MAKE RC RANLIB AR | > | 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 | ZLIB_LIBS TOMMATH_DLL_FILE ZLIB_DLL_FILE CFLAGS_NOLTO CFLAGS_WARNING CFLAGS_OPTIMIZE CFLAGS_DEBUG DL_LIBS WINE CYGPATH SHARED_BUILD SET_MAKE RC RANLIB AR |
︙ | ︙ | |||
4819 4820 4821 4822 4823 4824 4825 4826 4827 4828 4829 4830 4831 4832 | printf "%s\n" "$tcl_cv_cast_to_union" >&6; } if test "$tcl_cv_cast_to_union" = "yes"; then printf "%s\n" "#define HAVE_CAST_TO_UNION 1" >>confdefs.h fi fi | > > | 4820 4821 4822 4823 4824 4825 4826 4827 4828 4829 4830 4831 4832 4833 4834 4835 | printf "%s\n" "$tcl_cv_cast_to_union" >&6; } if test "$tcl_cv_cast_to_union" = "yes"; then printf "%s\n" "#define HAVE_CAST_TO_UNION 1" >>confdefs.h fi fi # DL_LIBS is empty, but then we match the Unix version |
︙ | ︙ |
Changes to win/makefile.vc.
︙ | ︙ | |||
217 218 219 220 221 222 223 | TCLREGLIBNAME = $(PROJECT)9registry$(REGVERSION)$(SUFX:t=).$(EXT) TCLREGLIB = $(OUT_DIR)\$(TCLREGLIBNAME) TCLDDELIBNAME = $(PROJECT)9dde$(DDEVERSION)$(SUFX:t=).$(EXT) TCLDDELIB = $(OUT_DIR)\$(TCLDDELIBNAME) | | | > | 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 | TCLREGLIBNAME = $(PROJECT)9registry$(REGVERSION)$(SUFX:t=).$(EXT) TCLREGLIB = $(OUT_DIR)\$(TCLREGLIBNAME) TCLDDELIBNAME = $(PROJECT)9dde$(DDEVERSION)$(SUFX:t=).$(EXT) TCLDDELIB = $(OUT_DIR)\$(TCLDDELIBNAME) TCLTEST = $(OUT_DIR)\$(PROJECT)test$(VERSION)$(SUFX:t=).exe TCLTESTRAW = $(TCLTEST:.exe=-raw.exe) TCLSHOBJS = \ $(TMP_DIR)\tclAppInit.obj \ $(TMP_DIR)\tclsh.res TCLTESTOBJS = \ $(TMP_DIR)\tclTest.obj \ $(TMP_DIR)\tclTestObj.obj \ $(TMP_DIR)\tclTestProcBodyObj.obj \ $(TMP_DIR)\tclThreadTest.obj \ $(TMP_DIR)\tclWinTest.obj \ $(TMP_DIR)\tclTestABSList.obj \ !if !$(STATIC_BUILD) $(OUT_DIR)\tommath.lib \ !endif $(TMP_DIR)\testMain.obj \ $(TMP_DIR)\tcltest.res COREOBJS = \ $(TMP_DIR)\regcomp.obj \ $(TMP_DIR)\regerror.obj \ $(TMP_DIR)\regexec.obj \ $(TMP_DIR)\regfree.obj \ $(TMP_DIR)\tclArithSeries.obj \ |
︙ | ︙ | |||
578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 | !endif # $(STATIC_BUILD) $(TCLSTUBLIB): $(TCLSTUBOBJS) $(LIBCMD) -nodefaultlib $(TCLSTUBOBJS) $(TCLSH): $(TCLSHOBJS) $(TCLSTUBLIB) $(TCLIMPLIB) $(CONEXECMD) -stack:2300000 $** $(_VC_MANIFEST_EMBED_EXE) !if $(TCL_EMBED_SCRIPTS) && $(STATIC_BUILD) $(COPY) $@ $(TCLSHRAW) !endif $(TCLTEST): $(TCLTESTOBJS) $(TCLSTUBLIB) $(TCLIMPLIB) $(CONEXECMD) -stack:2300000 $** $(_VC_MANIFEST_EMBED_EXE) !if $(TCL_EMBED_SCRIPTS) && $(STATIC_BUILD) $(COPY) $@ $(TCLTESTRAW) !endif !if $(STATIC_BUILD) $(TCLDDELIB): $(TMP_DIR)\tclWinDde.obj | > > | 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 | !endif # $(STATIC_BUILD) $(TCLSTUBLIB): $(TCLSTUBOBJS) $(LIBCMD) -nodefaultlib $(TCLSTUBOBJS) $(TCLSH): $(TCLSHOBJS) $(TCLSTUBLIB) $(TCLIMPLIB) $(CONEXECMD) -stack:2300000 $** copy $(TMP_DIR)\tclsh.exe.manifest $(TCLSH).manifest $(_VC_MANIFEST_EMBED_EXE) !if $(TCL_EMBED_SCRIPTS) && $(STATIC_BUILD) $(COPY) $@ $(TCLSHRAW) !endif $(TCLTEST): $(TCLTESTOBJS) $(TCLSTUBLIB) $(TCLIMPLIB) $(CONEXECMD) -stack:2300000 $** copy $(TMP_DIR)\tclsh.exe.manifest $(TCLTEST).manifest $(_VC_MANIFEST_EMBED_EXE) !if $(TCL_EMBED_SCRIPTS) && $(STATIC_BUILD) $(COPY) $@ $(TCLTESTRAW) !endif !if $(STATIC_BUILD) $(TCLDDELIB): $(TMP_DIR)\tclWinDde.obj |
︙ | ︙ | |||
1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 | {$(COMPATDIR)\zlib}.c{$(TMP_DIR)}.obj:: $(cc32) $(pkgcflags) -Fo$(TMP_DIR)\ @<< $< << $(TMP_DIR)\tclsh.res: $(TMP_DIR)\tclsh.exe.manifest $(WIN_DIR)\tclsh.rc #--------------------------------------------------------------------- # Installation. #--------------------------------------------------------------------- install-binaries: @echo Installing to '$(_INSTALLDIR)' | > | 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 | {$(COMPATDIR)\zlib}.c{$(TMP_DIR)}.obj:: $(cc32) $(pkgcflags) -Fo$(TMP_DIR)\ @<< $< << $(TMP_DIR)\tclsh.res: $(TMP_DIR)\tclsh.exe.manifest $(WIN_DIR)\tclsh.rc $(TMP_DIR)\tcltest.res: $(TMP_DIR)\tclsh.exe.manifest $(WIN_DIR)\tcltest.rc #--------------------------------------------------------------------- # Installation. #--------------------------------------------------------------------- install-binaries: @echo Installing to '$(_INSTALLDIR)' |
︙ | ︙ |
Changes to win/rules.vc.
︙ | ︙ | |||
1620 1621 1622 1623 1624 1625 1626 | LIBCMD = $(lib32) -nologo $(LINKERFLAGS) -out:$@ DLLCMD = $(link32) $(dlllflags) -out:$@ $(baselibs) $(tcllibs) $(tklibs) CONEXECMD = $(link32) $(conlflags) -out:$@ $(baselibs) $(tcllibs) $(tklibs) GUIEXECMD = $(link32) $(guilflags) -out:$@ $(baselibs) $(tcllibs) $(tklibs) RESCMD = $(rc32) -fo $@ -r -i "$(GENERICDIR)" -i "$(TMP_DIR)" \ | | | 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 | LIBCMD = $(lib32) -nologo $(LINKERFLAGS) -out:$@ DLLCMD = $(link32) $(dlllflags) -out:$@ $(baselibs) $(tcllibs) $(tklibs) CONEXECMD = $(link32) $(conlflags) -out:$@ $(baselibs) $(tcllibs) $(tklibs) GUIEXECMD = $(link32) $(guilflags) -out:$@ $(baselibs) $(tcllibs) $(tklibs) RESCMD = $(rc32) -fo $@ -r -i "$(GENERICDIR)" -i "$(TMP_DIR)" \ $(TCL_INCLUDES) /DSTATIC_BUILD=$(STATIC_BUILD) \ /DDEBUG=$(DEBUG) -d UNCHECKED=$(UNCHECKED) \ /DCOMMAVERSION=$(RCCOMMAVERSION) \ /DDOTVERSION=\"$(DOTVERSION)\" \ /DVERSION=\"$(VERSION)\" \ /DSUFX=\"$(SUFX)\" \ /DPROJECT=\"$(PROJECT)\" \ /DPRJLIBNAME=\"$(PRJLIBNAME)\" |
︙ | ︙ |
Changes to win/tcl.dsp.
︙ | ︙ | |||
226 227 228 229 230 231 232 | SOURCE=..\doc\ByteArrObj.3 # End Source File # Begin Source File SOURCE=..\doc\CallDel.3 # End Source File | < < < < | 226 227 228 229 230 231 232 233 234 235 236 237 238 239 | SOURCE=..\doc\ByteArrObj.3 # End Source File # Begin Source File SOURCE=..\doc\CallDel.3 # End Source File # Begin Source File SOURCE=..\doc\catch.n # End Source File # Begin Source File SOURCE=..\doc\cd.n |
︙ | ︙ |
Changes to win/tcl.m4.
︙ | ︙ | |||
955 956 957 958 959 960 961 962 963 964 965 966 967 968 | ) if test "$tcl_cv_cast_to_union" = "yes"; then AC_DEFINE(HAVE_CAST_TO_UNION, 1, [Defined when compiler supports casting to union type.]) fi fi AC_SUBST(CFLAGS_DEBUG) AC_SUBST(CFLAGS_OPTIMIZE) AC_SUBST(CFLAGS_WARNING) AC_SUBST(CFLAGS_NOLTO) ]) #------------------------------------------------------------------------ | > > | 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 | ) if test "$tcl_cv_cast_to_union" = "yes"; then AC_DEFINE(HAVE_CAST_TO_UNION, 1, [Defined when compiler supports casting to union type.]) fi fi # DL_LIBS is empty, but then we match the Unix version AC_SUBST(DL_LIBS) AC_SUBST(CFLAGS_DEBUG) AC_SUBST(CFLAGS_OPTIMIZE) AC_SUBST(CFLAGS_WARNING) AC_SUBST(CFLAGS_NOLTO) ]) #------------------------------------------------------------------------ |
︙ | ︙ |
Changes to win/tclWinChan.c.
︙ | ︙ | |||
76 77 78 79 80 81 82 | static void FileChannelExitHandler(void *clientData); static void FileCheckProc(void *clientData, int flags); static int FileCloseProc(void *instanceData, Tcl_Interp *interp, int flags); static int FileEventProc(Tcl_Event *evPtr, int flags); static int FileGetHandleProc(void *instanceData, int direction, void **handlePtr); | | | 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 | static void FileChannelExitHandler(void *clientData); static void FileCheckProc(void *clientData, int flags); static int FileCloseProc(void *instanceData, Tcl_Interp *interp, int flags); static int FileEventProc(Tcl_Event *evPtr, int flags); static int FileGetHandleProc(void *instanceData, int direction, void **handlePtr); static int FileGetOptionProc(void *instanceData, Tcl_Interp *interp, const char *optionName, Tcl_DString *dsPtr); static ThreadSpecificData *FileInit(void); static int FileInputProc(void *instanceData, char *buf, int toRead, int *errorCode); static int FileOutputProc(void *instanceData, const char *buf, int toWrite, int *errorCode); |
︙ | ︙ | |||
890 891 892 893 894 895 896 | #undef STORE_ELEM return dictObj; } static int FileGetOptionProc( | | | 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 | #undef STORE_ELEM return dictObj; } static int FileGetOptionProc( void *instanceData, /* The file state. */ Tcl_Interp *interp, /* For error reporting. */ const char *optionName, /* What option to read, or NULL for all. */ Tcl_DString *dsPtr) /* Where to write the value read. */ { FileInfo *infoPtr = (FileInfo *)instanceData; int valid = 0; /* Flag if valid option parsed. */ int len; |
︙ | ︙ |
Changes to win/tclWinConsole.c.
︙ | ︙ | |||
2269 2270 2271 2272 2273 2274 2275 | if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't read console mode: %s", Tcl_PosixError(interp))); } return TCL_ERROR; } | | | | | | 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 | if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't read console mode: %s", Tcl_PosixError(interp))); } return TCL_ERROR; } if (strncasecmp(value, "NORMAL", vlen) == 0) { mode |= ENABLE_ECHO_INPUT | ENABLE_LINE_INPUT | ENABLE_PROCESSED_INPUT; } else if (strncasecmp(value, "PASSWORD", vlen) == 0) { mode |= ENABLE_LINE_INPUT|ENABLE_PROCESSED_INPUT; mode &= ~ENABLE_ECHO_INPUT; } else if (strncasecmp(value, "RAW", vlen) == 0) { mode &= ~(ENABLE_ECHO_INPUT | ENABLE_LINE_INPUT | ENABLE_PROCESSED_INPUT); } else if (strncasecmp(value, "RESET", vlen) == 0) { /* * Reset to the initial mode, whatever that is. */ mode = chanInfoPtr->initMode; } else { if (interp) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( |
︙ | ︙ |
Changes to win/tclWinDde.c.
︙ | ︙ | |||
86 87 88 89 90 91 92 93 | #define DDE_FLAG_ASYNC 1 #define DDE_FLAG_BINARY 2 #define DDE_FLAG_FORCE 4 TCL_DECLARE_MUTEX(ddeMutex) /* | > > > > > > > > > > > > > > > > | | 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 | #define DDE_FLAG_ASYNC 1 #define DDE_FLAG_BINARY 2 #define DDE_FLAG_FORCE 4 TCL_DECLARE_MUTEX(ddeMutex) #if (TCL_MAJOR_VERSION < 9) && defined(TCL_MINOR_VERSION) && (TCL_MINOR_VERSION < 7) # if TCL_UTF_MAX > 3 # define Tcl_WCharToUtfDString(a,b,c) Tcl_WinTCharToUtf((TCHAR *)(a),(b)*sizeof(WCHAR),c) # define Tcl_UtfToWCharDString(a,b,c) (WCHAR *)Tcl_WinUtfToTChar(a,b,c) # else # define Tcl_WCharToUtfDString Tcl_UniCharToUtfDString # define Tcl_UtfToWCharDString Tcl_UtfToUniCharDString # endif #ifndef Tcl_Size # define Tcl_Size int #endif #ifndef Tcl_CreateObjCommand2 # define Tcl_CreateObjCommand2 Tcl_CreateObjCommand #endif #endif /* * Declarations for functions defined in this file. */ static LRESULT CALLBACK DdeClientWindowProc(HWND hwnd, UINT uMsg, WPARAM wParam, LPARAM lParam); static int DdeCreateClient(DdeEnumServices *es); static BOOL CALLBACK DdeEnumWindowsCallback(HWND hwndTarget, LPARAM lParam); |
︙ | ︙ | |||
110 111 112 113 114 115 116 | static void DeleteProc(void *clientData); static Tcl_Obj * ExecuteRemoteObject(RegisteredInterp *riPtr, Tcl_Obj *ddeObjectPtr); static int MakeDdeConnection(Tcl_Interp *interp, const WCHAR *name, HCONV *ddeConvPtr); static void SetDdeError(Tcl_Interp *interp); static int DdeObjCmd(void *clientData, | | < < < < < < < < < < < < | | 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 | static void DeleteProc(void *clientData); static Tcl_Obj * ExecuteRemoteObject(RegisteredInterp *riPtr, Tcl_Obj *ddeObjectPtr); static int MakeDdeConnection(Tcl_Interp *interp, const WCHAR *name, HCONV *ddeConvPtr); static void SetDdeError(Tcl_Interp *interp); static int DdeObjCmd(void *clientData, Tcl_Interp *interp, Tcl_Size objc, Tcl_Obj *const objv[]); #ifdef __cplusplus extern "C" { #endif DLLEXPORT int Dde_Init(Tcl_Interp *interp); DLLEXPORT int Dde_SafeInit(Tcl_Interp *interp); #if TCL_MAJOR_VERSION < 9 /* With those additional entries, "load tcldde14.dll" works without 3th argument */ DLLEXPORT int Tcldde_Init(Tcl_Interp *interp); DLLEXPORT int Tcldde_SafeInit(Tcl_Interp *interp); #endif #ifdef __cplusplus } #endif |
︙ | ︙ | |||
163 164 165 166 167 168 169 | Dde_Init( Tcl_Interp *interp) { if (!Tcl_InitStubs(interp, "8.5-", 0)) { return TCL_ERROR; } | | | 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 | Dde_Init( Tcl_Interp *interp) { if (!Tcl_InitStubs(interp, "8.5-", 0)) { return TCL_ERROR; } Tcl_CreateObjCommand2(interp, "dde", DdeObjCmd, NULL, NULL); Tcl_CreateExitHandler(DdeExitProc, NULL); return Tcl_PkgProvideEx(interp, TCL_DDE_PACKAGE_NAME, TCL_DDE_VERSION, NULL); } #if TCL_MAJOR_VERSION < 9 int Tcldde_Init( Tcl_Interp *interp) |
︙ | ︙ | |||
411 412 413 414 415 416 417 | for (n = 0; n < srvCount; ++n) { Tcl_Obj* namePtr; Tcl_DString ds; Tcl_ListObjIndex(interp, srvPtrPtr[n], 1, &namePtr); Tcl_DStringInit(&ds); | | | 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 | for (n = 0; n < srvCount; ++n) { Tcl_Obj* namePtr; Tcl_DString ds; Tcl_ListObjIndex(interp, srvPtrPtr[n], 1, &namePtr); Tcl_DStringInit(&ds); Tcl_UtfToWCharDString(Tcl_GetString(namePtr), -1, &ds); if (wcscmp(actualName, (WCHAR *)Tcl_DStringValue(&ds)) == 0) { suffix++; Tcl_DStringFree(&ds); break; } Tcl_DStringFree(&ds); } |
︙ | ︙ | |||
441 442 443 444 445 446 447 | tsdPtr->interpListPtr = riPtr; wcscpy(riPtr->name, actualName); if (Tcl_IsSafe(interp)) { Tcl_ExposeCommand(interp, "dde", "dde"); } | | | 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 | tsdPtr->interpListPtr = riPtr; wcscpy(riPtr->name, actualName); if (Tcl_IsSafe(interp)) { Tcl_ExposeCommand(interp, "dde", "dde"); } Tcl_CreateObjCommand2(interp, "dde", DdeObjCmd, riPtr, DeleteProc); if (Tcl_IsSafe(interp)) { Tcl_HideCommand(interp, "dde", "dde"); } Tcl_DStringFree(&dString); /* |
︙ | ︙ | |||
569 570 571 572 573 574 575 | { Tcl_Obj *returnPackagePtr; int result = TCL_OK; if ((riPtr->handlerPtr == NULL) && Tcl_IsSafe(riPtr->interp)) { Tcl_SetObjResult(riPtr->interp, Tcl_NewStringObj("permission denied: " "a handler procedure must be defined for use in a safe " | | | 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 | { Tcl_Obj *returnPackagePtr; int result = TCL_OK; if ((riPtr->handlerPtr == NULL) && Tcl_IsSafe(riPtr->interp)) { Tcl_SetObjResult(riPtr->interp, Tcl_NewStringObj("permission denied: " "a handler procedure must be defined for use in a safe " "interp", -1)); Tcl_SetErrorCode(riPtr->interp, "TCL", "DDE", "SECURITY_CHECK", (void *)NULL); result = TCL_ERROR; } if (riPtr->handlerPtr != NULL) { /* * Add the dde request data to the handler proc list. |
︙ | ︙ | |||
851 852 853 854 855 856 857 | utilString = (WCHAR *) DdeAccessData(hData, &len2); len = len2; if (uFmt != CF_TEXT) { Tcl_DStringInit(&ds2); Tcl_WCharToUtfDString(utilString, wcslen(utilString), &ds2); utilString = (WCHAR *) Tcl_DStringValue(&ds2); } | | | 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 | utilString = (WCHAR *) DdeAccessData(hData, &len2); len = len2; if (uFmt != CF_TEXT) { Tcl_DStringInit(&ds2); Tcl_WCharToUtfDString(utilString, wcslen(utilString), &ds2); utilString = (WCHAR *) Tcl_DStringValue(&ds2); } variableObjPtr = Tcl_NewStringObj((char *)utilString, -1); Tcl_SetVar2Ex(convPtr->riPtr->interp, Tcl_DStringValue(&ds), NULL, variableObjPtr, TCL_GLOBAL_ONLY); Tcl_DStringFree(&ds2); Tcl_DStringFree(&ds); Tcl_DStringFree(&dString); |
︙ | ︙ | |||
1149 1150 1151 1152 1153 1154 1155 | && ((es->topic == (ATOM)0) || (es->topic == topic))) { Tcl_Obj *matchPtr = Tcl_NewListObj(0, NULL); Tcl_Obj *resultPtr = Tcl_GetObjResult(es->interp); GlobalGetAtomNameW(service, sz, 255); Tcl_DStringInit(&dString); Tcl_WCharToUtfDString(sz, wcslen(sz), &dString); | | | | 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 | && ((es->topic == (ATOM)0) || (es->topic == topic))) { Tcl_Obj *matchPtr = Tcl_NewListObj(0, NULL); Tcl_Obj *resultPtr = Tcl_GetObjResult(es->interp); GlobalGetAtomNameW(service, sz, 255); Tcl_DStringInit(&dString); Tcl_WCharToUtfDString(sz, wcslen(sz), &dString); Tcl_ListObjAppendElement(NULL, matchPtr, Tcl_NewStringObj(Tcl_DStringValue(&dString), -1)); Tcl_DStringFree(&dString); GlobalGetAtomNameW(topic, sz, 255); Tcl_DStringInit(&dString); Tcl_WCharToUtfDString(sz, wcslen(sz), &dString); Tcl_ListObjAppendElement(NULL, matchPtr, Tcl_NewStringObj(Tcl_DStringValue(&dString), -1)); Tcl_DStringFree(&dString); /* * Adding the hwnd as a third list element provides a unique * identifier in the case of multiple servers with the name * application and topic names. */ |
︙ | ︙ | |||
1272 1273 1274 1275 1276 1277 1278 | errorCode = "NOCANDO"; break; default: errorMessage = "dde command failed"; errorCode = "FAILED"; } | | | 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 | errorCode = "NOCANDO"; break; default: errorMessage = "dde command failed"; errorCode = "FAILED"; } Tcl_SetObjResult(interp, Tcl_NewStringObj(errorMessage, -1)); Tcl_SetErrorCode(interp, "TCL", "DDE", errorCode, (void *)NULL); } /* *---------------------------------------------------------------------- * * DdeObjCmd -- |
︙ | ︙ | |||
1297 1298 1299 1300 1301 1302 1303 | *---------------------------------------------------------------------- */ static int DdeObjCmd( void *dummy, /* Not used. */ Tcl_Interp *interp, /* The interp we are sending from */ | | | 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 | *---------------------------------------------------------------------- */ static int DdeObjCmd( void *dummy, /* Not used. */ Tcl_Interp *interp, /* The interp we are sending from */ Tcl_Size objc, /* Number of arguments */ Tcl_Obj *const *objv) /* The arguments */ { static const char *const ddeCommands[] = { "servername", "execute", "poke", "request", "services", "eval", NULL}; enum DdeSubcommands { DDE_SERVERNAME, DDE_EXECUTE, DDE_POKE, DDE_REQUEST, DDE_SERVICES, DDE_EVAL |
︙ | ︙ | |||
1325 1326 1327 1328 1329 1330 1331 | static const char *const ddeEvalOptions[] = { "-async", NULL }; static const char *const ddeReqOptions[] = { "-binary", NULL }; | | | | 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 | static const char *const ddeEvalOptions[] = { "-async", NULL }; static const char *const ddeReqOptions[] = { "-binary", NULL }; int index, argIndex; Tcl_Size length, i; int flags = 0, result = TCL_OK, firstArg = 0; HSZ ddeService = NULL, ddeTopic = NULL, ddeItem = NULL, ddeCookie = NULL; HDDEDATA ddeData = NULL, ddeItemData = NULL, ddeReturn; HCONV hConv = NULL; const WCHAR *serviceName = NULL, *topicName = NULL; const char *string; DWORD ddeResult; |
︙ | ︙ | |||
1558 1559 1560 1561 1562 1563 1564 | dataString = Tcl_UtfToWCharDString(src, dataLength, &dsBuf); dataLength = Tcl_DStringLength(&dsBuf) + sizeof(WCHAR); } if (dataLength + 1 < 2) { Tcl_SetObjResult(interp, | | | 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 | dataString = Tcl_UtfToWCharDString(src, dataLength, &dsBuf); dataLength = Tcl_DStringLength(&dsBuf) + sizeof(WCHAR); } if (dataLength + 1 < 2) { Tcl_SetObjResult(interp, Tcl_NewStringObj("cannot execute null data", -1)); Tcl_DStringFree(&dsBuf); Tcl_SetErrorCode(interp, "TCL", "DDE", "NULL", (void *)NULL); result = TCL_ERROR; break; } hConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL); DdeFreeStringHandle(ddeInstance, ddeService); |
︙ | ︙ | |||
1609 1610 1611 1612 1613 1614 1615 | src = Tcl_GetStringFromObj(objv[firstArg + 2], &length); Tcl_DStringInit(&itemBuf); itemString = Tcl_UtfToWCharDString(src, length, &itemBuf); length = Tcl_DStringLength(&itemBuf) / sizeof(WCHAR); if (length == 0) { Tcl_SetObjResult(interp, | | | 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 | src = Tcl_GetStringFromObj(objv[firstArg + 2], &length); Tcl_DStringInit(&itemBuf); itemString = Tcl_UtfToWCharDString(src, length, &itemBuf); length = Tcl_DStringLength(&itemBuf) / sizeof(WCHAR); if (length == 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj("cannot request value of null data", -1)); Tcl_SetErrorCode(interp, "TCL", "DDE", "NULL", (void *)NULL); result = TCL_ERROR; goto cleanup; } hConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL); DdeFreeStringHandle(ddeInstance, ddeService); DdeFreeStringHandle(ddeInstance, ddeTopic); |
︙ | ︙ | |||
1675 1676 1677 1678 1679 1680 1681 | src = Tcl_GetStringFromObj(objv[firstArg + 2], &length); Tcl_DStringInit(&itemBuf); itemString = Tcl_UtfToWCharDString(src, length, &itemBuf); length = Tcl_DStringLength(&itemBuf) / sizeof(WCHAR); if (length == 0) { Tcl_SetObjResult(interp, | | | 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 | src = Tcl_GetStringFromObj(objv[firstArg + 2], &length); Tcl_DStringInit(&itemBuf); itemString = Tcl_UtfToWCharDString(src, length, &itemBuf); length = Tcl_DStringLength(&itemBuf) / sizeof(WCHAR); if (length == 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj("cannot have a null item", -1)); Tcl_SetErrorCode(interp, "TCL", "DDE", "NULL", (void *)NULL); result = TCL_ERROR; goto cleanup; } Tcl_DStringInit(&dsBuf); if (flags & DDE_FLAG_BINARY) { dataString = (BYTE *) |
︙ | ︙ | |||
1729 1730 1731 1732 1733 1734 1735 | case DDE_EVAL: { RegisteredInterp *riPtr; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); if (serviceName == NULL) { Tcl_SetObjResult(interp, | | | 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 | case DDE_EVAL: { RegisteredInterp *riPtr; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); if (serviceName == NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj("invalid service name \"\"", -1)); Tcl_SetErrorCode(interp, "TCL", "DDE", "NO_SERVER", (void *)NULL); result = TCL_ERROR; goto cleanup; } objc -= firstArg + 1; objv += firstArg + 1; |
︙ | ︙ | |||
1777 1778 1779 1780 1781 1782 1783 | * interp is then deleted, the bytecode structure would be * referring to deallocated objects. */ if (Tcl_IsSafe(riPtr->interp) && (riPtr->handlerPtr == NULL)) { Tcl_SetObjResult(riPtr->interp, Tcl_NewStringObj( "permission denied: a handler procedure must be" | | | 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 | * interp is then deleted, the bytecode structure would be * referring to deallocated objects. */ if (Tcl_IsSafe(riPtr->interp) && (riPtr->handlerPtr == NULL)) { Tcl_SetObjResult(riPtr->interp, Tcl_NewStringObj( "permission denied: a handler procedure must be" " defined for use in a safe interp", -1)); Tcl_SetErrorCode(interp, "TCL", "DDE", "SECURITY_CHECK", (void *)NULL); result = TCL_ERROR; } if (result == TCL_OK) { if (objc == 1) { |
︙ | ︙ | |||
1843 1844 1845 1846 1847 1848 1849 | * This is a non-local request. Send the script to the server and * poll it for a result. */ if (MakeDdeConnection(interp, serviceName, &hConv) != TCL_OK) { invalidServerResponse: Tcl_SetObjResult(interp, | | | 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 | * This is a non-local request. Send the script to the server and * poll it for a result. */ if (MakeDdeConnection(interp, serviceName, &hConv) != TCL_OK) { invalidServerResponse: Tcl_SetObjResult(interp, Tcl_NewStringObj("invalid data returned from server", -1)); Tcl_SetErrorCode(interp, "TCL", "DDE", "BAD_RESPONSE", (void *)NULL); result = TCL_ERROR; goto cleanup; } objPtr = Tcl_ConcatObj(objc, objv); string = Tcl_GetStringFromObj(objPtr, &length); |
︙ | ︙ |
Changes to win/tclWinPipe.c.
︙ | ︙ | |||
57 58 59 60 61 62 63 | /* * This list is used to map from pids to process handles. */ typedef struct ProcInfo { HANDLE hProcess; | | | 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 | /* * This list is used to map from pids to process handles. */ typedef struct ProcInfo { HANDLE hProcess; int dwProcessId; struct ProcInfo *nextPtr; } ProcInfo; static ProcInfo *procList; /* * Bit masks used in the flags field of the PipeInfo structure below. |
︙ | ︙ | |||
860 861 862 863 864 865 866 | * * Side effects: * None. * *-------------------------------------------------------------------------- */ | | | | | 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 | * * Side effects: * None. * *-------------------------------------------------------------------------- */ Tcl_Size TclpGetPid( Tcl_Pid pid) /* The HANDLE of the child process. */ { ProcInfo *infoPtr; PipeInit(); Tcl_MutexLock(&pipeMutex); for (infoPtr = procList; infoPtr != NULL; infoPtr = infoPtr->nextPtr) { if (infoPtr->dwProcessId == (Tcl_Size)pid) { Tcl_MutexUnlock(&pipeMutex); return infoPtr->dwProcessId; } } Tcl_MutexUnlock(&pipeMutex); return -1; } /* *---------------------------------------------------------------------- * * TclpCreateProcess -- * |
︙ | ︙ | |||
1164 1165 1166 1167 1168 1169 1170 | * CreateProcessW() and CloseHandle(), the problem does not occur." PSS ID * Number: Q124121 */ WaitForInputIdle(procInfo.hProcess, 5000); CloseHandle(procInfo.hThread); | | | 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 | * CreateProcessW() and CloseHandle(), the problem does not occur." PSS ID * Number: Q124121 */ WaitForInputIdle(procInfo.hProcess, 5000); CloseHandle(procInfo.hThread); *pidPtr = (Tcl_Pid)INT2PTR(procInfo.dwProcessId); if (*pidPtr != 0) { TclWinAddProcess(procInfo.hProcess, procInfo.dwProcessId); } result = TCL_OK; end: Tcl_DStringFree(&cmdLine); |
︙ | ︙ | |||
1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 | Tcl_DString *linePtr) /* Initialized Tcl_DString that receives the * command line (WCHAR). */ { const char *arg, *start, *special, *bspos; int quote = 0; size_t 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}; | > > > > > > > > | 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 | Tcl_DString *linePtr) /* Initialized Tcl_DString that receives the * command line (WCHAR). */ { const char *arg, *start, *special, *bspos; int quote = 0; size_t i; Tcl_DString ds; #ifdef TCL_WIN_PIPE_FULLESC /* full escape inclusive %-subst avoidance */ 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). */ #else /* escape considering quotation only (no %-subst avoidance) */ static const char specMetaChars[] = "&|^<>!()"; /* Characters to enclose in quotes if unpaired * quote flag set. */ #endif /* * 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}; |
︙ | ︙ | |||
1689 1690 1691 1692 1693 1694 1695 | /* * Start to current or first backslash */ start = !bspos ? special : bspos; continue; } | | > | 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 | /* * Start to current or first backslash */ start = !bspos ? special : bspos; continue; } #ifdef TCL_WIN_PIPE_FULLESC /* * 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; } #endif /* * Other not special (and not meta) character */ bspos = NULL; /* reset last backslash position (not * interesting) */ |
︙ | ︙ | |||
2110 2111 2112 2113 2114 2115 2116 | if (pipePtr->errorFile) { WinFile *filePtr = (WinFile *) pipePtr->errorFile; errChan = Tcl_MakeFileChannel((void *) filePtr->handle, TCL_READABLE); Tcl_Free(filePtr); | > > | | 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 | if (pipePtr->errorFile) { WinFile *filePtr = (WinFile *) pipePtr->errorFile; errChan = Tcl_MakeFileChannel((void *) filePtr->handle, TCL_READABLE); Tcl_Free(filePtr); Tcl_SetChannelOption(NULL, errChan, "-profile", "replace"); } else { errChan = NULL; } result = TclCleanupChildren(interp, pipePtr->numPids, pipePtr->pidPtr, errChan); } |
︙ | ︙ | |||
2560 2561 2562 2563 2564 2565 2566 | * Find the process and cut it from the process list. */ Tcl_MutexLock(&pipeMutex); prevPtrPtr = &procList; for (infoPtr = procList; infoPtr != NULL; prevPtrPtr = &infoPtr->nextPtr, infoPtr = infoPtr->nextPtr) { | | | 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 | * Find the process and cut it from the process list. */ Tcl_MutexLock(&pipeMutex); prevPtrPtr = &procList; for (infoPtr = procList; infoPtr != NULL; prevPtrPtr = &infoPtr->nextPtr, infoPtr = infoPtr->nextPtr) { if (infoPtr->dwProcessId == (Tcl_Size)pid) { *prevPtrPtr = infoPtr->nextPtr; break; } } Tcl_MutexUnlock(&pipeMutex); /* |
︙ | ︙ | |||
2670 2671 2672 2673 2674 2675 2676 | *statPtr = exitCode; break; } result = pid; } else { errno = ECHILD; *statPtr = 0xC0000000 | ECHILD; | | | 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 | *statPtr = exitCode; break; } result = pid; } else { errno = ECHILD; *statPtr = 0xC0000000 | ECHILD; result = (Tcl_Pid)-1; } /* * Officially close the process handle. */ CloseHandle(infoPtr->hProcess); |
︙ | ︙ | |||
2704 2705 2706 2707 2708 2709 2710 | * *---------------------------------------------------------------------- */ void TclWinAddProcess( void *hProcess, /* Handle to process */ | | | 2715 2716 2717 2718 2719 2720 2721 2722 2723 2724 2725 2726 2727 2728 2729 | * *---------------------------------------------------------------------- */ void TclWinAddProcess( void *hProcess, /* Handle to process */ Tcl_Size id) /* Global process identifier */ { ProcInfo *procPtr = (ProcInfo *)Tcl_Alloc(sizeof(ProcInfo)); PipeInit(); procPtr->hProcess = hProcess; procPtr->dwProcessId = id; |
︙ | ︙ |
Changes to win/tclWinReg.c.
︙ | ︙ | |||
82 83 84 85 86 87 88 89 90 91 92 93 | static const char *const typeNames[] = { "none", "sz", "expand_sz", "binary", "dword", "dword_big_endian", "link", "multi_sz", "resource_list", NULL }; static DWORD lastType = REG_RESOURCE_LIST; /* * Declarations for functions defined in this file. */ static void AppendSystemError(Tcl_Interp *interp, DWORD error); | > > > > > > > > > > > > > > > > | | 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 | static const char *const typeNames[] = { "none", "sz", "expand_sz", "binary", "dword", "dword_big_endian", "link", "multi_sz", "resource_list", NULL }; static DWORD lastType = REG_RESOURCE_LIST; #if (TCL_MAJOR_VERSION < 9) && defined(TCL_MINOR_VERSION) && (TCL_MINOR_VERSION < 7) # if TCL_UTF_MAX > 3 # define Tcl_WCharToUtfDString(a,b,c) Tcl_WinTCharToUtf((TCHAR *)(a),(b)*sizeof(WCHAR),c) # define Tcl_UtfToWCharDString(a,b,c) (WCHAR *)Tcl_WinUtfToTChar(a,b,c) # else # define Tcl_WCharToUtfDString Tcl_UniCharToUtfDString # define Tcl_UtfToWCharDString Tcl_UtfToUniCharDString # endif #ifndef Tcl_Size # define Tcl_Size int #endif #ifndef Tcl_CreateObjCommand2 # define Tcl_CreateObjCommand2 Tcl_CreateObjCommand #endif #endif /* * Declarations for functions defined in this file. */ static void AppendSystemError(Tcl_Interp *interp, DWORD error); static int BroadcastValue(Tcl_Interp *interp, Tcl_Size objc, Tcl_Obj *const objv[]); static DWORD ConvertDWORD(DWORD type, DWORD value); static void DeleteCmd(void *clientData); static int DeleteKey(Tcl_Interp *interp, Tcl_Obj *keyNameObj, REGSAM mode); static int DeleteValue(Tcl_Interp *interp, Tcl_Obj *keyNameObj, Tcl_Obj *valueNameObj, REGSAM mode); |
︙ | ︙ | |||
114 115 116 117 118 119 120 | HKEY *keyPtr); static int ParseKeyName(Tcl_Interp *interp, char *name, char **hostNamePtr, HKEY *rootKeyPtr, char **keyNamePtr); static DWORD RecursiveDeleteKey(HKEY hStartKey, const WCHAR * pKeyName, REGSAM mode); static int RegistryObjCmd(void *clientData, | | < < < < < < < < < < < < | | 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 | HKEY *keyPtr); static int ParseKeyName(Tcl_Interp *interp, char *name, char **hostNamePtr, HKEY *rootKeyPtr, char **keyNamePtr); static DWORD RecursiveDeleteKey(HKEY hStartKey, const WCHAR * pKeyName, REGSAM mode); static int RegistryObjCmd(void *clientData, Tcl_Interp *interp, Tcl_Size objc, Tcl_Obj *const objv[]); static int SetValue(Tcl_Interp *interp, Tcl_Obj *keyNameObj, Tcl_Obj *valueNameObj, Tcl_Obj *dataObj, Tcl_Obj *typeObj, REGSAM mode); #ifdef __cplusplus extern "C" { #endif DLLEXPORT int Registry_Init(Tcl_Interp *interp); DLLEXPORT int Registry_Unload(Tcl_Interp *interp, int flags); #if TCL_MAJOR_VERSION < 9 /* With those additional entries, "load tclregistry13.dll" works without 3th argument */ DLLEXPORT int Tclregistry_Init(Tcl_Interp *interp); DLLEXPORT int Tclregistry_Unload(Tcl_Interp *interp, int flags); #endif #ifdef __cplusplus } #endif |
︙ | ︙ | |||
172 173 174 175 176 177 178 | { Tcl_Command cmd; if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) { return TCL_ERROR; } | | | 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 | { Tcl_Command cmd; if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) { return TCL_ERROR; } cmd = Tcl_CreateObjCommand2(interp, "registry", RegistryObjCmd, interp, DeleteCmd); Tcl_SetAssocData(interp, REGISTRY_ASSOC_KEY, NULL, cmd); return Tcl_PkgProvideEx(interp, "registry", "1.3.7", NULL); } #if TCL_MAJOR_VERSION < 9 int Tclregistry_Init( |
︙ | ︙ | |||
215 216 217 218 219 220 221 | Tcl_Obj *objv[3]; (void)flags; /* * Unregister the registry package. There is no Tcl_PkgForget() */ | | | | | 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 | Tcl_Obj *objv[3]; (void)flags; /* * Unregister the registry package. There is no Tcl_PkgForget() */ objv[0] = Tcl_NewStringObj("package", -1); objv[1] = Tcl_NewStringObj("forget", -1); objv[2] = Tcl_NewStringObj("registry", -1); Tcl_EvalObjv(interp, 3, objv, TCL_EVAL_GLOBAL); /* * Delete the originally registered command. */ cmd = (Tcl_Command)Tcl_GetAssocData(interp, REGISTRY_ASSOC_KEY, NULL); |
︙ | ︙ | |||
287 288 289 290 291 292 293 | *---------------------------------------------------------------------- */ static int RegistryObjCmd( void *dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ | | | | | 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 | *---------------------------------------------------------------------- */ static int RegistryObjCmd( void *dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ Tcl_Size objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument values. */ { Tcl_Size n = 1, argc; int index; REGSAM mode = 0; const char *errString = NULL; static const char *const subcommands[] = { "broadcast", "delete", "get", "keys", "set", "type", "values", NULL }; enum SubCmdIdx { |
︙ | ︙ | |||
457 458 459 460 461 462 463 | &keyName) != TCL_OK) { Tcl_Free(buffer); return TCL_ERROR; } if (*keyName == '\0') { Tcl_SetObjResult(interp, | | | 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 | &keyName) != TCL_OK) { Tcl_Free(buffer); return TCL_ERROR; } if (*keyName == '\0') { Tcl_SetObjResult(interp, Tcl_NewStringObj("bad key: cannot delete root keys", -1)); Tcl_SetErrorCode(interp, "WIN_REG", "DEL_ROOT_KEY", (void *)NULL); Tcl_Free(buffer); return TCL_ERROR; } tail = strrchr(keyName, '\\'); if (tail) { |
︙ | ︙ | |||
479 480 481 482 483 484 485 | result = OpenSubKey(hostName, rootKey, keyName, mode, 0, &subkey); if (result != ERROR_SUCCESS) { Tcl_Free(buffer); if (result == ERROR_FILE_NOT_FOUND) { return TCL_OK; } Tcl_SetObjResult(interp, | | | | | 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 | result = OpenSubKey(hostName, rootKey, keyName, mode, 0, &subkey); if (result != ERROR_SUCCESS) { Tcl_Free(buffer); if (result == ERROR_FILE_NOT_FOUND) { return TCL_OK; } Tcl_SetObjResult(interp, Tcl_NewStringObj("unable to delete key: ", -1)); AppendSystemError(interp, result); return TCL_ERROR; } /* * Now we recursively delete the key and everything below it. */ Tcl_DStringInit(&buf); nativeTail = Tcl_UtfToWCharDString(tail, -1, &buf); result = RecursiveDeleteKey(subkey, nativeTail, saveMode); Tcl_DStringFree(&buf); if (result != ERROR_SUCCESS && result != ERROR_FILE_NOT_FOUND) { Tcl_SetObjResult(interp, Tcl_NewStringObj("unable to delete key: ", -1)); AppendSystemError(interp, result); result = TCL_ERROR; } else { result = TCL_OK; } RegCloseKey(subkey); |
︙ | ︙ | |||
727 728 729 730 731 732 733 | * Set the type into the result. Watch out for unknown types. If we don't * know about the type, just use the numeric value. */ if (type > lastType) { Tcl_SetObjResult(interp, Tcl_NewIntObj((int) type)); } else { | | | 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 | * Set the type into the result. Watch out for unknown types. If we don't * know about the type, just use the numeric value. */ if (type > lastType) { Tcl_SetObjResult(interp, Tcl_NewIntObj((int) type)); } else { Tcl_SetObjResult(interp, Tcl_NewStringObj(typeNames[type], -1)); } return TCL_OK; } /* *---------------------------------------------------------------------- * |
︙ | ︙ | |||
991 992 993 994 995 996 997 | strcpy(buffer, keyName); result = ParseKeyName(interp, buffer, &hostName, &rootKey, &keyName); if (result == TCL_OK) { result = OpenSubKey(hostName, rootKey, keyName, mode, flags, keyPtr); if (result != ERROR_SUCCESS) { Tcl_SetObjResult(interp, | | | 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 | strcpy(buffer, keyName); result = ParseKeyName(interp, buffer, &hostName, &rootKey, &keyName); if (result == TCL_OK) { result = OpenSubKey(hostName, rootKey, keyName, mode, flags, keyPtr); if (result != ERROR_SUCCESS) { Tcl_SetObjResult(interp, Tcl_NewStringObj("unable to open key: ", -1)); AppendSystemError(interp, result); result = TCL_ERROR; } else { result = TCL_OK; } } |
︙ | ︙ | |||
1039 1040 1041 1042 1043 1044 1045 | /* * Attempt to open the root key on a remote host if necessary. */ if (hostName) { Tcl_DStringInit(&buf); | | | | 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 | /* * Attempt to open the root key on a remote host if necessary. */ if (hostName) { Tcl_DStringInit(&buf); hostName = (char *) Tcl_UtfToWCharDString(hostName, -1, &buf); result = RegConnectRegistryW((WCHAR *)hostName, rootKey, &rootKey); Tcl_DStringFree(&buf); if (result != ERROR_SUCCESS) { return result; } } /* * Now open the specified key with the requested permissions. Note that * this key must be closed by the caller. */ if (keyName) { Tcl_DStringInit(&buf); keyName = (char *) Tcl_UtfToWCharDString(keyName, -1, &buf); } if (flags & REG_CREATE) { DWORD create; result = RegCreateKeyExW(rootKey, (WCHAR *)keyName, 0, NULL, REG_OPTION_NON_VOLATILE, mode, NULL, keyPtr, &create); } else if (rootKey == HKEY_PERFORMANCE_DATA) { |
︙ | ︙ | |||
1159 1160 1161 1162 1163 1164 1165 | } } /* * Look for a matching root name. */ | | | 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 | } } /* * Look for a matching root name. */ rootObj = Tcl_NewStringObj(rootName, -1); result = Tcl_GetIndexFromObj(interp, rootObj, rootKeyNames, "root name", TCL_EXACT, &index); Tcl_DecrRefCount(rootObj); if (result != TCL_OK) { return TCL_ERROR; } *rootKeyPtr = rootKeys[index]; |
︙ | ︙ | |||
1395 1396 1397 1398 1399 1400 1401 | } Tcl_DStringFree(&nameBuf); RegCloseKey(key); if (result != ERROR_SUCCESS) { Tcl_SetObjResult(interp, | | | 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 | } Tcl_DStringFree(&nameBuf); RegCloseKey(key); if (result != ERROR_SUCCESS) { Tcl_SetObjResult(interp, Tcl_NewStringObj("unable to set value: ", -1)); AppendSystemError(interp, result); return TCL_ERROR; } return TCL_OK; } /* |
︙ | ︙ | |||
1422 1423 1424 1425 1426 1427 1428 | * *---------------------------------------------------------------------- */ static int BroadcastValue( Tcl_Interp *interp, /* Current interpreter. */ | | | 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 | * *---------------------------------------------------------------------- */ static int BroadcastValue( Tcl_Interp *interp, /* Current interpreter. */ Tcl_Size objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument values. */ { LRESULT result; DWORD_PTR sendResult; int timeout = 3000; Tcl_Size len; const char *str; |
︙ | ︙ |
Changes to win/tclWinSerial.c.
︙ | ︙ | |||
1638 1639 1640 1641 1642 1643 1644 | vlen = strlen(value); /* * Option -closemode drain|discard|default */ if ((len > 2) && (strncmp(optionName, "-closemode", len) == 0)) { | | | | | 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 | vlen = strlen(value); /* * Option -closemode drain|discard|default */ if ((len > 2) && (strncmp(optionName, "-closemode", len) == 0)) { if (strncasecmp(value, "DEFAULT", vlen) == 0) { infoPtr->flags &= ~SERIAL_CLOSE_MASK; } else if (strncasecmp(value, "DRAIN", vlen) == 0) { infoPtr->flags &= ~SERIAL_CLOSE_MASK; infoPtr->flags |= SERIAL_CLOSE_DRAIN; } else if (strncasecmp(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)); |
︙ | ︙ |
Changes to win/tclWinSock.c.
︙ | ︙ | |||
370 371 372 373 374 375 376 | Tcl_DString inDs; Tcl_DStringInit(&inDs); Tcl_DStringSetLength(&inDs, 256); if (gethostname(Tcl_DStringValue(&inDs), Tcl_DStringLength(&inDs)) == 0) { Tcl_ExternalToUtfDStringEx(NULL, NULL, Tcl_DStringValue(&inDs), | | | 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 | Tcl_DString inDs; Tcl_DStringInit(&inDs); Tcl_DStringSetLength(&inDs, 256); if (gethostname(Tcl_DStringValue(&inDs), Tcl_DStringLength(&inDs)) == 0) { Tcl_ExternalToUtfDStringEx(NULL, NULL, Tcl_DStringValue(&inDs), -1, TCL_ENCODING_PROFILE_LOSSLESS, &ds, NULL); } Tcl_DStringFree(&inDs); } *encodingPtr = Tcl_GetEncoding(NULL, "utf-8"); *lengthPtr = Tcl_DStringLength(&ds); *valuePtr = (char *)Tcl_Alloc(*lengthPtr + 1); |
︙ | ︙ |
Added win/tcltest.rc.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | // // Version Resource Script // #include <winver.h> #include <tcl.h> // // build-up the name suffix that defines the type of build this is. // #if STATIC_BUILD #define SUFFIX_STATIC "s" #else #define SUFFIX_STATIC "" #endif #if DEBUG && !UNCHECKED #define SUFFIX_DEBUG "g" #else #define SUFFIX_DEBUG "" #endif #define SUFFIX SUFFIX_STATIC SUFFIX_DEBUG LANGUAGE 0x9, 0x1 /* LANG_ENGLISH, SUBLANG_DEFAULT */ VS_VERSION_INFO VERSIONINFO FILEVERSION TCL_MAJOR_VERSION,TCL_MINOR_VERSION,TCL_RELEASE_LEVEL,TCL_RELEASE_SERIAL PRODUCTVERSION TCL_MAJOR_VERSION,TCL_MINOR_VERSION,TCL_RELEASE_LEVEL,TCL_RELEASE_SERIAL FILEFLAGSMASK 0x3fL #ifdef DEBUG FILEFLAGS VS_FF_DEBUG #else FILEFLAGS 0x0L #endif FILEOS VOS__WINDOWS32 FILETYPE VFT_APP FILESUBTYPE 0x0L BEGIN BLOCK "StringFileInfo" BEGIN BLOCK "040904b0" BEGIN VALUE "FileDescription", "Tcltest Application\0" VALUE "OriginalFilename", "tcltest" STRINGIFY(TCL_MAJOR_VERSION) STRINGIFY(TCL_MINOR_VERSION) SUFFIX ".exe\0" VALUE "FileVersion", TCL_PATCH_LEVEL VALUE "LegalCopyright", "Copyright \251 1987-2022 Regents of the University of California and other parties\0" VALUE "ProductName", "Tcl " TCL_VERSION " for Windows\0" VALUE "ProductVersion", TCL_PATCH_LEVEL END END BLOCK "VarFileInfo" BEGIN VALUE "Translation", 0x409, 1200 END END // // Icon // tclsh ICON DISCARDABLE "tclsh.ico" // // This is needed for Windows 8.1 onwards. // #ifndef RT_MANIFEST #define RT_MANIFEST 24 #endif #ifndef CREATEPROCESS_MANIFEST_RESOURCE_ID #define CREATEPROCESS_MANIFEST_RESOURCE_ID 1 #endif CREATEPROCESS_MANIFEST_RESOURCE_ID RT_MANIFEST "tclsh.exe.manifest" |